一个基于VBA的数据字典生成宏(直接生成word文档)

        发布一个可直接在word中，根据指定连接字段生成数据字典的宏，原文及代码：Generating Data Dictionary or Database Design Document using MS Word Macros ，实用于Sql Server 2005。2000下不行，2008没测试过……

        用法：

        1，新建一个word文档，在文档中新建一个宏，将代码copy到里面；

        2，添加对Microsoft ActiveX Data Object的引用；

        3，修改里面的连接字段Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;password=123;Initial Catalog=Northwind;Data Source=(local)

        4，保存，并运行宏中的About方法

        原代码中有几个不太完美的地方，由于之前接触过一点VBA，花了两个小时，动手改了一下：

        1，汉化（其实就换了几个字符串而已:-D）；

        2，新增“描述”列，对应表中字段的说明(这个才是最有用的，想不通为啥“洋鬼子”不把此列显示出来)；

        3，将对表的描述，作为二级大纲标题显示出来；

        4，在文档中生成TOC(如果一个项目中有上百张表，可以想象没有TOC的文档，可读性是多么差)。

        代码直接贴在下面，希望有兴趣的朋友继续改进，别忘了发我一份就行:-)

 

Code
'Attribute VB_Name = "NewMacros"

Sub Start()
'Attribute About.VB_Description = "Macro created 3/18/2008 by shashi"
'Attribute About.VB_ProcData.VB_Invoke_Func = "Normal.NewMacros.About"
'
' Macro created 3/18/2008 by shashi
'
Dim conn As New ADODB.Connection
Dim rsMain As New ADODB.Recordset
Dim rsFields As New ADODB.Recordset
Dim rsKey As New ADODB.Recordset
Dim rsKeyTemp As ADODB.Recordset
Dim Range As Range
Dim row As Integer
Dim strQuery As String
Dim strFieldType As String
Dim I As Long

'Open a connection object
If conn.State = 1 Then conn.Close
conn.Open "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;password=123456;Initial Catalog=PQMAGIC;Data Source=(local)"

'Open the recordset to retrieve the tables in the database
If rsMain.State = 1 Then rsMain.Close
rsMain.Open "Select tb.[name],ex.value from sys.tables as tb inner join sys.extended_properties as ex" & _
" on tb.[object_id]=ex.major_id where tb.[name]<>'sysdiagrams' and ex.minor_id=0 order by name", conn, adOpenKeyset, adLockOptimistic

