mdlkmfunction.bas

一个用VB写的财务软件源码

Attribute VB_Name = "mdlKmFunction"
Option Explicit

'''''''''''''''''''
'是否末级科目
'
Public Function IsEndSubject(ByVal sKmdm As String) As Boolean
Dim rSt As New Recordset
rSt.Open "Select kmdm from tZW_Km" + glo.sOperateYear + " where kmdm='" + sKmdm + "' and IsEndkm=-1", glo.cnnMain, adOpenKeyset
IsEndSubject = Not rSt.EOF
rSt.Close
End Function

''''''''''''''''''
'是否银行科目
Public Function IsBankSubject(ByVal sKmdm As String) As Boolean
Dim rSt As New Recordset
rSt.Open "Select kmdm from tZW_Km" + glo.sOperateYear + " where kmdm='" + sKmdm + "' and IsYhz=-1", glo.cnnMain, adOpenKeyset
IsBankSubject = Not rSt.EOF
rSt.Close
End Function


'''''''''''''''''''
'获取科目的外币单位
'
Public Function GetKmWbdw(ByVal sKmdm As String) As String
Dim rSt As New Recordset
rSt.Open "Select Wbdw from tZW_Km" + glo.sOperateYear + " where kmdm='" + sKmdm + "'", glo.cnnMain, adOpenKeyset
If rSt.EOF = False Then
    If IsNull(rSt.Fields(0).value) = True Then
        GetKmWbdw = ""
    Else
        GetKmWbdw = Trim$(rSt.Fields(0).value)
    End If
End If
rSt.Close
End Function

'''''''''''''''''''
'获取科目的名称
'
Public Function GetKmmc(ByVal sKmdm As String) As String
Dim rSt As New Recordset
rSt.Open "Select Kmmc from tZW_KM" + glo.sOperateYear + " where kmdm='" + sKmdm + "'", glo.cnnMain, adOpenKeyset, adLockOptimistic
If rSt.EOF = False Then
    GetKmmc = rSt.Fields(0).value
End If
rSt.Close
End Function

'''''''''''''''''''''''
'获取科目的父级科目代码
'
'
Public Function GetParentKmdm(ByVal sKmdm As String) As String
Dim i As Integer
sKmdm = Trim$(sKmdm)
i = InStrRev(sKmdm, glo.sSeparateSubject, , vbTextCompare)
If i > 0 Then
    GetParentKmdm = Left$(sKmdm, i - 1)
Else
    GetParentKmdm = ""
End If
End Function

'''''''''''''''''''''''
'获取科目的一级科目代码
'
'
Public Function GetRootParentKmdm(ByVal sKmdm As String) As String
Dim i As Integer
sKmdm = Trim$(sKmdm)
i = InStr(1, sKmdm, glo.sSeparateSubject, vbTextCompare)
If i > 0 Then
    GetRootParentKmdm = Left$(sKmdm, i - 1)
Else
    GetRootParentKmdm = sKmdm
End If
End Function
''''''''''''
'检查科目的级次
'1级 返回 0
'...........
'
Public Function GetKmJc(ByVal sKm As String) As Integer
Dim i As Integer
GetKmJc = 0
sKm = Trim$(sKm)
For i = 1 To Len(sKm)
    If StrComp(Mid(sKm, i, Len(glo.sSeparateSubject)), glo.sSeparateSubject, vbTextCompare) = 0 Then
        GetKmJc = GetKmJc + 1
    End If
Next i
End Function

