数据字典到SQL语句的转换(使用word与VBA)

一般我们有几种方式对数据库建模：

1.采用PowerDesign或ErWin等建模工具进行建模

2.利用WORD或EXCEL进行建模

使用第一种方式，可以自动导出要生产表的SQL语句，建表比较方便，而对于第二种方式，则可能需要手工建表，其实在WORD中可以用VBA完成对SQL语句的生成，如将下面格式的WORD数据字典生成SQL语句，就可以利用VBA进行

WORD文档样式为：

	Table1
			PK	默认值
Field1		Varchar(50)	是	1
Field2		Int
Field3		Int
Field4		Numeric(18,4)

Function GetCreateStr()
    Dim docOld As Document
    Dim rngDoc As Range
    Dim tblDoc As Table
    Dim i As Integer, iIndex1 As Integer, iIndex2 As Integer
    Dim myCell As Cell
    Dim sTemp As String, sTemp1 As String, sTemp2 As String
    Dim sHead As String
    Dim sResult As String, sLength As String
    Dim sDou As String, s1 As String
    Dim sDou1 As String, sKey As String
    Dim sTableName As String

    sDou = """": sDou1 = "'"
    If ActiveDocument.Tables.Count >= 1 Then
        For i = 1 To ActiveDocument.Tables.Count
            sTableName = ActiveDocument.Tables(i).Cell(1, 2).Range.Text
            sTableName = Mid(sTableName, 1, Len(sTableName) - 2)
            s1 = "USE [SocialKey]" & vbCrLf & vbCrLf & "GO " & vbCrLf & vbCrLf & _
                "/****** 对象:  Table [dbo].[" & sTableName & "]    脚本日期: " & Now & _
                "******/" & vbCrLf & vbCrLf & _
                "SET ANSI_NULLS ON " & vbCrLf & vbCrLf & _
                "SET QUOTED_IDENTIFIER ON " & vbCrLf & _
                "GO " & vbCrLf
                
            sHead = s1 & vbctrl & "if exists (select * from dbo.sysobjects where id = object_id(N" & sDou1 & _
                "[dbo].[" & sTableName & "]" & sDou1 & ") and OBJECTPROPERTY(id, N" & sDou1 & _
                "IsUserTable" & sDou1 & ") = 1)" & vbCrLf & _
                vbTab & " drop table [dbo].[" & sTableName & "]" & vbCrLf & _
                "GO" & vbCrLf & _
                "CREATE TABLE [dbo].[" & sTableName & "] ("
                
            sTemp = "": sResult = ""
                
            For j = 3 To ActiveDocument.Tables(i).Rows.Count
                Set myCell = ActiveDocument.Tables(i).Cell(j, 1)
                sTemp = Mid(myCell.Range.Text, 1, Len(myCell.Range.Text) - 2)
                If Trim(sTemp) <> "" Then
                    sTemp = vbTab & "[" & sTemp & "]"
                
                    Set myCell = ActiveDocument.Tables(i).Cell(j, 3)
                    sTemp1 = Mid(myCell.Range.Text, 1, Len(myCell.Range.Text) - 2)
                    iIndex1 = InStr(sTemp1, "(")
                    If iIndex1 > 0 Then
                        iIndex2 = InStr(sTemp1, ")")
                        sLength = Mid(sTemp1, iIndex1 + 1, iIndex2 - iIndex1 - 1)
                        sTemp1 = Mid(sTemp1, 1, iIndex1 - 1)
                        sTemp2 = "[" & sTemp1 & "]" & " (" & sLength & ")" & " NULL" & ","
                    
                    Else
                        sTemp2 = "[" & sTemp1 & "]" & " NULL" & ","
                    End If
                    sResult = sResult & sTemp & " " & sTemp2 & vbCrLf
                End If
            Next j
            sResult = sHead & vbCrLf & sResult
        Next i
    End If
    sResult = Mid(sResult, 1, Len(sResult) - 3) & vbCrLf & ")"
    GetCreateStr = sResult
    'Debug.Print GetCreateStr
End Function

Sub StrToFile(sContent As String, sFile As String)
    Kill sFile    '首先删除源文件
    Open sFile For Append As #1    '打开文件
    Print #1, sContent    '写入文件
    Close #1
End Sub

Private Sub CommandButton2_Click()
    Dim sTemp As String, sPath As String
    sTemp = GetCreateStr
    'Debug.Print sTemp
    sPath = Left(ActiveDocument.Name, Len(ActiveDocument.Name) - 4)
    'Debug.Print ActiveDocument.Path & sPath & ".txt"
    Call StrToFile(sTemp, ActiveDocument.Path & "\" & sPath & ".txt")
End Sub