row = 1
'Iterate through the tables recordset
While Not rsMain.EOF
    'Start with the active document
    With Word.ActiveDocument
            'Procedure to set the table name
            Call SetTableName(rsMain(0), rsMain(1))
            
            'Query to get the Indexes,Views,Stored Procedures,Functions,Triggers of the table
            
            strQuery = "select ind.name,'INDEX' as col2 from sys.indexes ind inner join sys.tables tab" & _
                       " on ind.object_id = tab.object_id where tab.name =  '" & rsMain(0) & "'" & _
                       " and ind.name is not null" & _
                       " union" & _
                       " Select Distinct Procedures.Name, 'View'  as col2 From SysObjects" & _
                       " Join (SysObjects Procedures Join SysDepends on Procedures.Id = SysDepends.Id)" & _
                       " On SysDepends.DepId = SysObjects.Id Where SysObjects.XType = 'U'" & _
                       " And Procedures.XType = 'V' And SysObjects.Name =  '" & rsMain(0) & "'" & _
                       " union" & _
                       " Select Distinct Procedures.Name, 'Stored Procedure'  as col2 From SysObjects" & _
                       " Join (SysObjects Procedures Join SysDepends on Procedures.Id = SysDepends.Id)" & _
                       " On SysDepends.DepId = SysObjects.Id Where SysObjects.XType = 'U'" & _
                       " And Procedures.XType = 'P'And SysObjects.Name = '" & rsMain(0) & "'" & _
                       " AND   (lower(Procedures.Name) like 'spalias%' or lower(Procedures.Name) like 'spcustom%' " & _
                       " or lower(Procedures.Name) like 'spncustom%') " & _
                       " union" & _
                       " Select Distinct Procedures.Name, 'Function'  as col2 From SysObjects" & _
                       " Join (SysObjects Procedures Join SysDepends on Procedures.Id = SysDepends.Id)" & _
                       " On SysDepends.DepId = SysObjects.Id Where SysObjects.XType = 'U'" & _
                       " And Procedures.XType in ( 'Fn','If','Tf') And SysObjects.Name =  '" & rsMain(0) & "'" & _
                       " union" & _
                       " Select Distinct Procedures.Name, 'Trigger'  as col2 From SysObjects" & _
                       " Join (SysObjects Procedures Join SysDepends on Procedures.Id = SysDepends.Id)" & _
                       " On SysDepends.DepId = SysObjects.Id Where SysObjects.XType = 'U'" & _
                       " And Procedures.XType = 'Tr' And SysObjects.Name =  '" & rsMain(0) & "'"

            'Create a recordset to find Indexes,Views,Stored Procedures,Functions,Triggers of the table
            If rsKey.State = 1 Then rsKey.Close
            rsKey.Open strQuery, conn, adOpenKeyset, adLockReadOnly
            

            '***************Index************************
            If Not rsKey Is Nothing Then
                'Clone the recordset object to find the indexes of the table
                 Set rsKeyTemp = rsKey.Clone(adLockReadOnly)
                 rsKeyTemp.Filter = "col2='INDEX'"
                 'Set the labelling in the document
                 Call SetHeading("索引:")
                 If rsKeyTemp.EOF Then
                     Call SetTextAfter("-无-")
                 End If
                 While Not rsKeyTemp.EOF
                     Call SetTextAfter(rsKeyTemp(0))
                     rsKeyTemp.MoveNext
                 Wend
                '****************************************************
                '******************Views***************
                
                'Clone the recordset object to find the indexes of the table
                 Set rsKeyTemp = rsKey.Clone(adLockReadOnly)
                 rsKeyTemp.Filter = "col2='View'"
                 'Set the labelling in the document
                 Call SetHeading("视图:")
                 If rsKeyTemp.EOF Then
                     Call SetTextAfter("-无-")
                 End If
                 While Not rsKeyTemp.EOF
                     Call SetTextAfter(rsKeyTemp(0))
                     rsKeyTemp.MoveNext
                 Wend
                 
                 '************************************
                 '******************Stored Procedures***************
                 
                 'Clone the recordset object to find the indexes of the table
                 Set rsKeyTemp = rsKey.Clone(adLockReadOnly)
                 rsKeyTemp.Filter = "col2='Stored Procedure'"
                 'Set the labelling in the document
                 Call SetHeading("存储过程:")
                 If rsKeyTemp.EOF Then
                     Call SetTextAfter("-无-")
                 End If
                 While Not rsKeyTemp.EOF
                     Call SetTextAfter(rsKeyTemp(0))
                     rsKeyTemp.MoveNext
                 Wend
                 
                 '************************************
                 '******************Functions***************
                 
                'Clone the recordset object to find the indexes of the table
                 Set rsKeyTemp = rsKey.Clone(adLockReadOnly)
                 rsKeyTemp.Filter = "col2='Function'"
                 'Set the labelling in the document
                 Call SetHeading("用户自定义函数:")
                 If rsKeyTemp.EOF Then
                     Call SetTextAfter("-无-")
                 End If
                 While Not rsKeyTemp.EOF
                     Call SetTextAfter(rsKeyTemp(0))
                     rsKeyTemp.MoveNext
                 Wend
                 
                 '************************************
                 '******************Triggers***************
                 
                 'Clone the recordset object to find the indexes of the table
                 Set rsKeyTemp = rsKey.Clone(adLockReadOnly)
                 rsKeyTemp.Filter = "col2='Trigger'"
                'Set the labelling in the document
                 Call SetHeading("触发器:")
                 If rsKeyTemp.EOF Then
                     Call SetTextAfter("-无-")
                 End If
                 While Not rsKeyTemp.EOF
                     Call SetTextAfter(rsKeyTemp(0))
                     rsKeyTemp.MoveNext
                 Wend
            End If
            '************************************
        'Set the labelling in the document
        Call SetHeading("表详细信息")
        'Procedure to position the cursor in the document
        Call MoveDown
        
        On Error GoTo Err
        
        'Query to get the column names of the table
        strQuery = ""
        strQuery = "select st.name,col.*,ex.value from syscolumns col inner join " & _
                   " sysobjects sob on col.id = sob.id and sob.XType = 'U' " & _
                   " inner join systypes st on col.usertype = st.usertype " & _
                   " and col.xtype = st.xtype " & _
                   " and sob.Name = '" & rsMain(0) & "'" & _
                   " inner join sys.extended_properties ex on colid=ex.minor_id and col.id=ex.major_id"
                   
        If rsFields.State = 1 Then rsFields.Close
        rsFields.Open strQuery, conn, adOpenKeyset, adLockOptimistic
        
        If Not rsFields Is Nothing And rsFields.Fields.Count > 0 Then
            
            'Create the table in the document to display the columns
            'Table will display "Field Name","Field Type","Size","Key","Description"
            
            .Tables.Add Range:=Selection.Range, NumRows:=rsFields.RecordCount + 1, NumColumns _
             :=6, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
             wdAutoFitFixed
             .Tables(row).Cell(1, 1).Shading.BackgroundPatternColor = wdColorGray20
             .Tables(row).Cell(1, 1).Range.InsertBefore "字段名"
             .Tables(row).Cell(1, 1).Range.Bold = True
             .Tables(row).Cell(1, 2).Range.InsertBefore "类型"
             .Tables(row).Cell(1, 2).Shading.BackgroundPatternColor = wdColorGray20
             .Tables(row).Cell(1, 2).Range.Bold = True
             .Tables(row).Cell(1, 3).Range.InsertBefore "长度"
             .Tables(row).Cell(1, 3).Shading.BackgroundPatternColor = wdColorGray20
             .Tables(row).Cell(1, 3).Range.Bold = True
             Call .Tables(row).Columns(2).SetWidth(50, wdAdjustSameWidth)
             Call .Tables(row).Columns(3).SetWidth(40, wdAdjustSameWidth)
             Call .Tables(row).Columns(4).SetWidth(40, wdAdjustSameWidth)
             Call .Tables(row).Columns(5).SetWidth(100, wdAdjustSameWidth)
             Call .Tables(row).Columns(6).SetWidth(80, wdAdjustSameWidth)
             .Tables(row).Cell(1, 4).Range.InsertBefore "键"
             .Tables(row).Cell(1, 4).Shading.BackgroundPatternColor = wdColorGray20
             .Tables(row).Cell(1, 4).Range.Bold = True
             .Tables(row).Cell(1, 5).Range.InsertBefore "描述"
             .Tables(row).Cell(1, 5).Shading.BackgroundPatternColor = wdColorGray20
             .Tables(row).Cell(1, 5).Range.Bold = True
             .Tables(row).Cell(1, 6).Range.InsertBefore "备注"
             .Tables(row).Cell(1, 6).Shading.BackgroundPatternColor = wdColorGray20
             .Tables(row).Cell(1, 6).Range.Bold = True
            I = 0
             While Not rsFields.EOF
                .Tables(row).Cell(I + 2, 1).Range.InsertBefore rsFields(1)
                .Tables(row).Cell(I + 2, 2).Range.InsertBefore rsFields(0)
                .Tables(row).Cell(I + 2, 3).Range.InsertBefore rsFields(6)
                Dim arr() As String
                arr = Split(rsFields(33), " ")
                If UBound(arr) = 3 Then
                    .Tables(row).Cell(I + 2, 5).Range.InsertBefore "关联" & arr(2) & "表"
                Else
                    .Tables(row).Cell(I + 2, 5).Range.InsertBefore rsFields(33)
                End If
                rsFields.MoveNext
                I = I + 1
            Wend
          End If
          
          'Query to retrieve the constraints,Keys and Identity of the table
          
         strQuery = "select  c.COLUMN_NAME,CONSTRAINT_TYPE,''  as DefaultValue " & _
            " from    INFORMATION_SCHEMA.TABLE_CONSTRAINTS pk ," & _
            " INFORMATION_SCHEMA.KEY_COLUMN_USAGE c" & _
            " where   pk.TABLE_NAME = '" & rsMain(0) & "' " & _
            " and c.TABLE_NAME = pk.TABLE_NAME" & _
            " and c.CONSTRAINT_NAME = pk.CONSTRAINT_NAME" & _
            " union" & _
            " select c.name,'DEFAULT CONSTRAINT' AS defaultcontraint," & _
            " replace(replace(ind.definition,'(',''),')','') AS DefaultValue" & _
            " from sys.default_constraints ind" & _
            " inner join sys.tables tab" & _
            " on ind.parent_object_id = tab.object_id" & _
            " inner join sys.columns c" & _
            " on tab.object_id = c.object_id and" & _
            " c.column_id = ind.parent_column_id" & _
            " where tab.name = '" & rsMain(0) & "' " & _
            " union " & _
            " select COLUMN_NAME, 'IDENTITY' AS defaultcontraint,''  as DefaultValue " & _
            " from INFORMATION_SCHEMA.Columns " & _
            " where TABLE_NAME = '" & rsMain(0) & "' " & _
            " and COLUMNPROPERTY(object_id(TABLE_NAME), COLUMN_NAME, 'IsIdentity') = 1"

        If rsKey.State = 1 Then rsKey.Close
        rsKey.Open strQuery, conn, adOpenKeyset, adLockOptimistic
        If Not rsKey Is Nothing Then
            'Iterate through the recordset to find the constraints,Keys and Identity of the table
            While Not rsKey.EOF
             I = 0
             rsFields.MoveFirst
             'Iterate throught the fields recordset and set the keys in the 4 and 5 columns of the table
             Do While Not rsFields.EOF
                If UCase(rsFields(1)) = UCase(rsKey(0)) Then
                    If UCase(rsKey(1)) = "FOREIGN KEY" Then
                            .Tables(row).Cell(I + 2, 4).Range.InsertBefore "外键"
                            Exit Do
                    ElseIf UCase(rsKey(1)) = "PRIMARY KEY" Then
                            .Tables(row).Cell(I + 2, 4).Range.InsertBefore "主键"
                            Exit Do
                    ElseIf UCase(rsKey(1)) = "DEFAULT CONSTRAINT" Then
                            .Tables(row).Cell(I + 2, 6).Range.InsertBefore "默认" & rsKey(2)
                            Exit Do
                    ElseIf UCase(rsKey(1)) = "IDENTITY" Then
                            .Tables(row).Cell(I + 2, 6).Range.InsertBefore "标识列"
                            Exit Do
                    End If
                End If
                I = I + 1
                rsFields.MoveNext
             Loop
                rsKey.MoveNext
            Wend
        End If
     
     
    End With
    row = row + 1
    rsMain.MoveNext
