|
思路大概是这样子的：
1、新建一个数据库文件
2、根据储存的表字段信息：表名、字段名、字段类型、长度、默认值来创建表
听起来是不是很简单？现在看来，实际上也并不复杂，但在没有做出来之前，还是费了不少脑筋的，主要是自己的水平差了么一点点，很多方法都得现学现卖，少不得也跟ChatGPT进行了几轮较量，终于……长出了一口气，废话少说，还是直接上代码吧（代码有点长，解释在后面）：
Private Sub CmdSave_Click() Dim newDB As String, newCompanyPath As String Dim compCode As String Dim FSO As Object Dim cnn As Object '数据库连接 Dim StrCnn As String 'ACCESS连接语句 Dim rs As Object Dim aData(), arr() Dim tbName As String Dim arr1(), arr2(), arr3() Dim catADO As Object Dim fldName As String, dataType As String, size As String, defValue As String Dim arrTable() Dim tableName As String Set catADO = CreateObject("ADOX.Catalog") currDB = clsGT.GetDB If Me.tbCompany = "" Or Me.TbCompAbbr = "" Or Len(Me.TbYear) <> 4 Then MsgBox "请完整正确填写公司全称、公司简称、账套年度！" Exit Sub End If Psw = clsGT.GetPsW Set FSO = CreateObject("Scripting.FileSystemObject") compCode = CtoPYI(Me.tbCompany) p = Me.LbDataPath newCompanyPath = p & "\" & Me.tbCompany newDB = newCompanyPath & "\" & compCode & "_" & Me.TbYear & ".accdb" If Not FSO.folderexists(newCompanyPath) Then FSO.createfolder newCompanyPath End If If FSO.fileexists(newDB) Then MsgBox "已存在账套，新建失败！" Exit Sub Else catADO.Create "Provider=Microsoft.ACE.OLEDB.12.0;Jet OLEDB:Database Password=" & Psw & ";" & "Data Source=" & newDB & ";Jet OLEDB:Engine Type=5" End If If FSO.fileexists(newDB) Then Application.Wait (Now + TimeValue("0:00:02")) ' Set cnn = CreateObject("ADODB.Connection") Set rs = CreateObject("ADODB.Recordset") StrCnn = clsGT.GetStrCnn(newDB, Psw) cnn.Open StrCnn '打开数据库链接 '读取表信息数组 With Sheets("数据库表信息") .Activate arrTable = .UsedRange.Value End With iRow = UBound(arrTable, 1) iCol = UBound(arrTable, 2) For i = 2 To iRow If arrTable(i, 1) <> arrTable(i - 1, 1) Then tableName = arrTable(i, 1) sql = "CREATE TABLE " & tableName & " (ID AUTOINCREMENT primary key," Else fldName = arrTable(i, 2) dataType = TypeNameToSQLType(arrTable(i, 3)) '数据类型 If dataType = "text" Then size = arrTable(i, 4) Else size = "" End If defValue = arrTable(i, 5) '默认值 If Len(defValue) > 0 Then defValue = " default " & defValue Else defValue = "" End If '添加字段到SQL语句 sql = sql & fldName & " " & dataType If Len(size) > 0 Then sql = sql & "(" & size & ")" End If sql = sql & defValue & "," If i = iRow Then sql = Left(sql, Len(sql) - 1) & ")" '删除最后一个逗号 cnn.Execute sql Else If arrTable(i, 1) <> arrTable(i + 1, 1) Then sql = Left(sql, Len(sql) - 1) & ")" '删除最后一个逗号 cnn.Execute sql End If End If End If Next rs.Open "tb报表类型", cnn, 1, 3 arr1 = Array("A", "B", "C") arr2 = Array("资产负债表", "利润表", "现金流量表") arr3 = Array("科目", "科目", "项目") For i = LBound(arr1) To UBound(arr1) rs.AddNew rs.Fields("报表代码") = arr1(i) rs.Fields("报表名称") = arr2(i) rs.Fields("取数方式") = arr3(i) rs.Update Next rs.Close rs.Open "tb报表项目数据类型", cnn, 1, 3 arr1 = Array("数据项", "明细项", "小计项", "合计项", "计算项", "分类项") For i = LBound(arr1) To UBound(arr1) rs.AddNew rs.Fields(1) = arr1(i) rs.Update Next rs.Close rs.Open "tb核算项目分类", cnn, 1, 3 arr1 = Array("XJ", "BM", "KS") arr2 = Array("现金流量", "部门核算", "客商核算") For i = LBound(arr1) To UBound(arr1) rs.AddNew rs.Fields("项目分类码") = arr1(i) rs.Fields("项目分类") = arr2(i) rs.Update Next rs.Close rs.Open "tb会计制度", cnn, 1, 3 arr1 = Array("小企业", "一般企业", "小贷公司", "金融企业") For i = LBound(arr1) To UBound(arr1) rs.AddNew rs.Fields(1) = arr1(i) rs.Update Next rs.Close rs.Open "tb基础信息", cnn, 1, 3 arr1 = Array("公司名称", "公司简称", "公司代码", "账套年度", "会计制度", "结转下年", "损益结转对方科目", "损益结转频率", "凭证制单方式") arr2 = Array(tbCompany, TbCompAbbr, compCode, TbYear, CmbAccountingPolicy, "未结转", "", "年", "E") arr3 = Array(0, 0, 0, 0, -1, 0, -1, -1, -1) For i = LBound(arr1) To UBound(arr1) rs.AddNew rs.Fields("信息名称") = arr1(i) rs.Fields("信息值") = arr2(i) rs.Fields("可否修改") = arr3(i) rs.Update Next rs.Close rs.Open "tb科目分类", cnn, 1, 3 arr1 = Array("1", "2", "3", "4", "5", "6", "9") arr2 = Array("资产类", "负债类", "共同类", "所有者权益类", "成本类", "损益类", "表外类") arr3 = Array("借", "贷", "", "贷", "借", "", "") For i = LBound(arr1) To UBound(arr1) rs.AddNew rs.Fields("科目分类码") = arr1(i) rs.Fields("科目分类") = arr2(i) rs.Fields("默认方向") = arr3(i) rs.Update Next rs.Close rs.Open "tb用户", cnn, 1, 3 rs.AddNew rs.Fields("用户ID") = "admin" rs.Fields("姓名") = "管理员" rs.Fields("密码") = "111111" rs.Fields("状态") = "正常" rs.Fields("权限") = "管理" rs.Update rs.AddNew rs.Fields("用户ID") = "Superuser" rs.Fields("姓名") = "超级管理员" rs.Fields("密码") = clsGT.GetPsW rs.Fields("状态") = "正常" rs.Fields("权限") = "管理" rs.Update rs.Close rs.Open "tb用户权限", cnn, 1, 3 arr1 = Array("管理", "审核", "制单", "查询") For i = LBound(arr1) To UBound(arr1) rs.AddNew rs.Fields(1) = arr1(i) rs.Update Next rs.Close cnn.Close Set cnn = Nothing MsgBox "新建账套成功！" Else MsgBox "新建失败！" End If Unload Me End Sub
简单解释一下代码思路：
首先定义一堆变量，变量的定义方式各人喜欢，主要还是要有利于写代码、读代码，所以，我的基本原则是： 不强制声明，不喜欢被强！
循环变量不定义， for i = 0 to 100 '这个i我一般不定义
其他有一定含义的变量还是要定义一下，基本能看出这个变量是储存什么内容的。不啰嗦了，这些内容网上一搜一大堆。
然后检查一下新建账套的要素是否填全，省得做无用功，代码也会报错。 接下来创建数据库文件，这里是有一定的命名规则的，不展开。
接着读取sheets(“数据库表信息”)内容到数组，也可以直接在excel表中循环，不过如果数据量大的话，数组要快很多，这个不用多说，数组一定要用好。
接下来关键代码来了，就是下面的一个for循环，生成创建表的SQL语句，这段代码ChatGPT功不可没。创建表的SQL语句大概是这个样子的：
'创建凭证表 sql = "Create table tb凭证 " _ & "(ID AUTOINCREMENT primary key,日期 Date,凭证号 Integer,摘要 text(255)," _ & "科目代码 text(255),科目全称 text(255),核算项目 text(255),借方金额 double," _ & "贷方金额 double,余额 double,分录号 text(255),月份 text(255)," _ & "作废标志 Bit DEFAULT no,制单人 text(255),审核人 text(255),记账人 text(255)," _ & "月结状态 Bit DEFAULT no,项目查询 text(255))"
后面大段大段的打开具体表的记录集，写入一些记录。 基本就是这样子。 感想：之前我是一个表一个表地写出创建表的SQL语句的（就像上面这个'创建凭证表’的代码），这样也能达到目的，不过一旦表结构、字段发生一点点变化，都要来修改SQL语句，灵活性太差，特别是在设计过程当中，经常会有变化，比较头疼。
现在好了，只要保存最新的表的信息，一切就在点点之间，感觉倍爽！
|