'''''''''''''''
'修改方向
'
'

Public Function modifyFX(ByVal sKm As String, ByVal sFx As String, ByVal s As String) As Boolean
Dim bFx As Boolean
If Left(sFx, 1) = "借" Then
    sFx = "借方"
    bFx = True
Else
    sFx = "贷方"
    bFx = False
End If
On Error GoTo Err
glo.cnnMain.BeginTrans
If bFx = True Then
    glo.cnnMain.Execute "Update tZw_km" + glo.sOperateYear + " set yefx='借方'" + " where kmdm='" + sKm + "'"
    glo.cnnMain.Execute "Update tZw_Balance" + glo.sOperateYear + _
        " set yefx='借方',ljjsl" + s + "=ljjsl" + s + "-ljdsl" + s + _
        ",ljjwb" + s + "=ljjwb" + s + "- ljdwb" + s + ",ljj" + s + "=ljj" + s + "-ljd" + s + " where kmdm='" + sKm + "'"
    glo.cnnMain.Execute "update tZw_Balance" + glo.sOperateYear + _
        " set ljdsl" + s + "=0" + _
        ",ljdwb" + s + "=0" + s + ",ljd" + s + "=0 where kmdm='" + sKm + "'"
Else
    glo.cnnMain.Execute "Update tZw_km" + glo.sOperateYear + " set yefx='贷方'" + " where kmdm='" + sKm + "'"
    glo.cnnMain.Execute "Update tZw_Balance" + glo.sOperateYear + _
        " set yefx='贷方',ljdsl" + s + "=ljdsl" + s + "-ljjsl" + s + _
        ",ljdwb" + s + "=ljdwb" + s + "- ljjwb" + s + ",ljd" + s + "=ljd" + s + "-ljj" + s + " where kmdm='" + sKm + "'"
    glo.cnnMain.Execute "Update tZw_Balance" + glo.sOperateYear + _
        " set ljjsl" + s + "=0" + _
        ",ljjwb" + s + "=0,ljj" + s + "=0 where kmdm='" + sKm + "'"
End If
glo.cnnMain.CommitTrans
modifyFX = True
Exit Function
Err:
    glo.cnnMain.RollbackTrans
    modifyFX = False
End Function

Public Function modifyFxAll(ByVal sKm As String, ByVal sFx As String, ByVal bExtend As Boolean) As Boolean
Dim strSQL As String
Dim QcYue As String
Dim sBeginMonth  As String
Dim rSt As New ADODB.Recordset
modifyFxAll = False
    rSt.CursorLocation = adUseClient
    ' 获得账务子系统的启用月份,和启用年份
    strSQL = "SELECT BeginYear,BeginMonth FROM tSYS_SubSysUsed WHERE SubSysID='" & _
            gloSys.sSubSysID & "' AND AccountID='" & glo.sAccountID & "'"
    With rSt
        .Open strSQL, gloSys.cnnSYS, adOpenStatic, adLockOptimistic
        If .RecordCount > 0 Then
            '如果注册年份大于账务子系统启用年份, 查询开始月份等于1;
            '否则如果注册年份等于账务子系统启用年份, 查询开始月份等于账务子系统启用月份;
            '否则报错;
            If glo.sOperateYear > .Fields("BeginYear").value Then
                sBeginMonth = "1"
                .Close
            ElseIf glo.sOperateYear = .Fields("BeginYear").value Then
                sBeginMonth = .Fields("BeginMonth").value
                .Close
            Else
                MsgBox "注册年份不能小于账务子系统启用年份", vbCritical
                .Close
                Exit Function
            End If
        Else
            .Close
        End If
        QcYue = IIf(sBeginMonth = "1", "00", Format(CStr(Val(sBeginMonth) - 1), "00"))
        If bExtend = True Then
            .Open "Select kmdm from tZw_km" + glo.sOperateYear + " where kmdm like '" + sKm + "%'", glo.cnnMain, adOpenKeyset, adLockPessimistic
            While Not .EOF
                modifyFX .Fields(0).value, sFx, QcYue
                .MoveNext
            Wend
            .Close
        Else
            modifyFX sKm, sFx, QcYue
        End If
    End With
    
    
modifyFxAll = True
End Function

''''''''''''''''''''''
' 检查是否有某科目(全部)的记账凭证
'
'注:修改标志为2表示该凭证记录已记账;
Public Function HasRecordAccountKm(ByVal sKm As String) As Boolean
Dim rSt As New Recordset
Dim sSQL As String
If g_FLAT = "SQL" Then
    If sKm = "" Then
        sSQL = "Select top 1 * from tZW_pzsj" + glo.sOperateYear + " where xgbz='2'"
    Else
        sSQL = "Select top 1 * from tZW_pzsj" + glo.sOperateYear + " where kmdm='" + sKm + "' and xgbz='2'"
    End If
Else
    If sKm = "" Then
        sSQL = "Select * from tZW_pzsj" + glo.sOperateYear + " where xgbz='2' and rownum<2"
    Else
        sSQL = "Select * from tZW_pzsj" + glo.sOperateYear + " where kmdm='" + sKm + "' and xgbz='2' and rownum<2"
    End If
