📄 mod_access.bas
字号:
Attribute VB_Name = "Mod_Access"
'导出一个数据库（ACCESS文件）的数据库结构到一个HTML文件。
Public Function DbToHtml(ByVal strDbFileName As String, ByVal strHtmlFileName As String)
Dim adoRS As New ADODB.Recordset 'ADO记录集
Dim adoGetTab As New ADOX.Catalog 'ADOX的一个对象，用来读取数据库里的表
Dim strConn As String '连接字符串
Dim i As Integer
Dim j As Integer
Dim S As Integer
Dim lngFileNum As Long '当前可使用的文件号
Dim lngFields As Long '表里的字段总数
Dim strTabs() As String '保存数据库里的所有表名
Dim strFileName As String '文件名
Dim strNULL As String '是否必填
Dim strDefault As String '默认值
Dim strDescription As String '字段描述
On Error GoTo LocalErr
i = InStrRev(strDbFileName, "\")
strFileName = Fun_GetStr(strDbFileName, "\", ".", i)
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strDbFileName
adoGetTab.ActiveConnection = strConn
S = adoGetTab.Tables.Count - 1
ReDim strTabs(S)
For i = 0 To S
' MSYS开头的为系统表
If UCase(Left$(adoGetTab(i).Name, 4)) <> "MSYS" Then
strTabs(i) = adoGetTab(i).Name
End If
Next i
Set adoGetTab = Nothing
'判断这个文件是否存在
If Exists(strHtmlFileName, vbNormal) = False Then
lngFileNum = FreeFile
Open strHtmlFileName For Output As #lngFileNum
Close #lngFileNum
Else
If MsgBox(strHtmlFileName & "文件已经存在，是否覆盖？", vbYesNo + vbInformation) = vbYes Then
Kill strHtmlFileName
lngFileNum = FreeFile
Open strHtmlFileName For Output As #lngFileNum
Close #lngFileNum
Else
Exit Function
End If
End If
'打开那个HTML文件，准备写入数据
lngFileNum = FreeFile
Open strHtmlFileName For Append As #lngFileNum
Print #lngFileNum, "<html>"
Print #lngFileNum, "<head>"
Print #lngFileNum, "<meta http-equiv=Content-Type content=text/html; charset=gb2312>"
Print #lngFileNum, "<title>数据库结构表</title>"
Print #lngFileNum, "<style type='text/css'>"
Print #lngFileNum, "body{FONT-SIZE: 12px;"
Print #lngFileNum, "COLOR: #505050;"
Print #lngFileNum, "FONT-FAMILY: 宋体;"
Print #lngFileNum, "background-color: #FFFFFF;}"
Print #lngFileNum, "A:visited{TEXT-DECORATION: none;Color:#3366CC}"
Print #lngFileNum, "A:active{TEXT-DECORATION: none;Color:#3366CC}"
Print #lngFileNum, "A:hover{TEXT-DECORATION: underline;Color:#FF9933}"
Print #lngFileNum, "A:link{text-decoration: none;Color:#3366CC}"
Print #lngFileNum, "TD{font-family: 宋体;"
Print #lngFileNum, "font-size: 12px;"
Print #lngFileNum, "background-color: #FFFFFF;}"
Print #lngFileNum, "td.TableTitle{"
Print #lngFileNum, "Color: #FFFFFF;"
Print #lngFileNum, "font-weight: bold;"
Print #lngFileNum, "background-color: #336699;}"
Print #lngFileNum, "td.TableTitle2{"
Print #lngFileNum, "Color: #FF6600;"
Print #lngFileNum, "background-color: #F1F1F1;}"
Print #lngFileNum, "</style>"
Print #lngFileNum, "</head>"
Print #lngFileNum, "<body>"
Print #lngFileNum, "<p align=center><font color=#336699>" & strFileName & "数据库结构</font></p>"
Print #lngFileNum, "<div align=center>"
Print #lngFileNum, "<Table border=1 width=90% cellspacing=0 cellpadding=2 bordercolordark=#FFFFFF bordercolorlight=#AABBCC>"
With adoRS
.ActiveConnection = strConn
.CursorLocation = adUseServer
.CursorType = adOpenStatic
.LockType = adLockReadOnly
End With
For i = 0 To S
If strTabs(i) = "" Then GoTo NextFor
DoEvents
Frm_Main.lblState.Caption = "正在导出表 -> " & strTabs(i)
'增加一个表名的单元格
Print #lngFileNum, "<TR><TD Width=100% colspan=7 Class='TableTitle' align=center>" _
& strTabs(i) & "(" & GetTabDescription(strDbFileName, strTabs(i)) & ")</TD></TR>"
adoRS.Source = "Select * From " & strTabs(i)
adoRS.Open
lngFields = adoRS.Fields.Count - 1
Print #lngFileNum, "<TR><TD Width=20% align=center Class='TableTitle2'>字段名称</TD>"
Print #lngFileNum, "<TD Width=10% align=center Class='TableTitle2'>字段大小</TD>"
Print #lngFileNum, "<TD Width=15% align=center Class='TableTitle2'>字段类型</TD>"
Print #lngFileNum, "<TD Width=8% align=center Class='TableTitle2'>默认值</TD>"
Print #lngFileNum, "<TD Width=7% align=center Class='TableTitle2'>必填</TD>"
Print #lngFileNum, "<TD Width=10% align=center Class='TableTitle2'>允许空</TD>"
Print #lngFileNum, "<TD Width=30% align=center Class='TableTitle2'>说明</TD></TR>"
For j = 0 To lngFields
DoEvents
strNULL = GetFieldIndex(strTabs(i), adoRS.Fields(j).Name, strConn, strDefault, strDescription)
Print #lngFileNum, "<TR><TD Width=20% align=left>" & adoRS.Fields(j).Name & "</TD>"
Print #lngFileNum, "<TD Width=10% align=center>" & adoRS.Fields(j).DefinedSize & "</TD>"
Print #lngFileNum, "<TD Width=10% align=center>" & GetTypeName(adoRS.Fields(j).Type) & "</TD>"
Print #lngFileNum, "<TD Width=10% align=center>" & IIf(Len(strDefault) = 0, "-", strDefault) & "</TD>"
Print #lngFileNum, "<TD Width=10% align=center>" & IIf(strNULL = "True", "√", "×") & "</TD>"
Print #lngFileNum, "<TD Width=10% align=center>" & IIf(strNULL = "True", "×", "√") & "</TD>"
Print #lngFileNum, "<TD Width=30% align=center>" & strDescription & "</TD></TR>"
Next j
adoRS.Close
NextFor:
Next i
Set adoRS = Nothing
Print #lngFileNum, "</Table></div>"
Print #lngFileNum, "<p align='center'>谢谢使用！如有问题请E-Mail联系我，或到论坛给我留言！"
Print #lngFileNum, "<br>BBS:<a href='http://www.5ivb.net'>程序太平洋社区</a>"
Print #lngFileNum, "<br>E-Mail:<a href='mailto:zhouronggang@163.com'>zhouronggang@163.com</a></p>"
Print #lngFileNum, "</body>"
Print #lngFileNum, "</html>"
Close #lngFileNum
Frm_Main.lblState.Caption = "导出操作已经完成！"
MsgBox "导出操作已经完成！", vbInformation
Exit Function
LocalErr:
MsgBox "导出过程发生错误！！" & Err.Description, vbExclamation
Err.Clear
Set adoRS = Nothing
End Function
'取得类型名称
Function GetTypeName(ByVal intType As Integer) As String
Select Case intType
'与其他类型一起加入逻辑 OR 以指示该数据是那种类型的安全数组 (DBTYPE_ARRAY)。
Case adArray
GetTypeName = "adArray"
'8 字节带符号的整数 (DBTYPE_I8)。
Case adBigInt
GetTypeName = "adBigInt"
'二进制值 (DBTYPE_BYTES)。
Case adBinary
GetTypeName = "adBinary"
'布尔型值 (DBTYPE_BOOL)。
Case adBoolean
GetTypeName = "adBoolean"
GetTypeName = "是/否"
'与其他类型一起加入逻辑 OR 以指示该数据是其他类型数据的指针 (DBTYPE_BYREF)。
Case adByRef
GetTypeName = "adByRef"
'以空结尾的字符串 (Unicode) (DBTYPE_BSTR)。
Case adBSTR
GetTypeName = "adBSTR"
'字符串值 (DBTYPE_STR)。
Case adChar
GetTypeName = "adChar"
'货币值 (DBTYPE_CY)。货币数字的小数点位置固定、小数点右侧有四位数字。
'该值保存为 8 字节范围为 10,000 的带符号整型值。
Case adCurrency
GetTypeName = "adCurrency"
GetTypeName = "货币"
'日期值 (DBTYPE_DATE)。日期按双精度型数值来保存，数字全部表示从 1899 年 12 月 30 开始的日期数。
'小数部分是一天当中的片段时间。
Case adDate
GetTypeName = "adDate"
GetTypeName = "日期/时间"
'日期值 (yyyymmdd) (DBTYPE_DBDATE)。
Case adDBDate
GetTypeName = "adDBDate"
'时间值 (hhmmss) (DBTYPE_DBTIME)。
Case adDBTime
GetTypeName = "adDBTime"
'时间戳（yyyymmddhhmmss 加 10 亿分之一的小数）(DBTYPE_DBTIMESTAMP).
Case adDBTimeStamp
GetTypeName = "adDBTimeStamp"
'具有固定精度和范围的精确数字值 (DBTYPE_DECIMAL)。
Case adDecimal
GetTypeName = "adDecimal"
'双精度浮点值 (DBTYPE_R8)。
Case adDouble
GetTypeName = "adDouble"
'未指定值 (DBTYPE_EMPTY)。
Case adEmpty
GetTypeName = "adEmpty"
'32 - 位错误代码 (DBTYPE_ERROR)。
Case adError
GetTypeName = "adError"
'全局唯一的标识符 (GUID) (DBTYPE_GUID)。
Case adGUID
GetTypeName = "adGUID"
'OLE 对象上 Idispatch 接口的指针 (DBTYPE_IDISPATCH)。
Case adIDispatch
GetTypeName = "adIDispatch"
'4 字节的带符号整型 (DBTYPE_I4)。
Case adInteger
GetTypeName = "adInteger"
GetTypeName = "数字"
'OLE 对象上 IUnknown 接口的指针 (DBTYPE_IUNKNOWN)。
Case adIUnknown
GetTypeName = "adIUnknown"
'长二进制值（仅用于 Parameter 对象）。
Case adLongVarBinary
GetTypeName = "adLongVarBinary"
GetTypeName = "OLE 对象"
'长字符串值（仅用于 Parameter 对象）。
Case adLongVarChar
GetTypeName = "adLongVarChar"
'以空结尾的长字符串值（仅用于 Parameter 对象）。
Case adLongVarWChar
GetTypeName = "adLongVarWChar"
GetTypeName = "备注/超级链接"
'具有固定精度和范围的精确数字值 (DBTYPE_NUMERIC)。
Case adNumeric
GetTypeName = "adNumeric"
'单精度浮点值 (DBTYPE_R4)。
Case adSingle
GetTypeName = "adSingle"
'2 字节带符号整型 (DBTYPE_I2)。
Case adSmallInt
GetTypeName = "adSmallInt"
'1 字节带符号整型 (DBTYPE_I1)。
Case adTinyInt
GetTypeName = "adTinyInt"
'8 字节不带符号整型 (DBTYPE_UI8)。
Case adUnsignedBigInt
GetTypeName = "adUnsignedBigInt"
'4 字节不带符号整型 (DBTYPE_UI4)。
Case adUnsignedInt
GetTypeName = "adUnsignedInt"
'2 字节不带符号整型 (DBTYPE_UI2)。
Case adUnsignedSmallInt
GetTypeName = "adUnsignedSmallInt"
'1 字节不带符号整型 (DBTYPE_UI1)。
Case adUnsignedTinyInt
GetTypeName = "adUnsignedTinyInt"
'用户定义的变量 (DBTYPE_UDT)。
Case adUserDefined
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -