2008-3-31 22:35:32
[原创]多因多果成本核算模型建立的VB源程序
以下是2000年10月至2001年1月用VB6开发的《多因多果成本管理软件》中建立多因多果成本核算模型的源程序，回想起来已过了7年多。整个软件共三十多万条语句，我个人独自开发，每天12个工作小时，共耗3个月时间，仅作为CSS成本体系发展历程中的一份值得纪念的人生答卷吧。
.jpg)
Option Explicit
Dim I As Integer
Dim intCheck As Integer
Dim tpDeptID, tpResourceID, tpActivityID, tpCostObjectID As String
'For Opening the Joining Tables for Treeview1
Dim tbName, sJoinCondition As String
'Treeview1
Dim tpDeptName, tpResourceName, tpActivityName, tpCostObjectName As String
Dim tpDeptName1, tpResourceName1, tpActivityName1, tpCostObjectName1 As String
Dim tpDeptName2, tpResourceName2, tpActivityName2, tpCostObjectName2 As String
Private Sub cmdCancel_Click()
DataComboDept_Name.Text = ""
fraDExp.Enabled = True
DataComboResource_Name_DExp.BackColor = &H80000005
DataComboResource_Name_DExp.Text = ""
fraIExp.Enabled = True
DataComboResource_Name_IExp.BackColor = &H80000005
DataComboResource_Name_IExp.Text = ""
DataComboActivity_Name.BackColor = &H80000005
DataComboActivity_Name.Text = ""
For I = 1 To ListViewCostObject_Name.ListItems.Count
If ListViewCostObject_Name.ListItems(I).Checked Then
ListViewCostObject_Name.ListItems(I).Checked = False
End If
Next
End Sub
Private Sub cmdDisplay_Click()
'如是第二次CLICK，清掉前一显示内容
If TreeView1.Nodes.Count <> 0 Then
TreeView1.Nodes.Clear
End If
Set TreeView1.ImageList = ImageList1
'执行指定的SQL命令,打开直接模型表
tbName = "J_ModelingDExp A" & " "
sJoinCondition = "INNER JOIN J_DeptCode_Property B ON A.DeptID = B.DeptID " & _
"JOIN J_ResourceCode_Property C ON A.ResourceID = C.ResourceID " & _
"JOIN J_CostObjectCode D ON A.CostObjectID = D.CostObjectID " & _
"Where YearM = '" & strYearM & "' Order by A.DeptID"
sSQL = "Select A.DeptID,B.Dept_Name,C.Resource_Name,D.CostObject_Name from " & tbName & sJoinCondition
cnJITSOFTDB.Execute (sSQL)
'设置ADODC5
Adodc5.ConnectionString = strConnect
Adodc5.CommandType = adCmdText
Adodc5.RecordSource = sSQL
Adodc5.Refresh
'执行指定的SQL命令,打开间接模型表
tbName = "J_ModelingIExp A" & " "
sJoinCondition = "INNER JOIN J_DeptCode_Property B ON A.DeptID = B.DeptID " & _
"JOIN J_ResourceCode_Property C ON A.ResourceID = C.ResourceID " & _
"JOIN J_ActivityCode_Property D ON A.ActivityID = D.ActivityID " & _
"JOIN J_CostObjectCode E ON A.CostObjectID = E.CostObjectID " & _
"Where YearM = '" & strYearM & "'"
sSQL = "Select A.DeptID,B.Dept_Name,C.Resource_Name,D.Activity_Name,E.CostObject_Name from " & tbName & sJoinCondition
cnJITSOFTDB.Execute (sSQL)
'设置ADODC6
Adodc6.ConnectionString = strConnect
Adodc6.CommandType = adCmdText
Adodc6.RecordSource = sSQL
Adodc6.Refresh
If Not Adodc5.Recordset.BOF Then
'显示树型核算模型
Set nodtvw = TreeView1.Nodes.Add(, , "Title", "成本核算模型", "Root")
tpDeptName1 = ""
tpResourceName1 = ""
tpCostObjectName1 = ""
Adodc5.Recordset.MoveFirst
Do While Not Adodc5.Recordset.EOF
tpDeptName = Adodc5.Recordset("Dept_Name")
If tpDeptName <> tpDeptName1 Then '新部门
Set nodtvw = TreeView1.Nodes.Add("Title", tvwChild, "'" & tpDeptName & "'", tpDeptName, "Folder")
TreeView1.Nodes("'" & tpDeptName & "'").ExpandedImage = "Openfold"
End If
tpResourceName = Adodc5.Recordset("Resource_Name")
If tpResourceName <> tpResourceName1 Or tpDeptName <> tpDeptName1 Then '新资源或新部门的资源
Set nodtvw = TreeView1.Nodes.Add("'" & tpDeptName & "'", tvwChild, "'" & tpDeptName & "_'" & "'" & tpResourceName & "'", tpResourceName, "Folder")
TreeView1.Nodes("'" & tpDeptName & "_'" & "'" & tpResourceName & "'").ExpandedImage = "Openfold"
End If
tpCostObjectName = Adodc5.Recordset("CostObject_Name")
If tpCostObjectName <> tpCostObjectName1 Or tpResourceName <> tpResourceName1 Or tpDeptName <> tpDeptName1 Then '新成本对象或新资源或新部门的成本对象
Set nodtvw = TreeView1.Nodes.Add("'" & tpDeptName & "_'" & "'" & tpResourceName & "'", tvwChild, "'" & tpDeptName & "_'" & "'" & tpResourceName & "_'" & tpCostObjectName & "'", tpCostObjectName, "Bottom")
End If
'将当前记录的值赋给临时变量
tpDeptName1 = tpDeptName
tpResourceName1 = tpResourceName
tpCostObjectName1 = tpCostObjectName
Adodc5.Recordset.MoveNext '下一条记录
If Not Adodc5.Recordset.EOF Then '如前记录不是该表的最后一条记录，将下一条记录的DeptName取出
tpDeptName = Adodc5.Recordset("Dept_Name")
Else
tpDeptName = ""
End If
Adodc5.Recordset.MovePrevious '返回本条记录
'是否为同一部门，此部门的记录是否未显示完
If tpDeptName1 <> tpDeptName Then '如前记录是该部门的最后一条记录，打开间接模型表
tpResourceName2 = ""
tpActivityName2 = ""
tpCostObjectName2 = ""
On Error Resume Next
Adodc6.Refresh
Adodc6.Recordset.MoveFirst
strCriteria = "Dept_Name = '" & tpDeptName1 & "'"
Adodc6.Recordset.Find strCriteria
Do While Not Adodc6.Recordset.EOF
'将间接模型表同一部门的内容显示
If Adodc6.Recordset("Dept_Name") = tpDeptName1 Then
tpResourceName = Adodc6.Recordset("Resource_Name")
If tpResourceName <> tpResourceName2 Then '新资源
Set nodtvw = TreeView1.Nodes.Add("'" & tpDeptName1 & "'", tvwChild, "'" & tpDeptName1 & "_'" & "'" & tpResourceName & "'", tpResourceName, "Folder")
TreeView1.Nodes("'" & tpDeptName1 & "_'" & "'" & tpResourceName & "'").ExpandedImage = "Openfold"
End If
tpActivityName = Adodc6.Recordset("Activity_Name")
If tpActivityName <> tpActivityName2 Or tpResourceName <> tpResourceName2 Then '新作业或新资源的作业
Set nodtvw = TreeView1.Nodes.Add("'" & tpDeptName1 & "_'" & "'" & tpResourceName & "'", tvwChild, "'" & tpDeptName1 & "_'" & "'" & tpResourceName & "_'" & tpActivityName & "'", tpActivityName, "Folder")
TreeView1.Nodes("'" & tpDeptName1 & "_'" & "'" & tpResourceName & "_'" & tpActivityName & "'").ExpandedImage = "Openfold"
End If
tpCostObjectName = Adodc6.Recordset("CostObject_Name")
If tpCostObjectName <> tpCostObjectName2 Or tpActivityName <> tpActivityName2 Or tpResourceName <> tpResourceName2 Then '新成本对象或新资源或新部门的成本对象
Set nodtvw = TreeView1.Nodes.Add("'" & tpDeptName1 & "_'" & "'" & tpResourceName & "_'" & tpActivityName & "'", tvwChild, "'" & tpDeptName1 & "_'" & "'" & tpResourceName & "_'" & tpActivityName & "_'" & tpCostObjectName & "'", tpCostObjectName, "Bottom")
End If
'将当前记录的值赋给临时变量
tpResourceName2 = tpResourceName
tpActivityName2 = tpActivityName
tpCostObjectName2 = tpCostObjectName
End If
Adodc6.Recordset.MoveNext
Loop
End If
Adodc5.Recordset.MoveNext '下一条记录
Loop
'对在直接模型表没有间接模型表的部门，即新部门，打开间接模型表显示出来
tpDeptName1 = ""
tpResourceName1 = ""
tpActivityName1 = ""
tpCostObjectName1 = ""
Adodc6.Recordset.MoveFirst
Do While Not Adodc6.Recordset.EOF
tpDeptName = Adodc6.Recordset("Dept_Name")
'检查是否已在直接模型表有此部门
Adodc5.Recordset.MoveFirst
strCriteria = "Dept_Name = '" & tpDeptName & "'"
Adodc5.Recordset.Find strCriteria
'如无有此部门，即新部门
If Adodc5.Recordset.EOF Then
tpDeptName = Adodc6.Recordset("Dept_Name")
If tpDeptName <> tpDeptName1 Then '新部门
Set nodtvw = TreeView1.Nodes.Add("Title", tvwChild, "'" & tpDeptName & "'", tpDeptName, "Folder")
TreeView1.Nodes("'" & tpDeptName & "'").ExpandedImage = "Openfold"
End If
tpResourceName = Adodc6.Recordset("Resource_Name")
If tpResourceName <> tpResourceName1 Or tpDeptName <> tpDeptName1 Then '新资源或新部门的资源
Set nodtvw = TreeView1.Nodes.Add("'" & tpDeptName & "'", tvwChild, "'" & tpDeptName & "_'" & "'" & tpResourceName & "'", tpResourceName, "Folder")
TreeView1.Nodes("'" & tpDeptName & "_'" & "'" & tpResourceName & "'").ExpandedImage = "Openfold"
End If
tpActivityName = Adodc6.Recordset("Activity_Name")
If tpActivityName <> tpActivityName1 Or tpResourceName <> tpResourceName1 Or tpDeptName <> tpDeptName1 Then '新作业或新资源的作业
Set nodtvw = TreeView1.Nodes.Add("'" & tpDeptName & "_'" & "'" & tpResourceName & "'", tvwChild, "'" & tpDeptName & "_'" & "'" & tpResourceName & "_'" & tpActivityName & "'", tpActivityName, "Folder")
TreeView1.Nodes("'" & tpDeptName & "_'" & "'" & tpResourceName & "_'" & tpActivityName & "'").ExpandedImage = "Openfold"
End If
tpCostObjectName = Adodc6.Recordset("CostObject_Name")
If tpCostObjectName <> tpCostObjectName1 Or tpActivityName <> tpActivityName1 Or tpResourceName <> tpResourceName1 Or tpDeptName <> tpDeptName1 Then '新成本对象或新作业或新资源或新部门的成本对象
Set nodtvw = TreeView1.Nodes.Add("'" & tpDeptName & "_'" & "'" & tpResourceName & "_'" & tpActivityName & "'", tvwChild, "'" & tpDeptName & "_'" & "'" & tpResourceName & "_'" & tpActivityName & "_'" & tpCostObjectName & "'", tpCostObjectName, "Bottom")
End If
End If
'将当前记录的值赋给临时变量
tpDeptName1 = tpDeptName
tpResourceName1 = tpResourceName
tpActivityName1 = tpActivityName
tpCostObjectName1 = tpCostObjectName
Adodc6.Recordset.MoveNext '下一条记录
Loop
End If
End Sub
Private Sub cmdInput_Click()
'判断是否有输入内容
If (DataComboDept_Name.Text = "") Or _
((DataComboResource_Name_DExp.Text = "") And _
(DataComboResource_Name_IExp.Text = "" Or _
DataComboActivity_Name.Text = "")) Then
strMsg = "请输入全部内容! "
ans = MsgBox(strMsg, vbOKOnly, msgTitle)
If ans = vbOKOnly Then
Exit Sub
End If
Else
intCheck = 0
For I = 1 To ListViewCostObject_Name.ListItems.Count
If ListViewCostObject_Name.ListItems(I).Checked Then
intCheck = 1
End If
Next
If intCheck = 0 Then
strMsg = "请输入全部内容! "
ans = MsgBox(strMsg, vbOKOnly, msgTitle)
If ans = vbOKOnly Then
Exit Sub
End If
Else
'如有输入内容,赋值给临时变量
Adodc1.Recordset.MoveFirst
strCriteria = "Dept_Name = '" & DataComboDept_Name.Text & "'"
Adodc1.Recordset.Find strCriteria
tpDeptID = Adodc1.Recordset("DeptID")
'判断是否为直接费用
If fraDExp.Enabled And Not fraIExp.Enabled Then '是直接费用
Adodc2.Recordset.MoveFirst
strCriteria = "Resource_Name = '" & DataComboResource_Name_DExp.Text & "'"
Adodc2.Recordset.Find strCriteria
tpResourceID = Adodc2.Recordset("ResourceID")
Else '是间接费用
Adodc3.Recordset.MoveFirst
strCriteria = "Resource_Name = '" & DataComboResource_Name_IExp.Text & "'"
Adodc3.Recordset.Find strCriteria
tpResourceID = Adodc3.Recordset("ResourceID")
Adodc4.Recordset.MoveFirst
strCriteria = "Activity_Name = '" & DataComboActivity_Name.Text & "'"
Adodc4.Recordset.Find strCriteria
tpActivityID = Adodc4.Recordset("ActivityID")
End If
rs.MoveFirst '移动成本对象定义表的记录指针到第一
For I = 1 To ListViewCostObject_Name.ListItems.Count
If ListViewCostObject_Name.ListItems(I).Checked Then
tpCostObjectID = rs("CostObjectID")
'判断是否为直接费用
If fraDExp.Enabled And Not fraIExp.Enabled Then '是直接费用
sSQL = "Insert into J_ModelingDExp (YearM,DeptID,ResourceID,CostObjectID) " & _
"Values(" & "'" & strYearM & "'" & ",'" & tpDeptID & "','" & tpResourceID & "','" & tpCostObjectID & "')"
Else '是间接费用
sSQL = "Insert into J_ModelingIExp (YearM,DeptID,ResourceID,ActivityID,CostObjectID) " & _
"Values(" & "'" & strYearM & "'" & ",'" & tpDeptID & "','" & tpResourceID & "','" & tpActivityID & "','" & tpCostObjectID & "')"
End If
'执行指定的SQL命令
On Error Resume Next
cnJITSOFTDB.Execute (sSQL)
If Err.Number <> 0 Then
ans = MsgBox("这是重复输入，请输入不同的选择。", vbOKOnly, msgTitle)
Exit Sub
End If
End If
rs.MoveNext
Next
ans = MsgBox("输入正确。 ", vbOKOnly, msgTitle)
'恢复frame1 and frame2
fraDExp.Enabled = True
DataComboResource_Name_DExp.BackColor = &H80000005
DataComboResource_Name_DExp.Text = ""
fraIExp.Enabled = True
DataComboResource_Name_IExp.BackColor = &H80000005
DataComboActivity_Name.BackColor = &H80000005
DataComboResource_Name_IExp.Text = ""
DataComboActivity_Name.Text = ""
For I = 1 To ListViewCostObject_Name.ListItems.Count
If ListViewCostObject_Name.ListItems(I).Checked Then
ListViewCostObject_Name.ListItems(I).Checked = False
End If
Next
End If
End If
End Sub
Private Sub cmdReturn_Click()
Unload Me
End Sub
Private Sub DataComboActivity_Name_Change()
If DataComboActivity_Name.Text <> "" Then
fraDExp.Enabled = False
DataComboResource_Name_DExp.BackColor = &H80000004
End If
End Sub
Private Sub DataComboActivity_Name_Click(Area As Integer)
DataComboActivity_Name.Locked = False
End Sub
Private Sub DataComboActivity_Name_KeyPress(KeyAscii As Integer)
DataComboActivity_Name.Locked = True
End Sub
Private Sub DataComboDept_Name_Click(Area As Integer)
DataComboDept_Name.Locked = False
End Sub
Private Sub DataComboDept_Name_KeyPress(KeyAscii As Integer)
DataComboDept_Name.Locked = True
End Sub
Private Sub DataComboResource_Name_DExp_Change()
If DataComboResource_Name_DExp.Text <> "" Then
fraIExp.Enabled = False
DataComboResource_Name_IExp.BackColor = &H80000004
DataComboActivity_Name.BackColor = &H80000004
End If
End Sub
Private Sub DataComboResource_Name_DExp_Click(Area As Integer)
DataComboResource_Name_DExp.Locked = False
End Sub
Private Sub DataComboResource_Name_DExp_KeyPress(KeyAscii As Integer)
DataComboResource_Name_DExp.Locked = True
End Sub
Private Sub DataComboResource_Name_IExp_Change()
If DataComboResource_Name_IExp.Text <> "" Then
fraDExp.Enabled = False
DataComboResource_Name_DExp.BackColor = &H80000004
End If
End Sub
Private Sub DataComboResource_Name_IExp_Click(Area As Integer)
DataComboResource_Name_IExp.Locked = False
End Sub
Private Sub DataComboResource_Name_IExp_KeyPress(KeyAscii As Integer)
DataComboResource_Name_IExp.Locked = True
End Sub
Private Sub Form_Load()
frmModeling_Add.Caption = "模型管理 - 编辑 - 新增模型内容"
'有关人工设置：
'--------------
'设置ListViewCostObject_Name.LabelEdit = 1, 标签内容不能修改
Adodc1.Visible = False
Adodc2.Visible = False
Adodc3.Visible = False
Adodc4.Visible = False
Adodc5.Visible = False
Adodc6.Visible = False
Adodc7.Visible = False
lblMLYearM.Caption = strYearM
'执行指定的SQL命令,打开部门定义表
sSQL = "Select DeptID,Dept_Name from J_DeptCode_Property Where IsBottom = 1 Order by DeptID "
cnJITSOFTDB.Execute (sSQL)
'设置ADODC1
Adodc1.ConnectionString = strConnect
Adodc1.CommandType = adCmdText
Adodc1.RecordSource = sSQL
Adodc1.Refresh
'有关人工设置：
'--------------
'设置DataComboDriver_Name
'DataComboDept_Name.ListField = Dept_Name
'DataComboDept_Name.Rowsource = Adodc1
'执行指定的SQL命令,打开资源定义表
sSQL = "Select ResourceID,Resource_Name, ResourceType from J_ResourceCode_Property Where IsBottom = 1and ResourceType = '直接费用' Order by ResourceID"
cnJITSOFTDB.Execute (sSQL)
'设置ADODC2
Adodc2.ConnectionString = strConnect
Adodc2.CommandType = adCmdText
Adodc2.RecordSource = sSQL
Adodc2.Refresh
'有关人工设置：
'--------------
'设置DataComboDriver_Name_DExp
'DataComboResource_Name_DExp.ListField = Resource_Name
'DataComboResource_Name_DExp.Rowsource = Adodc2
'执行指定的SQL命令,打开资源定义表
sSQL = "Select ResourceID,Resource_Name, ResourceType from J_ResourceCode_Property Where IsBottom = 1and ResourceType = '间接费用' Order by ResourceID"
cnJITSOFTDB.Execute (sSQL)
'设置ADODC3
Adodc3.ConnectionString = strConnect
Adodc3.CommandType = adCmdText
Adodc3.RecordSource = sSQL
Adodc3.Refresh
'有关人工设置：
'--------------
'设置DataComboDriver_Name_IExp
'DataComboResource_Name_IExp.ListField = Resource_Name
'DataComboResource_Name_IExp.Rowsource = Adodc3
'执行指定的SQL命令,打开作业定义表
sSQL = "Select ActivityID,Activity_Name from J_ActivityCode_Property Order by ActivityID"
cnJITSOFTDB.Execute (sSQL)
'设置ADODC4
Adodc4.ConnectionString = strConnect
Adodc4.CommandType = adCmdText
Adodc4.RecordSource = sSQL
Adodc4.Refresh
'有关人工设置：
'--------------
'设置DataComboDriver_Name
'DataComboActivity_Name.ListField = Activity_Name
'DataComboActivity_Name.Rowsource = Adodc4
ListViewCostObject_Name.View = lvwReport
ListViewCostObject_Name.ColumnHeaders.Add , , "成本对象名称"
ListViewCostObject_Name.ColumnHeaders(1).Width = 6000
'执行指定的SQL命令,打开成本对象定义表
sSQL = "Select CostObjectID,CostObject_Name from J_CostObjectCode Where IsBottom = 1 Order by CostObjectID"
Set rs = cnJITSOFTDB.Execute(sSQL)
Do While Not rs.EOF
ListViewCostObject_Name.ListItems.Add , , rs("CostObject_Name")
rs.MoveNext
Loop
End Sub
0
推荐到鲜果： 查阅更多相关主题的帖子: 多因多果 成本核算 模型 源程序
评论
发布者 jinlijie
2008-4-11 1:17:42
发布者 青青我之心
2008-5-28 16:14:17