Attribute VB_Name = "DevTools"
Option Compare Database
Option Explicit

Const C_THISMODULE = "DevTools"

'This code is written by Bas Cost Budde
'You may use any of it.
'You need the OrderedReeks class module (and depending StringObj class module) for 'dpm' to function

'these are to be called from the Debug Window:
' dbf toggles output redirection: file or debug window (see code)
' dbq displays redirection status (always to debug window, of course)
' dump displays different objects
' dcs dumps all containers
' dpm dumps module code and references
' # can you see my C/Unix background?
'these are to be used as necessary:
' ReportList gives a list of all reports, in RowSource format for ListBox
' TableList does this for tables (all tables)
' TablesList displays only user tables - I admit that these are not clear names.

Dim OpenFile As Boolean, nFile As Integer, linecount As Long


Sub dbf() 'DeBug talks to File toggle
   dbpToggleOutput
End Sub


Sub dbq() 'DeBug talks to, inQuiry
   Debug.Print IIf(OpenFile, "Redirecting", "Default")
End Sub


Sub dump(Optional cName, Optional cElem)
'possible arguments:
'cName   relations, relation  : prints all relations in database, with properties
'        tables               : prints all tables in database, with properties
'        table 'name'         : prints info about specified table (fields, properties, indexes)
'        report               :
'        container 'name'     : prints info about specified container (permissions, properties, documents)
Dim pr As Property, co As Container, dc As Document
On Error Resume Next
   If IsMissing(cName) Then
      Debug.Print "dump what?"
   Else
      Select Case cName
      Case "relations", "relation"
         For Each rl In CurrentDb.Relations
            dbp rl.Name
            dumpProps rl
         Next
      Case "tables"
         For Each td In CurrentDb.TableDefs
            If Left(td.Name, 4) <> "MSys" Then
               dbp td.Name
               dumpProps td
            End If
         Next
      Case "report"
         'I thought I needed this, but found something else. If you write this chunk, you have to mail it to me
      Case "table"
         If IsMissing(cElem) Then
            Debug.Print "which table?"
         Else
            Set td = DBEngine(0)(0).TableDefs(cElem)
            dbp td.Name
            For Each fd In td.Fields
               dbp "FD: " & fd.Name
               For Each pr In fd.Properties
                  dbp "  " & pr.Name & " = " & pr.Value
                  If Err > 0 Then dbp "  " & pr.Name & " ongeldig": Err = 0
               Next
            Next
            For Each ID In td.Indexes
               dbp "  ID: " & ID.Name & " foreign: " & ID.Foreign
               For Each fd In ID.Fields
                  dbp "    FD: " & fd.Name
               Next
            Next
         End If
      Case "container"
         If IsMissing(cElem) Then
            Debug.Print "which container?"
         Else
            Set co = DBEngine(0)(0).Containers(cElem)
            dbp co.Name
            objectPermissions co
            dumpProps co
            For Each dc In co.Documents
               dbp vbCrLf & "document " & dc.Name
               objectPermissions dc
               dumpProps dc
            Next
         End If
      Case Else
         dbp "unknown object " & cName
      End Select
   End If
End Sub


Sub dcs() 'Dump ContainerS
   dbpDumpContainers
End Sub
   

Sub dpm(Optional bDump = True) 'Debug Print Module
'supply False if you want to suppress 'descriptive headers'
'calls pm, dref
'uses orderedreeks
Dim db As Database, co As Container, dc As Document
Dim prox As New OrderedReeks
   Set db = CurrentDb
   Set co = db.Containers("modules")
   For Each dc In co.Documents
      If dc.Name <> C_THISMODULE Then
         DoCmd.OpenModule dc.Name
         pm dc.Name, prox, bDump
         DoCmd.Close acModule, dc.Name
      End If
   Next
   For Each dc In co.Documents
      If dc.Name <> C_THISMODULE Then
         DoCmd.OpenModule dc.Name
         dRef dc.Name, prox, bDump
         DoCmd.Close acModule, dc.Name
      End If
   Next
   If bDump Then dbp "* References:"
   prox.FirstItem
   Do While prox.Valid
      dbp prox.CurrentItem & ":" & prox.CurrentContents
      prox.NextItem
   Loop
End Sub


Sub dumpProps(What As Object)
Dim pr As Property
   For Each pr In What.Properties
      dbp "  " & pr.Name & "(" & getFieldTypeName(pr.Type) & ") = " & pr.Value
   Next
End Sub


Sub dbpDumpContainers()
Dim co As Container, db As Database, dc As Document
   Set db = CurrentDb
   For Each co In db.Containers
      objectPermissions co
      For Each dc In co.Documents
         dbp co.Name & "." & dc.Name
         'dumpProps dc
      Next
      dbp
   Next
   Debug.Print linecount; "lines written"
End Sub


Sub objectPermissions(obj As Object)
Dim gp As Group, ws As Workspace
   Set ws = DBEngine(0)
   dbp "Permissions of " & obj.Name & ":"
   For Each gp In ws.Groups
      obj.UserName = gp.Name
      dbp " group " & gp.Name & " " & PermissionString(obj.Name, obj.Permissions)
   Next
End Sub


