Attribute VB_Name = "modMarkSourceCode" 
Option Explicit 
Option Base 1 
 
Const acDesign = 1& 
Const acFormReadOnly = 2& 
Const acViewDesign = 1& 
Const acModule = 5& 
Const acForm = 2& 
Const acReport = 3& 
Const acQuery = 1& 
Const vbext_pk_Proc = 0 
 
Public Sub MarkTOC() 
    Dim objects() 
    Dim obj 
    ReDim TOC(5) 
    Dim strTOC          As String 
    Dim i               As Integer 
    Dim j               As Integer, k As Integer 
    Dim rng             As Range 
    Dim strDB           As String 
    Dim aWhereUsed 
    Dim strObjName      As String 
    Dim strDBName       As String 
    Dim strForms        As String 
    Dim strReports      As String 
    Dim strQueries      As String 
    Dim tbl             As Table 
    Dim fso             As Object 
    Dim blnWU            As Boolean 
    Dim response 
     
    On Error GoTo MarkTOC_Error 
     
    ActiveDocument.ShowGrammaticalErrors = False 
    ActiveDocument.ShowSpellingErrors = False 
    Application.ScreenUpdating = False 
     
     'initialize array of procedures from original db
    Set rng = ActiveDocument.Content 
    rng.Find.Execute findtext:="^t", Forward:=True 
    strDB = ActiveDocument.Range(Start:=0, End:=rng.Start).Text 
    strDBName = strDB 
    Set fso = CreateObject("Scripting.FileSystemObject") 
     
    If Not fso.FileExists(strDB) Then 
        MsgBox "Access database not available; cannot proceed", vbCritical, "Database error" 
        Exit Sub 
    End If 
     
    response = MsgBox("Include Where Used table?", vbYesNoCancel, "MarkUp Source Code") 
    Debug.Print response = vbYes 
    Select Case response 
    Case vbYes 
        blnWU = True 
    Case vbNo 
        blnWU = False 
    Case vbCancel 
        Exit Sub 
    End Select 
     
     'remove hard-wired page numbers
    StripPageNumbers 
     
     'define array of possible objects in documentation
    objects() = Array("Query", "Form", "Module", "Report", "Macro") 
    i = 1 
     
     'define array of objects that exist in documentation
    For Each obj In objects() 
        Set rng = ActiveDocument.Content 
        If rng.Find.Execute(findtext:=obj & ":", Forward:=True) Then 
            TOC(i) = obj 
            i = i + 1 
        End If 
    Next 
    i = i - 1 
    ReDim Preserve TOC(i) 
     
     'set a heading style for unique objects in documentation
     
    For Each obj In TOC() 
        Set rng = ActiveDocument.Content 
        Do While rng.Find.Execute(findtext:=obj & ": ", Forward:=True, MatchCase:=True) 
            rng.Expand Unit:=wdParagraph 
            rng.MoveEnd Unit:=wdCharacter, Count:=-1 
             
             'only markup once per object; object name must be at beginning of line
            If rng.Text <> strTOC And InStr(rng.Text, obj) = 1 Then 
                 'get limits of previous object and its name
                 
                strTOC = rng.Text 
                 'replace wdStyleHeading3 with preferred heading style
                rng.Style = wdStyleHeading3 
                strObjName = Right(strTOC, Len(strTOC) - Len(obj) - 2) 
                 
                 'code below populates strings with names of found objects
                Select Case obj 
                Case "Form" 
                    If InStr(strForms, strObjName) = 0 Then 
                        strForms = strObjName & "," & strForms 
                    End If 
                Case "Report" 
                    If Not InStr(strReports, strObjName) Then 
                        strReports = strObjName & "," & strReports 
                    End If 
                Case "Query" 
                    If Not InStr(strQueries, strObjName) Then 
                        strQueries = strObjName & "," & strQueries 
                    End If 
                     
                End Select 
                 
            End If 
            rng.Collapse direction:=wdCollapseEnd 
             
        Loop 
    Next 
     
    If blnWU Then 
         'create array of modules and procedures
        aWhereUsed = ModuleInfo(strDB) 
         
        If strForms <> "" Then 
            aWhereUsed = isInThis(strDBName, "Forms", strForms, aWhereUsed) 
        End If 
         
        If strReports <> "" Then 
            aWhereUsed = isInThis(strDBName, "Reports", strReports, aWhereUsed) 
        End If 
         
        If strQueries <> "" Then 
            aWhereUsed = isInThis(strDBName, "Queries", strQueries, aWhereUsed) 
        End If 
         
         'aInProcs = inProc(strDBName, awhereused)
         
        Application.ScreenUpdating = True 
         'add page to end of source code
        Set rng = ActiveDocument.Range 
        rng.Collapse direction:=wdCollapseEnd 
        rng.InsertBreak Type:=wdPageBreak 
        rng.Text = "Where Used" 
        rng.Style = wdStyleHeading3 
        rng.InsertParagraphAfter 
        rng.Collapse direction:=wdCollapseEnd 
         
        Set tbl = ActiveDocument.Tables.Add(Range:=rng, numrows:=1, numcolumns:=3) 
        tbl.Cell(1, 1).Range.InsertAfter "Module" 
        tbl.Cell(1, 2).Range.InsertAfter "Procedure" 
        tbl.Cell(1, 3).Range.InsertAfter "Where Used" 
        tbl.AllowAutoFit = True 
         
        For i = 1 To UBound(aWhereUsed, 1) 
            For j = 3 To UBound(aWhereUsed, 2) 
                If aWhereUsed(i, j) <> "" Then 
                    tbl.Rows.Add 
                    k = tbl.Rows.Count 
                    tbl.Cell(k, 1).Range.InsertAfter aWhereUsed(i, 1) 
                    tbl.Cell(k, 2).Range.InsertAfter aWhereUsed(i, 2) 
                    tbl.Cell(k, 3).Range.InsertAfter aWhereUsed(i, j) 
                End If 
            Next j 
        Next i 
         
        tbl.Rows(1).HeadingFormat = True 
         
        tbl.Sort ExcludeHeader:=True, FieldNumber:="Column 1", SortFieldType _ 
        :=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending, FieldNumber2 _ 
        :="Column 2", SortFieldType2:=wdSortFieldAlphanumeric, SortOrder2:= _ 
        wdSortOrderAscending, FieldNumber3:="Column 3", SortFieldType3:= _ 
        wdSortFieldAlphanumeric, SortOrder3:=wdSortOrderAscending 
        tbl.AllowAutoFit = True 
        tbl.ApplyStyleHeadingRows = True 
         
    End If 
     
    Set rng = ActiveDocument.Content 
    rng.Collapse direction:=wdCollapseStart 
     
    InsertPageNumbers 
     
    InsertTOC 
     
     'turn off bold throughout document
    ActiveDocument.Content.Bold = False 
     
    Application.ScreenUpdating = True 
     
    On Error GoTo 0 
    Exit Sub 
     
