Public Function ProjectDocumentor()
Dim tdf As TableDef
Dim blnExists As Boolean
Dim strFormEvents As String
Dim strControlEvents As String
Dim frmobj As AccessObject
Dim ctlobj As Control
Dim objProp As Property
Dim frmobj1 As Form
Dim i As Integer
Dim rst As DAO.Recordset
Dim rst1 As DAO.Recordset
Dim j As Integer
Dim qdf As QueryDef
Dim sProcName As String
Dim VBIx As VBIDE.VBE
Dim oCodePane As CodePane
Dim oCodeMod As CodeModule
Dim obj As CodePane
Dim aObj As AccessObject
Dim eProcKind As vbext_ProcKind
Dim strComment As String
Dim strFormName As String
Dim k As Long
Dim m As Long
Dim varDictItems As Variant
Dim strLine As String
Dim dictProcNames As New Scripting.Dictionary
Dim strProcname As String
Dim lngStartLine As Long
Set VBIx = Application.VBE
strFormEvents = ".OnCurrent.BeforeInsert.AfterInsert.BeforeUpdate.AfterUpdate.OnDirty.OnUndo.OnDelete.BeforeDelConfirm.AfterDelConfirm.OnOpen.OnLoad.OnResize.OnUnload.OnClose.OnActivate.OnDeactivate.OnGotFocus.OnLostFocus.OnClick.OnDblClick.OnMouseDown.OnMouseMove.OnMouseUp.OnMouseWheel.OnKeyDown.OnKeyUp.OnKeyPress.OnError.OnFilter.OnApplyFilter.OnTimer.OnCmdEnabled.OnCmdChecked.OnCmdBeforeExecute.OnCmdExecute.OnDataChange.OnDataSetChange.OnPivotTableChange.OnSelectionChange.OnViewChange.OnConnect.OnDisconnect.BeforeQuery.OnQuery.AfterLayout.BeforeRender.AfterRender.AfterFinalRender"
strControlEvents = ".OnUndo.OnChange.OnEnter.OnExit.OnGotFocus.OnLostFocus.OnClick.OnDblClick.OnMouseDown.OnMouseMove.OnMouseUp.OnKeyDown.OnKeyUp.OnKeyPress.BeforeUpdate.AfterUpdate.OnDirty.OnNotInList"
For Each tdf In CurrentDb.TableDefs
If tdf.Name = "msysProcCalls" Then
blnExists = True
Exit For
End If
Next
If blnExists Then
DoCmd.RunSQL "DELETE msysProcCalls.* FROM msysProcCalls"
Else
Set tdf = CurrentDb.CreateTableDef("msysProcCalls")
With tdf
.Fields.Append .CreateField("Form", dbText)
.Fields.Append .CreateField("Function", dbText)
.Fields.Append .CreateField("Control", dbText)
.Fields.Append .CreateField("Module", dbText)
End With
CurrentDb.TableDefs.Append tdf
End If
Set rst = CurrentDb.OpenRecordset("msysProcCalls", dbOpenDynaset)
blnExists = False
For Each tdf In CurrentDb.TableDefs
If tdf.Name = "Switchboard Items" Then
blnExists = True
Exit For
End If
Next
If blnExists Then
Set rst1 = CurrentDb.OpenRecordset("Switchboard items")
With rst1
Do While Not .EOF
rst.AddNew
rst!Form = "Switchboard"
rst!Function = !Argument
rst!Control = "Switchboard Argument"
rst.Update
.moveNext
Loop
End With
End If
For Each frmobj In CurrentProject.AllForms
If Not frmobj.IsLoaded Then
DoCmd.openForm frmobj.Name, acDesign, , , , acHidden
End If
Set frmobj1 = Forms(frmobj.Name)
For Each objProp In frmobj1.Properties
If InStr(1, strFormEvents, "." & objProp.Name, vbBinaryCompare) > 0 Then
If Len(objProp.Value) > 0 Then
With rst
.AddNew
!Form = frmobj1.Name
!Function = objProp.Value
!Control = frmobj1.Name & "." & objProp.Name
.Update
End With
End If
End If
Next
If frmobj1.Controls.COUNT > 0 Then
For Each ctlobj In frmobj1.Controls
For Each objProp In ctlobj.Properties
If InStr(1, strControlEvents, "." & objProp.Name, vbBinaryCompare) > 0 Then
If Len(objProp.Value) > 0 Then
With rst
.AddNew
!Form = frmobj1.Name
!Function = objProp.Value
!Control = ctlobj.Name & "." & objProp.Name
.Update
End With
End If
End If
Next objProp
Next ctlobj
End If
DoCmd.Close acForm, frmobj.Name, acSaveNo
Next
CurrentDb.Execute "DELETE msysProcCalls.Function FROM msysProcCalls WHERE (((msysProcCalls.Function) Is Null))"
For i = 1 To VBIx.ActiveVBProject.VBComponents.COUNT
VBIx.ActiveVBProject.VBComponents.item(i).Activate
Next i
For Each obj In VBIx.CodePanes
Set oCodePane = obj
Set oCodeMod = oCodePane.CodeModule
For i = oCodeMod.CountOfDeclarationLines + 1 To oCodeMod.CountOfLines
If sProcName <> oCodeMod.ProcOfLine(i, eProcKind) Then
sProcName = oCodeMod.ProcOfLine(i, eProcKind)
CurrentDb.Execute "UPDATE msysProcCalls SET msysProcCalls.[Module] = '" & oCodeMod.Parent.Name & "' WHERE (((InStr(1,[msysProcCalls].[Function],'" & sProcName & "'))>0) AND ((msysProcCalls.Function) Is Not Null))"
End If
Next i
Next obj
rst.Close
Set rst = Nothing
For Each obj In VBIx.CodePanes
Set oCodePane = obj
Set oCodeMod = oCodePane.CodeModule
k = 0
dictProcNames.removeAll
For m = oCodeMod.CountOfLines To oCodeMod.CountOfDeclarationLines + 1 Step -1
If InStr(1, oCodeMod.Lines(m, 1), "'Object Assn:") > 0 Then
oCodeMod.DeleteLines m, 1
End If
If strProcname <> oCodeMod.ProcOfLine(m, eProcKind) Then
strProcname = oCodeMod.ProcOfLine(m, eProcKind)
k = k + 1
dictProcNames.Add k, strProcname
End If
Next m
varDictItems = dictProcNames.Items
For m = 0 To dictProcNames.COUNT - 1
If varDictItems(m) <> "" Then
strComment = "'Object Assn: "
Set rst = CurrentDb.OpenRecordset("SELECT msysProcCalls.* FROM msysProcCalls WHERE (((trimFunction([msysProcCalls]![Function]))='" & varDictItems(m) & "'))")
lngStartLine = oCodeMod.ProcStartLine(varDictItems(m), eProcKind)
strLine = oCodeMod.Lines(lngStartLine, 1)
With rst
Do While Not .EOF
If strFormName <> ![Form] & "." & ![Control] Then
strFormName = ![Form] & "." & ![Control]
strComment = strComment & strFormName & "/"
End If
.moveNext
Loop
End With
strComment = Mid(strComment, 1, Len(strComment) - 1)
If Len(Trim(strLine)) < 1 Then
If strComment <> "'Object Assn:" Then
oCodeMod.ReplaceLine lngStartLine, strComment
End If
Else
If strComment <> "'Object Assn:" Then
oCodeMod.InsertLines lngStartLine, strComment
End If
End If
rst.Close
Set rst = Nothing
End If
Next
Next obj
rst1.Close
Set rst1 = Nothing
Set frmobj1 = Nothing
Set oCodePane = Nothing
Set oCodeMod = Nothing
MsgBox "Documenting complete"
End Function
Public Function trimFunction(strInput As String) As String
If InStr(1, strInput, "=") > 0 Then
strInput = Mid(strInput, 2)
End If
If InStr(1, strInput, "(") > 0 Then
strInput = Mid(strInput, 1, InStr(1, strInput, "(") - 1)
End If
trimFunction = strInput
End Function
