card.bas

金算盘软件代码

'    strSql = "UPDATE AccountDaily SET " & strField & "=" & lngPID & " WHERE " _
'        & strField & "=" & lngID
'    gclsBase.BaseDB.Execute strSql
    strSql = "SELECT * FROM AccountDaily WHERE " & strField & "=" & lngID
    Set recAB = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    Do Until recAB.EOF
        dftAB(0).strName = "lngAccountID"
        dftAB(0).lngID = recAB("lngAccountID")
        dftAB(1).strName = "lngCurrencyID"
        dftAB(1).lngID = recAB("lngCurrencyID")
        dftAB(2).strName = "lngClassID1"
        dftAB(2).lngID = recAB("lngClassID1")
        dftAB(3).strName = "lngClassID2"
        dftAB(3).lngID = recAB("lngClassID2")
        dftAB(4).strName = "lngCustomerID"
        dftAB(4).lngID = recAB("lngCustomerID")
        dftAB(5).strName = "lngDepartmentID"
        dftAB(5).lngID = recAB("lngDepartmentID")
        dftAB(6).strName = "lngEmployeeID"
        dftAB(6).lngID = recAB("lngEmployeeID")
        strDate = recAB("strDate")
        
        strCon = ConSQL(strField, dftAB) & " AND strDate='" & strDate & "'"
        strSql = "SELECT * FROM AccountDaily WHERE " & strField _
            & "=" & lngID & strCon
        strSql1 = "SELECT * FROM AccountDaily WHERE " & strField _
            & "=" & lngPID & strCon
        MergeRecord "AccountDaily", strSql, strSql1
        recAB.MoveNext
    Loop
    recAB.Close
    strSql = "UPDATE AccountDaily SET " & strField & "=" & lngPID & " WHERE " _
        & strField & "=" & lngID
    gclsBase.BaseDB.Execute strSql
    strSql = "DELETE FROM AccountDaily WHERE " & strField & "=" & lngID
    gclsBase.ExecSQL strSql
End Function

'合并计划预算
Public Function MergeBudgetBalance(ByVal lngPID As Long, ByVal lngID As Long, ByVal strField As String) As Boolean
    Dim intYear As Integer, bytPeriod As Byte, recBB1 As rdoResultset
    Dim recBB As rdoResultset, strSql As String, strOP As String
    Dim strCon As String, dftBB(8) As dftKey
    Dim dblBudget As Double, dblCurrencyBudget As Double, dblQuantityBudget As Double
    
    MergeBudgetBalance = True
    If strField = "lngAccountID" Then
        strOP = GetOperator(lngPID, lngID)
    Else
        strOP = "+"
    End If
    strSql = "SELECT * FROM BudgetBalance WHERE " & strField & "=" & lngID _
        & " AND intYear=" & gclsBase.AccountYear
    Set recBB = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    Do Until recBB.EOF
        dftBB(0).strName = "lngAccountID"
        dftBB(0).lngID = recBB("lngAccountID")
        dftBB(1).strName = "lngCurrencyID"
        dftBB(1).lngID = recBB("lngCurrencyID")
        dftBB(2).strName = "lngClassID1"
        dftBB(2).lngID = recBB("lngClassID1")
        dftBB(3).strName = "lngClassID2"
        dftBB(3).lngID = recBB("lngClassID2")
        dftBB(4).strName = "lngCustomerID"
        dftBB(4).lngID = recBB("lngCustomerID")
        dftBB(5).strName = "lngDepartmentID"
        dftBB(5).lngID = recBB("lngDepartmentID")
        dftBB(6).strName = "lngEmployeeID"
        dftBB(6).lngID = recBB("lngEmployeeID")
        dftBB(7).strName = "lngCurrencyID"
        dftBB(7).lngID = recBB("lngCurrencyID")
        dftBB(8).strName = "lngJobID"
        dftBB(8).lngID = recBB("lngJobID")
        intYear = recBB("intYear")
        bytPeriod = recBB("bytPeriod")
        dblBudget = recBB("dblBudget")
        dblCurrencyBudget = recBB("dblCurrencyBudget")
        dblQuantityBudget = recBB("dblQuantityBudget")
        
        strCon = ConSQL(strField, dftBB) & " AND intYear=" & intYear & " AND bytPeriod=" & bytPeriod
        strSql = "SELECT * FROM BudgetBalance WHERE " & strField _
            & "=" & lngPID & strCon
        Set recBB1 = gclsBase.BaseDB.OpenResultset(strSql, rdOpenDynamic)
        If recBB1.EOF Then
            strSql = "UPDATE BudgetBalance SET " & strField & "=" & lngPID _
                & " WHERE intYear=" & intYear & strCon
            gclsBase.BaseDB.Execute strSql
        Else
            recBB1.Edit
            If strOP = "+" Then
                recBB1("dblBudget") = dblBudget + recBB1("dblBudget")
                recBB1("dblCurrencyBudget") = dblCurrencyBudget + recBB1("dblCurrencyBudget")
                recBB1("dblQuantityBudget") = dblQuantityBudget + recBB1("dblQuantityBudget")
            Else
                recBB1("dblBudget") = recBB1("dblBudget") - dblBudget
                recBB1("dblCurrencyBudget") = recBB1("dblCurrencyBudget") - dblCurrencyBudget
                recBB1("dblQuantityBudget") = recBB1("dblQuantityBudget") - dblQuantityBudget
            End If
            recBB1.Update
            strSql = "DELETE FROM BudgetBalance WHERE " & strField _
                & "=" & lngID & strCon
            gclsBase.BaseDB.Execute strSql
        End If
        recBB1.Close
        recBB.MoveNext
    Loop
    recBB.Close
