En un reciente curso de Microsoft Access 2010, los alumnos –conocedores de mi preferencia por la programación- me pidieron que hiciera un giro en el temario del curso y lo orientara hacia sus necesidades fundamentales: enlazar bases de datos Access con libros Excel. Así, surgió la necesidad de desarrollar un conjunto procedimientos (la gran mayoría de ellos del tipo FUNCTION).
Para compartir esta información, pongo ese código a la disposición de quién lo necesite.
‘ =================================================================
‘ Para trabajar con ADO, se requiere añadir la referencia:
‘ Microsoft ActiveX Data Objects x.y Library
‘ Para trabajar con ADOX,se requiere añadir la referencia a:
‘ Microsoft ADO Ext. x.y for DDL and Security
‘ Para trabajar con Access.Application,se requiere añadir la referencia a:
‘ Microsoft Access x.y Object Library
‘ Para trabajar con DAO, se requiere añadir la referencia a:
‘ Microsoft DAO x.y Object Library
‘ ====================================================================
Function ReadAccessTableToExcel(ByVal pAccessDatabaseFullName As String, _
ByVal pAccessTableName As String, _
ByVal pExcelWorkbookFullName As String, _
ByVal pExcelTargetSheetName As String) As Boolean
Dim oConnection As ADODB.Connection
Dim oRecordset As ADODB.Recordset
Dim oWorkbook As Workbook
Dim oWorksheet As Worksheet
Dim i As Integer
On Error GoTo TError
Set oConnection = New ADODB.Connection
oConnection.Open «Provider=Microsoft.Ace.OLEDB.12.0; » & _
«Data Source=» & pAccessDatabaseFullName
Set oRecordset = New ADODB.Recordset
oRecordset.Open pAccessTableName, oConnection, _
adOpenKeyset, adLockOptimistic, adCmdTable
If FileExist(pExcelWorkbookFullName) = False Then
Set oWorkbook = Application.Workbooks.Add
Else
Set oWorkbook = Application.Workbooks.Open(pExcelWorkbookFullName)
End If
If SheetExist(oWorkbook, pExcelTargetSheetName) = False Then
Set oWorksheet = oWorkbook.Worksheets.Add
oWorksheet.Name = pExcelTargetSheetName
Else
Set oWorksheet = oWorkbook.Worksheets(pExcelTargetSheetName)
End If
oWorksheet.UsedRange.Clear
For i = 0 To oRecordset.Fields.Count – 1
oWorksheet.Range(«A1»).Offset(, i).Value = oRecordset.Fields(i).Name
Next i
oWorksheet.Range(«A1»).Resize(, oRecordset.Fields.Count).Font.Bold = True
oWorksheet.Range(«A2»).CopyFromRecordset oRecordset
Application.DisplayAlerts = False
oWorkbook.SaveAs (pExcelWorkbookFullName)
oWorkbook.Close
Application.DisplayAlerts = True
oRecordset.Close
Set oRecordset = Nothing
oConnection.Close
Set oConnection = Nothing
ReadAccessTableToExcel = True
Exit Function
TError:
If Not (oRecordset Is Nothing) Then
If (oRecordset.State And adStateOpen) = adStateOpen Then oRecordset.Close
Set oRecordset = Nothing
End If
If oConnection.State = adStateOpen Then oConnection.Close
ReadAccessTableToExcel = False
End Function
‘ ====================================================================
‘ ====================================================================
Function ReadAccessSQLToExcel(ByVal pAccessDatabaseFullName As String, _
ByVal pSQLSentence As String, _
ByVal pExcelWorkbookFullName As String, _
ByVal pExcelTargetSheetName As String) As Boolean
Dim oConnection As ADODB.Connection
Dim oRecordset As ADODB.Recordset
Dim sConnection As String
Dim oWorkbook As Workbook
Dim oWorksheet As Worksheet
Dim i As Long
On Error GoTo TError
Set oConnection = CreateObject(«ADODB.Connection»)
sConnection = «Provider=Microsoft.ACE.OLEDB.12.0;» & _
«Data Source=» & pAccessDatabaseFullName
oConnection.Open sConnection
Set oRecordset = oConnection.Execute(pSQLSentence)
If FileExist(pExcelWorkbookFullName) = False Then
Set oWorkbook = Application.Workbooks.Add
Else
Set oWorkbook = Application.Workbooks.Open(pExcelWorkbookFullName)
End If
If SheetExist(oWorkbook, pExcelTargetSheetName) = False Then
Set oWorksheet = oWorkbook.Worksheets.Add
oWorksheet.Name = pExcelTargetSheetName
Else
Set oWorksheet = oWorkbook.Worksheets(pExcelTargetSheetName)
End If
Set oWorksheet = oWorkbook.Worksheets(pExcelTargetSheetName)
oWorksheet.UsedRange.Clear
For i = 0 To oRecordset.Fields.Count – 1
oWorksheet.Range(«A1»).Offset(, i).Value = oRecordset.Fields(i).Name
Next i
oWorksheet.Range(«A1»).Resize(,
oRecordset.Fields.Count).Font.Bold = True
oWorksheet.Range(«A2»).CopyFromRecordset oRecordset
Application.DisplayAlerts = False
oWorkbook.SaveAs (pExcelWorkbookFullName)
oWorkbook.Close
Application.DisplayAlerts = True
oRecordset.Close
Set oRecordset = Nothing
oConnection.Close
Set oConnection = Nothing
ReadAccessSQLToExcel = True
Exit Function
TError:
If Not (oRecordset Is Nothing) Then
If (oRecordset.State And adStateOpen) = adStateOpen Then oRecordset.Close
Set oRecordset = Nothing
End If
If oConnection.State = adStateOpen Then oConnection.Close
ReadAccessSQLToExcel = False
End Function
Function GetAccessTableNames(ByVal pAccessDatabaseFullName As String) _
As String()
Dim oConnection As ADODB.Connection
Dim oCatalog As ADOX.Catalog
Dim oTable As ADOX.Table
Dim sConnectionString As String
Dim arrTableNames() As String
Dim i As Long
On Error GoTo TError
sConnectionString = «Provider=Microsoft.ACE.OLEDB.12.0;» & _
«Data Source=» & pAccessDatabaseFullName
Set oConnection = New ADODB.Connection
oConnection.Open sConnectionString
Set oCatalog = New ADOX.Catalog
Set oCatalog.ActiveConnection = oConnection
i = -1
For Each oTable In oCatalog.Tables
If oTable.Type = «TABLE» Then
i = i + 1
ReDim Preserve arrTableNames(i)
arrTableNames(i) = oTable.Name
End If
Next oTable
oConnection.Close
Set oCatalog = Nothing
Set oConnection = Nothing
GetAccessTableNames = arrTableNames
Exit Function
TError:
If oConnection.State = adStateOpen Then oConnection.Close
End Function
Function GetAccessTableFieldNames(ByVal pAccessDatabaseFullName As String, _
ByVal pAccessTableName As String) As String()
Dim oConnection As ADODB.Connection
Dim oRecordset As ADODB.Recordset
Dim arrFieldNames() As String
Dim i As Long
On Error GoTo TError
Set oConnection = New ADODB.Connection
oConnection.Open «Provider=Microsoft.Ace.OLEDB.12.0; » & _
«Data Source=» & pAccessDatabaseFullName
Set oRecordset = New ADODB.Recordset
oRecordset.Open pAccessTableName, oConnection, _
adOpenKeyset, adLockOptimistic, adCmdTable
For i = 0 To oRecordset.Fields.Count – 1
ReDim Preserve arrFieldNames(i)
arrFieldNames(i) = oRecordset.Fields(i).Name
Next i
oRecordset.Close
Set oRecordset = Nothing
oConnection.Close
Set oConnection = Nothing
GetAccessTableFieldNames = arrFieldNames
Exit Function
TError:
If Not (oRecordset Is Nothing) Then
If (oRecordset.State And adStateOpen) = adStateOpen Then oRecordset.Close
Set oRecordset = Nothing
End If
If oConnection.State = adStateOpen Then oConnection.Close
End Function
Function GetAccessTableFieldTypes(ByVal pAccessDatabaseFullName As String, _
ByVal pAccessTableName As String) As String()
Dim oConnection As ADODB.Connection
Dim oRecordset As ADODB.Recordset
Dim arrFieldTypes() As String
Dim i As Long
On Error GoTo TError
Set oConnection = New ADODB.Connection
oConnection.Open «Provider=Microsoft.Ace.OLEDB.12.0; » & _
«Data Source=» & pAccessDatabaseFullName
Set oRecordset = New ADODB.Recordset
oRecordset.Open pAccessTableName, oConnection, _
adOpenKeyset, adLockOptimistic, adCmdTable
For i = 0 To oRecordset.Fields.Count – 1
ReDim Preserve arrFieldTypes(i)
arrFieldTypes(i) = TypeName(oRecordset.Fields(i).Value)
Next i
oRecordset.Close
Set oRecordset = Nothing
oConnection.Close
Set oConnection = Nothing
GetAccessTableFieldTypes = arrFieldTypes
Exit Function
TError:
If Not (oRecordset Is Nothing) Then
If (oRecordset.State And adStateOpen) = adStateOpen Then oRecordset.Close
Set oRecordset = Nothing
End If
If oConnection.State = adStateOpen Then oConnection.Close
End Function
Function GetAccessTableFieldValues(ByVal pAccessDatabaseFullName As String, _
ByVal pAccessTableName As String, _
ByVal pFieldName As String) As Variant()
Dim oConnection As ADODB.Connection
Dim oRecordset As ADODB.Recordset
Dim arrFieldValues() As Variant
Dim i As Long
On Error GoTo TError
Set oConnection = New ADODB.Connection
oConnection.Open «Provider=Microsoft.Ace.OLEDB.12.0; » & _
«Data Source=» & pAccessDatabaseFullName
Set oRecordset = New ADODB.Recordset
oRecordset.Open pAccessTableName, oConnection, _
adOpenKeyset, adLockOptimistic, adCmdTable
ReDim arrFieldValues(oRecordset.RecordCount – 1)
i = -1
Do While Not oRecordset.EOF
i = i + 1
arrFieldValues(i) = oRecordset.Fields(pFieldName).Value
oRecordset.MoveNext
Loop
oRecordset.Close
Set oRecordset = Nothing
oConnection.Close
Set oConnection = Nothing
GetAccessTableFieldValues = arrFieldValues
Exit Function
TError:
If Not (oRecordset Is Nothing) Then
If (oRecordset.State And adStateOpen) = adStateOpen Then oRecordset.Close
Set oRecordset = Nothing
End If
If oConnection.State = adStateOpen Then oConnection.Close
End Function
Function GetAccessQueryNames_1(ByVal pAccessDatabaseFullName As String) _
As String()
Dim sConnectionString As String
Dim oConnection As ADODB.Connection
Dim oCatalog As ADOX.Catalog
Dim oView As ADOX.View
Dim arrQueryNames() As String
Dim i As Long
On Error GoTo TError
sConnectionString = «Provider=Microsoft.ACE.OLEDB.12.0;» & _
«Data Source=» & pAccessDatabaseFullName
Set oConnection = New ADODB.Connection
oConnection.Open sConnectionString
Set oCatalog = New ADOX.Catalog
Set oCatalog.ActiveConnection = oConnection
i = -1
For Each oView In oCatalog.Views
i = i + 1
ReDim Preserve arrQueryNames(i)
arrQueryNames(i) = oView.Name
Next oView
oConnection.Close
Set oCatalog = Nothing
Set oConnection = Nothing
GetAccessQueryNames_1 = arrQueryNames
Exit Function
TError:
If oConnection.State = adStateOpen Then oConnection.Close
End Function
Function GetAccessQueryNames_2(ByVal pAccessDatabaseFullName As String) _
As String()
Dim oDatabase As DAO.Database
Dim oQueryDef As DAO.QueryDef
Dim arrQueryNames() As String
Dim i As Long
On Error GoTo TError
Set oDatabase = DBEngine.OpenDatabase(pAccessDatabaseFullName)
i = -1
For Each oQueryDef In oDatabase.QueryDefs
If Mid(oQueryDef.Name, 1, 1) <> «~» Then
i = i + 1
ReDim Preserve arrQueryNames(i)
arrQueryNames(i) = oQueryDef.Name
End If
Next
oQueryDef.Close
Set oQueryDef = Nothing
oDatabase.Close
Set oDatabase = Nothing
GetAccessQueryNames_2 = arrQueryNames
Exit Function
TError:
On Error Resume Next
oQueryDef.Close
On Error Resume Next
oDatabase.Close
End Function
Function GetAccessQuerySELECTFromQueryName(ByVal pAccessDatabaseFullName As String, _
ByVal pAccessQueryName As String) As String
Dim oDatabase As DAO.Database
Dim oQueryDef As DAO.QueryDef
On Error GoTo TError
Set oDatabase = DBEngine.OpenDatabase(pAccessDatabaseFullName)
Set oQueryDef = oDatabase.QueryDefs(pAccessQueryName)
GetAccessQuerySELECTFromQueryName = oQueryDef.Sql
oDatabase.Close
Set oDatabase = Nothing
Exit Function
TError:
On Error Resume Next
oDatabase.Close
GetAccessQuerySELECTFromQueryName = «»
End Function
Function ExecuteAccessQueryName(ByVal pAccessDatabaseFullName As String, _
ByVal pAccessQueryName As String) As ADODB.Recordset
Dim sConnectionString As String
Dim oConnection As ADODB.Connection
Dim oRecordset As ADODB.Recordset
Dim sSQL As String
On Error GoTo TError
sConnectionString = «Provider=Microsoft.ACE.OLEDB.12.0;» & _
«Data Source=» & pAccessDatabaseFullName
Set oConnection = New ADODB.Connection
oConnection.Open sConnectionString
sSQL = GetAccessQuerySELECTFromQueryName(pAccessDatabaseFullName, _
pAccessQueryName)
Set oRecordset = oConnection.Execute(sSQL)
Set ExecuteAccessQueryName = oRecordset
Set oRecordset = Nothing
Exit Function
TError:
On Error Resume Next
Set oRecordset = Nothing
Set ExecuteAccessQueryName = Nothing
End Function
Function ExecuteAccessQuerySELECT(ByVal pAccessDatabaseFullName As String, _
ByVal pAccessQuerySELECT As String) As ADODB.Recordset
Dim sConnectionString As String
Dim oConnection As New ADODB.Connection
Dim oRecordset As New ADODB.Recordset
Dim oCommand As New ADODB.Command
On Error GoTo TError
sConnectionString = «Provider=Microsoft.ACE.OLEDB.12.0;» & _
«Data Source=» & pAccessDatabaseFullName
oConnection.Open sConnectionString
oCommand.CommandType = adCmdText
oCommand.CommandText = pAccessQuerySELECT
oCommand.ActiveConnection = oConnection
Set oRecordset = oCommand.Execute()
Set ExecuteAccessQuerySELECT = oRecordset
Set oCommand = Nothing
Set oRecordset = Nothing
oConnection.Close
Set oConnection = Nothing
Exit Function
TError:
If Not (oRecordset Is Nothing) Then
If (oRecordset.State And adStateOpen) = adStateOpen Then oRecordset.Close
Set oRecordset = Nothing
End If
If oConnection.State = adStateOpen Then oConnection.Close
Set ExecuteAccessQuerySELECT = Nothing
End Function