Die Funktionen dokumentieren im Zusammenspiel die in der Datenbank verwendeten Objekte.
Option Compare Database
Option Explicit
Sub ObjWrite(v_Objekte As String, v_ObjName As String, v_ObjDescription As String)
On Error GoTo ErrorExit
Dim dbs As DAO.Database
Dim tdf As DAO.TableDef
Dim rst As DAO.Recordset
Set dbs = CurrentDb
Set tdf = dbs.TableDefs("doc_Objekte_Pgm")
Set rst = dbs.OpenRecordset("doc_Objekte_Pgm")
With rst
.AddNew
![ObjType] = v_Objekte
![ObjName] = v_ObjName
![ObjDescription] = v_ObjDescription
.Update
End With
dbs.Close
Set dbs = Nothing
Exit Sub
ErrorExit:
MsgBox Error(Err), vbInformation, "ObJWrite: Fehlermeldung (" & LTrim(Str(Err)) & ")"
Resume Next
End Sub
Sub ObjTblAnlegen()
On Error GoTo ErrorExit
Dim dbs As Database
Dim tdf As TableDef
Dim fld As Field
Dim tmpI As Integer
Set dbs = CurrentDb
Set tdf = dbs.CreateTableDef("doc_Objekte_Pgm")
With tdf
.Fields.Append .CreateField("ObjType", dbText, 150)
.Fields.Append .CreateField("ObjName", dbText, 50)
.Fields.Append .CreateField("ObjDescription", dbText, 250)
End With
dbs.TableDefs.Append tdf
dbs.Close
Set dbs = Nothing
Exit Sub
ErrorExit:
If Err = 3010 Then
DoCmd.DeleteObject acTable, "doc_Objekte_Pgm"
Resume
End If
End Sub
Sub listObjects(ObjectType As String)
On Error GoTo ErrorExit
Dim Obj As Object
' ObjectType: qry, tbl, ber, mod, frm
' ObjWrite(v_Objekte As String, v_ObjName As String, v_ObjDescription As String)
Select Case ObjectType
Case "qry"
For Each Obj In CurrentDb.QueryDefs
If InStr(Obj.Name, "~") = 0 Then
' Debug.Print Obj.Name, Obj.Properties("Description")
ObjWrite "Abfrage", Obj.Name, Obj.Properties("Description")
End If
Next Obj
Case "tbl"
For Each Obj In CurrentDb.TableDefs
If InStr(Obj.Name, "MSys") = 0 And InStr(Obj.Name, "~") = 0 And InStr(Obj.Name, "doc") = 0 And InStr(Obj.Name, "tmp") = 0 Then
' Debug.Print Obj.Name, Obj.Properties("Description")
ObjWrite "Tabelle", Obj.Name, Obj.Properties("Description")
End If
Next Obj
Case "ber"
For Each Obj In CurrentProject.AllReports
If InStr(Obj.Name, "doc") = 0 Then
' Debug.Print Obj.Name, CurrentDb.Containers("Reports").Documents(Obj.Name).Properties("Description")
ObjWrite "Report", Obj.Name, CurrentDb.Containers("Reports").Documents(Obj.Name).Properties("Description")
End If
Next Obj
Case "mod"
For Each Obj In CurrentProject.AllModules
If InStr(Obj.Name, "doc") = 0 Then
' Debug.Print Obj.Name, CurrentDb.Containers("Modules").Documents(Obj.Name).Properties("Description")
ObjWrite "Modul", Obj.Name, CurrentDb.Containers("Modules").Documents(Obj.Name).Properties("Description")
End If
Next Obj
Case "frm"
For Each Obj In CurrentProject.AllForms
' Debug.Print Obj.Name, CurrentDb.Containers("Forms").Documents(Obj.Name).Properties("Description")
ObjWrite "Formular", Obj.Name, CurrentDb.Containers("Forms").Documents(Obj.Name).Properties("Description")
Next Obj
Case Else
MsgBox "Falscher Parameter", vbCritical + vbOKOnly, "Fehler"
End Select
Exit Sub
ErrorExit:
If Err <> 3270 Then
MsgBox Error(Err), vbInformation, "ListObjects Fehlermeldung (" & LTrim(Str(Err)) & ")"
Else
ObjWrite ObjectType, Obj.Name, "ERFASSEN"
End If
Resume Next
End Sub
Sub runAll()
On Error GoTo ErrorExit
ObjTblAnlegen
listObjects "qry"
listObjects "tbl"
listObjects "ber"
listObjects "mod"
listObjects "frm"
Exit Sub
ErrorExit:
MsgBox Error(Err), vbInformation, "runAll Fehlermeldung (" & LTrim(Str(Err)) & ")"
Resume Next
End Sub
Sub UpdateMenueTbl()
On Error GoTo ErrorExit
Dim sqlStrg As String
sqlStrg = "UPDATE tbl_Sys_Menue INNER JOIN doc_Objekte_Pgm ON tbl_Sys_Menue.fld_menue_Value = "
sqlStrg = sqlStrg & "doc_Objekte_Pgm.ObjName SET tbl_Sys_Menue.fld_menue_Beschreibung = [doc_objekte_pgm].[ObjDescription] "
sqlStrg = sqlStrg & "WHERE (((tbl_Sys_Menue.fld_menue_Beschreibung) Is Null)) OR (((tbl_Sys_Menue.fld_menue_Beschreibung)=''));"
DoCmd.SetWarnings False
DoCmd.RunSQL sqlStrg
DoCmd.SetWarnings True
Exit Sub
ErrorExit:
MsgBox Error(Err), vbInformation, "runAll Fehlermeldung (" & LTrim(Str(Err)) & ")"
Resume Next
End Sub
Sub UpdateMenue()
On Error GoTo ErrorExit
runAll
UpdateMenueTbl
MsgBox "Kommentare wurden aus den Objekteigenschaften in die leeren Anmerkungen übernommen!", vbOKOnly, "Hinweis"
Exit Sub
ErrorExit:
MsgBox Error(Err), vbInformation, "runAll Fehlermeldung (" & LTrim(Str(Err)) & ")"
Resume Next
End Sub