Attribute VB_Name = "USysPatch"
Option Compare Database
Option Explicit

'constants for EnumDatabase
Public Const enumActionView = 4
Public Const enumActionOpenRead = 2 'close doesn't save
Public Const enumActionOpenWrite = 3 'close does save
Public Const enumActionNothing = 0
'low bit: to save or not to save
'2nd bit: design view
'3rd bit: action view

Sub EnumDatabase(cCollection As String, cAction As String, Optional nMode = enumActionOpenRead)
'cCollection is Forms, or Tables, etc
'cAction is a function name INCLUDING PARENTHESIS, plus optionally arguments
' Every document from the collection is sent to this function as a parameter
Dim db As Database
Dim ctr As Container
Dim doc As Document
Dim docmode As Long
On Error GoTo err_EnumDatabase
   Set db = CurrentDb
   Set ctr = db.Containers(cCollection)
   For Each doc In ctr.Documents
      ' "optionally" open
      Select Case nMode
      Case enumActionNothing
      Case enumActionOpenRead, enumActionOpenWrite
         docmode = acDesign
      Case enumActionView
         docmode = acNormal
      End Select
      If nMode > enumActionNothing Then
         Select Case cCollection
         Case "forms"
            DoCmd.OpenForm doc.Name, docmode
         Case "reports"
            DoCmd.OpenReport doc.Name, docmode
         Case "tables"
            DoCmd.OpenTable doc.Name, docmode
         Case "modules"
            DoCmd.OpenModule doc.Name 'not: docmode, since OpenModule expects a procedure name here
         End Select
      End If
      'workhorse:
      Eval cAction & Quote & doc.Name & Quote & ")"
      ' "optionally" close
      Select Case nMode
      Case enumActionNothing
      Case enumActionOpenRead, enumActionView
         docmode = acSaveNo
      Case enumActionOpenWrite
         docmode = acSaveYes
      End Select
      If nMode > enumActionNothing Then
         Select Case cCollection
         Case "forms"
            DoCmd.Close acForm, doc.Name, docmode
         Case "reports"
            DoCmd.Close acReport, doc.Name, docmode
         Case "tables"
            DoCmd.Close acTable, doc.Name, docmode
         Case "modules"
            DoCmd.Close acModule, doc.Name, docmode
         End Select
      End If
   Next
exit_EnumDatabase:
   Set ctr = Nothing
   Set db = Nothing
   Exit Sub
err_EnumDatabase:
   Select Case Err
   Case Else
      Debug.Print cAction & doc.Name & ")"
      Debug.Print Err.number; Err.Description
      Resume Next
   End Select
End Sub

'These are several implementations: how to work with EnumDatabase

Sub DoFormPatch(cControl As String, cProperty As String, cNewValue As String)
'this routine can be called
Dim action As String
   action = "execDFP("
   action = action & Quote & cControl & Quote & ","
   action = action & Quote & cProperty & Quote & ","
   action = action & Quote & cNewValue & Quote & ","
   EnumDatabase "forms", action, enumActionOpenWrite
End Sub

Function execDFP(cControl As String, cProperty As String, cNewValue As String, cForm As String) As Boolean
'this routine is the workhorse for DoFormPatch
On Error Resume Next
   Forms(cForm).Controls(cControl).Properties(cProperty).Value = cNewValue
End Function

Sub duh()
   EnumDatabase "forms", "execfqt("
End Sub

Function execFQT(cForm As String) As Boolean
Dim cSQL As String
Dim ctl As Control
On Error Resume Next
   Set ctl = Forms(cForm)!selector
   If Err > 0 Then Exit Function
   If ctl.ControlType = acListBox Then
      Set ctl = Nothing
      DeleteControl cForm, "selector"
      Set ctl = CreateControl(cForm, acComboBox, acHeader)
      ctl.Top = 1 * tWips
      ctl.Left = 0.2 * tWips
      ctl.Name = "selector"
      ctl.OnClick = vbEvent
      ctl.ColumnCount = 2
      ctl.ColumnWidths = "0"
   End If
End Function

Sub findUsedField(cField As String)
'debug window helper: writes all occurrences of some field in the tables
Dim td As TableDef
Dim fd As Field
Dim db As Database
   Set db = CurrentDb
   For Each td In db.TableDefs
      For Each fd In td.Fields
         If fd.Name = cField Then Debug.Print td.Name
      Next
   Next
   Set db = Nothing
End Sub

