Computer Genius Blog :: aka “TheGarage”

Where I work they have over a hundred Microsoft Access databases that act as interfaces into their corporate SQL data. These databases range from Access 97 to Access 2003. My client would like to get away from this code base but so much of their business rules are embedded in the access code (VB6) that it has proven difficult to even contemplate ditching MS Access and VB6. Lax version control has made the planning much more difficult and tedious. Live and learn, right.

To get a handle on the task at hand I wanted to document all the databases by recording all the objects into another database. A meta-database, as it were. Didn’t seem like a big deal until I started trying to access different properties of some of the different objects I was interested in; specifically the record source for reports and forms and the content of the code modules. I came to the conclusion in the process that the Microsoft object model is so unwieldy that I now categorize it as crap.

So the Internet search for knowledge began and the insight that I needed to finish my little utility came from John Barnett who wrote a similar utility called mdbDoc that builds a nice html document of all the db objects contained in an Access application. His app was set up as an MS Access add-on (.mda) that could be executed from within any Access application. It is a very nice piece of work except that the html formatting is embedded with the code and that it has to be run one database at a time. I needed to document a couple hundred databases all at once and with an eye toward consolidation I needed to be able to view all the queries from all the applications sorted together in one place. Same with the code modules and tables. Though his utility wasn’t suitable for what I needed I was able to configure it as if it were a function in my app and attached the resulting HTML doc to a rich text field in the database structure I built for each .mdb file.

There were a couple of subroutines in John’s code that I was going to have to write or do without so with much gratitude I borrowed the ListCodeBlocks and dependent subs from John Barnett’s mdbDoc. I have a nice Logger class that I use when scripting in Domino but since I was doing this all in VB6 and I am so rusty with VB, I borrowed John’s mdbdclsFileHandle too. Another nice piece of work that takes away all the mundane tasks of reading and writing to disk.

So here it is. The following code builds a Domino database with a record for each MS Access object. The back end could just as easily by SQL Server or MySQL. I just chose Domino because it was easily accessible and convenient. Now I can sort by object type regardless of what database actually contains the object.

To use the app you fill an array with all the target directories you want to scan. You can rig it to crawl servers but in my case that was extra features that weren’t needed.

When you start the application you check off the objects you want to document and click ‘Do It!’ When the app finishes you open up your target database and look at the results. In Domino it looks something like this:

The main code follows. If you want the modDocumenter code or the file handle class in John Barnett’s mdbd utility, you can get it from his site, linked above. (If you have a free editor like like PSPad or ConText, paste the code over there. To me it’s easier to read code that way.)

'Global declarations
Dim iFileNo As Integer
Dim Filename As String
Dim appName As String
Dim acDB As DAO.Database
Dim myfh As mdbdclsFileHandle
Dim applobj As Object
Dim sourceDir() As String
Dim errLocation As String
Dim errMsgPre As String
Global doc
Global db
Dim I As Integer
Dim j As Integer
Dim k As Integer

