Option Compare Database
Option Explicit


' usage: FieldUsage_Report "[table name]"


' ============================================================
' Field usage report -> text file (+ optional table)
' - TableName: specific table or "*ALL*"
' - FilePath:  target .txt path; default: <db folder>\<Table>_FieldUsage.txt
' - Append:    append to existing file (useful for *ALL*)
' - IncludeSystemTables: include MSys/hidden/temp tables (False = skip)
' - WriteToTable: also fill FieldUsageReport table (one row per hit)
' ============================================================
Public Sub FieldUsage_Report(TableName As String, _
                             Optional FilePath As String = "", _
                             Optional Append As Boolean = False, _
                             Optional IncludeSystemTables As Boolean = False, _
                             Optional WriteToTable As Boolean = False)

    Dim db As DAO.Database: Set db = CurrentDb
    Dim tdf As DAO.TableDef
    Dim tblList As Collection
    Dim fnum As Integer
    Dim started As Boolean
    Dim runStamp As String

    runStamp = Format(Now, "yyyy-mm-dd hh:nn:ss")

    If WriteToTable Then EnsureReportTable

    ' Build list of tables to process
    Set tblList = New Collection
    If UCase$(TableName) = "*ALL*" Then
        For Each tdf In db.TableDefs
            If ShouldIncludeTable(tdf, IncludeSystemTables) Then _
                tblList.Add tdf.Name
        Next
    Else
        On Error Resume Next
        Set tdf = db.TableDefs(TableName)
        On Error GoTo 0
        If tdf Is Nothing Then
            MsgBox "Table '" & TableName & "' not found.", vbCritical
            Exit Sub
        End If
        tblList.Add TableName
    End If

    ' Default file path
    If Len(FilePath) = 0 Then
        If tblList.Count = 1 Then
            FilePath = CurrentProject.Path & "\" & tblList(1) & "_FieldUsage.txt"
        Else
            FilePath = CurrentProject.Path & "\ALL_FieldUsage.txt"
        End If
    End If

    ' Open file
    fnum = FreeFile
    If Append Then
        Open FilePath For Append As #fnum
    Else
        Open FilePath For Output As #fnum
    End If

    Print #fnum, "=== Field usage report ===  " & runStamp
    Print #fnum, "Database: " & CurrentProject.FullName
    Print #fnum,

    ' Process each table
    Dim i As Long
    For i = 1 To tblList.Count
        WriteTableSection tblList(i), fnum, WriteToTable
        started = True
    Next i

    Print #fnum, "=== End of report ==="
    Close #fnum

    MsgBox "Report written to:" & vbCrLf & FilePath, vbInformation
End Sub

' Decide whether to include a table in *ALL* mode
Private Function ShouldIncludeTable(tdf As DAO.TableDef, IncludeSystem As Boolean) As Boolean
    Dim nm As String: nm = tdf.Name
    If Not IncludeSystem Then
        If Left$(nm, 4) = "MSys" Then Exit Function
        If Left$(nm, 1) = "~" Then Exit Function
        If (tdf.Attributes And dbSystemObject) <> 0 Then Exit Function
        If (tdf.Attributes And dbHiddenObject) <> 0 Then Exit Function
    End If
    ' Exclude linked system temp names
    If InStr(1, nm, "MSys", vbTextCompare) > 0 And Not IncludeSystem Then Exit Function
    ShouldIncludeTable = True
End Function

' Write one table section to file, optionally to FieldUsageReport table
Private Sub WriteTableSection(TableName As String, fnum As Integer, WriteToTable As Boolean)
    Dim db As DAO.Database: Set db = CurrentDb
    Dim tdf As DAO.TableDef, fld As DAO.Field
    Dim hits As Collection
    Dim i As Long

    On Error Resume Next
    Set tdf = db.TableDefs(TableName)
    On Error GoTo 0
    If tdf Is Nothing Then
        Print #fnum, "Table '" & TableName & "' not found."
        Print #fnum,
        Exit Sub
    End If

    Print #fnum, "------------------------------------------------------------"
    Print #fnum, "TABLE: " & TableName
    Print #fnum, "------------------------------------------------------------"
    Print #fnum,

    For Each fld In tdf.Fields
        Set hits = FindAllReferences(fld.Name)

        ' Optional DB table output
        If WriteToTable Then
            If hits.Count = 0 Then
                WriteUsageRow TableName, fld.Name, "(none)", "", "", "", ""
            Else
                For i = 1 To hits.Count
                    WriteParsedHit TableName, fld.Name, CStr(hits(i))
                Next i
            End If
        End If

        ' Pretty, grouped text
        Print #fnum, "[" & fld.Name & "]"
        WriteCategory fnum, "Queries:", hits, "Query:"
        WriteCategory fnum, "Forms:", hits, "Form:"
        WriteCategory fnum, "Reports:", hits, "Report:"
        Print #fnum,
    Next fld

    Print #fnum,