End If
rSt.Open sSQL, glo.cnnMain, adOpenKeyset, adLockReadOnly
If rSt.EOF And rSt.BOF Then
    HasRecordAccountKm = False
Else
    HasRecordAccountKm = True
End If
rSt.Close
End Function
''''''''''''''''''''''
' 在某会计期间中，检查是否有某科目(全部)的记账凭证
'
'注:修改标志为2表示该凭证记录已记账;
Public Function HasRecordAccountSubjectInMonth(ByVal sKm As String, ByVal sKjqj As String) As Boolean
Dim rSt As New Recordset
Dim sSQL As String
If g_FLAT = "SQL" Then
    If sKm = "" Then
        sSQL = "Select top 1 * from tZW_pzsj" + glo.sOperateYear + " where xgbz='2' and Kjqj=" + sKjqj + ""
    Else
        sSQL = "Select top 1 * from tZW_pzsj" + glo.sOperateYear + " where kmdm='" + sKm + "' and xgbz='2' and Kjqj=" + sKjqj + ""
    End If
Else
    If sKm = "" Then
        sSQL = "Select * from tZW_pzsj" + glo.sOperateYear + " where xgbz='2' and rownum<2 and Kjqj=" + sKjqj + ""
    Else
        sSQL = "Select * from tZW_pzsj" + glo.sOperateYear + " where kmdm='" + sKm + "' and xgbz='2' and rownum<2 and Kjqj=" + sKjqj + ""
    End If
End If
rSt.Open sSQL, glo.cnnMain, adOpenKeyset, adLockReadOnly
If rSt.EOF And rSt.BOF Then
    HasRecordAccountSubjectInMonth = False
Else
    HasRecordAccountSubjectInMonth = True
End If
rSt.Close
End Function

''''''''''''''''''''''
' 检查是否有某科目的凭证

Public Function HasAccountKm(ByVal sKm As String) As Boolean
Dim rSt As New Recordset
Dim sSQL As String
If g_FLAT = "SQL" Then
    sSQL = "Select top 1 * from tZW_pzsj" + glo.sOperateYear + " where kmdm='" + sKm + "'"
Else
    sSQL = "Select * from tZW_pzsj" + glo.sOperateYear + " where kmdm='" + sKm + "' and rownum<2"
End If
rSt.Open sSQL, glo.cnnMain, adOpenKeyset, adLockReadOnly
If rSt.EOF And rSt.BOF Then
    HasAccountKm = False
Else
    HasAccountKm = True
End If
rSt.Close
End Function

''''''''''''''''''''''
'检查是否有期初余额
Public Function HasQcYe(ByVal sKm As String) As Boolean
Dim strSQL As String
Dim QcYue As String
Dim sBeginMonth  As String
Dim rSt As New ADODB.Recordset
    HasQcYe = False
    ' 获得账务子系统的启用月份,和启用年份
    strSQL = "SELECT BeginYear,BeginMonth FROM tSYS_SubSysUsed WHERE SubSysID='" & _
            gloSys.sSubSysID & "' AND AccountID='" & glo.sAccountID & "'"
    With rSt
        .Open strSQL, gloSys.cnnSYS, adOpenStatic, adLockOptimistic
        If Not (.EOF And .BOF) Then
            '如果注册年份大于账务子系统启用年份, 查询开始月份等于1;
            '否则如果注册年份等于账务子系统启用年份, 查询开始月份等于账务子系统启用月份;
            '否则报错;
            If glo.sOperateYear > .Fields("BeginYear").value Then
                sBeginMonth = "1"
                .Close
            ElseIf glo.sOperateYear = .Fields("BeginYear").value Then
                sBeginMonth = .Fields("BeginMonth").value
                .Close
            Else
                MsgBox "注册年份不能小于账务子系统启用年份", vbCritical
                .Close
                Exit Function
            End If
        Else
            .Close
        End If
        QcYue = IIf(sBeginMonth = "1", "00", Format(CStr(Val(sBeginMonth) - 1), "00"))
        .Open "Select ljj" + QcYue + "-ljd" + QcYue + " from tZW_Balance" + glo.sOperateYear + " where kmdm='" + sKm + "'", glo.cnnMain, adOpenKeyset, adLockPessimistic
        If Not (.EOF And .BOF) Then
            If Abs(.Fields(0).value) > 0.005 Then
                HasQcYe = True
            End If
        End If
        .Close
    End With
End Function



'''''''''''''''''
'获取最小科目代码
Public Function GetMinKmdm() As String
Dim rSt As New Recordset
rSt.Open "Select Min(Kmdm) from tZW_Km" + glo.sOperateYear, glo.cnnMain, adOpenKeyset, adLockOptimistic
If rSt.EOF = False Then
    If IsNull(rSt.Fields(0).value) = False Then
        GetMinKmdm = rSt.Fields(0).value
    End If