Sub gatherSigs()
'DB entry point
'write a record in _procedures for every procedure in modules, form modules
Dim cSQL As String
   DoCmd.Hourglass True
   CurrentDb.Execute "delete from _procedures"
   EnumDatabase "modules", "execmgs(", enumActionOpenRead
   EnumDatabase "forms", "execfgs(", enumActionOpenRead
   SysCmd acSysCmdSetStatus, "Inserting dependencies..."
   CurrentDb.Execute "delete from _procCalls"
   cSQL = "INSERT INTO _procCalls ( callerParent, caller, calleeParent, callee )"
   cSQL = cSQL & " SELECT DISTINCTROW org.parentName, org.procName, dest.parentName, dest.procName"
   cSQL = cSQL & " FROM _procedures AS org, _procedures AS dest"
   cSQL = cSQL & " WHERE (((org.procName)<>[dest].[procname]) AND ((InStr([org].[procbody],[dest].[procName]))>0));"
   CurrentDb.Execute cSQL 'create calling table
   'yields way too many hits.
   'we remove matches in comments (')
   'we remove partial matches -> attention, later in the same procedure a full match may occur
   RemoveFalseHits
   SysCmd acSysCmdClearStatus
   DoCmd.Hourglass False
End Sub

Function getCodeLine(cBody As String, nPoint As Long) As String
'assumes vbnewline-separated cbody; returns complete line containing nPoint without newlines
Const Sep = vbNewLine
Dim nStart As Long
Dim nEnd As Long
Dim nPos As Long
   nPos = InStr(cBody, Sep)
   If nPos = 0 Then 'it's just one line!
      getCodeLine = cBody
      Exit Function
   Else
      nStart = 1
      Do Until nPos = 0
         If nPos < nPoint Then nStart = nPos + Len(Sep) 'advance start as long as it's before point
         nEnd = nPos 'always advance end
         If nPos > nPoint Then 'nough
            Exit Do
         End If
         nPos = InStr(nPos + 1, cBody, Sep)
      Loop
      If nEnd < nPoint Then nEnd = Len(cBody) 'means nPoint is in the last line
      getCodeLine = Mid(cBody, nStart, nEnd - nStart)
   End If
End Function

Function isWholeMatch(cLine As String, cWord As String) As Boolean
'returns True if characters before and after cWord in cLine are non-letter.
' strictly, numbers can be part of a name, and underscores can. You get the idea
'I expect the separators to be either space, bracket, comma, quote, dot, bang... too much to check
Dim bRes As Boolean
Dim nPos As Long
Const IDCHARS = "abcdefghijklmnopqrstuvwxyz_0123456789"
   bRes = True
   nPos = InStr(cLine, cWord)
   If nPos > 1 Then
      bRes = bRes And (InStr(IDCHARS, Mid(cLine, nPos - 1, 1)) = 0)
   End If
   nPos = nPos + Len(cWord) - 1
   If nPos < Len(cLine) Then
      bRes = bRes And (InStr(IDCHARS, Mid(cLine, nPos + 1, 1)) = 0)
   End If
   isWholeMatch = bRes
End Function

Sub RemoveFalseHits()
Dim rs As Recordset
Dim cBody As String
Dim cLine As String
Dim cSQL As String
Dim nPos As Long
Dim bFlag As Boolean
'relies on query _procsCalling:
'
On Error GoTo err_RemoveFalseHits
   'consider procedures where the body contains a quote -- I never use the keyword Rem, if you do, adapt the code!
   cSQL = "SELECT [_procedures].*, [_procCalls].calleeParent, [_procCalls].callee"
   cSQL = cSQL & " FROM _procCalls INNER JOIN _procedures ON ([_procCalls].caller = [_procedures].procName)"
   cSQL = cSQL & " AND ([_procCalls].callerParent = [_procedures].parentName);"
   Set rs = CurrentDb.OpenRecordset(cSQL) '  initially, I used "WHERE procbody like '*''*'"
   rs.MoveLast
   SysCmd acSysCmdInitMeter, "False hit check:", rs.RecordCount
   rs.MoveFirst
   Do Until rs.EOF
      'set flag to false
      'while presence of [callee] in [procBody]
      ' if not remmed, flag can be set to true
      ' IFF the match is whole (ie <head and >tail are non-letters)
      'elihw
      'if flag is false, remove record from _procscalled
      DoEvents
      bFlag = False
      cBody = rs!procBody
      nPos = InStr(cBody, rs!callee)
      Do Until nPos = 0
         cLine = getCodeLine(cBody, nPos)
         'remove leading spaces
         Do While Left(cLine, 1) = " "
            cLine = Mid(cLine, 2)
         Loop
         If Left(cLine, 1) <> "'" Then 'to count as true match, line must NOT be comment
            If isWholeMatch(cLine, rs!callee) Then 'NOR a partial match
               bFlag = True
            End If
         End If
         nPos = InStr(nPos + 1, cBody, rs!callee)
      Loop
      If Not bFlag Then
         'we cannot remove the record here as that would confuse our recordset
         cSQL = "UPDATE _procCalls SET isFalse=true"
         cSQL = cSQL & " WHERE caller='" & rs!procName & "' AND callerparent='" & rs!parentName & "'"
         cSQL = cSQL & " AND callee='" & rs!callee & "' AND calleeParent='" & rs!calleeParent & "'"
         CurrentDb.Execute cSQL
      End If