MarkTOC_Error: 
     
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure MarkTOC of Module NewMacros" 
End Sub 
 
 '---------------------------------------------------------------------------------------
 ' Procedure : AllProcs
 ' Author    : gwb
 ' Date      : 4/27/2010
 ' Purpose   : adopted from B. Larson to discover procedures in a module
 '---------------------------------------------------------------------------------------
 '
Private Function AllProcs(strModuleName, ByVal acDb As Object) As String() 
    Dim mdl 
    Dim lngCount As Long 
    Dim lngCountDecl As Long 
    Dim lngI As Long 
    Dim strProcName As String 
    Dim astrProcNames() As String 
    Dim intI As Integer 
    Dim lngR As Long 
    Const acModule = 5& 
     
     ' Open specified Module object.
    On Error GoTo AllProcs_Error 
     
    acDb.DoCmd.OpenModule strModuleName 
     ' Return reference to Module object.
    Set mdl = acDb.Modules(strModuleName) 
     ' Count lines in module.
    lngCount = mdl.CountOfLines 
     ' Count lines in Declaration section in module.
    lngCountDecl = mdl.CountOfDeclarationLines 
     ' Determine name of first procedure.
    strProcName = mdl.ProcOfLine(lngCountDecl + 1, lngR) 
     ' Initialize counter variable.
    intI = 1 ' Redimension array.
    ReDim Preserve astrProcNames(intI) 
     ' Store name of first procedure in array.
    astrProcNames(intI) = strProcName 
     ' Determine procedure name for each line after declarations.
    For lngI = lngCountDecl + 1 To lngCount 
         ' Compare procedure name with ProcOfLine property value.
        If strProcName <> mdl.ProcOfLine(lngI, lngR) Then 
             ' Increment counter.
            intI = intI + 1 
            strProcName = mdl.ProcOfLine(lngI, lngR) 
            ReDim Preserve astrProcNames(intI) 
             ' Assign unique procedure names to array.
            astrProcNames(intI) = strProcName 
        End If 
    Next lngI 
     
     'acDb.DoCmd.Close acModule, strModuleName
    acDb.DoCmd.Close acModule, strModuleName 
    AllProcs = astrProcNames() 
     
    On Error GoTo 0 
    Exit Function 
     