Public Sub dumpCSV(m As Object)
    On Error GoTo Err_ProcessErr

    'define part of eror message we will reuse
    errMsgPre = "***ERROR-Main Dump: DBName --> " + Filename

    Dim tmp As String

    'set up a file to send log info generated by the script
    Set myfh = New mdbdclsFileHandle  'Thanks to John Barnett for this handy file handle class
    With myfh
        .Filename = "C:tempdumperrors.txt" ' prepare the file
        .FileMode = "A"
        .OpenFile
        .WriteData "Starting up analyzer"
    End With
    Debug.Print "Starting up analyzer"

    'set the source directories we want to scan for .mdb files
    loadDirs

    'Establish Notes connectivity through COM/OLE or whatever it's called
    'Domino Objects need to be included in Tools/References
    Dim notesDBPath As String                               'location of the target notes db
    notesDBPath = "//notes_server/dcc/AccessApps1.nsf"
    Set s = CreateObject("Notes.Notessession")
    Set db = s.GetDatabase("", notesDBPath)

    'Instantiate an access application from whence all other access objects are derived.
    Set applobj = CreateObject("Access.Application")

    'Iterate through all the specified dirs
    For I = 0 To UBound(sourceDir)
       ' If I < 0 Or I > 122 Then GoTo nextDir 'Use this condition to skip directories if needed
        errLocation = "***Start new directory --> " + sourceDir(I)
        myfh.WriteData errLocation
        Debug.Print errLocation

        'put a filter on our souceDIR so the DIR() command will only return access dbs
        DirSourceDir = sourceDir(I) + "*.mdb"

        'for each mdb file we will first create a top level notes doc
        'and then proceed to loop through and document the access design objects
        Filename = Dir(DirSourceDir, 0)
        Do While Not Filename = ""
            appName = Filename
            errLocation = " **Start new database -->" + Filename
            myfh.WriteData errLocation
            Debug.Print errLocation

            'exclude some problem databasses we know about
            errLocation = "...excluding..."
            If excludedFile(Filename) Then GoTo skip
            errLocation = "...processing..."

            'set up our Access application object
            ShowAccess instance:=applobj, size:=SW_MAXIMIZE
            SendKeys "+"
            applobj.OpenCurrentDatabase (sourceDir(I) + Filename)
            applobj.Visible = False
            Set acDB = applobj.CurrentDb

            'See if there is already a Notes doc for this db
            Set nView = db.GetView("AllDBsByName")
            Set doc = nView.GetDocumentByKey(Filename)

            'If there is no doc already in Notes for this db we need to set one up
            If doc Is Nothing Then
                Set doc = db.CreateDocument
                doc.dbname = Filename
                doc.Form = "DBInfo"
                doc.sourceLocation = sourceDir(I)
                doc.DBVersion = acDB.VERSION

                'call the mdbdoc analysis
                '***This is where you plug in the call to mdbDocumenter to attach the html report.
                '***If you re-analyze the objects you only need to do this once.
                '***If anyone is interested in seeing how this works I can post the snippet.
                'mdbDocumenter (doc, acDB) 'removed from final version due to performance issue
               Call doc.Save(True, True)
            End If

            'now lets work thru the access objects and create response docs for every object
            'm is the me object passed in from the form.
            If m.CheckQ.Value = 1 Then doQueries
            If m.CheckT.Value = 1 Then doTables
            If m.CheckM.Value = 1 Then doModules
            If m.CheckF.Value = 1 Then doForms
            If m.CheckR.Value = 1 Then doReports
            If m.CheckRef.Value = 1 Then doReferences
            If m.CheckMac.Value = 1 Then doMacros

            'clean up
            Set acDB = Nothing
            applobj.CloseCurrentDatabase
            errLocation = "   Completed processing database --> " + Filename

skip:
            myfh.WriteData errLocation
            myfh.WriteData ""
            Debug.Print errLocation
            Filename = Dir()
         '   Exit Sub   'Uncomment this to do just one db
        Loop 'Next databsase

        myfh.WriteData "***Completed processing directory --> " + sourceDir(I)
        Debug.Print "***Completed processing directory --> " + sourceDir(I)

nextDir:
        myfh.WriteData ""
        myfh.WriteData ""
    Next I 'Next target Directory

    'clean up
    Set doc = Nothing
    Set rdoc = Nothing
    Set db = Nothing
    Set s = Nothing
    Set obj = Nothing
    Set rt = Nothing
    Set acDB = Nothing
    Set applobj = Nothing
    myfh.WriteData "Shutting down analyzer..."
    myfh.CloseFile
    Debug.Print "Shutting down analyzer..."
    Exit Sub

Err_ProcessErr:
    errLocation = errLocation + " -- " + Err.Description + " (Skipping to next database)"
        Resume skip

End Sub

Private Sub doQueries()
        On Error GoTo Err_Queries
        Debug.Print "Processing Queries..."
        Dim qd As DAO.QueryDef
        errLocation = errMsgPre + " :: Querydefs ***ERROR --> " + Err.Description
        For Each qd In acDB.QueryDefs
            Set rdoc = db.CreateDocument
            rdoc.dbname = appName
            rdoc.resourceName = qd.Name
            rdoc.resourceType = QueryDefType(qd.Type)
            rdoc.SQL = qd.SQL
            rdoc.Form = "DBQuery"
            rdoc.sourceLocation = sourceDir(I)
            rdoc.MakeResponse (doc)
            Call rdoc.Save(True, True)
            Set rdoc = Nothing
        Next

Err_Queries:
    errLocation = errLocation + " -- " + Err.Description
    'Resume Next

End Sub

