VB资金管理系统及源代码

VB资金管理系统及源代码Dim addrecord As VariantDim usercheck As BooleanDim conn As New ADODB.ConnectionDim rszjsx As New ADODB.RecordsetDim rsyskm As New ADODB.RecordsetDim rsfygsbm As New ADODB.Recordset设置资金科目资金上限管理中按钮的状态Private Sub setbuttonsyskm(bval As Boolean) For i = 0 To 5 cmdyskm(i).Enabled = bval Next i cmdyskm(6).Enabled = Not bval Dacomyskmdm.Enabled = Not bval Dacomyskmmc.Enabled = Not bval Dacombmdm.Enabled = Not bval Dacombmmc.Enabled = Not bval Dacomzjsxje.Enabled = Not bval DataGrid1.Enabled = bval If bval Then cmdyskm(7).Caption = 退出 Else cmdyskm(7).Caption = 取消 End If Exit SubEnd Sub资金科目资金上限管理中记录增加或修改后的字段检验Private Function zjsxcheck() As Boolean Dim id As Integer Dim str As String Dim note(3) As String note(0) = 资金科目名称和代码不能同时为空！ note(1) = 费用归属部门名称和代码不能为空！ note(2) = 此部门在该资金科目上的资金上限已经设置！ zjsxcheck = False If Dacomyskmdm.Text = Or Dacomyskmmc.Text = Then MsgBox note(0) Dacomyskmdm.SetFocus Exit Function End If If Dacombmdm.Text = Or Dacombmmc.Text = Then MsgBox note(1) Dacombmdm.SetFocus Exit Function End If id = rszjsx.Fields(xuhao) If addrecord = True Then str = select * from zjsx where yskmmc= & Dacomyskmmc.Text & and gsbmmc= & Dacombmmc.Text & Set rs = conn.Execute(str) Else str = select * from zjsx where (yskmmc= & Dacomyskmmc.Text & and gsbmmc= & Dacombmmc.Text & ) and xuhao & id & Set rs = conn.Execute(str) End If If rs.EOF Then zjsxcheck = True Else MsgBox note(2) rszjsx.CancelBatch adAffectAllChapters Dacomyskmdm.SetFocus End If Exit FunctionEnd FunctionPrivate Sub cmdyskm_Click(Index As Integer) Dim i As IntegerDim result As BooleanDim m_name As StringDim bookmark As VariantOn Error GoTo adderrSelect Case Index Case 0 添加按钮 addrecord = True rszjsx.AddNew setbuttonsyskm False Dacomyskmdm.SetFocus Exit Sub Case 1 修改按钮 addrecord = False setbuttonsyskm False Dacomyskmdm.SetFocus Exit Sub Case 2 查询按钮 bookmark = rszjsx.bookmark m_name = InputBox(请输入资金科目代码或资金科目名称或归属部门代码或归属部门名称, 按资金科目代码或资金科目名称或归属部门代码或归属部门名称称搜索) If m_name = Then Exit Sub End If rszjsx.MoveFirst rszjsx.Find yskmdm like % & m_name & % If rszjsx.EOF Then rszjsx.MoveFirst rszjsx.Find yskmmc like % & m_name & % If rszjsx.EOF Then rszjsx.MoveFirst rszjsx.Find gsbmdm like % & m_name & % If rszjsx.EOF Then rszjsx.MoveFirst rszjsx.Find gsbmmc like % & m_name & % If rszjsx.EOF Then MsgBox 没有设置此部门在该资金科目上的资金上限！ rszjsx.bookmark = bookmark End If End If End If rszjsx.MoveFirst End If Exit Sub Case 3 删除按钮 If MsgBox(你确认要删除该条记录吗？, vbexclaimation + vbOKCancel, 记录删除) = vbCancel Then Exit Sub End If conn.Execute (delete from zjsx where xuhao= & rszjsx.Fields(xuhao) With rszjsx 删除该纪录 .Delete .UpdateBatch adAffectCurrent If .RecordCount = 0 Then Adodc1.Enabled = False Exit Sub End If 移到下一条 .MoveNext 如果到文件尾，移到最后一条 If .EOF Then .MoveLast End With Exit Sub Case 4 下一条 rszjsx.MoveNext If rszjsx.EOF Then MsgBox 这是最后一个记录！ rszjsx.MovePrevious End If Exit Sub Case 5 上一条 rszjsx.MovePrevious If rszjsx.BOF Then MsgBox 这是第一个记录！ rszjsx.MoveNext End If Exit Sub Case 6 保存按钮 result = zjsxcheck() If result = True Then rszjsx.UpdateBatch adAffectCurrent setbuttonsyskm True MsgBox 保存成功！ rszjsx.Requery End If Exit Sub Case 7 退出或取消按钮 If cmdyskm(Index).Caption = 退出 Then Unload Me Else rszjsx.CancelUpdate setbuttonsyskm True Exit Sub End IfEnd SelectExit Subadderr: MsgBox Err.Description Unload MeEnd SubPrivate Sub Dacombmdm_Change() Dim str1 As String str1 = Trim(Dacombmdm.Text) Set rs = conn.Execute(select * from yskmlb where dm= & Left(Dacomdm.Text, 1) & )rsfygsbm.MoveFirstIf str1 Then rsfygsbm.Filter = dm= & str1 & If Not rsfygsbm.EOF Then Dacombmmc.Text = rsfygsbm.Fields(gsbmmc).Value End If Dacomlbdm.RefreshEnd IfEnd SubPrivate Sub Dacombmmc_Change()Set rs = conn.Execute(select * from yskmlb where dm= & Left(Dacomdm.Text, 1) & )If Trim(Dacombmmc.Text) Then rsfygsbm.Filter = gsbmmc = & Trim(Dacombmmc.Text) & If Not rsfygsbm.EOF Then Dacombmdm.Text = rsfygsbm.Fields(dm).Value End If Dacomlbdm.RefreshEnd IfEnd SubPrivate Sub Dacomyskmdm_Click(Area As Integer) Set rs = conn.Execute(select * from yskmlb where dm= & Left(Dacomdm.Text, 1) & )If Trim(Dacomyskmdm.Text) Then rsyskm.Filter = dm = & Trim(Dacomyskmdm.Text) & If Not rsyskm.EOF Then Dacomyskmmc.Text = rsyskm.Fields(yskmmc).Value End If Dacomlbdm.RefreshEnd IfEnd SubPrivate Sub Dacomyskmmc_Change() Set rs = conn.Execute(select * from yskmlb where dm= & Left(Dacomdm.Text, 1) & )If Trim(Dacomyskmmc.Text) Then rsyskm.Filter = yskmmc= & Trim(Dacomyskmmc.Text) & If Not rsyskm.EOF Then Dacomyskmdm.Text = rsyskm.Fields(dm).Value End If Dacomlbdm.RefreshEnd IfEnd SubPrivate Sub DataGrid1_Click()End SubPrivate Sub Form_Load()Dim fieldname(6) As VariantDim wide(6) As VariantDim str As Stringfieldname(0) = 序号fieldname(1) = 资金科目代码fieldname(2) = 资金科目名称fieldname(3) = 费用归属部门代码fieldname(4) = 费用归属部门名称fieldname(5) = 资金上限wide(0) = 400wide(1) = 800wide(2) = 1400wide(3) = 1000wide(4) = 1800wide(5) = 800str = Provider=SQLOLEDB.1;Password=090309;Persist Security Info=True;User ID=cw;Initial Catalog=ysgl2004;Data Source=CWSERVERIf conn.State 1 Then conn.CursorLocation = adUseClient conn.Open nowconnectstringEnd Ifstr = SELECT a.xuhao, b.dm as yskmdm, a.yskmmc, c.dm AS gsbmdm, a.gsbmmc, a.zjsxje FROM zjsx a INNER JOIN yskm b ON a.yskmmc = b.yskmmc INNER JOIN fygsbm c ON a.gsbmmc = c.gsbmmc ORDER BY b.dm, c.dmrszjsx.Open str, conn, adOpenStatic, adLockBatchOptimisticrsyskm.Open select * from yskm order by dm, conn, adOpenStatic, adLockBatchOptimisticrsfygsbm.Open select * from fygsbm order by dm, conn, adOpenStatic, adLockBatchOptimisticSet DataGrid1.DataSource = rszjsxFor i = 0 To 5 DataGrid1.Columns(i).Caption = fieldname(i) DataGrid1.Columns(i).Width = wide(i) DataGrid1.Columns(i).DataField = rszjsx.Fields(i).NameNext iSet Dacomyskmdm.DataSource = rszjsxDacomyskmdm.DataField = rszjsx.Fields(yskmdm).NameSet Dacomyskmdm.RowSource = rsyskmDacomyskmdm.ListField = rsyskm.Fields(dm).NameSet Dacomyskmmc.DataSource = rszjsxDacomyskmmc.DataField = rszjsx.Fields(yskmmc).NameSet Dacomyskmmc.RowSource = rsyskmDacomyskmmc.ListField = rsyskm.Fields(yskmmc).NameSet Dacombmdm.DataSource = rszjsxDacombmdm.DataField = rszjsx.Fields(bmdm).NameSet Dacombmdm.RowSource = rsfygsbmDacombmdm.ListField = rsfygsbm.Fields(dm).NameSet Dacombmmc.DataSource = rszjsxDacombmmc.DataField = rszjsx.Fields(gsbmmc).NameSet Dacombmmc.RowSource = rsfygsbmDacombmmc.ListField = rsfygsbm.Fields(gsbmmc).NameSet Dacomzjsxje.DataSource = rszjsxDacomzjsxje.DataField = rszjsx.Fields(zjsxje).NameEnd SubPrivate Sub Form_Unload(Cancel As Integer)rs.Closeconn.CloseEnd SubDim conn As New ADODB.ConnectionDim rshistory As New ADODB.RecordsetDim rskjyw As New ADODB.RecordsetDim rspzlb As New ADODB.RecordsetDim rsgkglbm As New ADODB.RecordsetDim rsyskmlb As New ADODB.RecordsetDim rsyskm As New ADODB.RecordsetDim rsfygsbm As New ADODB.RecordsetDim rs As New ADODB.RecordsetDim addrecord As BooleanDim m_pzhm As StringDim m_glbmmc As StringDim m_gsbmmc As StringDim m_yskmmc As StringDim m_yslbmc As StringDim m_ywje As StringDim m_bz As StringDim m_fsrq As DatePrivate Sub setbuttons(bval As Boolean) Dim setcontrol As Control For Each setcontrol In Me.Controls If TypeName(setcontrol) = DataCombo Or TypeName(setcontrol) = TextBox Or TypeName(setcontrol) = CheckBox Then setcontrol.Enabled = bval End If Next cmdkjyw(0).Enabled = Not bval cmdkjyw(1).Enabled = bval cmdkjyw(2).Enabled = bval cmdkjyw(3).Enabled = Not bval DTfsrq.Enabled = bval Exit SubEnd Sub存储修改的纪录内容到历史数据表Private Sub storehistory() Dim i As Integer Dim j As Integer Dim str As String If m_pzhm rskjyw.Fields(pzhm) Then history = history & 票据号码( & rskjyw.Fields(pzhm) & ) End If If m_pzlbmc rspzlb.Fields(pzlbmc) Then history = history & 票据类别名称( & rspzlb.Fields(pzlbmc) & ) End If If m_yslbmc rskjyw.Fields(yslbmc) Then history = history & 资金科目类别名称( & rskjyw.Fields(yslbmc) & ) End If If m_yskmmc rskjyw.Fields(yskmmc) Then history = history & 资金科目名称( & rskjyw.Fields(yskmmc) & ) End If If m_gsbmmc rskjyw.Fields(gsbmmc) Then history = history & 费用归属部门名称( & rskjyw.Fields(gsbmmc) & ) End If If m_glbmmc rskjyw.Fields(glbmmc) Then history = history & 费用管理部门名称( & rskjyw.Fields(glbmmc) & ) End If If m_fsrq rskjyw.Fields(fsrq) Then history = history & 发生日期( & rskjyw.Fields(fsrq) & ) End If If m_ywje rskjyw.Fields(ywje) Then history = history & 业务金额( & rskjyw.Fields(ywje) & ) End If If m_bz rskjyw.Fields(bz) Then history = history & 备注( & txtbz.Text & ) End If If history Then conn.Execute (insert into ywhistory (pzhm,username,act,content,actdate) values( & m_pzhm & , & username & ,修改, & history & , & Format(Date, yyyy-MM-dd) & ) End IfEnd Sub保存会计业务纪录Private Function storekjyw() As Boolean Dim note(10) As String Dim str As String Dim gsbmzh As Single Dim jtzh As Single Dim gsbmsx As Single Dim jtsx As Single Dim i As Single gsbmje = 0 jtje = 0 jtsx = 0 gsbmsx = 0 note(0) = 票据号码不能为空！ note(1) = 发生日期不能为空！ note(2) = 归口管理部门代码和名称不能同时为空！ note(3) = 资金科目类别代码和名称不能同时为空！ note(4) = 资金科目代码和名称不能同时为空！ note(5) = 费用归属部门代码和名称不能同时为空！ note(6) = 业务金额不能为空！ note(7) = 该票据号码已经存在！ note(8) = 票据类别名称不能为空！ note(9) = 该票据号码的格式不正确！ storekjyw = False If Dacompzhm.Text = Then MsgBox note(0) Dacompzhm.SetFocus Exit Function End If If InStr(Dacompzhm.Text, -) = 0 Then MsgBox note(9) Dacompzhm.SetFocus Exit Function End If If Dacompzlbmc.Text = Then MsgBox note(8) Dacompzlbmc.SetFocus Exit Function End If If DTfsrq.Value = Then MsgBox note(1) DTfsrq.SetFocus Exit Function End If If Dacomglbmdm.Text = And Dacomglbmmc.Text = Then MsgBox note(2) Dacomglbmdm.SetFocus Exit Function End If If Dacomyslbdm.Text = And Dacomyslbmc.Text = Then MsgBox note(3) Dacomyslbdm.SetFocus Exit Function End If If Dacomyskmdm.Text = And Dacomyskmmc.Text = Then MsgBox note(4) Dacomyskmdm.SetFocus Exit Function End If If Dacomgsbmdm.Text = And Dacomgsbmmc.Text = Then MsgBox note(5) Dacomgsbmdm.SetFocus Exit Function End If If Dacomywje.Text = Then MsgBox note(6) Dacomywje.SetFocus Exit Function End If Set rs = conn.Execute(select sum(ywje) as jezh from kjyw where yskmmc= & Dacomyskmmc.Text & and gsbmmc= & Dacomgsbmmc.Text & ) If Not rs.EOF Then gsbmze = rs.Fields(jezh) Else gsbmze = 0 End If rs.Close Set rs = conn.Execute(select sum(ywje) as jezh from kjyw) If Not rs.EOF Then jtze = rs.Fields(jezh) Else jtze = 0 End If rs.Close Set rs = conn.Execute(select * from zjsx where yskmmc= & Dacomyskmmc.Text & and gsbmmc= & Dacomgsbmmc.Text & ) If Not rs.EOF Then gsbmsx = rs.Fields(zjsxje) Else gsbmsx = 0 End If rs.Close Set rs = conn.Execute(select * from zjsx where yskmmc= & Dacomyskmmc.Text & and gsbmmc=集团) If Not rs.EOF Then jtsx = rs.Fields(zjsxje) Else jtsx = 0 End If rs.Close If gsbmsx 0 Then i = gsbmze / gsbmsx Else i = 0 End If If i 0.8 Then If i 0.9 Then If MsgBox(Dacomgsbmmc.Text & 在资金科目 & Dacomyskmmc.Text & 上的 & Dacomyslbmc.Text & 已经超过90%，请确定是否继续添加？, vbOKCancel) = vbCancel Then Exit Function End If Else If MsgBox(Dacomgsbmmc.Text & 在资金科目 & Dacomyskmmc.Text & 上的 & Dacomyslbmc.Text & 已经超过80%，请确定是否继续添加？, vbOKCancel) = vbCancel Then Exit Function End If End If End If If jtsx 0 Then i = jtze / jtsx Else i = 0 End If If i 0.8 Then If i 0.95 Then If MsgBox(集团在资金科目 & Dacomyskmmc.Text & 上的支出已经超过90%，请确定是否继续添加？, vbOKCancel) = vbCancel Then Exit Function End If Else If MsgBox(集团在资金科目 & Dacomyskmmc.Text & 上的支出已经超过80%，请确定是否继续添加？, vbOKCancel) = vbCancel Then Exit Function End If End If End If If addrecord = True Then Set rs = conn.Execute(select * from kjyw where pzhm= & Dacompzhm.Text & ) Else Set rs = conn.Execute(select * from kjyw where pzhm= & Dacompzhm.Text & and xuhao & rskjyw.Fields(xuhao).Value) End If If Not rs.EOF Then MsgBox note(7) Dacompzhm.SetFocus Exit Function End If storekjyw = True Exit FunctionEnd FunctionPrivate Sub cmdkjyw_Click(Index As Integer) Select Case Index Case 0 添加、修改或删除 If cmdkjyw(Index).Caption = 添加 Then addrecord = True Dacomglbmdm.Text = Dacomyslbdm.Text = Dacomyskmdm.Text = Dacomgsbmdm.Text = setbuttons True rskjyw.AddNew DTfsrq.Value = Date txtbz.Text = Else If cmdkjyw(Index).Caption = 修改 Then addrecord = False setbuttons True Else 删除 conn.Execute (insert into ywhistory (pzhm,username,act,content,actdate) values( & pzhm & , & username & ,删除, & Format(Date, yyyy-MM-dd) & ) conn.Execute (delete from kjyw where xuhao= & rskjyw.Fields(xuhao) rskjyw.Requery Exit Sub End If End If Dacompzhm.SetFocus Exit Sub Case 1 保存 If storekjyw = True Then If addrecord = True Then rskjyw.UpdateBatch adAffectCurrent storehistory setbuttons False rshistory.Requery MsgBox 保存成功！ Else End If setbuttons False storehistory adorefresh conn.Execute (insert into hthistory (username,act,content,date) values( & yhmc & ,增加, & Date & ) End If Exit Sub Case 2 取消 rskjyw.CancelUpdate setbuttons False Exit Sub Case 3 退出 Unload Me End SelectEnd SubPrivate Sub Dacomglbmdm_Change() Set rs = conn.Execute(select * from yskmlb where dm= & Left(Dacomdm.Text, 1) & )If Trim(Dacomglbmdm.Text) Then rsgkglbm.Filter = dm = & Trim(Dacomglbmdm.Text) & If Not rsgkglbm.EOF Then Dacomglbmmc.Text = rsgkglbm.Fields(glbmmc).Value End If Dacomlbdm.RefreshEnd IfEnd SubPrivate Sub Dacomglbmmc_Change()If Trim(Dacomglbmmc.Text) Then rsgkglbm.Filter = glbmmc = & Trim(Dacomglbmmc.Text) & If Not rsgkglbm.EOF Then Dacomglbmdm.Text = rsgkglbm.Fields(dm).Value End If Dacomlbdm.RefreshEnd IfEnd SubPrivate Sub Dacomyslbdm_Change() Set rs = conn.Execute(select * from yskmlb where dm= & Left(Dacomdm.Text, 1) & )If Trim(Dacomyslbdm.Text) Then rsyskmlb.Filter = dm = & Trim(Dacomyslbdm.Text) & If Not rsyskmlb.EOF Then Dacomyslbmc.Text = rsyskmlb.Fields(yslbmc).Value Set rsyskm = conn.Execute(select * from yskm where left(dm,1)= & Trim(Dacomyslbdm.Text) & ) Set Dacomyskmdm.RowSource = rsyskm Dacomyskmdm.ListField = rsyskm.Fields(dm).Name Set Dacomyskmmc.RowSource = rsyskm Dacomyskmmc.ListField = rsyskm.Fields(yskmmc).Name If Not rsyskm.EOF Then Dacomyskmdm.Text = rsyskm.Fields(dm) Dacomyskmmc.Text = rsyskm.Fields(yskmmc) Else Dacomyskmdm.Text = Dacomyskmmc.Text = End If Else Dacomyslbmc.Text = rsyskmlb.Filter = dm= & Left(Trim(Dacomyslbdm.Text), 1) & Dacomyskmdm.Text = Dacomyskmmc.Text = End If Dacomlbdm.RefreshElse Dacomyslbmc.Text = End IfEnd SubPrivate Sub Dacomyslbmc_Change()If Trim(Dacomyslbmc.Text) Then rsyskmlb.Filter = yslbmc = & Trim(Dacomyslbmc.Text) & If Not rsgkglbm.EOF Then Dacomyslbdm.Text = rsyskmlb.Fields(dm).Value Set rsyskm = conn.Ex