VBA 读取access中的SQL语句 access用vba执行sql语句

转载

flyingsmiling 2024-05-24 13:09:44

文章标签 VBA 读取access中的SQL语句数据库 SQL 数据类型 VBA 文章分类 架构后端开发

access生成sql脚本，通过VBA调用ADOX。

使用 MS Access 2016 的VBA，读取mdb文件中的所有表结构（数据类型/长度/精度等），生成对应的SQL create table语句，将结果SQL脚本保存到文件，每个表一行。

access数据库中提取表结构，生成sql查询语句，通过sql脚本可以建表

对原文代码做出的修改：

原来的代码在生成文件后又使用了生成的sql语句进行创建，下面的代码删除了创建部分。
原来的代码decimal数据类型没有保留小数位数，下面的代码进行了添加。

运行原代码的问题：

缺少引用的库出错，在下图中的引用上要加入相应的依赖库。

VBA 读取access中的SQL语句 access用vba执行sql语句_SQL

VBA 读取access中的SQL语句 access用vba执行sql语句_SQL_02

这个最坑，直接百度、google不到，试出来的……

生成的sql语句在access中不能直接运行

由于access语句不支持decimal、nvarchar等数据类型，如果需要运行生成的sql语句需要在其它的软件中处理，或者使用查找替换更改数据类型。

Option Compare DatabaseFunction 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 StringOn 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 = TrueCreateSQLScript_Exit: Exit FunctionCreateSQLScript_Err: MsgBox Err.Description, vbExclamation CreateSQLScript = False Resume CreateSQLScript_ExitEnd FunctionFunction 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 NextEnd FunctionFunction 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 FunctionFunction 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 & "," & objField.NumericScale & ")" 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 = pEnd Function'Please copy these code in VBA module and press F5 to run the follow function'请将以下代码 COPY 到 VBA 模块中，然后按 F5 键运行以下两段函数生成的sql文件目标路径Sub RunTest_CreateScript() CreateSQLString "d:\temp.jetsql"End Sub