一个基于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