637152296
' -- Referencia a la Hoja activa ( la que a�ade por defecto Excel )
Set Obj_Hoja = Obj_Excel.ActiveSheet
iCol = 0
' -- Recorrer el Datagrid ( Las columnas )
For i = 0 To [Link] - 1
If [Link](i).Visible Then
' -- Incrementar �ndice de columna
iCol = iCol + 1
' -- Obtener el caption de la columna
Obj_Hoja.Cells(1, iCol) = [Link](i).Caption
' -- Recorrer las filas
For j = 0 To n_Filas - 1
' -- Asignar el valor a la celda del Excel
Obj_Hoja.Cells(j + 2, iCol) = _
[Link](i).CellValue([Link](j))
Next
End If
Next
' -- Hacer excel visible
Obj_Excel.Visible = True
'********************************************
Private Sub Command1_Click()
' Para el Path de la base de datos
Dim Path As String
' Para la consulta sQL
Dim Consulta As String
'Path de la base de datos: Cambiar
Path = "C:\Archivos de programa\Microsoft Visual Studio\VB98\[Link]"
'Cadena Sql : Cambiar
Consulta = "Select * From Authors"
'**********************************************
'Se le env�a el Path de la base de datos, _
la consulta sql y el nombre de la hoja del Lisbor de Excel
Call Exportar_DbGrid_Excel("Hoja1", Data1)
End Sub
'Funci�n que exporta el DbGrid a la hoja de Excel
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Function Exportar_DbGrid_Excel( _
NameHoja As String, _
Control_Data As Data) 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("[Link]")
Set oLibro = [Link]
'Hace referencia a la hoja de Excel indicada
Set Hoja = [Link](NameHoja)
'Colocamos la aplicaci�n Invisible
[Link] = True: [Link] = True
'cantidad de campos
i_Field = Control_Data.[Link]
For Columna = 1 To i_Field
[Link](1, Columna).Value = Control_Data.[Link](Columna -
1).Name
Next
If Val(Mid([Link], 1, InStr(1, [Link], ".") - 1)) > 8 Then
[Link](2, 1).CopyFromRecordset Control_Data.Recordset
Else
'Obtiene todos los registros en el array
recArreglo =
Control_Data.[Link](Control_Data.[Link])
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
[Link](2, 1).Resize(iRec, i_Field).Value = Pasar(recArreglo)
End If
[Link]
[Link]
'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 [Link], vbCritical, "Error"
Exportar_DbGrid_Excel = False
End Function
Private 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