Private Sub doTables()
    On Error GoTo Err_Tables
    Debug.Print "Processing Tables..."
    errLocation = errMsgPre + " :: TableDefs ***ERROR --> " + Err.Description
    Dim td As DAO.TableDef
    Dim fld As DAO.FIELD
    Dim ItemVal1 As String
    Dim ItemVal2 As String
    Dim ItemVal3 As String
    Dim ItemVal4 As String

    For Each td In acDB.TableDefs
        Set rdoc = db.CreateDocument
        rdoc.dbname = appName
        rdoc.resourceName = td.Name
        If Len(td.Connect) > 0 Then
        rdoc.remoteLocation = td.Connect
        End If
        rdoc.Form = "DBTable"
        rdoc.sourceLocation = sourceDir(I)

        rdoc.MakeResponse (doc)
        Call rdoc.Save(True, True)

        'init our variables to build the field documentation
        ItemVal1 = ""
        ItemVal2 = ""
        ItemVal3 = ""
        ItemVal4 = ""

        For Each fld In td.Fields 'build some semi-colon delimited lists
            ItemVal1 = ItemVal1 + fld.Name + ";"
            If fld.Type = 10 Then
                ItemVal2 = ItemVal2 + getFieldType(fld, fld.size) + ";"
            Else
                ItemVal2 = ItemVal2 + getFieldType(fld, 0) + ";"
            End If
            If fld.Required Then
                ItemVal3 = ItemVal3 + "True" + ";"
            Else
                ItemVal3 = ItemVal3 + "False" + ";"
            End If
            If mdbdIsPK(td, fld) Then
                ItemVal4 = ItemVal4 + "True" + ";"
            Else
                ItemVal4 = ItemVal4 + "False" + ";"
            End If
        Next 'field

        'put the lists we just built into a multi-value notes field.
        Set item1 = rdoc.ReplaceItemValue("col_1", ItemVal1)
        Set item2 = rdoc.ReplaceItemValue("col_2", ItemVal2)
        Set item3 = rdoc.ReplaceItemValue("col_3", ItemVal3)
        Set item4 = rdoc.ReplaceItemValue("col_4", ItemVal4)
        Call rdoc.Save(True, True)
        Set rdoc = Nothing
    Next

Err_Tables:
    errLocation = errLocation + " -- " + Err.Description
    Resume Next

End Sub

Private Sub doReports()
'you can't get a report object unless the report is open. The "AllReports" Object returns a collection
'of AccessObjects, not report objects. Since we are interested in documenting the "recordsource" property
'of the report object we need to open the rpt first.

    On Error GoTo Err_Reports
    Debug.Print "Processing Reports..."
    Dim rpt As Access.Report
    openAllReports applobj
    errLocation = errMsgPre + " :: REPORTS ***ERROR --> " + Err.Description

    For Each rpt In applobj.Reports
        Set rdoc = db.CreateDocument
        rdoc.dbname = appName
        rdoc.resourceName = rpt.Name
        rdoc.resourceType = rpt.RecordSource
        rdoc.Form = "DBReport"
        rdoc.sourceLocation = sourceDir(I)
        rdoc.MakeResponse (doc)
        Call rdoc.Save(True, True)
        Set rdoc = Nothing
'       applobj.DoCmd.Close acReport, rpt.Name    'Dont do this, it screws up the iteration
    Next

Err_Reports:
    errLocation = errLocation + " -- " + Err.Description
    Resume Next

End Sub

Private Sub doForms()
'you can't get a form object using app.forms unless the form is open. The "AllForms" Object returns a collection
'of AccessObjects, not form objects. Since we are interested in documenting the "recordsource" and the "AccessObject" does
'not expose the "recordsource" property we need to open the form first.

    On Error GoTo Err_Forms
    Debug.Print "Processing Forms..."
    Dim frm As Access.Form
    openAllForms applobj
    errLocation = errMsgPre + " :: FORMS ***ERROR --> " + Err.Description
    For Each frm In applobj.Forms
        Set rdoc = db.CreateDocument
        rdoc.dbname = appName
        rdoc.resourceName = frm.Name
        rdoc.resourceType = frm.RecordSource
        rdoc.Form = "DBForm"
        rdoc.sourceLocation = sourceDir(I)
        rdoc.MakeResponse (doc)
        Call rdoc.Save(True, True)
        Set rdoc = Nothing
