Attribute VB_Name = "ModuloExpExcel"
Public Function Exportar_DbGrid_Excel( _
                            NameHoja As String) As Boolean
       
    On Error GoTo errSub
       
    'Variables para manejar el Excel
    Dim oXls As Object, oLibro As Object, Hoja As Object
       
    'Matriz para los registros
    Dim recArreglo As Variant
       
    Dim i_Field As Integer, iRec As Long
    Dim Columna As Integer, Fila As Integer
  
    'Crea los objetos para utilizar el Excel
    Set oXls = CreateObject("Excel.Application")
    Set oLibro = oXls.Workbooks.Add
       
    'Hace referencia a la hoja de Excel indicada
    Set Hoja = oLibro.Worksheets(NameHoja)
     
    'Colocamos la aplicación Invisible
    oXls.Visible = True: oXls.UserControl = True
       
    'cantidad de campos
    i_Field = rs3.Fields.Count
       
    For Columna = 1 To i_Field
        Hoja.Cells(1, Columna).Value = rs3.Fields(Columna - 1).Name
    Next
           
  
    If Val(Mid(oXls.Version, 1, InStr(1, oXls.Version, ".") - 1)) > 8 Then
  
        Hoja.Cells(2, 1).CopyFromRecordset rs3
       
    Else
        'Obtiene todos los registros en el array
        recArreglo = rs3.GetRows(rs3.RecordCount)
  
        iRec = UBound(recArreglo, 2) + 1
           
        For Columna = 0 To i_Field - 1
            For Fila = 0 To iRec - 1
  
                If IsDate(recArreglo(Columna, Fila)) Then
                    recArreglo(Columna, Fila) = Format(recArreglo(Columna, Fila))
  
                ElseIf IsArray(recArreglo(Columna, Fila)) Then
                    recArreglo(Columna, Fila) = "Array Field"
                End If
            Next Fila
        Next Columna
               
        'traspasa los datos a la hoja
        Hoja.Cells(2, 1).Resize(iRec, i_Field).Value = Pasar(recArreglo)
    End If
       
    oXls.Selection.CurrentRegion.Columns.AutoFit
    oXls.Selection.CurrentRegion.Rows.AutoFit
  
  
    'Elimina las referencias del Excel
    Set Hoja = Nothing
    Set oLibro = Nothing
    Set oXls = Nothing
       
    ' Se exporto con éxito
    Exportar_DbGrid_Excel = True
       
    Exit Function
       
'Error
errSub:
    MsgBox Err.Description, vbCritical, "Error"
    Exportar_DbGrid_Excel = False
  
End Function
  
  
Public Function Pasar(v As Variant) As Variant
  
    Dim x As Long, y As Long, xMax As Long, yMax As Long, T As Variant
       
    xMax = UBound(v, 2): yMax = UBound(v, 1)
       
    ReDim T(xMax, yMax)
    For x = 0 To xMax
        For y = 0 To yMax
            T(x, y) = v(y, x)
        Next y
    Next x
       
    Pasar = T
  
End Function



