'*********************************************************
' ExpAExcel
'
' Este procedimiento exporta a un libro nuevo de Excel
' las tablas, consultas o consultas SQL que le pasemos
' en la matriz cadSQL
'
' Argumentos
'   ParamArray cadSQL(): matriz que contiene los nombres
'   de las tablas, consultas o sentencias SQL que se han
'   de grabar en las diferentes hojas del libro de Excel
'
' Ejemplo de uso:
'
'   ExpAExcel "tabla1", "tabla2", "consulta1", _
'             "consulta2", "SELECT * FROM tabla1"
'
' Juan M. Afán de Ribera
' Julio/2002
'
Sub ExpAExcel(ParamArray cadSQL() As Variant)
Dim appExcel As Object 'Excel.Application
Dim hoja As Object
Dim rst As Object 'DAO.Recordset
Dim fld As Object 'DAO.Field
Dim i As Integer
Dim nom As String
Dim fila As Integer, columna As Integer

    ' abrimos excel y añadimos un libro nuevo
    appExcel.Visible = True
    appExcel.Workbooks.Add

    For i = 0 To UBound(cadSQL())

        ' añadimos una hoja nueva por cada consulta que se
        ' haya pasado como parámetro
        Set hoja = appExcel.Sheets.Add
        nom = cadSQL(i)

        ' si el nombre de la consulta es >31 caracteres
        ' dará error así que lo recortamos
        If Len(nom) > 31 Then
            nom = Left(nom, 31)
        End If

        ' ... y le damos nombre a la hoja
        hoja.Name = cadSQL(i)
        ' abrimos un recordset
        Set rst = CurrentDb.OpenRecordset(cadSQL(i))

        ' ponemos nombre a las columnas de las hojas
        ' igual que el nombre de los campos del recordset
        fila = 1
        columna = 1
        For Each fld In rst.Fields
            hoja.Cells(fila, columna) = fld.Name
            columna = columna + 1
        Next

        ' después traspasamos el valor de los campos
        ' a las celdas de la hoja de excel
        fila = 2
        columna = 1
        While Not rst.EOF
            For Each fld In rst.Fields
                hoja.Cells(fila, columna) = fld.Value
                columna = columna + 1
            Next
            columna = 1
            fila = fila + 1
            rst.MoveNext
        Wend

        rst.Close

    Next

    Set appExcel = Nothing

End Sub
'*********************************************************