'       applobj.DoCmd.Close acForm, frm.Name, acSavePrompt  'Dont do this, it screws up the iteration
    Next

Err_Forms:
    errLocation = errLocation + " -- " + Err.Description
    Resume Next

End Sub

Private Sub doModules()
    On Error GoTo Err_Modules
    Debug.Print "Processing Modules..."
    Dim m As Module
    Dim modArray(1) As String
    Dim myModStr As String

    'The Modules collection only returns open modules so...
    openAllModules applobj
    errLocation = errMsgPre + " :: MODULES ***ERROR --> " + Err.Description

    'We want 2 lists from this iteration so I'm using an array.
    'Module headers go in ndx(0) and code in ndx(1)
    modArray(0) = ""
    modArray(1) = ""

    For k = 0 To Modules.Count - 1
        Set rdoc = db.CreateDocument
        rdoc.dbname = appName
        rdoc.resourceName = Modules(k).Name
        rdoc.Form = "DBModule"
        rdoc.sourceLocation = sourceDir(I)
        Call ListCodeBlocks(Modules(k), modArray)
        Set rt = rdoc.CreateRichTextItem("ModuleHeaders")
        Set rt1 = rdoc.CreateRichTextItem("ModuleDetails")
        Call rt.AppendText(modArray(0))
        Call rt1.AppendText(modArray(1))
        rdoc.MakeResponse (doc)
        Call rdoc.Save(True, True)
        Set rt = Nothing
        Set rt1 = Nothing
        Set rdoc = Nothing
        modArray(0) = ""
        modArray(1) = ""
        'applobj.DoCmd.Close acModule, Modules(k).Name   'Dont do this, it screws up the iteration
    Next

Err_Modules:
    errLocation = errLocation + " -- " + Err.Description
    Resume Next

End Sub

Private Sub doMacros()
    On Error GoTo Err_Macros
    Debug.Print "Processing Macros..."
    Dim q As AccessObject
    For Each q In applobj.CurrentProject.AllMacros
        errLocation = errMsgPre + " :: MACROS ***ERROR --> " + Err.Description
        Set rdoc = db.CreateDocument
        rdoc.dbname = appName
        rdoc.resourceName = q.Name
        rdoc.Form = "DBMacro"
        rdoc.sourceLocation = sourceDir(I)
        rdoc.MakeResponse (doc)
        Call rdoc.Save(True, True)
        Set rdoc = Nothing
    Next

Err_Macros:
    errLocation = errLocation + " -- " + Err.Description
    Resume Next

End Sub

Private Sub doReferences()
    On Error GoTo Err_References
    errLocation = errMsgPre + " :: REFERENCES ***ERROR --> " + Err.Description
    Debug.Print "Processing References..."
    Dim rc As Access.Reference
    For Each rc In applobj.References
        Set rdoc = db.CreateDocument
        rdoc.dbname = appName
        'the fullpath property throws an error on a regular basis so lets not skip to next db just because of that
        On Error Resume Next
        rdoc.resourceName = rc.Name + " :: " + rc.FullPath
        On Error GoTo Err_References
        rdoc.Form = "DBReference"
        rdoc.sourceLocation = sourceDir(I)
        rdoc.MakeResponse (doc)
        Call rdoc.Save(True, True)
        Set rdoc = Nothing
        Set rc = Nothing
    Next

Err_References:
    errLocation = errLocation + " -- " + Err.Description
    Resume Next

End Sub

Sub openAllReports(app As Access.APPLICATION)
    On Error GoTo Err_ProcessOpenRptErr
    For Each r In app.CurrentProject.AllReports
        app.DoCmd.OpenReport r.Name, acViewDesign, windowmode:=acHidden
    Next
    Exit Sub

Err_ProcessOpenRptErr:
 '   MsgBox Err.Description
    Debug.Print "     Sub openAllReports: " + Err.Description
 '   myfh.WriteData "     Sub openAllReports: " + Err.Description
    Resume Next
End Sub

Sub openAllForms(app As Access.APPLICATION)
    On Error GoTo Err_ProcessOpenFormErr
    For Each r In app.CurrentProject.AllForms
        app.DoCmd.OpenForm r.Name, acViewDesign, windowmode:=acHidden
    Next
    Exit Sub