nobody:
      SysCmd acSysCmdUpdateMeter, rs.AbsolutePosition
      rs.MoveNext
   Loop
exit_RemoveFalseHits:
   SysCmd acSysCmdRemoveMeter
   rs.Close
   Set rs = Nothing
   'batch remove all invalids here
   CurrentDb.Execute "DELETE FROM _procCalls WHERE isFalse"
   Exit Sub
err_RemoveFalseHits:
   Select Case Err
   Case er94InvalidUseOfNull
      Resume nobody
   Case Else
      Select Case MsgBox("Error " & Err.number & " in RemoveFalseHits: " & Err.Description, vbAbortRetryIgnore)
      Case vbAbort
         Resume exit_RemoveFalseHits
      Case vbRetry
         Resume
      Case vbIgnore
         Resume Next
      End Select
   End Select
End Sub

Function execMgs(cModule As String) As Boolean
   extractProcs cModule
End Function

Function execFgs(cModule As String) As Boolean
'module is still to be opened
   If Forms(cModule).HasModule Then
      DoCmd.OpenModule "form_" & cModule
      extractProcs "form_" & cModule
      DoCmd.Close acModule, "form_" & cModule
   End If
End Function

Sub extractProcs(cModule As String)
Dim nStart As Long
Dim M As Module
Dim cProc As String
Dim pKind As Long
Dim cKind As String
Dim cPType As String
Dim cLine As String
Dim nOffs As Integer
Dim nLines As Long
   Set M = Modules(cModule)
   cPType = IIf(M.Type = acStandardModule, "Module", "Class")
   nStart = M.CountOfDeclarationLines + 1
   Do Until nStart >= M.CountOfLines
      nOffs = 0
      cProc = M.ProcOfLine(nStart, pKind)
      cLine = M.Lines(nStart, 1)
      Do Until InStr(cLine, "sub") > 0 Or InStr(cLine, "function") > 0 Or InStr(cLine, "property") > 0
         cLine = M.Lines(nStart + nOffs, 1)
         nOffs = nOffs + 1
      Loop
      cKind = Choose(pKind + 1, "proc", "Let", "Get", "Set")
      writeSig cPType, cModule, cProc, cKind, cLine
      nLines = M.ProcCountLines(cProc, pKind) - 3 'kopregel, einderegel, witregel alle overslaan
      writeBody cModule, cProc, cKind, M.Lines(nStart + nOffs, nLines)
      nStart = nStart + M.ProcCountLines(cProc, pKind)
   Loop
   Set M = Nothing
End Sub

Sub writeBody(parentName As String, procName As String, procKind As String, procBody As String)
Dim rs As Recordset
   Set rs = CurrentDb.OpenRecordset("_procedures", dbOpenDynaset)
   rs.FindFirst "parentname='" & parentName & "' and procname='" & procName & "' AND procType='" & procKind & "'"
   rs.Edit
   rs!procBody = procBody
   rs.Update
   rs.Close
   Set rs = Nothing
End Sub

Sub writeSig(parentType As String, parentName As String, procName As String, procType As String, procSig As String)
'interface to storage routine
' so we don't need to deal with table fuss in the actual thinking procedures
Dim cSQL As String
   SysCmd acSysCmdSetStatus, parentName & "." & procName
   cSQL = "INSERT INTO _procedures(parentType,parentName,procName,procType,procSig)"
   cSQL = cSQL & " VALUES('" & parentType & "','" & parentName & "','" & procName & "','" & procType & "',"
   If InStr(procSig, """") > 0 Then
      cSQL = cSQL & "'" & procSig & "'"
   Else
      cSQL = cSQL & """" & procSig & """"
   End If
   cSQL = cSQL & ")"
   CurrentDb.Execute cSQL, dbFailOnError
End Sub

Sub createSigsTables()
Dim db As Database
Dim td As TableDef
   Set db = CurrentDb
   Set td = db.CreateTableDef("_procedures")
   td.Fields.Append td.CreateField("parentType", dbText, 255)
   td.Fields.Append td.CreateField("parentName", dbText, 255)
   td.Fields.Append td.CreateField("procName", dbText, 255)
   td.Fields.Append td.CreateField("procType", dbText, 255)
   td.Fields.Append td.CreateField("procSig", dbText, 255)
   td.Fields.Append td.CreateField("procBody", dbMemo)
   db.TableDefs.Append td
   Set td = db.CreateTableDef("_procCalls")
   td.Fields.Append td.CreateField("callerParent", dbText, 255)
   td.Fields.Append td.CreateField("caller", dbText, 255)
   td.Fields.Append td.CreateField("calleeParent", dbText, 255)
   td.Fields.Append td.CreateField("callee", dbText, 255)
   td.Fields.Append td.CreateField("isFalse", dbBoolean)
   db.TableDefs.Append td
   Set td = Nothing
   Set db = Nothing
End Sub