module1.bas

本人开发的商业财务软件

Attribute VB_Name = "Module1"
'李树永 QQ 82341763
'Email:[e-mail]
Option Explicit
Public fMainForm As frmMain
Public pubConn As New ADODB.Connection
Public nYear As Integer

Sub Main()
    initApp
'    Dim strSql As String
 '   strSql = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\Data.mdb;" & "Jet OLEDB:Database Password=125915;"
    '数据库密码为“125915”
  '  pubConn.Open strSql, "admin", ""
    frmLogin.Show vbModal
    If frmLogin.LoginSucceeded = False Then
        Unload frmLogin
        End
    End If
    Set fMainForm = New frmMain
    fMainForm.Show vbModal
    pubConn.Close
    End
End Sub
Public Sub initApp()
    Dim rstTemp As New ADODB.Recordset
    
    If pubConn.State <> adStateOpen Then
        Dim strSql As String
        strSql = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\Data.mdb;" & "Jet OLEDB:Database Password=125915;"
        '数据库密码为“125915”
        pubConn.Open strSql, "admin", ""
    End If
    
    rstTemp.Open "select min(日期) as rq from mingxiZhang ", pubConn
    If IsNull(rstTemp!rq) Then
        MsgBox "程序初始化会计年度出错，明细帐为空", , "初始化出错"
        Exit Sub
    End If
    nYear = Year(rstTemp!rq)
    
    rstTemp.Close
    Set rstTemp = Nothing
End Sub
Public Function strFindMainKemu(strTemp As String) As String
    Dim iEnd As Integer
    iEnd = InStr(1, strTemp, "-")
    If iEnd = 0 Then
       strFindMainKemu = strTemp
    Else
       strFindMainKemu = Left(strTemp, iEnd - 1)
    End If
      
End Function
Public Function strFindSubKemu(strTemp As String) As String
    Dim iStart As Integer
    iStart = InStr(1, strTemp, "-")
    If iStart = 0 Then
       strFindSubKemu = ""
    Else
       strFindSubKemu = Mid(strTemp, iStart + 1)
    End If
End Function

Public Sub CreatMX(pzStart As Long)
'功能说明：本函数给一个起始凭证号开始生成分类明细帐，并调整余额
    'pzStart 生成明细帐的开始凭证号
    Dim rstPZ As New ADODB.Recordset
    Dim rstMingxi As New ADODB.Recordset
    Dim rstTemp As New ADODB.Recordset
    Dim rstKemu As New ADODB.Recordset
    Dim strSql As String
    Dim strKemu As String
    Dim curRemaining As Currency
    Dim curDebit As Currency
    Dim curCredit As Currency
    '删除明细帐多余记录
    strSql = "delete * from mingxiZhang where 凭证号 >= " & Str(pzStart)
    pubConn.Execute strSql
    strSql = "insert into  MingXiZhang(日期,科目,科目编号,凭证号,记录号,摘要,借方金额,贷方金额,pzid,月凭证号) " _
        & " select 日期,科目,科目编号,凭证号,记录号,摘要,借方金额,贷方金额,id,月凭证号 from pingZheng where " _
        & " 凭证号 >= " & Str(pzStart)
    pubConn.Execute strSql
    rstKemu.CursorLocation = adUseClient
    rstKemu.Open "select  科目,编号,借贷 from kemu ", pubConn
    rstMingxi.CursorLocation = adUseClient
    rstKemu.MoveFirst
    Do Until rstKemu.EOF
        '按科目分别进行余额计算，分析科目填写
        strKemu = rstKemu!科目
        strSql = "select 日期,科目,科目编号,凭证号,摘要,借方金额,贷方金额,借或贷,余额,pzid from MingXiZhang  where 科目='" _
            & strKemu & "' order by 凭证号"
        If rstMingxi.State = adStateOpen Then
            rstMingxi.Close
        End If
        rstMingxi.Open strSql, pubConn, adOpenDynamic, adLockOptimistic
        If rstMingxi.RecordCount = 0 Then
        '相关记录集为空，进行一轮循环
            GoTo lisy123
        End If
        rstMingxi.MoveFirst
        Do Until rstMingxi.EOF
            '取得起始凭证号同各上最邻近科目余额
            If rstMingxi!凭证号 >= pzStart Then Exit Do
            If Not IsNull(rstMingxi!余额) Then
                curRemaining = rstMingxi!余额
                Else
                curRemaining = 0
                'MsgBox "余额为空"
                'Exit Do
            End If
            rstMingxi.MoveNext
        Loop
        Do Until rstMingxi.EOF
            If IsNull(rstMingxi!贷方金额) Then
                curCredit = 0
            Else
                curCredit = rstMingxi!贷方金额
            End If
            If IsNull(rstMingxi!借方金额) Then
                curDebit = 0
            Else
                curDebit = rstMingxi!借方金额
            End If
                        
            If rstKemu!借贷 = "借" Then
                curRemaining = curRemaining + curDebit - curCredit
            Else
                curRemaining = curRemaining - curDebit + curCredit
            End If
            rstMingxi!余额 = curRemaining
            rstMingxi.MoveNext
        Loop

        
lisy123:
        rstKemu.MoveNext
    Loop
    '对分析科目赋值
    Dim rstKemufx As New ADODB.Recordset
    Dim strSqlfx As String
    rstKemufx.Open "select 科目 from  fxkemu", pubConn
    rstKemufx.MoveFirst
    Do Until rstKemufx.EOF
        strSqlfx = "update mingxizhang,PingZhengfx set " & rstKemufx!科目 _
            & "= pingZhengfx.金额 where (pingzhengfx.科目='" _
            & rstKemufx!科目 & "') and (MingXiZhang.pzid=PingZhengFx.pzid)"
        pubConn.Execute strSqlfx
        rstKemufx.MoveNext
    Loop
    strSql = "update mingxizhang,pingzheng set mingxizhang.摘要=pingZheng.摘要 where pingzheng.凭证号=mingxizhang.凭证号" _
        & " and pingzheng.记录号=1"
    pubConn.Execute strSql
    
End Sub