根据Word表格自动生成SQL数据库脚本的VBScript代码

这是几年前写的根据Word表格自动生成SQL数据库脚本的VBScript代码，最近修改了下（原来只支持单个Word表格）使其支持一个Word文档中的多个表格，生成的SQL文件名以Word文件名+.SQL，并和Word文档存放在同一目录下（如果需要更改文件名或目录请修改sSQLFileName 变量），另外表格需要使用规定的格式（见附件），如果更换表格格式当然也同时修改代码了。


Sub CreateSQLFile()


'


' CreateSQLFile Macro


' 宏在 2005-4-15 由 czl 创建


'


'数组声明


'有缺省值有字段数组


Dim DefaultFieldArr(35, 1) As String


'主键字段数组


Dim PKFieldArr(10) As String


'缺省数组长度


Dim DefaultArrLen As Integer


'主键数组长度


Dim PKArrLen As Integer


'上一行


Dim sPreLine As String


'是否有文本图像字段


Dim bHasTextImageField As Boolean


'循环变量


Dim i As Integer


'最大字段描述行


Dim iMaxLine As Integer


'文档表总数


Dim iTableCount As Integer




'脚本文件保存路径


'sSQLFileSavePath = "E:/Hugesoft/表设计/Scripts/"


'脚本文件名


sSQLFileName = ActiveDocument.FullName + ".SQL"


'创建文件


Set fs = CreateObject("Scripting.FileSystemObject")


Set a = fs.CreateTextFile(sSQLFileName, True)




iTableCount = ActiveDocument.Tables.Count


For iIndex = 1 To iTableCount




'取得表名


Set oTable = ActiveDocument.Tables(iIndex)


Set aCell = oTable.Rows(4).Cells(2)


Set myRange = ActiveDocument.Range(Start:=aCell.Range.Start, _


End:=aCell.Range.End - 1)


sTableName = myRange.Text




'取表格的总行数


iRowCount = oTable.Rows.Count




DefaultArrLen = 0


PKArrLen = 0


sPreLine = ""


bHasTextImageField = False




'写入脚本文件


a.WriteLine ("if exists (select * from dbo.sysobjects where id = object_id(N'[dbo].[" + sTableName + "]') and OBJECTPROPERTY(id, N'IsUserTable') = 1)")


a.WriteLine ("drop table [dbo].[" + sTableName + "]")


a.WriteLine ("GO")


a.WriteLine ("")


a.WriteLine ("CREATE TABLE [dbo].[" + sTableName + "] (")




For i = 9 To iRowCount


sLine = ""


'取得字段名


Set myRange = ActiveDocument.Range(Start:=oTable.Rows(i).Cells(2).Range.Start, _


End:=oTable.Rows(i).Cells(2).Range.End - 1)


sFieldName = myRange.Text


If sFieldName = "" Then


Exit For


End If


'取得数据类型


Set myRange = ActiveDocument.Range(Start:=oTable.Rows(i).Cells(4).Range.Start, _


End:=oTable.Rows(i).Cells(4).Range.End - 1)


sFieldType = myRange.Text


sFieldType = StrConv(sFieldType, vbLowerCase)




'取得字段长度


Set myRange = ActiveDocument.Range(Start:=oTable.Rows(i).Cells(5).Range.Start, _


End:=oTable.Rows(i).Cells(5).Range.End - 1)


sFieldLen = myRange.Text


'取得小数位数


Set myRange = ActiveDocument.Range(Start:=oTable.Rows(i).Cells(6).Range.Start, _


End:=oTable.Rows(i).Cells(6).Range.End - 1)


sFieldDigLen = myRange.Text


'取得缺省值


Set myRange = ActiveDocument.Range(Start:=oTable.Rows(i).Cells(7).Range.Start, _


End:=oTable.Rows(i).Cells(7).Range.End - 1)


sFieldDefaultValue = myRange.Text


'取得允许空值


Set myRange = ActiveDocument.Range(Start:=oTable.Rows(i).Cells(8).Range.Start, _


End:=oTable.Rows(i).Cells(8).Range.End - 1)


sFieldAllowNull = myRange.Text


'取得是否主键


Set myRange = ActiveDocument.Range(Start:=oTable.Rows(i).Cells(9).Range.Start, _


End:=oTable.Rows(i).Cells(9).Range.End - 1)


sFieldIsPKey = myRange.Text




'是否有文本图像字段


If sFieldType = "text" Or sFieldType = "ntext" Or sFieldType = "image" Then


bHasTextImageField = True


End If




'是否主键字段


If sFieldIsPKey = "√" Then


PKFieldArr(PKArrLen) = sFieldName


PKArrLen = PKArrLen + 1


End If




'是否有缺省值


If sFieldDefaultValue <> "" Then


'处理全角字符


iLen = Len(sFieldDefaultValue)


If iLen >= 2 Then


If Left(sFieldDefaultValue, 1) = "‘" Then


sFieldDefaultValue = Chr(39) + Mid(sFieldDefaultValue, 2, iLen - 2) + Chr(39)


End If


