思路大概是这样子的:
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语句,灵活性太差,特别是在设计过程当中,经常会有变化,比较头疼。
现在好了,只要保存最新的表的信息,一切就在点点之间,感觉倍爽!
联系客服