End Function

'合并商品发生额1
Public Function MergeItemDaily1(ByVal lngPID As Long, ByVal lngID As Long, ByVal strField As String) As Boolean
    Dim strCon As String, strDate As String
    Dim recIB As rdoResultset, strSql As String, strSql1 As String
    Dim dftIB(1) As dftKey
    
    On Error Resume Next
    MergeItemDaily1 = True
    strSql = "UPDATE ItemDaily1 SET " & strField & "=" & lngPID & " WHERE " _
        & strField & "=" & lngID
    gclsBase.BaseDB.Execute strSql
    strSql = "SELECT * FROM ItemDaily1 WHERE " & strField & "=" & lngID
    Set recIB = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    Do Until recIB.EOF
        dftIB(0).strName = "lngItemID"
        dftIB(0).lngID = recIB("lngItemID")
        dftIB(1).strName = "lngCustomerID"
        dftIB(1).lngID = recIB("lngCustomerID")
        strDate = recIB("strDate")
        strCon = ConSQL(strField, dftIB) & " AND strDate='" & strDate & "'"
        strSql = "SELECT * FROM ItemDaily1 WHERE " & strField _
            & "=" & lngID & strCon
        strSql1 = "SELECT * FROM ItemDaily1 WHERE " & strField _
            & "=" & lngPID & strCon
        MergeRecord "ItemDaily1", strSql, strSql1
        recIB.MoveNext
    Loop
    recIB.Close
    strSql = "DELETE FROM ItemDaily1 WHERE " & strField & "=" & lngID
    gclsBase.ExecSQL strSql
End Function

'合并商品发生额2
Public Function MergeItemDaily2(ByVal lngPID As Long, ByVal lngID As Long, ByVal strField As String) As Boolean
    Dim recIB As rdoResultset, strSql As String, strSql1 As String, strDate As String
    
    On Error Resume Next
    MergeItemDaily2 = True
    strSql = "UPDATE ItemDaily2 SET " & strField & "=" & lngPID & " WHERE " _
        & strField & "=" & lngID
    gclsBase.BaseDB.Execute strSql
    strSql = "SELECT * FROM ItemDaily2 WHERE " & strField & "=" & lngID
    Set recIB = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    Do Until recIB.EOF
        strDate = recIB("strDate")
        strSql = "SELECT * FROM ItemDaily2 WHERE lngItemID=" & lngID & " AND strDate='" & strDate & "'"
        strSql1 = "SELECT * FROM ItemDaily2 WHERE lngItemID=" & lngPID & " AND strDate='" & strDate & "'"
        MergeRecord "ItemDaily2", strSql, strSql1
        recIB.MoveNext
    Loop
    recIB.Close
    strSql = "DELETE FROM ItemDaily2 WHERE " & strField & "=" & lngID
    gclsBase.ExecSQL strSql
End Function

'合并货位余额
Public Function MergePositionBalance(ByVal lngPID As Long, ByVal lngID As Long, ByVal strField As String) As Boolean
    Dim recPB As rdoResultset, strSql As String
    Dim strCon As String, strSql1 As String
    Dim dftPB(1) As dftKey
    
    On Error Resume Next
    MergePositionBalance = True
    strSql = "UPDATE PositionBalance SET " & strField & "=" & lngPID & " WHERE " _
        & strField & "=" & lngID
    gclsBase.BaseDB.Execute strSql
    strSql = "SELECT * FROM PositionBalance WHERE " & strField & "=" & lngID
    Set recPB = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    Do Until recPB.EOF
        dftPB(0).strName = "lngItemID"
        dftPB(0).lngID = recPB("lngItemID")
        dftPB(1).strName = "lngPositionID"
        dftPB(1).lngID = recPB("lngPositionID")
        strCon = ConSQL(strField, dftPB)
        strSql = "SELECT * FROM PositionBalance WHERE " & strField _
            & "=" & lngID & strCon
        strSql1 = "SELECT * FROM PositionBalance WHERE " & strField _
            & "=" & lngPID & strCon
        MergeRecord "PositionBalance", strSql, strSql1
        recPB.MoveNext
    Loop
    recPB.Close
    strSql = "DELETE FROM PositionBalance WHERE " & strField & "=" & lngID
    If Not gclsBase.ExecSQL(strSql) Then Exit Function