End Sub

' ---------- File print helpers ----------
Private Sub WriteCategory(fnum As Integer, Header As String, hits As Collection, prefix As String)
    Dim found As Boolean, h As Variant
    found = False
    Print #fnum, "  " & Header
    For Each h In hits
        If Left$(h, Len(prefix)) = prefix Then
            Print #fnum, "    - " & Mid$(h, Len(prefix) + 2)
            found = True
        End If
    Next
    If Not found Then Print #fnum, "    (none)"
End Sub

' ---------- Core search ----------
' Returns strings like:
' "Query: qrySales"
' "Form: frmX (txtY.ControlSource)"
' "Report: rptZ (RecordSource)"
Private Function FindAllReferences(FieldName As String) As Collection
    Dim results As New Collection
    Dim s As String

    ' Queries
    Dim q As DAO.QueryDef
    For Each q In CurrentDb.QueryDefs
        If InStr(1, q.sql, FieldName, vbTextCompare) > 0 Then
            results.Add "Query: " & q.Name
        End If
    Next q

    ' Forms
    Dim ao As AccessObject, ctl As Control
    For Each ao In CurrentProject.AllForms
        DoCmd.OpenForm ao.Name, acDesign, , , , acHidden
        With Forms(ao.Name)
            If InStr(1, Nz(.RecordSource, ""), FieldName, vbTextCompare) > 0 Then _
                results.Add "Form: " & ao.Name & " (RecordSource)"
            If InStr(1, Nz(.Filter, ""), FieldName, vbTextCompare) > 0 Then _
                results.Add "Form: " & ao.Name & " (Filter)"
            If InStr(1, Nz(.OrderBy, ""), FieldName, vbTextCompare) > 0 Then _
                results.Add "Form: " & ao.Name & " (OrderBy)"
        End With
        For Each ctl In Forms(ao.Name).Controls
            On Error Resume Next
            s = ctl.ControlSource
            If Len(s) > 0 And InStr(1, s, FieldName, vbTextCompare) > 0 Then _
                results.Add "Form: " & ao.Name & " (" & ctl.Name & ".ControlSource)"
            s = ctl.RowSource
            If Len(s) > 0 And InStr(1, s, FieldName, vbTextCompare) > 0 Then _
                results.Add "Form: " & ao.Name & " (" & ctl.Name & ".RowSource)"
            On Error GoTo 0
        Next ctl
        DoCmd.Close acForm, ao.Name, acSaveNo
    Next ao

    ' Reports
    Dim ro As AccessObject
    For Each ro In CurrentProject.AllReports
        DoCmd.OpenReport ro.Name, acViewDesign, , , acHidden
        With Reports(ro.Name)
            If InStr(1, Nz(.RecordSource, ""), FieldName, vbTextCompare) > 0 Then _
                results.Add "Report: " & ro.Name & " (RecordSource)"
            If InStr(1, Nz(.Filter, ""), FieldName, vbTextCompare) > 0 Then _
                results.Add "Report: " & ro.Name & " (Filter)"
            If InStr(1, Nz(.OrderBy, ""), FieldName, vbTextCompare) > 0 Then _
                results.Add "Report: " & ro.Name & " (OrderBy)"
        End With
        For Each ctl In Reports(ro.Name).Controls
            On Error Resume Next
            s = ctl.ControlSource
            If Len(s) > 0 And InStr(1, s, FieldName, vbTextCompare) > 0 Then _
                results.Add "Report: " & ro.Name & " (" & ctl.Name & ".ControlSource)"
            s = ctl.RowSource
            If Len(s) > 0 And InStr(1, s, FieldName, vbTextCompare) > 0 Then _
                results.Add "Report: " & ro.Name & " (" & ctl.Name & ".RowSource)"
            On Error GoTo 0
        Next ctl
        DoCmd.Close acReport, ro.Name, acSaveNo
    Next ro

    ' Table-level validation props that might reference field names
    Dim tdf As DAO.TableDef
    For Each tdf In CurrentDb.TableDefs
        On Error Resume Next
        s = tdf.ValidationRule
        If Len(s) > 0 And InStr(1, s, FieldName, vbTextCompare) > 0 Then _
            results.Add "TableProp: " & tdf.Name & " (ValidationRule)"
        s = tdf.ValidationText
        If Len(s) > 0 And InStr(1, s, FieldName, vbTextCompare) > 0 Then _
            results.Add "TableProp: " & tdf.Name & " (ValidationText)"
        On Error GoTo 0
    Next tdf

    Set FindAllReferences = results