Function PermissionString(cona As String, pe As Long) As String
Dim cRes As New StringObj
   cRes.Init Hex((pe)), ", "
   'Select Case cona
   'Case "databases"
      If pe = dbSecFullAccess Then
         cRes.Add "dbSecFullAccess (" & Hex(dbSecFullAccess) & ")"
      Else
         If pe And dbSecDBAdmin Then cRes.Add "dbSecDBAdmin (" & Hex(dbSecDBAdmin) & ")"
         If pe And dbSecDBCreate Then cRes.Add "dbSecDBCreate (" & Hex(dbSecDBCreate) & ")"
         If pe And dbSecDBExclusive Then cRes.Add "dbSecDBExclusive (" & Hex(dbSecDBExclusive) & ")"
         If pe And dbSecDBOpen Then cRes.Add "dbSecDBOpen (" & Hex(dbSecDBOpen) & ")"
      'Case "tables"
         If pe And dbSecCreate Then cRes.Add "dbSecCreate (" & Hex(dbSecCreate) & ")"
         If pe And dbSecReadDef Then cRes.Add "dbSecReadDef (" & Hex(dbSecReadDef) & ")"
         If pe And dbSecWriteDef Then cRes.Add "dbSecWriteDef (" & Hex(dbSecWriteDef) & ")"
         If pe And dbSecDeleteData Then cRes.Add "dbSecDeleteData (" & Hex(dbSecDeleteData) & ")"
         If pe And dbSecInsertData Then cRes.Add "dbSecInsertData (" & Hex(dbSecInsertData) & ")"
         If pe And dbSecReplaceData Then cRes.Add "dbSecReplaceData (" & Hex(dbSecReplaceData) & ")"
         If pe And dbSecRetrieveData Then cRes.Add "dbSecRetrieveData (" & Hex(dbSecRetrieveData) & ")"
      'Case Else
         If pe And dbSecDelete Then cRes.Add "dbSecDelete (" & Hex(dbSecDelete) & ")"
         If pe And dbSecNoAccess Then cRes.Add "dbSecNoAccess (" & Hex(dbSecNoAccess) & ")"
         If pe And dbSecReadSec Then cRes.Add "dbSecReadSec (" & Hex(dbSecReadSec) & ")"
         If pe And dbSecWriteOwner Then cRes.Add "dbSecWriteOwner (" & Hex(dbSecWriteOwner) & ")"
         If pe And dbSecWriteSec Then cRes.Add "dbSecWriteSec (" & Hex(dbSecWriteSec) & ")"
      End If
   'End Select
   PermissionString = cRes.Value
End Function


Sub dbp(Optional C = "") 'DeBug Print
   If OpenFile Then
      Print #nFile, C
      linecount = linecount + 1
   Else
      Debug.Print C
   End If
End Sub


Sub dbpToggleOutput()
   If OpenFile Then
      Close nFile
      Debug.Print linecount; "lines written, file should be c:\a.out"
      Debug.Print "File closed, redirection inactive"
   Else
      nFile = FreeFile
      Open "c:\a.out" For Output As nFile
      linecount = 0
      Debug.Print "Redirection active"
   End If
   OpenFile = Not OpenFile
End Sub


Sub pm(cMod As String, prox As OrderedReeks, Optional bDump = False)
Dim M As Module, cProc As String, nProc As Long
Dim nStart As Long, nEnd As Long
   Set M = Modules(cMod)
   'filter prox
   nStart = M.CountOfDeclarationLines + 1
   Do While nStart < M.CountOfLines
      cProc = M.ProcOfLine(nStart, nProc)
      nStart = M.ProcStartLine(cProc, nProc) + M.ProcCountLines(cProc, nProc) + 1
      prox.Add cMod & "." & cProc, ""
   Loop
   If bDump Then
      dbp "' **** MODULE DEFINITION ****"
      dbp "' **** " & cMod
      dbp M.Lines(1, M.CountOfLines)
   End If
End Sub


Sub dRef(cMod As String, prox As OrderedReeks, Optional bDump = False) 'Debug code REFerences
Dim M As Module
Dim nStartL As Long, nStartC As Long, nEndL As Long, nEndC As Long
Dim fdl As String, dummy As Long, cRef As String, cProc As String
   Set M = Modules(cMod)
   prox.FirstItem
   Do While prox.Valid
      nStartL = 1
      nStartC = 0
      cRef = prox.CurrentItem
      cProc = Mid(cRef, InStr(cRef, ".") + 1)
      Do While M.Find(cProc, nStartL, nStartC, nEndL, nEndC, True)
         fdl = M.Name & "." & M.ProcOfLine(nStartL, dummy)
         If fdl <> cRef Then prox.Append2Current " " & fdl
         nStartC = nStartC + 1
      Loop
      prox.NextItem
   Loop
End Sub


Function ReportList() As String
Dim co As Container, dc As Document, cRes As String
   Set co = DBEngine(0)(0).Containers("Reports") 
   For Each dc In co.Documents
      If cRes <> "" Then cRes = cRes & ";"
      cRes = cRes & dc.Name
   Next
   ReportList = cRes
End Function


Function TableList() As String
Dim co As Container, dc As Document, cRes As String
   Set co = DBEngine(0)(0).Containers("Tables")
   For Each dc In co.Documents
      If cRes <> "" Then cRes = cRes & ";"
      cRes = cRes & dc.Name
   Next
   TableList = cRes
End Function


Function TablesList() As String
Dim td As TableDef, cRes As String
'returns string, usable as rowsource for a listbox
   cRes = ""
   For Each td In CurrentDb.TableDefs
      If Left(td.Name, 4) <> "MSys" Then
         'do not include system tables
         cRes = cRes & td.Name & ";"
      End If
   Next
   'remove trailing semicolon
   TablesList = Left(cRes, Len(cRes) - 1)
End Function