AllProcs_Error: 
     
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure AllProcs of Module modMarkSourceCode" 
     
End Function 
 
Private Sub InsertPageNumbers() 
    ActiveDocument.Paragraphs(1).TabStops.Add Position:=InchesToPoints(6), _ 
    Alignment:=wdAlignTabRight, Leader:=wdTabLeaderSpaces 
    ActiveDocument.Range.InsertBreak Type:=wdSectionBreakNextPage 
    With ActiveDocument.Sections(2).Footers(wdHeaderFooterPrimary) 
        .LinkToPrevious = False 
        .PageNumbers.RestartNumberingAtSection = True 
        .PageNumbers.StartingNumber = 1 
        .PageNumbers.Add pagenumberalignment:=wdAlignPageNumberCenter 
    End With 
End Sub 
 
Private Sub InsertTOC() 
     'Dim BBtemplate As Template, tmpTemplate As Template
    Dim rng As Range 
    Set rng = ActiveDocument.Content 
    rng.Collapse direction:=wdCollapseStart 
    rng.InsertAfter "Table of Contents" 
    rng.Font.Size = 14 
    rng.InsertParagraphAfter 
    rng.Collapse direction:=wdCollapseEnd 
    ActiveDocument.Paragraphs(2).TabStops.Add Position:=InchesToPoints(6), _ 
    Alignment:=wdAlignTabRight, Leader:=wdTabLeaderDots 
    ActiveDocument.TablesOfContents.Add Range:=rng, UseHeadingStyles:=True 
     
End Sub 
 
 '---------------------------------------------------------------------------------------
 ' Procedure : isInThis
 ' Author    : gwb
 ' Date      : 4/26/2010
 ' Purpose   :   takes string of found objects (strFound) of given object type (strType), converts to array
 '               then searchs those objects for instances of procedures appearing in aWhereUsed array
 '               if procedure is found, adds the object name and its procedure to aWhereUsed array
 '               and returns aWhereUsed
 '---------------------------------------------------------------------------------------
 '
