Sección de códigos, trucos y ejemplos para visual basic

Clic para descargar Velneo Open source Software - Plataforma para el desarrollo de aplicaciones sobre base de datos

144 - Exportar un Recordset ADO a una hoja de Excel

La siguiente función permite exportar un Recordset de tipo ADO a una hoja de Excel

El ejemplo tiene una función llamada Exportar que tiene tres parámetros. El primero es la ruta a la base de datos, el segundo la consulta Sql para llenar el recordset y el tercero es el nombre de la hoja de excel donde se agregarán los datos

Ejemplo

Iniciar un nuevo proyecto e incluir la referencia para poder utilizar ADO : Microsoft Activex Data Objects.
Colocar un Command1 que llama a la función Exportar_ADO y especificar los datos dichos anteriormente.

Código en un formulario :

Private Sub Command1_Click() Dim Path As String, Consulta As String 'Path de la base de datos Path = "C:\Archivos de programa\Microsoft Visual Studio\VB98\BIBLIO.MDB" 'Cadena Sql Consulta = "Select * From Authors" 'Se le envía el Path de la base de datos, _ la consulta sql y el nombre de la hoja Call Exportar_ADO_Excel(Path, Consulta, "Hoja1") End Sub 'Función que exporta el recordset ADO a una hoja de Excel '########################################################### Private Function Exportar_ADO_Excel(Path As String, Sql As String, _ NameHoja As String) As Boolean On Error GoTo errSub Dim cn As New ADODB.Connection, rec As New ADODB.Recordset Dim oXls As Object, oLibro As Object, Hoja As Object Dim recArreglo As Variant Dim Path_Bd As String, i_Field As Integer, iRec As Long Dim Columna As Integer, Fila As Integer 'Abre la base cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _ "Data Source=" & Path & ";" 'Abre el Recordset pasandole la cadena sql rec.Open Sql, cn 'Crea los objetos para utilizar el Excel Set oXls = CreateObject("Excel.Application") Set oLibro = oXls.Workbooks.Add 'Hace referencia a la hoja Set Hoja = oLibro.Worksheets(NameHoja) oXls.Visible = True: oXls.UserControl = True i_Field = rec.Fields.Count For Columna = 1 To i_Field Hoja.Cells(1, Columna).Value = rec.Fields(Columna - 1).Name Next If Val(Mid(oXls.Version, 1, InStr(1, oXls.Version, ".") - 1)) > 8 Then Hoja.Cells(2, 1).CopyFromRecordset rec Else recArreglo = rec.GetRows 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 de Excel Hoja.Cells(2, 1).Resize(iRec, i_Field).Value = Pasar(recArreglo) End If oXls.Selection.CurrentRegion.Columns.AutoFit oXls.Selection.CurrentRegion.Rows.AutoFit 'Cierra el recordset y la base de datos y los objetos ADO rec.Close cn.Close Set rec = Nothing Set cn = Nothing 'Elimina las referencias Xls Set Hoja = Nothing Set oLibro = Nothing Set oXls = Nothing Exportar_ADO_Excel = True Exit Function errSub: MsgBox Err.Description, vbCritical, "Error" Exportar_ADO_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

Recursos vb6 - Enlaces relacionados

Buscar en Recursos vb