End If




DefaultFieldArr(DefaultArrLen, 0) = sFieldName


DefaultFieldArr(DefaultArrLen, 1) = sFieldDefaultValue


DefaultArrLen = DefaultArrLen + 1


End If




'生成行


sLine = Chr(9) + "[" + sFieldName + "] [" + sFieldType + "] "




If sFieldType = "varchar" Or sFieldType = "nvarchar" Then


sLine = sLine + "(" + sFieldLen + ") "


End If




If sFieldType = "numeric" Then


sLine = sLine + "(" + sFieldLen + ", " + sFieldDigLen + ") "


End If




If sFieldDigLen = "*" Then


'表示该列自动增长，一般作主键用


sLine = sLine + "IDENTITY (1, 1) "


End If




If (sFieldType = "varchar") Or (sFieldType = "nvarchar") Or (sFieldType = "text") Or ((sFieldType = "ntext")) Then


sLine = sLine + "COLLATE Chinese_PRC_CI_AS "


End If




If sFieldAllowNull = "√" Then


sLine = sLine + "NULL "


Else


sLine = sLine + "NOT NULL "


End If




If sPreLine <> "" Then


a.WriteLine (sPreLine + ",")


End If




sPreLine = sLine


Next i




iMaxLine = i




If sPreLine <> "" Then


a.WriteLine (sPreLine)


End If




If bHasTextImageField Then


a.WriteLine (") ON [PRIMARY] TEXTIMAGE_ON [PRIMARY]")


Else


a.WriteLine (") ON [PRIMARY]")


End If


a.WriteLine ("GO")


a.WriteLine ("")




'生成主键描述


a.WriteLine ("ALTER TABLE [dbo].[" + sTableName + "] WITH NOCHECK ADD")


a.WriteLine (Chr(9) + "CONSTRAINT [PK_" + sTableName + "] PRIMARY KEY CLUSTERED")


a.WriteLine (Chr(9) + "(")




sPreLine = ""


For i = 0 To PKArrLen - 1


sLine = Chr(9) + Chr(9) + "[" + PKFieldArr(i) + "]"


If sPreLine <> "" Then


a.WriteLine (sPreLine + ",")


End If


sPreLine = sLine


Next i


If sPreLine <> "" Then


a.WriteLine (sPreLine)


End If


a.WriteLine (Chr(9) + ") ON [PRIMARY]")


a.WriteLine ("GO")


a.WriteLine ("")




'生成缺省值描述


If DefaultArrLen > 0 Then


a.WriteLine ("ALTER TABLE [dbo].[" + sTableName + "] WITH NOCHECK ADD")


sPreLine = ""


For i = 0 To DefaultArrLen - 1


sLine = Chr(9) + "CONSTRAINT [DF_" + sTableName + "_" + DefaultFieldArr(i, 0) + "] DEFAULT (" + DefaultFieldArr(i, 1) + ") FOR [" + DefaultFieldArr(i, 0) + "]"


If sPreLine <> "" Then


a.WriteLine (sPreLine + ",")


End If


sPreLine = sLine


Next i


If sPreLine <> "" Then


a.WriteLine (sPreLine)


End If


a.WriteLine ("GO")


a.WriteLine ("")


End If




'生成索引描述


'查找索引描述开始行


iIndexStartLine = 0




For i = iMaxLine To iRowCount


Set myRange = ActiveDocument.Range(Start:=oTable.Rows(i).Cells(1).Range.Start, _


End:=oTable.Rows(i).Cells(1).Range.End - 1)


sTmp = myRange.Text


If sTmp = "索引组成：" Then


iIndexStartLine = i


Exit For


End If


Next i




'生成索引描述


If iIndexStartLine > 0 Then


For i = iIndexStartLine + 2 To iRowCount


'取得索引名称


Set myRange = ActiveDocument.Range(Start:=oTable.Rows(i).Cells(2).Range.Start, _


End:=oTable.Rows(i).Cells(2).Range.End - 1)


sIndexName = myRange.Text


If sIndexName = "" Then


Exit For


End If


'取得索引列序列


Set myRange = ActiveDocument.Range(Start:=oTable.Rows(i).Cells(3).Range.Start, _


End:=oTable.Rows(i).Cells(3).Range.End - 1)


sIndexFieldList = myRange.Text


'写入文件


a.WriteLine (" CREATE UNIQUE INDEX [" + sIndexName + "] ON [dbo].[" + sTableName + "](" + sIndexFieldList + ") ON [PRIMARY]")


a.WriteLine ("GO")


Next i


End If


Next iIndex




a.Close




MsgBox "成功生成脚本文件：" + Chr(13) + Chr(9) + sSQLFileName + "。"


End Sub



使用方法：点Word菜单“工具→宏→宏”，单击弹出对话框中右侧的“创建”，进入编辑器后把下面的代码复制粘贴覆盖缺省生成的代码，完成后可以通过Word工具栏的自定义功能把宏放在工具栏，方便使用。

标准Word表格请到炬源信息技术网（http://www.hugesoft.net/）下载。