Private Function isInThis(strDBName, strType, strFound, aWhereUsed) 
     
    Dim appAccess As Object 
    Dim db As Object 
    Dim cntContainers As Long 
    Dim aFound 
    Dim intI As Integer 
    Dim intJ As Integer 
    Dim intK As Integer 
    Dim blnProcs As Boolean 
    Dim mdl 
    Dim strProcName As String 
    Dim strModName As String 
    Dim strSQL As String 
    Dim lngStart        As Long 
    Dim strModsProc     As String 
     
    On Error GoTo isInThis_Error 
     
    Set appAccess = CreateObject("Access.Application") 
    appAccess.OpenCurrentDatabase strDBName, exclusive:=True 
    Set db = appAccess.CurrentDb 
    appAccess.Visible = False 
     
     'remove comma from end of string
    strFound = Left(strFound, Len(strFound) - 1) 
     'make array of objects
    aFound = Split(strFound, ",") 
     
    cntContainers = UBound(aFound, 1) 
     'for all the found objects
    For intI = 0 To cntContainers - 1 
         'get name of object
        strModName = aFound(intI) 
        blnProcs = False 
        Select Case strType 
        Case "Forms" 
            With appAccess 
                .DoCmd.OpenForm strModName, acDesign 
                 'get module name if it exists
                If .Forms(strModName).HasModule Then 
                    .DoCmd.OpenForm strModName, acDesign, , , acFormReadOnly 
                    Set mdl = .Forms(strModName).Module 
                    blnProcs = True 
                End If 
            End With 
        Case "Reports" 
            With appAccess 
                .DoCmd.OpenReport strModName, acDesign 
                If .Reports(strModName).HasModule Then 
                    .DoCmd.OpenReport strModName, acViewDesign 
                    Set mdl = .Reports(strModName).Module 
                    blnProcs = True 
                End If 
            End With 
        Case "Queries" 
             'check queries here
            strSQL = db.QueryDefs(strModName).SQL 
            For intK = 1 To UBound(aWhereUsed, 1) 
                strProcName = aWhereUsed(intK, 2) 
                If InStr(strSQL, strProcName) > 0 Then 
                    If aWhereUsed(intK, UBound(aWhereUsed, 2)) <> "" Then 
                        ReDim Preserve aWhereUsed(UBound(aWhereUsed, 1), UBound(aWhereUsed, 2) + 1) 
                    End If 
                     'look for first blank entry for procedure
                    intJ = 3 
                    Do While aWhereUsed(intK, intJ) <> "" 
                        intJ = intJ + 1 
                    Loop 
                     'add entry
                    aWhereUsed(intK, intJ) = strModName 
                End If 
            Next intK 
        Case Else 
        End Select 
        If blnProcs Then 
             'check for each procedure
            For intK = 1 To UBound(aWhereUsed, 1) 
                strProcName = aWhereUsed(intK, 2) 
                lngStart = 0 
                If mdl.Find(Target:=strProcName, startline:=lngStart, startcolumn:=0, endline:=999, endcolumn:=99, wholeword:=True, MatchCase:=True) Then 
                    If aWhereUsed(intK, UBound(aWhereUsed, 2)) <> "" Then 
                        ReDim Preserve aWhereUsed(UBound(aWhereUsed, 1), UBound(aWhereUsed, 2) + 1) 
                    End If 
                     'look for first blank entry for procedure
                    intJ = 3 
                    Do While aWhereUsed(intK, intJ) <> "" 
                        intJ = intJ + 1 
                    Loop 
                     'add entry
                    strModsProc = mdl.ProcOfLine(lngStart, vbext_pk_Proc) 
                    aWhereUsed(intK, intJ) = strModName & ": " & strModsProc 
                End If 
            Next intK 
        End If 
        appAccess.DoCmd.Close acModule, strModName 
        Select Case strType 
        Case "Forms" 
            appAccess.DoCmd.Close acForm, strModName 
        Case "Reports" 
            appAccess.DoCmd.Close acReport, strModName 
        Case "Queries" 
            appAccess.DoCmd.Close acQuery, strModName 
        Case Else 
        End Select 
    Next intI 
     
    appAccess.CloseCurrentDatabase 
    appAccess.Quit 
    db.Close 
    Set db = Nothing 
     
    isInThis = aWhereUsed 
     
    On Error GoTo 0 
    Exit Function 
     
isInThis_Error: 
     
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure isInThis of Module modMarkSourceCode" 
     
End Function 
 
 '---------------------------------------------------------------------------------------
 ' Procedure : ModuleInfo
 ' Author    : gwb
 ' Date      : 5/3/2010
 ' Purpose   : initializes where used array with procedures for db's normal & class modules
 '---------------------------------------------------------------------------------------
 '