End Function

'合并货位发生额
Public Function MergePositionDaily(ByVal lngPID As Long, ByVal lngID As Long, ByVal strField As String) As Boolean
    Dim recPB As rdoResultset, strSql As String
    Dim strCon As String, strSql1 As String
    Dim dftPB(1) As dftKey, strDate As String
    
    On Error Resume Next
    MergePositionDaily = True
    strSql = "UPDATE PositionDaily SET " & strField & "=" & lngPID & " WHERE " _
        & strField & "=" & lngID
    gclsBase.BaseDB.Execute strSql
    strSql = "SELECT * FROM PositionDaily WHERE " & strField & "=" & lngID
    Set recPB = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    Do Until recPB.EOF
        dftPB(0).strName = "lngItemID"
        dftPB(0).lngID = recPB("lngItemID")
        dftPB(1).strName = "lngPositionID"
        dftPB(1).lngID = recPB("lngPositionID")
        strDate = recPB("strDate")
        strCon = ConSQL(strField, dftPB) & " AND strDate='" & strDate & "'"
        strSql = "SELECT * FROM PositionDaily WHERE " & strField _
            & "=" & lngID & strCon
        strSql1 = "SELECT * FROM PositionDaily WHERE " & strField _
            & "=" & lngPID & strCon
        MergeRecord "PositionDaily", strSql, strSql1
        recPB.MoveNext
    Loop
    recPB.Close
    strSql = "DELETE FROM PositionDaily WHERE " & strField & "=" & lngID
    If Not gclsBase.ExecSQL(strSql) Then Exit Function
End Function

'产生工资表中可以合并的字段串
Private Function MakeFields() As String
    Dim fieX As rdoColumn, strFields As String
    
    MakeFields = "dblLastTax,dblNowTax,dblLastZero,dblNowZero"
    For Each fieX In gclsBase.BaseDB.rdoTables("Salary").rdoColumns
        If Left(fieX.Name, 2) = "Sa" Then MakeFields = MakeFields & "," & fieX.Name
    Next fieX
End Function

'产生合并工资的SQL
Private Function MakeMergeSalarySQL(ByVal strFields As String, ByVal strValues As String) As String
    Dim dblValue As Double, strField As String, strSql As String
    
    strSql = "UPDATE Salary SET "
    strField = StringOut(strFields, ",")
    dblValue = TxtToDouble(StringOut(strValues, ","))
    Do Until strField = ""
        strSql = strSql & strField & "=" & strField & "+" & dblValue & ","
        strField = StringOut(strFields, ",")
        dblValue = TxtToDouble(StringOut(strValues, ","))
    Loop
    If Right(strSql, 1) = "," Then strSql = Left(strSql, Len(strSql) - 1)
    MakeMergeSalarySQL = strSql
End Function

'合并工资
Public Function MergeSalary(ByVal lngPID As Long, ByVal lngID As Long) As Boolean
    Dim recSalList As rdoResultset, strSql As String, strFieldStr As String
    
    MergeSalary = False
    strFieldStr = MakeFields
    strSql = "SELECT * FROM SalaryList"
    Set recSalList = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    Do Until recSalList.EOF
        If Not MergeSalaryDetail(lngPID, lngID, recSalList!lngSalaryListID, strFieldStr) Then
            recSalList.Close
            Exit Function
        End If
        recSalList.MoveNext
    Loop
    recSalList.Close
    MergeSalary = True
End Function

'合并工资明细
Private Function MergeSalaryDetail(ByVal lngPID As Long, ByVal lngID As Long, ByVal lngSalaryListID As Long, ByVal strFieldStr As String) As Boolean
    Dim i As Integer, fieX As rdoColumn, recSalary As rdoResultset, strSql As String, strValues As String
    
    On Error GoTo ErrHandle
    MergeSalaryDetail = True
    strSql = "SELECT " & strFieldStr & " FROM Salary WHERE lngSalaryListID=" & lngSalaryListID _
        & " AND lngEmployeeID=" & lngID