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 130
'指示一個以 Null 終止的 Unicode 字符串 (DBTYPE_WSTR)。 這种數據類型用 ACCESS 設計器是無法設計出來的。
'20100826 新增
p = " char"
p = p & "(" & objField.DefinedSize & ")"
Case Else
p = " (" & objField.Type & " 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,[文本定長10] char(10),[小數精度18] DECIMAL(10) default 0,Primary KEY ([ID]))"
End Function |