End If
rSt.Close
End Function


'''''''''''''''''
'获取最大科目代码
Public Function GetMaxKmdm() As String
Dim rSt As New Recordset
rSt.Open "Select Max(Kmdm) from tZW_Km" + glo.sOperateYear, glo.cnnMain, adOpenKeyset, adLockOptimistic
If rSt.EOF = False Then
    If IsNull(rSt.Fields(0).value) = False Then
        GetMaxKmdm = rSt.Fields(0).value
    End If
End If
rSt.Close
End Function

''''''''''''''''
'是否辅助核算科目
Public Function IsFzKm(ByVal sKmdm As String) As Boolean
Dim rSt As New Recordset
rSt.Open "Select * from tZW_km" + glo.sOperateYear + " where kmdm='" + sKmdm + "' and (IsBmhs=-1 or IsXmhs=-1)", glo.cnnMain, adOpenKeyset, adLockPessimistic
If Not (rSt.EOF And rSt.BOF) Then
    IsFzKm = True
Else
    IsFzKm = False
End If
rSt.Close
End Function

'''''''''''''''''
'是否应收应付核算科目
Public Function IsYsyfKm(ByVal sKmdm As String) As Boolean
Dim rSt As New Recordset
rSt.Open "Select * from tZW_km" + glo.sOperateYear + " where kmdm='" + sKmdm + "' and (IsGyswlhs=-1 or IsGrwlhs=-1 or IsKhwlhs=-1)", glo.cnnMain, adOpenKeyset, adLockPessimistic
If Not (rSt.EOF And rSt.BOF) Then
    IsYsyfKm = True
Else
    IsYsyfKm = False
End If
rSt.Close
End Function

''''''''''''''''''
'科目发生凭证最迟的期间
Public Function HasChangeLastPeriod(ByVal sKmdm As String) As Integer
Dim rSt As New ADODB.Recordset
rSt.Open "Select Kjqj,Count(kmdm) from tZW_Pzsj" + glo.sOperateYear + " where kmdm like '" + sKmdm + "%' group by kjqj order by kjqj desc", glo.cnnMain, adOpenKeyset, adLockPessimistic
If Not (rSt.EOF And rSt.BOF) Then
    HasChangeLastPeriod = rSt.Fields(0).value
Else
    HasChangeLastPeriod = -1
End If
rSt.Close
End Function

''''''''''''''''
'是否祖先科目(包含自己)
Public Function IsAncestor(ByVal sKmdm As String, ByVal sAncestorKmdm As String) As Boolean
     While sKmdm <> sAncestorKmdm And sKmdm <> ""
        sKmdm = GetParentKmdm(sKmdm)
     Wend
     IsAncestor = (sKmdm = sAncestorKmdm)
End Function

''''''''''''''''
'取指定科目的所有子孙科目(包含自己)
Public Function GetChildrenKm(ByVal sKmdm As String) As String()
Dim rSt As New ADODB.Recordset
Dim result() As String
Dim coll As New VBA.Collection
rSt.Open "Select Kmdm from tZW_Km" + glo.sOperateYear + " where kmdm like '" + sKmdm + "%'", glo.cnnMain, adOpenKeyset, adLockPessimistic
If Not (rSt.EOF And rSt.BOF) Then
    While Not rSt.EOF
        If IsAncestor(rSt.Fields(0).value, sKmdm) Then
            coll.Add rSt.Fields(0).value
        End If
        rSt.MoveNext
    Wend
    If coll.Count = 0 Then rSt.Close: Exit Function
    ReDim result(0 To coll.Count - 1)
    Dim i As Integer
    For i = 0 To coll.Count - 1
        result(i) = coll.Item(i + 1)
    Next
    GetChildrenKm = result
Else
    
End If
rSt.Close
End Function