Err_ProcessOpenFormErr:
 '   MsgBox Err.Description
    Debug.Print "     Sub openAllForms: (" + r.Name + ") " + Err.Description;
   ' myfh.WriteData "     Sub openAllForms: " + Err.Description
    Resume Next
End Sub

Sub openAllModules(app As Access.APPLICATION)
    On Error GoTo Err_ProcessOpenModErr
    For Each m In app.CurrentProject.AllModules
        app.DoCmd.OpenModule m.Name
    Next
    Exit Sub

Err_ProcessOpenModErr:
 '   MsgBox Err.Description
    Debug.Print "     Sub openAllModules: " + Err.Description
   ' myfh.WriteData "     Sub openAllForms: " + Err.Description
    Resume Next
End Sub

Public Function GetAppName(nm As String) As String
            Dim wAppName As String
            Dim myApplCd As String
            Dim I As Integer

            wAppName = nm

            '-- Strip off the application name
            myApplCd = ""

            For I = Len(wAppName) To 1 Step -1
                If Mid(wAppName, I, 1) = "\" _
                Or Mid(wAppName, I, 1) = ":" Then
                    'wAppDir = Left(wAppName, i - 1)
                    Exit For
                End If

                myApplCd = Mid(wAppName, I, 1) & myApplCd
            Next I

            GetAppName = myApplCd

End Function

Function QueryDefType(intType As Integer) As String

   Select Case intType
      Case dbQSelect
         QueryDefType = "dbQSelect"
      Case dbQAction
         QueryDefType = "dbQAction"
      Case dbQCrosstab
         QueryDefType = "dbQCrosstab"
      Case dbQDelete
         QueryDefType = "dbQDelete"
      Case dbQUpdate
         QueryDefType = "dbQUpdate"
      Case dbQAppend
         QueryDefType = "dbQAppend"
      Case dbQMakeTable
         QueryDefType = "dbQMakeTable"
      Case dbQDDL
         QueryDefType = "dbQDDL"
      Case dbQSQLPassThrough
         QueryDefType = "dbQSQLPassThrough"
      Case dbQSetOperation
         QueryDefType = "dbQSetOperation"
      Case dbQSPTBulk
         QueryDefType = "dbQSPTBulk"
   End Select

End Function

Private Function getFieldType(fld As DAO.FIELD, intSize As Integer)
Select Case fld.Type
    Case dbText
        getFieldType = "Text (" & intSize & ")"
    Case dbBigInt
        getFieldType = "Big Integer"
    Case dbBinary
        getFieldType = "Binary"
    Case dbBoolean
        getFieldType = "Boolean"
    Case dbByte
        getFieldType = "Byte"
    Case dbChar
        getFieldType = "Char"
    Case dbCurrency
        getFieldType = "Currency"
    Case dbDate
        getFieldType = "Date / Time"
    Case dbDecimal
        getFieldType = "Decimal"
    Case dbDouble
        getFieldType = "Double"
    Case dbFloat
        getFieldType = "Float"
    Case dbGUID
        getFieldType = "Guid"
    Case dbInteger
        getFieldType = "Integer"
    Case dbLong
        getFieldType = "Long"
    Case dbLongBinary
        getFieldType = "Long Binary (OLE Object)"
    Case dbMemo
        getFieldType = "Memo"
    Case dbNumeric
        getFieldType = "Numeric"
    Case dbSingle
        getFieldType = "Single"
    Case dbTime
        getFieldType = "Time"
    Case dbTimeStamp
        getFieldType = "Time Stamp"
    Case dbVarBinary
        getFieldType = "VarBinary"
    Case Else
        getFieldType = "Unknown field type " & fld.Type
End Select

' If the field has specific attributes, override the ones specified above.
If fld.Attributes And dbAutoIncrField Then
    getFieldType = "Auto Number"
End If
If fld.Attributes And dbHyperlinkField Then
    getFieldType = "Hyperlink"
End If
End Function

Private Sub ListCodeBlocks(mdl As Module, myMod() As String)
'MDBDOC: Provides a list of code blocks within a module and writes them to an output file.
' Function: mdbdListCodeBlocks
' Scope:    Private
' Parameters: mdl - Module to process; outfile - mdbdclsfilehandle to process data with.
' Return Value: String
' Author:   John Barnett
' Date:     22 July 2001.
' Description: mdbdListCodeBlocks parses the source code of a module and lists out the
' names, prototypes & return values of sub, function and property procedures.
' Called by: Modules, Form Modules and Report Modules section of mdbdProcessDatabase.
'
' As this module is quite complex, extra comments are included below indicating how it works.