Wend
Selection.HomeKey unit:=wdStory
Call InsertDomain
Selection.TypeParagraph
Selection.TypeParagraph
Exit Sub
Err:
MsgBox Err.Description
Call SetHeading("Error in the table: " & rsMain(0))
Set rsMain = Nothing
Set rsFields = Nothing
Set rsKey = Nothing
End Sub
Sub MoveDown()
    Dim Range3 As Range
    Dim I As Integer
    On Error Resume Next

    I = ActiveDocument.Tables.Count
    Set Range3 = ActiveDocument.Range(Start:=ActiveDocument.Range.End, End:=ActiveDocument.Range.End)
    Range3.MoveEnd unit:=wdCharacter, Count:=1
    Range3.SetRange Start:=Range3.Start + 2, End:=Range3.End
    Range3.Select
    With Selection
        .Collapse Direction:=wdCollapseEnd
        .TypeParagraph
    End With
End Sub

Sub SetText(str As String)
    Dim Range3 As Range
    Dim I As Integer
    On Error Resume Next
    I = ActiveDocument.Tables.Count
    Set Range3 = ActiveDocument.Range(Start:=ActiveDocument.Tables(I).Range.End, End:=ActiveDocument.Tables(I).Range.End)
    Range3.MoveEnd unit:=wdCharacter, Count:=1
    Range3.SetRange Start:=Range3.Start + 2, End:=Range3.End + Len(str)
    Range3.Select
        With Selection
        .Collapse Direction:=wdCollapseEnd
        .TypeParagraph
        .InsertParagraph
        .Font.Name = "verdana"
        .Font.Size = 10
        .InsertBefore str
    End With
