Access ----> Excel

[rsiles]

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