Blue Cog Blog

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, "<html>"
    Print #intFileH, "<head>"
    Print #intFileH, "<title>" & strTitle2 & "</title>"
    Print #intFileH, "</head>"
    Print #intFileH, "<body>"
    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 & "&nbsp;&nbsp;&nbsp;" & strTblTyp & "</b><br>"
        Print #intFileH, "<table border=""1"">"
        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>&nbsp;</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, "</body>"
  Print #intFileH, "</html>"
  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.