frmmain.frm

很不错的Access数据库结构打印工具

                    '循环字段信息
                    For Each oField In rsAccess.Fields
                        Printer.CurrentX = 1000
                        j = Printer.CurrentY
                        Printer.Print oField.Name
                        Printer.CurrentX = 3000
                        If Printer.CurrentY < j Then
                            j = Printer.CurrentY
                        End If
                        Printer.CurrentY = j
                        
                        '获取数据类型
                        Printer.Print GetFieldType(oField.Type)
                        
                        Printer.CurrentX = 5000
                        If Printer.CurrentY < j Then
                            j = Printer.CurrentY
                        End If
                        Printer.CurrentY = j
                        Printer.Print oField.Size
                        Printer.CurrentX = 7000
                        If Printer.CurrentY < j Then
                            j = Printer.CurrentY
                        End If
                        Printer.CurrentY = j
                        Printer.Print oField.Required
                        Printer.CurrentX = 9000
                        If Printer.CurrentY < j Then
                            j = Printer.CurrentY
                        End If
                        Printer.CurrentY = j
                        Printer.Print oField.AllowZeroLength
                        i = i + 1
                    Next
                End If
                
                '获取索引
                If oTable.Indexes.Count > 0 Then
                    Printer.Print ""
                    Printer.CurrentX = 500
                    Printer.FontBold = True
                    Printer.Print "索引列表"
                    Printer.FontBold = False
                    j = Printer.CurrentY
                    Printer.CurrentX = 1000
                    Printer.Print "索引名称"
                    If Printer.CurrentY < j Then
                        j = Printer.CurrentY
                    End If
                    Printer.CurrentY = j
                    Printer.CurrentX = 3000
                    Printer.Print "字段"
                    If Printer.CurrentY < j Then
                        j = Printer.CurrentY
                    End If
                    Printer.CurrentY = j
                    Printer.CurrentX = 6000
                    Printer.Print "唯一"
                    j = Printer.CurrentY
                    Printer.CurrentX = 1000
                    Printer.Print "----------------"
                    If Printer.CurrentY < j Then
                        j = Printer.CurrentY
                    End If
                    Printer.CurrentY = j
                    Printer.CurrentX = 3000
                    Printer.Print "----------"
                    If Printer.CurrentY < j Then
                        j = Printer.CurrentY
                    End If
                    Printer.CurrentY = j
                    Printer.CurrentX = 6000
                    Printer.Print "----------"
                    
                    '循环表索引结构
                    For i = 0 To oTable.Indexes.Count - 1
                        j = Printer.CurrentY
                        Printer.CurrentX = 1000
                        Printer.Print oTable.Indexes(i).Name
                        If Printer.CurrentY < j Then
                            j = Printer.CurrentY
                        End If
                        Printer.CurrentY = j
                        Printer.CurrentX = 3000
                        Printer.Print oTable.Indexes(i).Fields
                        If Printer.CurrentY < j Then
                            j = Printer.CurrentY
                        End If
                        Printer.CurrentY = j
                        Printer.CurrentX = 6000
                        Printer.Print oTable.Indexes(i).Unique
                    Next i
                End If
                
                '释放，进行下一个表
                Set rsAccess = Nothing
                
                '是否每个表输出为一页
                If chkSeparated.Value = vbChecked Then
                    Printer.EndDoc
                Else
                    Printer.Print ""
                    Printer.Print ""
                End If
            End If
        Next
        If Not chkSeparated.Value = vbChecked Then
            Printer.EndDoc
        End If
        
        '释放数据库变量
        Set dbAccess = Nothing
        MsgBox "当前Access数据库结构已经打印到 " & Printer.DeviceName, vbInformation, "完毕"
        Screen.MousePointer = vbDefault
        Exit Sub
    End If
NoDB:
    If Err.Number = 3031 Then '数据库需要密码
        frmPassword.Show vbModal
        If frmPassword.pblnCancel = True Then Exit Sub
        cmdPrint_Click
        Err.Clear
        Exit Sub
    End If
    MsgBox Err.Description
    Screen.MousePointer = vbDefault
End Sub

'获取字段类型函数
Private Function GetFieldType(TypeCode As Integer)
    Select Case TypeCode
        Case dbBinary
            GetFieldType = "Binary"
        Case dbBoolean
            GetFieldType = "Boolean"
        Case dbByte
            GetFieldType = "Byte"
        Case dbChar
            GetFieldType = "Character"
        Case dbCurrency
            GetFieldType = "Currency"
        Case dbDate
            GetFieldType = "Date/Time"
        Case dbDecimal
            GetFieldType = "Decimal"
        Case dbDouble
            GetFieldType = "Double"
        Case dbFloat
            GetFieldType = "Float"
        Case dbGUID
            GetFieldType = "GUID"
        Case dbInteger
            GetFieldType = "Integer"
        Case dbLong
            GetFieldType = "Long"
        Case dbLongBinary
            GetFieldType = "OLE Object"
        Case dbMemo
            GetFieldType = "Memo"
        Case dbNumeric
            GetFieldType = "Numeric"
        Case dbSingle
            GetFieldType = "Single"
        Case dbText
            GetFieldType = "Text"
        Case dbTime
            GetFieldType = "Time"
        Case dbTimeStamp
            GetFieldType = "TimeStamp"
        Case dbVarBinary
            GetFieldType = "VarBinary"
        Case Else
            GetFieldType = "Undetermined"
    End Select
End Function

'输出结构到HTML文件过程
Private Sub PrintHTML()