End Sub

Sub SetTextAfter(str As String)
    Dim Range3 As Range
    Dim I As Integer
    On Error Resume Next
    I = ActiveDocument.Tables.Count
    Set Range3 = ActiveDocument.Range(Start:=ActiveDocument.Range.End, End:=ActiveDocument.Range.End)
    Range3.MoveEnd unit:=wdCharacter, Count:=1
    Range3.SetRange Start:=Range3.Start + 2, End:=Range3.End + Len(str)
    Range3.Select
    With Selection
        .Collapse Direction:=wdCollapseEnd
        .TypeParagraph
        .Font.Name = "verdana"
        .Font.Size = 10
        .InsertAfter vbTab & str
    End With
End Sub

Sub SetHeading(str As String)
    Dim Range3 As Range
    Dim I As Integer
    On Error Resume Next
    I = ActiveDocument.Tables.Count
    Set Range3 = ActiveDocument.Range(Start:=ActiveDocument.Range.End, End:=ActiveDocument.Range.End)
    Range3.MoveEnd unit:=wdCharacter, Count:=1
    Range3.SetRange Start:=Range3.Start + 2, End:=Range3.End + Len(str)
    Range3.Select
    
    With Selection
        .Collapse Direction:=wdCollapseEnd
        .TypeParagraph
        .Font.Name = "verdana"
        .Font.Size = 10
        .TypeParagraph
        .Font.Bold = wdToggle
        .Font.ColorIndex = wdGreen
        .TypeText (Space(3) & str)
        .Font.ColorIndex = wdBlack
        .Font.Bold = wdToggle
    End With
