收藏：如何根据当前MDB中的表生成对应的JET SQL DDL “CREATE TABLE”语句/脚本？
2007-04-24 08:33 flyingfish 阅读(1149) 评论(0) 编辑 收藏 举报作者：cg1 摘自：access911.net 编辑
专题地址：
http://access911.net/?kbid;72FAB11E16DCEBF3
简述：
如何根据当前MDB中的表生成对应的JET SQL DDL “CREATE TABLE”语句？如何根据这个脚本在当前数据库中新建表？
如何根据当前MDB中的表生成对应的JET SQL DDL “CREATE TABLE”语句/脚本？《查询》
阅读前需掌握：
熟练掌握 VBA 编程；熟练掌握 JET SQL 语句问题：
如何根据当前MDB中的表生成对应的JET SQL DDL “CREATE TABLE”语句？
如何用这个脚本在一个新的数据库中新建表？
SQL SERVER可以将表结构导出为 *.SQL 的脚本，这个*.sql脚本里面是一些 "Create table" 语句，ACCESS 能做到么？
Access并未内置将表结构导出为脚本下次能直接建表的功能。
利用 ADOX / ADO / DAO 三个数据访问模型来获取对应的信息并组织 JET SQL DDL 语句，生成对应的 *.jetsql 文本文件脚本。再根据上述脚本在一个新的 MDB 数据库中新建上述表。
注意：由于 JET SQL DDL 语句并不支持所有的 ADOX / ADO / DAO 属性，所以有一部分表的属性，比如“格式”属性无法通过 JET SQL DDL 语句建立。最完整的解决方案是生成 *.VBA 脚本，而不是 JET SQL 脚本。
Function CreateSQLString(ByVal FilePath As String) As Boolean
'本函数根据当前MDB中的表创建一个 *.jetsql 脚本
'这个函数不是最完美的解决方案，因为 JET SQL DDL 语句不支持一些 ACCESS 特有的属性（DAO支持）
'This function create a "*.jetsql" script based on current mdb tables.
'This function is not the BEST, because the JET SQL DDL never support some DAO property.
Dim MyTableName As String
Dim MyFieldName As String
Dim MyDB As New ADOX.Catalog
Dim MyTable As ADOX.Table
Dim MyField As ADOX.Column
Dim pro
Dim iC As Long
Dim strField() As String
Dim strKey As String
Dim strSQL As String
Dim strSQLScript As String
Dim objFile, stmFile
Dim strText As String
On Error GoTo CreateSQLScript_Err
MyDB.ActiveConnection = CurrentProject.Connection
For Each MyTable In MyDB.Tables
If MyTable.Type = "TABLE" Then
'指定表的类型，例如“TABLE”、“SYSTEM TABLE”或“GLOBAL TEMPORARY”或者“ACCESS TABLE”。
'ADOX 无法判断该表是否已经被删除，还有两种方式判断，
'方法一：（用 DAO）
'If CurrentDb.TableDefs(strTableName).Attributes = 0 Then
'方法二：（在判断 ADOX.Table.Type 的基础上再判定表名）
'If Left(MyTable.Name, 7) <> "~TMPCLP" Then
strSQL = "create table [" & MyTable.Name & "]("
For Each MyField In MyTable.Columns
ReDim Preserve strField(iC)
strField(iC) = SQLField(MyField)
iC = iC + 1
Next
strSQL = strSQL & Join(strField, ",")
'获取当前表的字段信息后立即重新初始化 strField 数组
iC = 0
ReDim strField(iC)
'加入键信息
strKey = SQLKey(MyTable)
If Len(strKey) <> 0 Then
strSQL = strSQL & "," & strKey
End If
strSQL = strSQL & ");" & vbCrLf
strSQLScript = strSQLScript & strSQL
'Debug.Print SQLIndex(MyTable) 'Never support the INDEX,to be continued...
'暂未支持 index 脚本，未完待续...
End If
Next
Set MyDB = Nothing
'create the Jet SQL Script File
Set objFile = CreateObject("Scripting.FileSystemObject")
Set stmFile = objFile.CreateTextFile(FilePath, True)
stmFile.Write strSQLScript
stmFile.Close
Set stmFile = Nothing
Set objFile = Nothing
CreateSQLScript = True
CreateSQLScript_Exit:
Exit Function
CreateSQLScript_Err:
MsgBox Err.Description, vbExclamation
CreateSQLScript = False
Resume CreateSQLScript_Exit
End Function
Function RunFromText(ByVal FilePath As String)
'本函数将 CreateSQLScript 生成的 *.jetsql 脚本来生成 mdb 数据库中的表
'This Function run the "*.jetsql" which is created by CreateSQLScript to create the tables in current mdb database.
On Error Resume Next
Dim objFile, stmFile
Dim strText As String
Set objFile = CreateObject("Scripting.FileSystemObject")
Set stmFile = objFile.OpenTextFile(FilePath, 1, False)
strText = stmFile.ReadAll
stmFile.Close
Set stmFile = Nothing
Set objFile = Nothing
Dim strSQL() As String
Dim i As Long
strSQL = Split(strText, ";" & vbCrLf)
For i = LBound(strSQL) To UBound(strSQL)
CurrentProject.Connection.Execute Trim(strSQL(i))
If Err <> 0 Then
Debug.Print "Error SQL is:" & strSQL(i)
Err.Clear
End If
Next
End Function
Function SQLKey(ByVal objTable As ADOX.Table)
'调用 ADOX 生成有关“键”的 JET SQL DDL 子句
'Reference ADOX and create the JET SQL DDL clause about the "Key"
Dim MyKey As ADOX.Key
Dim MyKeyColumn As ADOX.Column
Dim strKey As String
Dim strColumns() As String
Dim strKeys() As String
Dim i As Long
Dim iC As Long
For Each MyKey In objTable.Keys
Select Case MyKey.Type
Case adKeyPrimary
strKey = "Primary KEY "
Case adKeyForeign
strKey = "FOREIGN KEY "
Case adKeyUnique
strKey = "UNIQUE "
End Select
For Each MyKeyColumn In MyKey.Columns
ReDim Preserve strColumns(iC)
strColumns(iC) = "[" & MyKeyColumn.Name & "]"
iC = iC + 1
Next
ReDim Preserve strKeys(i)
strKeys(i) = strKey & "(" & Join(strColumns, ",") & ")"
'获取信息后，立即初始化数组
iC = 0
ReDim strColumns(iC)
i = i + 1
Next
SQLKey = Join(strKeys, ",")
End Function
Function SQLField(ByVal objField As ADOX.Column)
'调用 ADOX 生成有关“字段”的 JET SQL DDL 子句
'Reference ADOX and create the JET SQL DDL clause about the "Field"
Dim p As String
Select Case objField.Type
Case 11
p = " yesno"
Case 6
p = " money"
Case 7
p = " datetime"
Case 5
p = " FLOAT" 'or " Double"
Case 72
'JET SQL DDL 语句无法创建“自动编号 GUID”字段，这里暂时用
'[d] GUID default GenGUID() 代替部分功能，详情请看文章
'如何用JET SQL DDL创建自动编号GUID字段
'http://access911.net/?kbid;72FABE1E17DCEEF3
If objField.Properties("Autoincrement") = True Then
p = " autoincrement GUID"
Else
p = " GUID"
End If
Case 3
If objField.Properties("Autoincrement") = False Then
p = " smallint"
Else
p = " AUTOINCREMENT(1," & objField.Properties("Increment") & ")"
End If
Case 205
p = " image"
Case 203
p = " memo" 'Access "HyperLink" field is also a MEMO data type.
'ACCESS 的超级链接也是 MEMO 类型的
Case 131
p = " DECIMAL"
p = p & "(" & objField.Precision & ")"
Case 4
p = " single" 'or " REAL"
Case 2
p = " smallint"
Case 17
p = " byte"
Case 202
p = " nvarchar"
p = p & "(" & objField.DefinedSize & ")"
Case Else
p = " (Unknown,You can find it in ADOX's help. Please Check it.)"
End Select
p = "[" & objField.Name & "]" & p
If IsEmpty(objField.Properties("Default")) = False Then
p = p & " default " & objField.Properties("Default")
End If
If objField.Properties("Nullable") = False Then
p = p & " not null"
End If
SQLField = p
End Function
'Please copy these code in VBA module and press F5 to run the follow function
'请将以下代码 COPY 到 VBA 模块中，然后按 F5 键运行以下两段函数
Function RunTest_CreateScript()
CreateSQLString "c:\temp.jetsql"
End Function
Function RunTest_RunScript()
delAllTable
RunFromText "c:\temp.jetsql"
End Function
Function delAllTable()
'在生成新表时先删除数据库中所有的表
'Delete all table in current mdb.
On Error Resume Next
Dim t As New TableDef
For Each t In CurrentDb.TableDefs
If t.Attributes = 0 Then
CurrentProject.Connection.Execute "drop table [" & t.Name & "]"
End If
Next
End Function
Function CreateEGTable()
CurrentProject.Connection.Execute "create table [表e2]([ID] AUTOINCREMENT(1,1),[URL] memo,[备注] memo,[长整] smallint default 0,[大二进制] image,[日期] datetime,[数字同步复制ID] GUID,[数字字节] byte default 0,[文本50UNICODE 关] nvarchar(50),[文本50UNICODE开] nvarchar(50),[文本50必填是允许空否] nvarchar(50) not null,[小数精度18] DECIMAL(10) default 0,Primary KEY ([ID]))"
End Function
