Here's a routine that creates a Word document with the database details.
There are probably some routines called that are missing. You can email me
with the "hideme" removed if you want more info.
Paul Shapiro
Private Sub CreateEntityAttributeReportInWord( _
dbData As DAO.Database _
)
'This routine generates a mini report for all tables
On Error GoTo ErrorHandler
'Dim MS Word variables
Dim oWord As Word.Application
Dim oActiveDoc As Word.Document
Dim oRange As Word.Range
'DAO objects for retrieving properties and settings
Dim tdf As DAO.TableDef
Dim fld As DAO.Field
Dim astrTableNames() As String
Dim lngLoop As Long
Dim lngTableCount As Long
Dim strCaption As String
'Start MS Word and make it visible.
Set oWord = CreateObject("Word.Application")
Call pjsWait(lngMilliSecs:=500) 'Wait to allow application to be
instantiated
oWord.Visible = True
Set oActiveDoc = oWord.Documents.Add
oActiveDoc.Activate
With oActiveDoc
.ShowSpellingErrors = False
.ShowGrammaticalErrors = False
With .PageSetup
.LeftMargin = 0.5 * 72 'Points
.RightMargin = 0.5 * 72
.TopMargin = 0.5 * 72
.BottomMargin = 0.5 * 72
.FooterDistance = 0.25 * 72
End With
Call pjsFooterMirrorSetCreate( _
oDoc:=oActiveDoc, _
strFooterTextOuterMargin:="Database documentation- " &
Dir(dbData.Name), _
strFooterTextInnerMargin:=Format$(Now(), "mmmm d, yyyy h:nn ampm")
_
)
End With
'Get the table names into an array
'First see how many there are
lngTableCount = 0
For Each tdf In dbData.TableDefs
If _
((tdf.Attributes And dbSystemObject) = 0) _
And ((tdf.Attributes And dbHiddenObject) = 0) _
Then
lngTableCount = lngTableCount + 1
End If
Next
'Size the array to hold the names
ReDim astrTableNames(lngTableCount - 1)
'Fill the array
lngTableCount = 0
For Each tdf In dbData.TableDefs
If _
((tdf.Attributes And dbSystemObject) = 0) _
And ((tdf.Attributes And dbHiddenObject) = 0) _
Then
astrTableNames(lngTableCount) = tdf.Name
lngTableCount = lngTableCount + 1
End If
Next
'Sort the entity names
Call dhQuickSort(astrTableNames)
'Iterate through all tables
For lngLoop = 0 To lngTableCount - 1
Set tdf = dbData.TableDefs(astrTableNames(lngLoop))
With oActiveDoc.Paragraphs.Last
'Some space before
.SpaceBefore = 6
'Keep the paragraph together, and with the next paragraph
.KeepTogether = True
.KeepWithNext = True
'Set a hanging indent
.LeftIndent = 10
.FirstLineIndent = -10
Set oRange = .Range
With oRange
'First the entity name
.Font.Bold = True
.Font.Underline = True
.Font.Size = 18
.InsertAfter Text:=tdf.Name
End With
oRange.Collapse Direction:=wdCollapseEnd
With oRange
'Now the entity definition
If Len(tdf.Properties("Description")) = 0 Then
.Font.Color = vbRed
.InsertAfter Text:=" ***NO TABLE DEFINITION ***"
Else
.Font.Color = vbBlack
.InsertAfter Text:=" " &
Replace(tdf.Properties("Description"), vbCrLf, "; ")
End If
.Font.Underline = False
.Font.Bold = False
.Font.Size = 12
End With
'Restore any color change
oRange.Collapse Direction:=wdCollapseEnd
oRange.Font.Color = vbBlack
'Is there a table validation rule?
If Len(tdf.ValidationRule) > 0 Then
oRange.Collapse Direction:=wdCollapseEnd
oRange.InsertBreak (wdLineBreak)
oRange.InsertAfter Text:="ValidationRule: " &
tdf.ValidationRule
oRange.Collapse Direction:=wdCollapseEnd
oRange.InsertBreak (wdLineBreak) 'Line break
oRange.InsertAfter Text:="ValidationText: " &
tdf.ValidationText
End If
End With
'Iterate through all the attributes in the current entity
For Each fld In tdf.Fields
Set oRange = oActiveDoc.Range
oRange.Collapse Direction:=wdCollapseEnd
oRange.Select
With Word.Selection
'First the attribute name
.Font.Color = wdColorBlack
.Font.Bold = True
.TypeText Text:=vbCrLf & fld.Name & ": "
.Paragraphs(1).SpaceBefore = 0
.Collapse Direction:=wdCollapseEnd
.Font.Bold = False
'Then the datatype
.TypeText Text:=DataTypeName(fld)
'Null option
.TypeText Text:= _
" " _
& IIf((fld.Attributes And dbAutoIncrField) =
dbAutoIncrField, _
"Identity", _
IIf(fld.Required, "Not Null", "Null") _
)
'Caption
If Len(fld.Properties("caption")) = 0 Then
'Don't flag missing caption if it's a surrogate PK
(auto-increment) field
If (fld.Attributes And dbAutoIncrField) = 0 Then
.Collapse Direction:=wdCollapseEnd
.Font.Color = wdColorRed
.TypeText Text:=": ***NO CAPTION*** "
.Collapse Direction:=wdCollapseEnd
.Font.Color = wdColorBlack
End If
Else
.TypeText Text:=": " & fld.Properties("caption")
End If
'Definition
If Len(fld.Properties("description")) = 0 Then
.Collapse Direction:=wdCollapseEnd
.Font.Color = wdColorRed
.TypeText Text:=": ***NO DEFINITION *** "
.Collapse Direction:=wdCollapseEnd
.Font.Color = wdColorBlack
Else
.TypeText Text:=": " &
Replace(fld.Properties("Description"), vbCrLf, "; ")
End If
'Is there a default value?
If Len(fld.DefaultValue) > 0 Then
.InsertBreak (6) 'Line break
.TypeText Text:="Default Value: " & fld.DefaultValue
End If
'Is there a validation rule?
If Len(fld.ValidationRule) > 0 Then
.InsertBreak (6) 'Line break
.TypeText Text:="ValidationRule: " & fld.ValidationRule
.InsertBreak (6) 'Line break
.TypeText Text:="ValidationText: " & fld.ValidationText
End If
'Input mask
If Len(fld.Properties("InputMask")) = 0 Then
Else
.InsertBreak (wdLineBreak)
.TypeText Text:="InputMask: " &
fld.Properties("InputMask")
End If
'Format
If Len(fld.Properties("Format")) = 0 Then
Else
.InsertBreak (wdLineBreak)
.TypeText Text:="Format: " & fld.Properties("Format")
End If
'Display control and lookup properties
Select Case fld.Properties("DisplayControl")
Case acTextBox
'Default case, nothing to report
Case acCheckBox
.InsertBreak (wdLineBreak)
.TypeText Text:="Display Checkbox"
Case acComboBox, acListBox
.InsertBreak (wdLineBreak)
.TypeText Text:="Display Lookup Box with Rowsource: " _
& FieldLookupRowSource(dbData, fld)
.InsertBreak (wdLineBreak)
.TypeText Text:=FieldLookupPropertyString(fld)
End Select
End With
Next
If False Then
With Word.Selection
.Paragraphs(1).KeepWithNext = False
.TypeText Text:=vbCrLf
End With
Else
With oActiveDoc.Paragraphs.Last
.KeepWithNext = False
.Range.InsertAfter Text:=vbCrLf
End With
End If
Next
ExitHandler:
On Error Resume Next
Set fld = Nothing
Set tdf = Nothing
Set oActiveDoc = Nothing
Set oWord = Nothing
Set oRange = Nothing
Exit Sub
ErrorHandler:
Select Case Err.Number
Case 3265, 3270 'Item not found in this collection, or Property not
found
Resume Next
Case Else
Set objError = New pjsError
objError.pjsErrorCode
Procedure:="CreateEntityAttributeReportInWord",
ModuleName:=mconStrModuleName
Set objError = Nothing
End Select
Resume ExitHandler
Resume
End Sub