Dim SaveFile As String
On Error GoTo CancelHTML
    
    '对话框
    With dlgCommon
        .CancelError = True
        .DialogTitle = "保存 HTML 页面..."
        .Filter = "网页文件 *.htm|*.htm;*.html"
        .InitDir = "C:\"
        .FileName = "Structure.htm"
        .ShowSave
        SaveFile = .FileName
    End With
    DoEvents
    Open SaveFile For Output As #2
    
    Set dbAccess = OpenDatabase(Trim(txtDBPath), True, True)
    
    'HTML 文件模板
    Print #2, "<html>"
    Print #2, "<head>"
    Print #2, "<meta name='Access Structure Print' content=Joseph Surls'>"
    Print #2, "<title>" & "Access 数据库结构，当前数据库是：" & Trim(txtDBPath) & "</title>"
    Print #2, "</head>"
    Print #2, "<body bgcolor='#0099FF'>"
    Print #2, "<p><font size='1'>"
    Print #2, "数据库路径：" & Trim(txtDBPath)
    Print #2, "</a></font></p>"
    
    '循环当前数据库的表
    For Each oTable In dbAccess.TableDefs
        Print #2, "<p><b><u><font size='4' color='#000000'>"
        Print #2, "表名称： " & oTable.Name & "</font><br>"
        Print #2, "</u></b><font size='2'>"
        Print #2, "建立日期 - " & oTable.DateCreated & "<br>"
        Print #2, "最终修改 - " & oTable.LastUpdated & "<br>"
        Print #2, "总记录数 - " & oTable.RecordCount & "<br>"
        Print #2, "-----------------------------------------------------------"
        Print #2, "</font></p>"
        
        '无系统表
        If Not UCase(Left(oTable.Name, 4)) = "MSYS" Then
            
            '打开表记录
            Set rsAccess = dbAccess.OpenRecordset(oTable.Name, dbOpenTable)
            Print #2, "<p>&nbsp;&nbsp; <font size='2'> </font><b><font size='3'>字段列表</font></b></p>"
            Print #2, "<table border='0' width='100%'>"
            Print #2, "<tr><td width='10%' align='center'></td>"
            Print #2, "<td width='30%' align='center'>"
            Print #2, "<p align='center'><u>字段名称</u></td>"
            Print #2, "<td width='20%' align='center'><u>类型</u></td>"
            Print #2, "<td width='10%' align='center'><u>宽度</u></td>"
            Print #2, "<td width='10%' align='center'><u>需求</u></td>"
            Print #2, "<td width='44%' align='center'><u>允许空值</u></td>"
            Print #2, "<td width='16%' align='center'></td></tr>"
            
            '循环表字段
            For Each oField In rsAccess.Fields
                Print #2, "<tr><td width='10%' align='center'></td>"
                Print #2, "<td width='30%' align='center'>"
                Print #2, oField.Name & "</td>"
                Print #2, "<td width='20%' align='center'>"
                
                '获取字段类型
                Print #2, GetFieldType(oField.Type) & "</td>"
                Print #2, "<td width='10%' align='center'>"
                Print #2, oField.Size & "</td>"
                Print #2, "<td width='10%' align='center'>"
                Print #2, oField.Required & "</td>"
                Print #2, "<td width='44%' align='center'>"
                Print #2, oField.AllowZeroLength & "</td>"
                Print #2, "<td width='16%' align='center'></td>"
                Print #2, "</tr>"
            Next
            Print #2, "</table>"
            
            '索引
            If oTable.Indexes.Count > 0 Then
                Print #2, "<p>&nbsp;&nbsp;&nbsp; <b>索引列表</b></p>"
                Print #2, "<table border='0' width='100%'>"
                Print #2, "<tr>"
                Print #2, "<td width='7%' align='center'></td>"
                Print #2, "<td width='23%' align='center'><u>索引名称</u></td>"
                Print #2, "<td width='44%' align='center'><u>字段</u></td>"
                Print #2, "<td width='19%' align='center'><u>唯一</u></td>"
                Print #2, "<td width='7%' align='center'></td>"
                Print #2, "</tr>"
                For i = 0 To oTable.Indexes.Count - 1
                    Print #2, "<tr>"
                    Print #2, "<td width='7%' align='center'></td>"
                    Print #2, "<td width='23%' align='center'>"
                    Print #2, oTable.Indexes(i).Name & "</td>"
                    Print #2, "<td width='44%' align='center'>"
                    Print #2, oTable.Indexes(i).Fields & "</td>"
                    Print #2, "<td width='19%' align='center'>"
                    Print #2, oTable.Indexes(i).Unique & "</td>"
                    Print #2, "<td width='7%' align='center'></td>"
                    Print #2, "</tr>"
                Next i
            End If
            Print #2, "</table>"
            Print #2, "<p>=======================================================================================================================</p>"
        End If
    Next
    Print #2, "<p align='center'>列表结束<br>"
    Print #2, "本页面使用Access数据库结构打印工具建立，建立日期： - " & _
        Date & "</p>"
    Print #2, "</body>"
    Print #2, "</html>"
    Close #2
    MsgBox "恭喜，您的文件已经保存为 " & dlgCommon.FileName, vbInformation, "完毕"
    Exit Sub
CancelHTML:
    If Err.Number = 32755 Then
        Exit Sub
    Else
        MsgBox Err.Number & Chr(10) & _
            Err.Description
    End If
End Sub

Private Sub optHTML_Click()
    chkSeparated.Enabled = False
    chkSystemTables.Enabled = False
End Sub

Private Sub optPrinter_Click()
    chkSeparated.Enabled = True
    chkSystemTables.Enabled = True
End Sub