Private Function ModuleInfo(strDBName) 
     
    Dim appAccess As Object 
    Dim db As Object 
     'Dim db
     
    Dim intCount As Integer 
    Dim intBound As Integer 
    Dim intI As Integer, intJ As Integer 
    Dim strDbFullName As String 
    Dim strModName As String 
    Dim aModProcs 
    Dim aModules() 
    Dim aWhereUsed() 
    Dim varProc 
    Dim sLine As Long 
    Dim lnglimit As Long 
    Dim i As Integer 
    Dim j As Integer 
    Dim k As Integer 
    Dim mdl 
    Dim procname As String 
    Dim strProc As String 
    Dim strFoundProc As String 
     
     'find out who we're working with
    On Error GoTo moduleinfo_Error 
     
    Set appAccess = CreateObject("Access.Application") 
    appAccess.Visible = False 
    appAccess.OpenCurrentDatabase strDBName, exclusive:=True 
    Set db = appAccess.CurrentDb 
     
     'redim array for number of modules
    intCount = db.Containers("Modules").Documents.Count 
    ReDim aModules(intCount, 1) 
    For intI = 1 To intCount 
        strModName = db.Containers("Modules").Documents(intI - 1).Name 
         'get array of procedures for current module
        aModProcs = AllProcs(strModName, appAccess) 
         'redim if necessary
        intBound = UBound(aModules, 2) 
        If intBound < UBound(aModProcs) Then 
            ReDim Preserve aModules(intCount, UBound(aModProcs) + 1) 
        End If 
         'load module name and its procedures
        intJ = 1 
        aModules(intI, 1) = strModName 
        For Each varProc In aModProcs 
            intJ = intJ + 1 
            aModules(intI, intJ) = varProc 
        Next varProc 
    Next intI 
     
     'get size for where used array
    lnglimit = 1 
    For i = 1 To UBound(aModules, 1) 
        For j = 2 To UBound(aModules, 2) 
            If aModules(i, j) = "" Then 
                lnglimit = lnglimit + 1 
            End If 
        Next j 
    Next i 
     
    ReDim aWhereUsed(UBound(aModules, 1) * (UBound(aModules, 2) - 1) - lnglimit + 1, 3) 
     'load where used array
    k = 1 
    For i = 1 To UBound(aModules, 1) 
        For j = 2 To UBound(aModules, 2) 
            If aModules(i, j) <> "" Then 
                aWhereUsed(k, 1) = aModules(i, 1) 
                aWhereUsed(k, 2) = aModules(i, j) 
                k = k + 1 
            End If 
             
        Next j 
    Next i 
     
    For intI = 1 To intCount 
        strModName = db.Containers("Modules").Documents(intI - 1).Name 
        appAccess.DoCmd.OpenModule strModName 
        Set mdl = appAccess.Modules(strModName) 
        For intJ = 1 To UBound(aWhereUsed, 1) 
             
            procname = aWhereUsed(intJ, 2) 
            Do While mdl.Find(procname, sLine, 0, 0, 0) 
                strProc = mdl.ProcOfLine(sLine, 0) 
                If strProc <> procname And InStr(strFoundProc, strProc) = 0 And strProc <> "" Then 
                    If aWhereUsed(intJ, UBound(aWhereUsed, 2)) <> "" Then 
                        ReDim Preserve aWhereUsed(UBound(aWhereUsed, 1), UBound(aWhereUsed, 2) + 1) 
                    End If 
                     'look for first blank entry for procedure
                    j = 3 
                    Do While aWhereUsed(intJ, j) <> "" 
                        j = j + 1 
                    Loop 
                     'add entry
                    aWhereUsed(intJ, j) = strModName & ": " & strProc 
                    strFoundProc = strFoundProc & strProc 
                     '                    i = i + 1
                End If 
                sLine = sLine + 1 
            Loop 
            strFoundProc = "" 
        Next intJ 
    Next intI 
     
     
    appAccess.CloseCurrentDatabase 
    appAccess.Quit 
    Set db = Nothing 
    ModuleInfo = aWhereUsed() 
     
    On Error GoTo 0 
    Exit Function 
     
moduleinfo_Error: 
     
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure moduleinfo of Module modMarkSourceCode" 
     
End Function 
 
 '---------------------------------------------------------------------------------------
 ' Procedure : StripPageNumbers
 ' Author    : gwb
 ' Date      : 4/12/2010
 ' Purpose   : remove hard-wired page numbers from documenter output
 '---------------------------------------------------------------------------------------
 '
Private Sub StripPageNumbers() 
    Dim length As Integer, doclen As Integer, i As Integer, j As Integer 
    Dim strPage As String, strChars As String, strPara As String 
    Dim strReplace As String 
    Dim rng As Range 
     
     'get number of pages
    On Error GoTo StripPageNumbers_Error 
     
    length = ActiveDocument.ComputeStatistics(wdStatisticPages) 
     
     'determine number of iterations to perform
    doclen = Len(Trim(Str(length))) 
    strPage = "^tPage: " 
    strChars = "^#" 
    strPara = "^p" 
     
    Set rng = ActiveDocument.Content 
     
     'for each order of magnitude, remove existing hard-wired page number
    For i = 1 To doclen 
        strReplace = strPage 
        For j = 1 To i 
            strReplace = strReplace & strChars 
        Next j 
        strReplace = strReplace & strPara 
        rng.Find.Execute findtext:=strReplace, replacewith:=strPara, Forward:=True, Replace:=wdReplaceAll 
    Next i 
     
    On Error GoTo 0 
    Exit Sub 
     
StripPageNumbers_Error: 
     
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure StripPageNumbers of Module NewMacros" 
End Sub