Dim strCurrentLine As String
Dim strDescription As String
Dim intCount As Integer, intStartLine As Integer, intStart As Integer
Dim blnWrittenHeader As Boolean
Dim blnProcHeader As Boolean, intLoop As Integer
Static strStartCombinations(1 To 25) As String ' Create static array as this can be used many times.
Dim strBody As String
Dim strHeaders As String

' Insert the data into the array
strStartCombinations(1) = "Property Get" ' Property Get routines
strStartCombinations(2) = "Public Property Get"
strStartCombinations(3) = "Public Static Property Get"
strStartCombinations(4) = "Private Static Property Get"
strStartCombinations(5) = "Private Property Get"

strStartCombinations(6) = "Property Let" ' Property Let routines
strStartCombinations(7) = "Public Property Let"
strStartCombinations(8) = "Public Static Property Let"
strStartCombinations(9) = "Private Property Let"
strStartCombinations(10) = "Private Static Property Let"

strStartCombinations(11) = "Property Set" ' Property Set routines
strStartCombinations(12) = "Public Property Set"
strStartCombinations(13) = "Public Static Property Set"
strStartCombinations(14) = "Private Property Set"
strStartCombinations(15) = "Private Static Property Set"

strStartCombinations(16) = "Function" ' Functions
strStartCombinations(17) = "Public Function"
strStartCombinations(18) = "Private Function"
strStartCombinations(19) = "Public Static Function"
strStartCombinations(20) = "Private Static Function"

strStartCombinations(21) = "Sub" ' Subs
strStartCombinations(22) = "Public Sub"
strStartCombinations(23) = "Private Sub"
strStartCombinations(24) = "Public Static Sub"
strStartCombinations(25) = "Private Static Sub"

' Means of starting in case there are no declaration lines in the module.
If mdl.CountOfDeclarationLines > 0 Then
    intStart = mdl.CountOfDeclarationLines
Else
    intStart = 1
End If

For intCount = intStart To mdl.CountOfLines
    ' Loop through the module, line by line avoiding the declaration section
    If Len(mdl.Lines(intCount, 1) & "") > 0 Then
        strCurrentLine = mdl.Lines(intCount, 1) & "" ' Grab the current line
        strCurrentLine = Trim$(strCurrentLine)  ' remove any leading / trailing spaces
    Else
        strCurrentLine = ""
    End If

    ' Now retrive MDBDoc's procedure/sub/function/property comments.

    If UCase$(Left$(strCurrentLine, 8)) = "'MDBDOC:" Then
        ' comments start 'MDBDOC:
        strDescription = Trim(Mid$(strCurrentLine, 9))
    End If

    If Left$(strCurrentLine, 1) <> "'" And Left$(strCurrentLine, 3) <> "Rem" Then
        ' Ignore comments

        Do While Right$(strCurrentLine, 1) = "_" ' If continuation char at end of line - grab continual until none left.
            ' grab the next line
            strCurrentLine = Left$(strCurrentLine, Len(strCurrentLine) - 1)  ' strip it off
            strCurrentLine = strCurrentLine & Chr$(13) & mdl.Lines(intCount, 1) ' and grab the next one
            intCount = intCount + 1
        Loop

        ' but now find out what type it is by comparing it to each element in the array in turn.
        intStartLine = 0
        For intLoop = LBound(strStartCombinations) To UBound(strStartCombinations)
            If Left$(strCurrentLine, Len(strStartCombinations(intLoop))) = strStartCombinations(intLoop) Then
                ' If its correct, then set the procedure header flag and record the start line number
                myMod(0) = myMod(0) & strCurrentLine
                intStartLine = intCount
            End If
        Next

        'All Lines go here. Comment this out if you dont want to document the code body
        myMod(1) = myMod(1) & strCurrentLine & Chr$(13)

        'When we find and END then closse out the Header line
        If Left$(strCurrentLine, 7) = "End Sub" Or Left$(strCurrentLine, 12) = "End Function" Or Left$(strCurrentLine, 12) = "End Property" Then
            myMod(0) = myMod(0) & Chr$(9) & intCount - intStartLine - 1 & Chr$(13)
            strDescription = ""
            intStartLine = 0
        End If
    End If
