Real developers and DBAs can stop right here and move along. This is a post about Microsoft Access. I’ve heard the jeers and snide remarks, and agree with some, especially with regard to the GUI changes in Access 2007 (let’s make everybody learn where to find everything again). Nonetheless, I do work with Access from time to time and actually think there are some things about it that are really awesome [EDIT: Yes, that’s an exaggeration. I was channeling a valley girl at the time].
Access is very powerful as an ad hoc analysis and reporting tool. The Access query builder is a great tool for learning SQL. You can use the visual designer and then switch to SQL View and see what the query is doing behind the scenes. I’ve used Access as a SQL generator when building complex queries for other databases. Copy, paste, and edit the SQL to make it compliant with the target database’s SQL dialect. Perhaps not an ideal work flow but faster than coding the SQL by hand.
Below are three VBA modules that I have found to be useful on several projects. I wanted to document them here for future reference. If anyone else finds them useful that’s a bonus.
Linking external tables:
In many cases, I prefer to create links to external tables, in another Access database or an ODBC data source, using code instead of the Linked Table Wizard. Doing so makes it easer to switch back-end databases when developing a front-end application in Access. The following VBA module provides that function.
Option Compare Database
Option Explicit
'- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
' modLibLinkTable
'
' Create or refresh linked tables using code instead of the wizard.
'- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Sub LinkDataTable(odbcDSN As String, dbPath As String, tableName As String)
'
' If odbcDSN (ODBC Data Source Name) is blank then the table is
' linked to the Access database file specified in dbPath.
' Otherwise the table is linked to the ODBC data source.
'
On Error GoTo Handle_Error
Dim dbs As Database
Dim tdf As TableDef
Dim conn As String
If odbcDSN = "" Then
conn = ";DATABASE=" & dbPath
SysCmd acSysCmdSetStatus, "Linking table " & tableName & " in " & dbPath
Else
conn = "ODBC;DSN=" & odbcDSN
SysCmd acSysCmdSetStatus, "Linking table " & tableName & " in ODBC data source " & odbcDSN
End If
Set dbs = CurrentDb
' Delete existing link.
On Error Resume Next
dbs.TableDefs.Delete tableName
On Error GoTo Handle_Error
' Create new link.
Set tdf = dbs.CreateTableDef(tableName)
tdf.Connect = conn
tdf.SourceTableName = tableName
dbs.TableDefs.Append tdf
Exit_Here:
Exit Sub
Handle_Error:
MsgBox Err.Description, , "ERROR in " & "LinkDataTable"
Resume Exit_Here
End Sub
Exporting Excel files:
There are a number of ways to get data from Access into Excel. Excel can pull data from an Access database and Access can export to Excel files. The following VBA module has two subroutines for quickly pushing a table or the results of a query out to an Excel file. The second subroutine lets you specify some formatting and add sums using parameters. It’s not pretty but it works (at least it has worked for me in the past).
Option Compare Database
Option Explicit
'- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
' modLibExcel
' Library of functions related to Excel.
' Requires reference to Microsoft Excel 12.0 Object Library.
'- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Sub ExportRecordsetToExcel(strSheetName As String, ByRef rst As DAO.Recordset)
'
' Generic procedure to export a RecordSet
' to an Excel workbook.
'
' Using the built-in DoCmd.OutputTo , , acFormatXLS
' command produces an Excel 95 format.
' This sub will create the newer Excel format.
'
Dim app As Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Dim i As Integer
On Error GoTo Handle_Error
Set app = New Excel.Application
Set wb = app.Workbooks.Add
app.DisplayAlerts = False
For i = wb.Worksheets.Count To 2 Step -1
wb.Worksheets(i).Delete
Next i
app.DisplayAlerts = True
Set ws = wb.ActiveSheet
ws.Name = strSheetName
For i = 1 To rst.Fields.Count
ws.Cells(1, i).Value = rst.Fields(i - 1).Name
ws.Cells(1, i).Font.Bold = True
Next i
ws.Range("A2").CopyFromRecordset rst
For i = 1 To rst.Fields.Count
ws.Columns(i).AutoFit
Next i
app.Visible = True
Exit_Here:
On Error Resume Next
Set ws = Nothing
Set wb = Nothing
Set app = Nothing
Exit Sub
Handle_Error:
MsgBox Err.Description, , "ERROR in ExportRecordsetToExcel"
Resume Exit_Here
End Sub
'- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
' Sub ExportToExcelNewWorksheet
'
' Parameters:
'
' strSheetName: Name to give worksheet.
'
' app: Reference to an Excel.Application object.
'
' wb: Reference to an Excel.Workbook object.
'
' rst: Reference to Recordset containing data to be
' placed on the worksheet.
'
' strPctColumns: Comma-separated list of columns to
' format as percent.
'
' strN2Columns: Comma-separated list of columns to
' format as number with 2 decimal places.
'
' strSumColumns: Comma-separated list of columns to add
' a Sum() formula below data.
'
' strColor1Columns: Comma-separated list of columns to
' set background color to COLOR_1.
'
' strColor2Columns: Comma-separated list of columns to
' set background color to COLOR_2.
'
' strColor3Columns: Comma-separated list of columns to
' set background color to COLOR_3.
'
'- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
'
Sub ExportToExcelNewWorksheet(strSheetName As String, _
ByRef app As Excel.Application, _
ByRef wb As Excel.Workbook, _
ByRef rst As DAO.Recordset, _
Optional strPctColumns As String = "", _
Optional strN2Columns As String = "", _
Optional strSumColumns As String = "", _
Optional strColor1Columns As String = "", _
Optional strColor2Columns As String = "", _
Optional strColor3Columns As String = "" _
)
On Error GoTo Handle_Error
Const DECIMAL_2 = "#,##0.00_);[Red](#,##0.00);"
Const PERCENT_2 = "#0.00%;(#0.00%);"
Const COLOR_1 = 12713921
Const COLOR_2 = 16777164
Const COLOR_3 = 12180223
Dim i As Integer
Dim n As Integer
Dim r As Integer
Dim C As Integer
Dim ws As Excel.Worksheet
Dim varPctList As Variant
Dim varN2List As Variant
Dim varSumList As Variant
Dim varColor1List As Variant
Dim varColor2List As Variant
Dim varColor3List As Variant
Dim strColumn As String
Dim strRange As String
Dim strFormula As String
Dim DoNewSheet As Boolean
varPctList = Split(strPctColumns, ",")
varN2List = Split(strN2Columns, ",")
varSumList = Split(strSumColumns, ",")
varColor1List = Split(strColor1Columns, ",")
varColor2List = Split(strColor2Columns, ",")
varColor3List = Split(strColor3Columns, ",")
Set ws = wb.ActiveSheet
' If active worksheet is empty then use it
' otherwise add a new worksheet. An empty
' sheet shows used range of one row and one
' column. This assumes that a non-empty sheet
' will actually use more than one cell.
'
C = ws.UsedRange.Columns.Count
r = ws.UsedRange.Rows.Count
DoNewSheet = ((r > 1) Or (C > 1))
If DoNewSheet Then
Set ws = Nothing
Set ws = wb.Worksheets.Add
End If
ws.Name = strSheetName
For i = 1 To rst.Fields.Count
ws.Cells(1, i).Value = rst.Fields(i - 1).Name
ws.Cells(1, i).Font.Bold = True
Next i
ws.Range("A2").CopyFromRecordset rst
For i = 1 To rst.Fields.Count
ws.Columns(i).AutoFit
Next i
r = ws.UsedRange.Rows.Count
C = ws.UsedRange.Columns.Count
' Add totals to specified columns.
n = UBound(varSumList)
If n >= 0 Then
For i = 0 To n
strColumn = varSumList(i)
strFormula = "=SUM(" & strColumn & "2:" & strColumn & CStr(r) & ")"
strRange = strColumn & CStr(r + 2)
With ws.Range(strRange)
.Formula = strFormula
.Font.Bold = True
End With
Next i
End If
' Refresh to include any totals rows.
r = ws.UsedRange.Rows.Count
n = UBound(varPctList)
For i = 0 To n
strColumn = varPctList(i)
strRange = strColumn & "1:" & strColumn & CStr(r)
ws.Range(strRange).NumberFormat = PERCENT_2
Next i
n = UBound(varN2List)
For i = 0 To n
strColumn = varN2List(i)
strRange = strColumn & "1:" & strColumn & CStr(r)
ws.Range(strRange).NumberFormat = DECIMAL_2
Next i
n = UBound(varColor1List)
For i = 0 To n
strColumn = varColor1List(i)
strRange = strColumn & "1:" & strColumn & CStr(r)
ws.Range(strRange).Interior.Color = COLOR_1
Next i
n = UBound(varColor2List)
For i = 0 To n
strColumn = varColor2List(i)
strRange = strColumn & "1:" & strColumn & CStr(r)
ws.Range(strRange).Interior.Color = COLOR_2
Next i
n = UBound(varColor3List)
For i = 0 To n
strColumn = varColor3List(i)
strRange = strColumn & "1:" & strColumn & CStr(r)
ws.Range(strRange).Interior.Color = COLOR_3
Next i
' Set borders (setting interior color
' wipes out the gridlines).
ws.UsedRange.Borders.LineStyle = xlContinuous
ws.UsedRange.Borders.Color = RGB(&HBB, &HBB, &HBB)
ws.Range("A2").Activate
app.ActiveWindow.FreezePanes = True
Exit_Here:
On Error Resume Next
Set ws = Nothing
Exit Sub
Handle_Error:
MsgBox Err.Description, , "ERROR in ExportToExcelNewWorksheet"
Resume Exit_Here
End Sub
Exporting code and table definitions:
One of the things I don’t like about Access is the way bits of code (and business rules) end up all over the place, hiding in parameters behind forms and reports. The last chunk of VBA code for this post is a utility I use to dump code from modules, forms, and reports into a set of text files. It also writes out table definitions. It creates a set of text files in a sub-folder named for the current date and time when the script is run. I use this mostly to track changes by running Beyond Compare against sets of files created at different times. I can see code and table structure changes that were made during the interval. This utility also comes in handy for exploring an unfamiliar database.
Option Compare Database
Option Explicit
Dim mstrCodeExportDir As String
Sub DevTool_ExportCode()
If ExportDirReady Then
DevTool_ExportQueries
DevTool_ExportModules
DevTool_ExportTableDefs
DevTool_ExportTableNames
DevTool_ExportFormModules
DevTool_ExportReportModules
MsgBox "Exported to " & mstrCodeExportDir, , "Finished"
End If
End Sub
Private Function ExportDirReady() As Boolean
Dim mr As Integer
mstrCodeExportDir = CurrentProject.Path & "_code_history"
' Create base code history directory if needed.
If Len(Dir(mstrCodeExportDir, vbDirectory)) = 0 Then
MkDir mstrCodeExportDir
End If
' Create subdirectory for current date and time.
mstrCodeExportDir = mstrCodeExportDir & "" & Format(Now(), "yyyymmdd_hhnn")
If Len(Dir(mstrCodeExportDir, vbDirectory)) = 0 Then
MkDir mstrCodeExportDir
ExportDirReady = True
Else
mr = MsgBox("Directory already exists:" & vbCrLf & vbCrLf & mstrCodeExportDir _
& vbCrLf & vbCrLf & "Overwrite existing files?", vbYesNo, "Warning")
ExportDirReady = (mr = vbYes)
End If
End Function
Sub DevTool_ExportQueries()
Dim db As DAO.Database
Dim qry As DAO.QueryDef
Dim ctr As DAO.Container
Dim doc As DAO.Document
Dim f As Integer
Dim fn As String
Set db = CurrentDb
For Each qry In db.QueryDefs
fn = mstrCodeExportDir & "sql-" & Replace(Trim(qry.Name), " ", "_", , , vbTextCompare) & ".txt"
SysCmd acSysCmdSetStatus, "Query: " & fn
f = FreeFile
Open fn For Output As #f
Print #f, qry.SQL
Close #f
Next qry
SysCmd acSysCmdClearStatus
'MsgBox "Done."
End Sub
Sub DevTool_ExportModules()
Dim db As DAO.Database
Dim ctr As DAO.Container
Dim doc As DAO.Document
Dim f As Integer
Dim fn As String
Set db = CurrentDb
Set ctr = db.Containers!Modules
For Each doc In ctr.Documents
fn = mstrCodeExportDir & "mod-" & Replace(Trim(doc.Name), " ", "_", , , vbTextCompare) & ".txt"
SysCmd acSysCmdSetStatus, "Module: " & fn
DoCmd.OutputTo acOutputModule, doc.Name, acFormatTXT, fn
Next doc
SysCmd acSysCmdClearStatus
'MsgBox "Done."
End Sub
Sub DevTool_ExportTableDefs()
Dim db As DAO.Database
Dim tdfs As DAO.TableDefs
Dim tdf As DAO.TableDef
Dim flds As DAO.Fields
Dim fld As DAO.Field
Dim strPath As String
Dim fnHTM As String
Dim fnTXT As String
Dim intFileH As Integer
Dim intFileT As Integer
Dim strTitle1 As String
Dim strTitle2 As String
Dim strTbl As String
Dim strFld As String
Dim strTyp As String
Dim strConn As String
Dim strTblTyp As String
Set db = CurrentDb
strPath = mstrCodeExportDir & ""
fnHTM = strPath & "table_defs.html"
fnTXT = strPath & "table_defs.txt"
intFileH = FreeFile
Open fnHTM For Output As #intFileH
intFileT = FreeFile
Open fnTXT For Output As #intFileT
Set tdfs = db.TableDefs
If tdfs.Count > 0 Then
strTitle1 = "[Created by DevTool_ExportTableDefs " & Format(Now, "yyyy-mm-dd Hh:Nn:Ss") & "]"
strTitle2 = "Tables in " & CurrentProject.Name
Print #intFileT, strTitle1
Print #intFileT, " "
Print #intFileT, strTitle2
Print #intFileH, ""
Print #intFileH, ""
Print #intFileH, "" & strTitle2 & ""
Print #intFileH, ""
Print #intFileH, ""
Print #intFileH, "<p>" & strTitle1 & "</p>"
Print #intFileH, "<h1>" & strTitle2 & "</h1>"
For Each tdf In tdfs
strTbl = tdf.Name
SysCmd acSysCmdSetStatus, "Table: " & strTbl
' Do not list MS Access system tables.
If Left(strTbl, 4) "MSys" Then
strConn = Nz(tdf.Properties("Connect"), "")
If Len(strConn) > 0 Then
'strTblTyp = "(LINKED)"
strTblTyp = "(LINKED " & Right(strConn, Len(strConn) - 10) & ")"
Else
'strTblTyp = "(local)"
strTblTyp = ""
End If
Print #intFileH, "<p><b>" & strTbl & " " & strTblTyp & "</b><br>"
Print #intFileH, "<table>"
Print #intFileT, " "
Print #intFileT, strTbl & " " & strTblTyp
'Print #intFileT, "Updatable = " & Nz(tdf.Properties("Updatable"))
'Print #intFileT, "Connect = " & Nz(tdf.Properties("Connect"))
Set flds = tdf.Fields
For Each fld In flds
strFld = fld.Name
strTyp = FieldType(fld.Type)
If strTyp = "Text" Then
strTyp = strTyp & " (" & CStr(fld.Size) & ")"
End If
Print #intFileH, "<tr><td>" & strFld & "</td><td>" & strTyp & "</td><td> </td></tr>"
Print #intFileT, " " & padStrL(30, strFld) & padStrL(14, strTyp)
Next fld
Set flds = Nothing
Print #intFileH, "</table>"
End If
Next tdf
End If
Print #intFileH, ""
Print #intFileH, ""
Close #intFileH
Close #intFileT
SysCmd acSysCmdClearStatus
End Sub
' Function FieldType is modified version of example in MS Access Help.
Private Function FieldType(intType As Integer) As String
Select Case intType
Case dbBoolean
FieldType = "Boolean"
Case dbByte
FieldType = "Byte"
Case dbInteger
FieldType = "Integer"
Case dbLong
FieldType = "Long"
Case dbCurrency
FieldType = "Currency"
Case dbSingle
FieldType = "Single"
Case dbDouble
FieldType = "Double"
Case dbDate
FieldType = "Date"
Case dbText
FieldType = "Text"
Case dbLongBinary
FieldType = "LongBinary"
Case dbMemo
FieldType = "Memo"
Case dbGUID
FieldType = "GUID"
End Select
End Function
Sub DevTool_ExportFormModules()
Dim dbs As Object
Dim obj As AccessObject
Dim frm As Form
Dim wasLoaded As Boolean
Dim strName As String
Dim fn As String
Set dbs = Application.CurrentProject
For Each obj In dbs.AllForms
strName = obj.Name
SysCmd acSysCmdSetStatus, "Form: " & strName
Debug.Print "Form: " & strName
wasLoaded = obj.IsLoaded
If Not wasLoaded Then
DoCmd.OpenForm strName, acDesign, , , , acHidden
End If
Set frm = Application.Forms(strName)
Debug.Print "Form Module: " & frm.Module
fn = mstrCodeExportDir & "" & Replace(Trim(frm.Module.Name), " ", "_", , , vbTextCompare) & ".txt"
DoCmd.OutputTo acOutputModule, frm.Module.Name, acFormatTXT, fn
Set frm = Nothing
If Not wasLoaded Then
DoCmd.Close acForm, strName, acSaveNo
End If
DoEvents
Next obj
SysCmd acSysCmdClearStatus
End Sub
Sub DevTool_ExportReportModules()
Dim dbs As Object
Dim obj As AccessObject
Dim RPT As Report
Dim wasLoaded As Boolean
Dim strName As String
Dim fn As String
Set dbs = Application.CurrentProject
For Each obj In dbs.AllReports
strName = obj.Name
SysCmd acSysCmdSetStatus, "Report: " & strName
Debug.Print strName
wasLoaded = obj.IsLoaded
If Not wasLoaded Then
DoCmd.OpenReport strName, acDesign, , , acHidden
End If
Set RPT = Application.Reports(strName)
Debug.Print RPT.Module
fn = mstrCodeExportDir & "" & Replace(Trim(RPT.Module.Name), " ", "_", , , vbTextCompare) & ".txt"
DoCmd.OutputTo acOutputModule, RPT.Module.Name, acFormatTXT, fn
Set RPT = Nothing
If Not wasLoaded Then
DoCmd.Close acReport, strName, acSaveNo
End If
DoEvents
Next obj
SysCmd acSysCmdClearStatus
End Sub
Sub DevTool_ExportTableNames()
Dim db As DAO.Database
Dim tdfs As DAO.TableDefs
Dim tdf As DAO.TableDef
Dim strPath As String
Dim fn1 As String
Dim fn2 As String
Dim fn3 As String
Dim intFile1 As Integer
Dim intFile2 As Integer
Dim intFile3 As Integer
Dim strTbl As String
Dim strMDB As String
Dim isLinked As Boolean
Set db = CurrentDb
strPath = mstrCodeExportDir & ""
fn1 = strPath & "table_names_all.txt"
fn2 = strPath & "table_names_linked.txt"
fn3 = strPath & "table_names_local.txt"
intFile1 = FreeFile
Open fn1 For Output As #intFile1
intFile2 = FreeFile
Open fn2 For Output As #intFile2
intFile3 = FreeFile
Open fn3 For Output As #intFile3
Set tdfs = db.TableDefs
If tdfs.Count > 0 Then
For Each tdf In tdfs
strTbl = tdf.Name
SysCmd acSysCmdSetStatus, "Table: " & strTbl
' Do not list MS Access system tables.
If Left(strTbl, 4) "MSys" Then
Print #intFile1, strTbl
isLinked = (tdf.Properties("Updatable") = False) And (Nz(tdf.Properties("Connect"), "") "")
If isLinked Then
strMDB = Nz(tdf.Properties("Connect"), "")
If Left(strMDB, 10) = ";DATABASE=" Then
strMDB = Right(strMDB, Len(strMDB) - 10)
End If
Print #intFile2, padStrL(30, strTbl) & " " & strMDB
Else
Print #intFile3, strTbl
End If
End If
Next tdf
End If
Close #intFile1
Close #intFile2
Close #intFile3
SysCmd acSysCmdClearStatus
End Sub
Private Function padStrL(intLen As Integer, ByVal S As String)
While Len(S) < intLen
S = S & " "
Wend
padStrL = S
End Function
One point I'd like to make regarding this VBA code is that I no longer think the practice of prefixing variable names with a type indicator (strBlah, intBlah, etc.) is helpful. I don’t think it is worthwhile to change the variable names just to get rid of that prefix so I left the code as it was when I wrote these modules.
What I have not included in this post are examples of calling the subroutines in these modules. For the code export utility I just run DevTool_ExportCode() manually from the Visual Basic editor. For the other modules I’m assuming that if you have the need for that functionality you probably know how to figure out how to call the subroutines (and you may very well have better ways of performing these functions). If you would like more detail, or if you have a better way, let me know.
Blue Cog Blog 