End Function

' ---------- Optional: write to FieldUsageReport ----------
Private Sub EnsureReportTable()
    Dim db As DAO.Database: Set db = CurrentDb
    Dim t As DAO.TableDef
    On Error Resume Next
    Set t = db.TableDefs("FieldUsageReport")
    On Error GoTo 0

    If t Is Nothing Then
        Set t = db.CreateTableDef("FieldUsageReport")
        t.Fields.Append t.CreateField("TableName", dbText, 128)
        t.Fields.Append t.CreateField("FieldName", dbText, 128)
        t.Fields.Append t.CreateField("LocationType", dbText, 32)   ' Query/Form/Report/TableProp/(none)
        t.Fields.Append t.CreateField("ObjectName", dbText, 128)    ' object/table name
        t.Fields.Append t.CreateField("ControlName", dbText, 128)   ' control if applicable
        t.Fields.Append t.CreateField("Property", dbText, 32)       ' ControlSource/RowSource/RecordSource/Filter/OrderBy
        t.Fields.Append t.CreateField("Snippet", dbMemo)            ' reserved
        db.TableDefs.Append t
    Else
        db.Execute "DELETE FROM FieldUsageReport"
    End If
End Sub

Private Sub WriteParsedHit(TableName As String, FieldName As String, Hit As String)
    Dim locType As String, objName As String, propPart As String
    Dim ctrlName As String, PropName As String
    Dim p As Long, q As Long, r As Long

    p = InStr(1, Hit, ":")
    If p > 0 Then
        locType = Trim$(Left$(Hit, p - 1))
        objName = Trim$(Mid$(Hit, p + 1))
        q = InStr(1, objName, "(")
        If q > 0 Then
            objName = Trim$(Left$(objName, q - 1))
            propPart = Mid$(Hit, InStr(1, Hit, "(") + 1)
            propPart = Left$(propPart, Len(propPart) - 1) ' remove ")"
            r = InStr(1, propPart, ".")
            If r > 0 Then
                ctrlName = Left$(propPart, r - 1)
                PropName = Mid$(propPart, r + 1)
            Else
                PropName = propPart
            End If
        End If
    End If

    WriteUsageRow TableName, FieldName, locType, objName, ctrlName, PropName, ""
End Sub

Private Sub WriteUsageRow(TableName As String, FieldName As String, _
                          LocationType As String, ObjectName As String, _
                          ControlName As String, PropName As String, Snippet As String)
    Dim sql As String
    sql = "PARAMETERS p1 Text(128), p2 Text(128), p3 Text(32), p4 Text(128), p5 Text(128), p6 Text(32), p7 Memo;" & _
          "INSERT INTO FieldUsageReport (TableName, FieldName, LocationType, ObjectName, ControlName, Property, Snippet) " & _
          "VALUES (p1,p2,p3,p4,p5,p6,p7);"
    Dim q As DAO.QueryDef: Set q = CurrentDb.CreateQueryDef("", sql)
    q.Parameters("p1") = TableName
    q.Parameters("p2") = FieldName
    q.Parameters("p3") = LocationType
    q.Parameters("p4") = ObjectName
    q.Parameters("p5") = ControlName
    q.Parameters("p6") = PropName
    q.Parameters("p7") = Snippet
    q.Execute dbFailOnError
    q.Close
End Sub