End Sub

Sub SetTableName(strTable As String, strDescription As String)
    Dim Range3 As Range
    Dim I As Integer
    On Error Resume Next
    I = ActiveDocument.Tables.Count
    Set Range3 = ActiveDocument.Range(Start:=ActiveDocument.Tables(I).Range.End, End:=ActiveDocument.Tables(I).Range.End)
    Range3.MoveEnd unit:=wdCharacter, Count:=1
    Range3.SetRange Start:=Range3.Start + 2, End:=Range3.End + Len(strTable)
    Range3.Select
        With Selection
        .Collapse Direction:=wdCollapseEnd
        .TypeParagraph
        .Font.Name = "verdana"
        .Font.Size = 11
        .Font.Italic = True
        .Font.Bold = wdToggle
        .Font.Color = wdColorDarkRed
        .TypeText strDescription + "： "
        .Font.ColorIndex = wdBlack
        .Font.Bold = wdToggle
        .TypeText strTable
        .Font.Italic = False
        .Paragraphs.OutlineLevel = wdOutlineLevel2
        .TypeParagraph
        .Paragraphs.OutlineLevel = wdOutlineLevelBodyText
    End With
End Sub
Sub InsertDomain()
'
' Domain Macro
' 宏在 2009-05-08 由 Microsoft USER 录制
'
    With ActiveDocument
        .TablesOfContents.Add Range:=Selection.Range, RightAlignPageNumbers:= _
            True, UseHeadingStyles:=True, UpperHeadingLevel:=1, _
            LowerHeadingLevel:=3, IncludePageNumbers:=True, AddedStyles:="", _
            UseHyperlinks:=True, HidePageNumbersInWeb:=True, UseOutlineLevels:= _
            True
        .TablesOfContents(1).TabLeader = wdTabLeaderDots
        .TablesOfContents.Format = wdIndexIndent
    End With
End Sub