nteger) As Integer
'''' Comments : Dumps the database structure to a text file
'''' In : strFile - path and name of file
'''' fProperties - true to dump properties
'''' fErrors - true to write errors
'''' Out : True/False - success/failure
'''' Revisions
'''' 04/08/96 djh initial version
''''
Dim dbsCurrent As Database
Dim tdfTmp As TableDef
Dim fldTmp As Field
Dim qdfTmp As QueryDef
Dim relTmp As Relation
Dim idxTmp As Index
Dim cntTmp As Container
Dim docTmp As Document
Dim prpTmp As Property
Dim intCounter As Integer
Dim intBCounter As Integer
Dim intCCounter As Integer
Dim intPCounter As Integer
'''' Delete the output file
On Error Resume Next
Kill strFile
On Error GoTo fDumpDAO_Err
'''' Initialize
intFileOut = FreeFile
Open strFile For Output As intFileOut
Set dbsCurrent = CurrentDB()
lngLines = 0
'''' Write the database info
Call WriteOutput("FMS DAO Dumper Version " & FMSVersion, 0)
Call WriteOutput("Generated: " & Now, 0)
Call WriteOutput("--------------------------------------------------------------------", 0)
If fProps Then
For intPCounter = 0 To dbsCurrent.Properties.Count - 1
Set prpTmp = dbsCurrent.Properties(intPCounter)
Call WriteProps(prpTmp, 1)
Next intPCounter
End If
'''' Iterate the Tabledefs collection
For intCounter = 0 To dbsCurrent.Tabledefs.Count - 1
Set tdfTmp = dbsCurrent.Tabledefs(intCounter)
Call WriteOutput("TABLE: " & tdfTmp.Name, 1)
If fProps Then
For intPCounter = 0 To tdfTmp.Properties.Count - 1
Set prpTmp = tdfTmp.Properties(intPCounter)
Call WriteProps(prpTmp, 2)
Next intPCounter
End If
'''' Iterate the fields collection
For intBCounter = 0 To tdfTmp.Fields.Count - 1
Set fldTmp = tdfTmp.Fields(intBCounter)
Call WriteOutput("TABLE FIELD: " & fldTmp.Name, 2)
If fProps Then
For intPCounter = 0 To fldTmp.Properties.Count - 1
Set prpTmp = fldTmp.Properties(intPCounter)
Call WriteProps(prpTmp, 3)
Next intPCounter
End If
Next intBCounter
'''' Iterate the Indexes collection
For intBCounter = 0 To tdfTmp.Indexes.Count - 1
Set idxTmp = tdfTmp.Indexes(intBCounter)
Call WriteOutput("INDEX: " & idxTmp.Name, 2)
If fProps Then
For intPCounter = 0 To idxTmp.Properties.Count - 1
Set prpTmp = idxTmp.Properties(intPCounter)
Call WriteProps(prpTmp, 3)
Next intPCounter
End If
'''' Iterate the index fields collection
For intCCounter = 0 To idxTmp.Fields.Count - 1
Set fldTmp = idxTmp.Fields(intCCounter)
Call WriteOutput("INDEX FIELD: " & fldTmp.Name, 3)
If fProps Then
For intPCounter = 0 To fldTmp.Properties.Count - 1
Set prpTmp = fldTmp.Properties(intPCounter)
Call WriteProps(prpTmp, 4)
Next intPCounter
End If
Next intCCounter
Next intBCounter
Next intCounter
'''' Iterate the Relations collection
For intCounter = 0 To dbsCurrent.Relations.Count - 1
Set relTmp = dbsCurrent.Relations(intCounter)
Call WriteOutput("RELATION: " & relTmp.Name, 1)
If fProps Then
For intPCounter = 0 To relTmp.Properties.Count - 1
Set prpTmp = relTmp.Properties(intPCounter)
Call WriteProps(prpTmp, 2)
Next intPCounter
End If
'''' Iterate the fields collection
For intBCounter = 0 To relTmp.Fields.Count - 1
Set fldTmp = relTmp.Fields(intBCounter)
Call WriteOutput("RELATION FIELD: " & fldTmp.Name, 2)
If fProps Then
For intPCounter = 0 To fldTmp.Properties.Count - 1
Set prpTmp = fldTmp.Properties(intPCounter)
Call WriteProps(prpTmp, 2)
Next intPCounter
End If
Next intBCounter
Next intCounter
'''' Iterate the querydefs collection
For intCounter = 0 To dbsCurrent.Querydefs.Count - 1
Set qdfTmp = dbsCurrent.Querydefs(intCounter)
Call WriteOutput("QUERY: " & qdfTmp.Name, 1)
If fProps Then
For intPCounter = 0 To qdfTmp.Properties.Count - 1
Set prpTmp = qdfTmp.Properties(intPCounter)
Call WriteProps(prpTmp, 2)
Next intPCounter
End If
'''' Iterate the fields collection
For intBCounter = 0 To qdfTmp.Fields.Count - 1
Set fldTmp = qdfTmp.Fields(intBCounter)
Call WriteOutput("QUERY FIELD: " & fldTmp.Name, 2)
If fProps Then
For intPCounter = 0 To fldTmp.Properties.Count - 1
Set prpTmp = fldTmp.Properties(intPCounter)
Call WriteProps(prpTmp, 2)
Next intPCounter
End If
Next intBCounter
Next intCounter
'''' Iterate the Containers collection
For intCounter = 0 To dbsCurrent.Containers.Count - 1
Set cntTmp = dbsCurrent.Containers(intCounter)
Call WriteOutput("CONTAINER: " & cntTmp.Name, 1)
If fProps Then
For intPCounter = 0 To cntTmp.Properties.Count - 1
Set prpTmp = cntTmp.Properties(intPCounter)
Call WriteProps(prpTmp, 2)
Next intPCounter
End If
'''' Iterate the Documents collection
For intBCounter = 0 To cntTmp.Documents.Count - 1
Set docTmp = dbsCurrent.Containers(intCounter).Documents(intBCounter)
Call WriteOutput("DOCUMENT: " & docTmp.Name, 2)
If fProps Then
For intPCounter = 0 To docTmp.Properties.Count - 1
Set prpTmp = docTmp.Properties(intPCounter)
Call WriteProps(prpTmp, 3)
Next intPCounter
End If
Next intBCounter
Next intCounter
fDumpDAO = True
Close intFileOut
fDumpDAO_Exit:
Exit Function
fDumpDAO_Err:
If fErrors Then
WriteOutput "************** Error: " & Error$, 0
End If
Resume Next
End Function
Sub Form_Open (Cancel As Integer)
Me!lblVersion.Caption = "Version " & FMSVersion
Me!txtFileName = "C:\DAO_DUMP.TXT"
Me!chkProperties = True
Me!chkErrors = True
Me!txtTabs = 4
End Sub
Sub WriteOutput (strOut As String, intIndent As Integer)
'''' Comments : Writes the string out to the file
'''' In : strOut - string to write
'''' intIndent - number of indents
'''' Out
'''' Revisions
''''
Dim strTabs As String
strTabs = Space(intIndent * intTabs)
Print #intFileOut, strTabs & strOut
lngLines = lngLines + 1
End Sub
Sub WriteProps (prpIn As Property, intIndent As Integer)
'''' Comments : Writes the name and value of the supplied property
'''' In : prpIn - property object
'''' intIndent - number of indents (hobo variable)
'''' Out :
'''' Revisions
''''
Dim intSaveErr As Integer
Dim strSaveErr As String
Dim strName As String
Dim varVal As Variant
'''' Disable error handler
On Error Resume Next
'''' Get the property name and value
strName = prpIn.Name
varVal = prpIn.Value
intSaveErr = Err
strSaveErr = Error$
'''' Reset error handler
On Error GoTo 0
If intSaveErr = 0 Then
Call WriteOutput(strName & ": " & varVal, intIndent)
Else
If fErrors Then
Call WriteOutput("************** " & strName & ": Error (" & strSaveErr & ")", intIndent)
End If
End If
End Sub
The Access 95/VBA Way
Now let''''s look at the VBA implementation of the same code base. You can see that code is much more efficient because we can now use "late binding"-that is we can Dim Foo As Object, and pass that Object around to subroutines. Also, we can use the For Each…Next construct to walk through collections:
Option Explicit
Dim intFileOut As Integer
Dim fErrors As Integer
Dim intTabs As Integer
Dim lngLines As Long
Const FMSVersion = "7.0"
Private Sub cmdCancel_Click()
DoCmd.Close
End Sub
Private Sub cmdClose_Click()
DoCmd.Close
End Sub
Private Sub cmdNotepad_Click()
Dim x As Variant
x = Shell("write.exe " & Me!txtFileName, 1)
End Sub
Private Sub cmdStart_Click()
Dim fOK As Integer
If Me!txtFileName <> "" Then
If Me!txtTabs <> "" Then
intTabs = Me!txtTabs
End If
DoCmd.Hourglass True
DoCmd.GoToPage 2
fOK = fDumpDAO(CStr(Me!txtFileName), CInt(Me!chkProperties), CInt(Me!chkErrors))
Me!cmdNotepad.Enabled = True
DoCmd.Hourglass False
Me!txtLines.Caption = lngLines & " lines were written to file: " & Me!txtFileName
DoCmd.GoToPage 3
End If
End Sub
Private Function fDumpDAO(strFile As String, fProps As Integer, fErrors As Integer) As Integer
'''' Comments : Dumps the database structure to a text file
'''' In : strFile - path and name of file
'''' fProperties - true to dump properties
'''' fErrors - true to write errors
'''' Out : True/False - success/failure
'''' Revisions
'''' 04/08/96 djh initial version
''''
Dim dbsCurrent As DATABASE
Dim tdfTmp As TableDef
Dim fldTmp As Field
Dim qdfTmp As QueryDef
Dim relTmp As Relation
Dim idxTmp As INDEX
Dim cntTmp As Container
Dim docTmp As Document
Dim prpTmp As Property
Dim intCounter As Integer
Dim intBCounter As Integer
Dim intCCounter As Integer
Dim intPCounter As Integer
'''' Delete the output file
On Error Resume Next
Kill strFile
On Error GoTo fDumpDAO_Err
'''' Initialize
intFileOut = FreeFile
Open strFile For Output As intFileOut
Set dbsCurrent = CurrentDb()
lngLines = 0
'''' Write the database info
Call WriteOutput("FMS DAO Dumper Version " & FMSVersion, 0)
Call WriteOutput("Generated: " & Now, 0)
Call WriteOutput("--------------------------------------------------------------------", 0)
If fProps Then Call WriteProps(dbsCurrent, 1)
'''' Iterate the Tabledefs collection
For Each tdfTmp In dbsCurrent.TableDefs
Call WriteOutput("TABLE:上一页 [1] [2] [3] [4] [5] 下一页
|
