| |||
text1.text 'contiene la ruta de la base de datos text2.text 'contien la ruta del archivo de excel If Text1.Text = "" Or Text2.Text = "" Then Else Dim cn As New ADODB.Connection Dim rs As New ADODB.Recordset Dim archiexcel cn.Provider = "microsoft.jet.oledb.4.0" cn.ConnectionString = Text1.Text cn.Open rs.Open "select * from Contactos", cn, adOpenKeyset, adLockOptimistic rs.MoveFirst ExportaFacturaExcel rs, Text2.Text End If Public Sub ExportaFacturaExcel(ByRef rs As ADODB.Recordset, NombreDocumento As String) On Error GoTo err 'Creamos los objetos que necesitaremos para gestionar el documento Dim xlApp As Excel.Application Dim xlBook As Excel.Workbook Dim xlSheet As Excel.Worksheet Dim exportFileName As String Dim i As Long Dim j As Long Dim numFilas As Long 'Inicializamos las variables que se encargaran de gestionar las filas 'y columnas del fichero Excel i = 1 j = 1 numFilas = 0 'exportFileName = "C:\Archivos de programa\0sistemas\csvbase\prueba\" & NombreDocumento & ".xls" 'exportFileName = "C:\Archivos de programa\0sistemas\csvbase\prueba\" & NombreDocumento & ".xls" exportFileName = NombreDocumento ' Asignamos las referencias a los objetos para inicializarlos Set xlApp = New Excel.Application Set xlBook = xlApp.Workbooks.Add Set xlSheet = xlBook.Worksheets.Add ' Asignamos los valores a la hoja de calculo para poder manejarlos xlApp.DisplayAlerts = False 'Ahora tenemos que movernos por el fichero para cargar los datos que nos 'han pasado por referencia. 'En primer lugar entraremos en un bucle que nos permite 'obtener los nombres de los campos que nos devuelve la sentencia 'sql, y de esta forma establecemos las cabeceras del fichero Excel. While (numFilas < rs.Fields.Count) xlSheet.Cells(i, j) = rs.Fields(numFilas).Name j = j + 1 numFilas = numFilas + 1 Wend 'Incrementamos el contador de las filas, para saltar de fila 'y proceder a imprimir los datos del recordset i = i + 1 While (Not rs.EOF) j = 0 'Antes de hacer esto y fuera del bucle tenemos que generar las cabeceras. 'Pasaamos a cargar los datos del recordset en la hoja excel While (j < numFilas) xlSheet.Cells(i, j + 1).Value = rs(j) j = j + 1 Wend i = i + 1 rs.MoveNext Wend 'Ahora procedemos a guardar la hoja de calculo xlSheet.SaveAs exportFileName ' Cerramos el libro en el cual guardamos los resultados. xlBook.Close ' Cerramos la aplicacion Excel xlApp.Quit ' Release the objects. Set xlApp = Nothing Set xlBook = Nothing Set xlSheet = Nothing 'Dejamos que el sistema realize las operaciones necesarias para 'poder gestionar las facturas 'DoEvents MsgBox "Fichero generado correctamente" 'Salimos del procedimiento Exit Sub 'Control de errores err: 'DEstruimos los objetos que hemos generado Set xlApp = Nothing Set xlBook = Nothing Set xlSheet = Nothing 'Generamos el log correspondiente y devolvemos un error MsgBox "EL fichero no ha podido ser generado" & vbNewLine & "Compruebe que este no se encuentre abierto", vbInformation, err.Description End Sub |