Next
'ListCodeBlocks = strHeaders & "~" & strBody
End Sub

Private Function mdbdReplaceSpecialChars(strInputString As String) As String
'MDBDOC: This function replaces special punctuation characters with their HTML escape equivalent
' Function: mdbdReplaceSpecialChars
' Scope:    Private
' Parameters: strInputString - input string
' Author:   John Barnett
' Date:     1 November 2003.
' Description: Repeatedly calls the mdbdReplace2 function (also written for tek-tips) to replace occurrences of special characters with their HTML escape equivalents.
' Called by: various parts of ProcessDatabase, for formatting description fields, SQL code, MDBDoc user comments etc. Basically anywhere where user defined text output could be written to the output file.

Dim strTemp As String

strTemp = mdbdReplace2(strInputString, "&", "&")
strTemp = mdbdReplace2(strTemp, "<", "<")
strTemp = mdbdReplace2(strTemp, ">", ">")
strTemp = mdbdReplace2(strTemp, "©", "©")
mdbdReplaceSpecialChars = strTemp
End Function

Private Function mdbdReplace2(Expression As String, Find As String, Replace As String, Optional Start As Long = 1) As String
'MDBDOC: Replace2 function taken from Tek-Tips database used for search/replace of special characters with their escape sequences.
' Author: John Barnett, handle jrbarnett
' In response to: http://www.tek-tips.com/viewthread.cfm?SQID=565966&SPID=700&page=1
' Date: 4th June 2003
' Purpose: A Find and replace VBA function for Access 97 and 2000, which didn't have the Replace() function of 2002(XP).
' although it does work in 2002 as well.  It implements the mandatory functionality of the 2002 function plus the optional start, but not the Count of replacements and Binary Compare method.
' It has the same function header, so can be dropped in as a replacement.
' Called by mdbdReplaceSpecialChars to do the brute force search/replace work programmatically.

Dim strResult As String ' variable to store result
Dim intPosition As Integer ' variable to store current position in Expression
Dim intStartPos As Integer ' variable to store current starting position within 'expression'

If IsMissing(Start) Then
    intStartPos = 1 ' start position not supplied; so set it to beginning
Else
    intStartPos = Start ' otherwise set it and...
    strResult = Left$(Expression, Start - 1) ' start by copying over first chars before start position
End If

intPosition = InStr(Expression, Find) ' locate first occurrence of 'find' data
' Remember that intPosition will = 0 if no occurrences are found.

Do While intPosition > 0
    strResult = strResult & Mid$(Expression, intStartPos, (intPosition - intStartPos)) ' copy everything over from it that hasn't been copied yet
    intStartPos = intPosition + Len(Find) ' increase the pointer by the length of the "to find" data so it won't find the current occurrence
    strResult = strResult & Replace ' add the replacement data
    intPosition = InStr(intPosition + Len(Find), Expression, Find) ' and reset the position for the new start point
Loop

' In case we aren't changing the very last part of the string...
If intStartPos < Len(Expression) Then
    ' copy over rest to result
    strResult = strResult & Mid$(Expression, intStartPos)
End If
mdbdReplace2 = strResult ' and return a value
End Function

Function excludedFile(fn As String) As Boolean
    excludedFile = False
    If fn = "emabsmnSQL.mdb" Or _
        fn = "2004_United_Way.mdb" Or _
        InStr(LCase(fn), "united_way") > 0 Or _
        InStr(LCase(fn), "old") > 0 Or _
        InStr(LCase(fn), "prior") > 0 Or _
        InStr(LCase(fn), "test") > 0 Or _
        InStr(LCase(fn), "copy") > 0 Or _
        InStr(LCase(fn), "bac") > 0 Then excludedFile = True
End Function

Private Sub loadDirs()
     'be sure to include the last backslash
     ReDim sourceDir(num_of_dirs_to_scan) As String

     'assign every directory you wish to scan to the sourceDir array
     sourceDir(0) = "//server_1/some_dir_with_mdb_files/"
     .
     .
     .
     sourceDir(n) = "//server_n/some_other_dir_with_mdb_files/"
End Sub

Share This