Dim rs As New ADODB.Recordset
Dim cn As New ADODB.Connection

Private Sub Command1_Click()

sSQL = "SHAPE {SELECT codcat,nomcat FROM categoria} AS CABECERA " & _
"APPEND ({SELECT codprod,nomprod,codcat FROM producto} AS DETALLE " & _
"RELATE codcat TO codcat) AS DETALLE"

rs.StayInSync = False
cn.Open "Provider=MSDataShape.1;Extended Properties=Jet OLEDB:Database Password=;Persist Security Info=False;Data Source=" & App.Path & "\bd_01.mdb;Data Provider=MICROSOFT.JET.OLEDB.4.0"
     
rs.Open sSQL, cn

Set MSHFlexGrid1.DataSource = rs

End Sub

Private Sub Command2_Click()
Call Exportar_Excel(rs)
End Sub

Public Function Exportar_Excel(rec As Recordset) As Boolean
    On Error GoTo errSub
    Dim Excel       As Object
    Dim Libro       As Object
    Dim Hoja        As Object
    Dim arrData     As Variant
    Dim iRec        As Long
    Dim iCol        As Integer
    Dim iRow        As Integer
       
    'Me.Enabled = False
    Screen.MousePointer = 11
    ' -- Crear los objetos para utilizar el Excel
    Set Excel = CreateObject("Excel.Application")
    Set Libro = Excel.Workbooks.Add
       
    ' -- Hacer referencia a la hoja
    Set Hoja = Libro.Worksheets(1)
       
    Excel.Visible = True: Excel.UserControl = True
    iCol = rec.Fields.Count
    For iCol = 1 To rec.Fields.Count
        Hoja.Cells(1, iCol).Value = rec.Fields(iCol - 1).Name
    Next
       
    If Val(Mid(Excel.Version, 1, InStr(1, Excel.Version, ".") - 1)) > 8 Then
        Hoja.Cells(2, 1).CopyFromRecordset rec
    Else
  
        arrData = rec.GetRows
  
        iRec = UBound(arrData, 2) + 1
           
        For iCol = 0 To rec.Fields.Count - 1
            For iRow = 0 To iRec - 1
  
                If IsDate(arrData(iCol, iRow)) Then
                    arrData(iCol, iRow) = Format(arrData(iCol, iRow))
  
                ElseIf IsArray(arrData(iCol, iRow)) Then
                    arrData(iCol, iRow) = "Array Field"
                End If
            Next iRow
        Next iCol
               
        ' -- Traspasa los datos a la hoja de Excel
        Hoja.Cells(2, 1).Resize(iRec, rec.Fields.Count).Value = GetData(arrData)
    End If
    Excel.Selection.CurrentRegion.Columns.AutoFit
    Excel.Selection.CurrentRegion.Rows.AutoFit
    
    'Hoja.Name = ""
    'Libro.saveAs App.Path & "\libro"
    'Libro.Close
    ' -- Elimina las referencias xls
    Set Hoja = Nothing
    Set Libro = Nothing
    'Excel.quit
    Set Excel = Nothing
       
    Exportar_Excel = True
    'Me.Enabled = True
    Screen.MousePointer = 0
    Exit Function
errSub:
    MsgBox Err.Description, vbCritical, "Error"
    Exportar_Excel = False
    'Me.Enabled = True
    Screen.MousePointer = 0
End Function
  
Private Function GetData(vValue As Variant) As Variant
    Dim X As Long, Y As Long, xMax As Long, yMax As Long, T As Variant
       
    xMax = UBound(vValue, 2): yMax = UBound(vValue, 1)
       
    ReDim T(xMax, yMax)
    For X = 0 To xMax
        For Y = 0 To yMax
            T(X, Y) = vValue(Y, X)
        Next Y
    Next X
       
    GetData = T
End Function

Dim rs As New ADODB.Recordset
Dim cn As New ADODB.Connection

Private Sub Command1_Click()

sSQL = "SHAPE {SELECT codcat,nomcat FROM categoria} AS CABECERA " & _
"APPEND ({SELECT codprod,nomprod,codcat FROM producto} AS DETALLE " & _
"RELATE codcat TO codcat) AS DETALLE"

rs.StayInSync = False
'cn.Open "Provider=MSDataShape.1;Extended Properties=Jet OLEDB:Database Password=;Persist Security Info=False;Data Source=c:\bd_01.mdb;Data Provider=MICROSOFT.JET.OLEDB.4.0"
 cn.Open "Provider=MSDataShape.1;Extended Properties=Jet OLEDB:Database Password=;Persist Security Info=False;Data Source=" & App.Path & "\bd_01.mdb;Data Provider=MICROSOFT.JET.OLEDB.4.0"
     
rs.Open sSQL, cn

Set MSHFlexGrid1.DataSource = rs

End Sub

Private Sub Command2_Click()
Call Exportar_HFlexgrid(App.Path & "\excel1.xls", MSHFlexGrid1)
End Sub


' -------------------------------------------------------------------------------------------
' \\ -- Función para crear un nuevo libro con el contenido del Grid
' -------------------------------------------------------------------------------------------
Public Function Exportar_HFlexgrid(sOutputPath As String, FlexGrid As Object) As Boolean
  
    On Error GoTo Error_Handler
  
    Dim o_Excel     As Object
    Dim o_Libro     As Object
    Dim o_Hoja      As Object
    Dim Fila        As Long
    Dim Columna     As Long
       
    ' -- Crea el objeto Excel, el objeto workBook y el objeto sheet
    Set o_Excel = CreateObject("Excel.Application")
    Set o_Libro = o_Excel.Workbooks.Add
    Set o_Hoja = o_Libro.Worksheets.Add
       
    ' -- Bucle para Exportar los datos
    With FlexGrid
        For Fila = 1 To .Rows - 1
            For Columna = 0 To .Cols - 1
                o_Hoja.Cells(Fila, Columna + 1).Value = .TextMatrix(Fila, Columna)
            Next
        Next
    End With
    o_Libro.Close True, sOutputPath
    ' -- Cerrar Excel
    o_Excel.Quit
    ' -- Terminar instancias
    Call ReleaseObjects(o_Excel, o_Libro, o_Hoja)
    Exportar_HFlexgrid = True
Exit Function
  
' -- Controlador de Errores
Error_Handler:
    ' -- Cierra la hoja y el la aplicación Excel
    If Not o_Libro Is Nothing Then: o_Libro.Close False
    If Not o_Excel Is Nothing Then: o_Excel.Quit
    Call ReleaseObjects(o_Excel, o_Libro, o_Hoja)
    If Err.Number <> 1004 Then MsgBox Err.Description, vbCritical
End Function
' -------------------------------------------------------------------
' \\ -- Eliminar objetos para liberar recursos
' -------------------------------------------------------------------
Private Sub ReleaseObjects(o_Excel As Object, o_Libro As Object, o_Hoja As Object)
    If Not o_Excel Is Nothing Then Set o_Excel = Nothing
    If Not o_Libro Is Nothing Then Set o_Libro = Nothing
    If Not o_Hoja Is Nothing Then Set o_Hoja = Nothing
End Sub