📄 mod_sqlserver.bas
字号:
Attribute VB_Name = "Mod_SQLServer"
Type SqlTable
strName As String '在SQLSERVER数据库里的表名称
lngID As Long '在SQLSERVER数据库里的表编号
End Type
Dim adoRS_Fields As New ADODB.Recordset '用来读取字段信息
'导出一个数据库（SqlServer）的数据库结构到一个HTML文件。
Public Function SqlServerToHtml(ByVal strConn As String, ByVal strHtmlFileName As String)
Dim adoRS As New ADODB.Recordset 'ADO记录集
Dim i As Integer, j As Integer
Dim S As Integer
Dim lngFileNum As Long
Dim lngCount As Long '表里的记录数
Dim userTabs() As SqlTable '保存数据库里的所有表名
Dim strNULL As String '是否必填
Dim strDefault As String '默认值
Dim strDescription As String '字段说明
Dim strSQL As String 'SQL 语句
Dim strFieldName As String '字段名称
Dim strIsKey As String '是否为关键字
Dim lngLen As Long '临时保存长度
On Error GoTo LocalErr
'从系统表 sysobjects 里读取用户数据表
strSQL = "SELECT * FROM sysobjects WHERE (xtype = 'U' AND name<>'dtproperties') ORDER BY name"
With adoRS
.ActiveConnection = strConn
.CursorLocation = adUseServer
.CursorType = adOpenStatic
.LockType = adLockReadOnly
.Source = strSQL
.Open
If .EOF And .BOF Then
Exit Function
End If
End With
Set adoRS_Fields = Nothing
With adoRS_Fields
.ActiveConnection = strConn
.CursorLocation = adUseServer
.CursorType = adOpenStatic
.LockType = adLockReadOnly
End With
S = adoRS.RecordCount - 1
ReDim userTabs(S)
'记录表名和表的编号
For i = 0 To S
userTabs(i).strName = adoRS.Fields("name").Value
userTabs(i).lngID = adoRS.Fields("id").Value
adoRS.MoveNext
Next i
adoRS.Close
'判断这个文件是否存在
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>"
For i = 0 To S
If userTabs(i).strName = "" Then GoTo NextFor
DoEvents
Frm_Main.lblState.Caption = "正在导出表 -> " & userTabs(i).strName
'增加一个表名的单元格
Print #lngFileNum, "<TR><TD Width=100% colspan=7 Class='TableTitle' align=center>" _
& userTabs(i).strName & "</TD></TR>"
adoRS.Source = "SELECT Col.NAME COLNAME,Types.name AS COLTYPE," & _
"Col.length AS COLLENGTH,(" & _
"SELECT CONVERT(nvarchar,value) AS COLMEMO " & _
"FROM sysproperties WHERE id=Obj.id AND smallid=Col.colid) AS COLMEMO " & _
"FROM sysobjects Obj,syscolumns Col,systypes Types " & _
"WHERE Obj.id=Col.id AND Obj.xtype='U' AND Col.xtype=Types.xtype " & _
" AND Types.name<>'sysname' AND Obj.NAME='" & userTabs(i).strName & "' ORDER BY Col.colid "
adoRS.Open
lngCount = adoRS.RecordCount - 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 lngCount
DoEvents
strFieldName = adoRS.Fields("COLNAME").Value
If IsNull(adoRS.Fields("COLMEMO").Value) Then
strDescription = "-"
Else
strDescription = adoRS.Fields("COLMEMO").Value
End If
Call GetFieldInfos(userTabs(i).lngID, strFieldName, strDefault, strNULL, strIsKey)
If strIsKey = "True" Then
strFieldName = strFieldName & "(*)"
End If
lngLen = adoRS.Fields("COLLENGTH").Value
If adoRS.Fields("COLTYPE").Value = "nvarchar" Then
lngLen = lngLen / 2
End If
Print #lngFileNum, "<TR><TD Width=20% align=left>" & strFieldName & "</TD>"
Print #lngFileNum, "<TD Width=10% align=center>" & lngLen & "</TD>"
Print #lngFileNum, "<TD Width=10% align=center>" & adoRS.Fields("COLTYPE").Value & "</TD>"
Print #lngFileNum, "<TD Width=10% align=center>" & IIf(Len(strDefault) = 0, "-", strDefault) & "</TD>"
Print #lngFileNum, "<TD Width=10% align=center>" & strNULL & "</TD>"
Print #lngFileNum, "<TD Width=10% align=center>" & IIf(strNULL = "√", "×", "√") & "</TD>"
Print #lngFileNum, "<TD Width=30% align=center>" & strDescription & "</TD></TR>"
adoRS.MoveNext
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
Set adoRS_Fields = Nothing
Frm_Main.lblState.Caption = "导出操作已经完成！"
MsgBox "导出操作已经完成！", vbInformation
Exit Function
LocalErr:
MsgBox "导出过程发生错误！！" & Err.Description, vbExclamation
Err.Clear
Set adoRS_Fields = Nothing
Set adoRS = Nothing
End Function
'取得字段的一些属性
Function GetFieldInfos(ByVal lngTabID As Long, _
ByVal strFieldName As String, _
strDefault As String, _
strIsNull As String, _
strIsKey As String) As Boolean
Dim strSQL As String '保存SQL语句
Dim i As Integer
Dim intCount As Integer '记录集里的记录数
'取得某个表里的“关键字”
strSQL = "SELECT name FROM syscolumns S WHERE id=" & lngTabID & _
" AND colid IN(SELECT colid FROM sysindexkeys WHERE S.id=id and indid IN(" & _
"SELECT indid FROM sysindexes WHERE S.id=id and name IN(" & _
"SELECT name FROM sysobjects WHERE xtype='PK' and parent_obj=S.id)))"
With adoRS_Fields
.Source = strSQL
.Open
strIsKey = "False"
If .EOF And .BOF Then
GoTo CloseAdo
End If
intCount = adoRS_Fields.RecordCount
For i = 1 To intCount
If strFieldName = .Fields(0).Value Then
strIsKey = "True"
Exit For
End If
.MoveNext
Next i
CloseAdo:
.Close
'取得一个字段的是否允许为空及说明信息
.Source = "SELECT isnullable,(SELECT [text] FROM syscomments WHERE id = (" & _
"SELECT cdefault FROM syscolumns WHERE name='" & _
strFieldName & "' AND id=" & lngTabID & ")) As Def FROM syscolumns WHERE name='" & _
strFieldName & "' AND id=" & lngTabID & ""
.Open
If .EOF And .BOF Then
.Close
Exit Function
End If
If IsNull(.Fields("Def").Value) Then
strDefault = ""
Else
strDefault = .Fields("Def").Value
End If
If .Fields("isnullable").Value = 0 Then
strIsNull = "√"
Else
strIsNull = "×"
End If
.Close
End With
End Function
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -