card.bas

金算盘软件代码

'                 Result(4) = IIf(recTemp!blnIsDetail, 1, 0)
'              Else
'                 Result(4) = 0
'              End If
'              Result(2) = recTemp!intLevel + 1
'            End Select
'
'
'       Else
'          '合并的情况
'          Result(1) = 2
'          Result(7) = recTemp(FIDName)
'          If Not IsNull(recTemp!blnIsDetail) Then
'             Result(8) = IIf(recTemp!blnIsDetail, 1, 0)
'          Else
'             Result(8) = 0
'          End If
'
'          lngSign = GetPreRecID(strOldCode, TName, FCodeName)
'          If lngSign > 0 Then
'            Result(5) = lngSign
'            '判断老上级是否有其它下级
'            strOldCode = CodePrefix(strOldCode)
'            strSql = "SELECT * FROM " & TName & " WHERE " & FCodeName & " LIKE  '" & strOldCode & "-%' AND " & FIDName & " NOT LIKE " & lngID
'            Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
''            Set recTemp = m_dbTest.openresultset(strSQL, rdopenstatic)   'test
'            If recTemp.EOF = False Then
'                Result(6) = 1
'            End If
'          End If
'       End If
'  End If
'End Sub
'
'改变下级卡片的编码和全名
Public Function ChangeLowerCardCodeAndFullName(strTable As String, strCodeField _
    As String, strFullNameField As String, strIDField As String, strOldCode As String, _
    strOLdName As String, strNewCode As String, strNewName As String, _
    intLevel As Integer, intNewLevel As Integer) As Boolean
    Dim lngID As Long
    Dim recX As rdoResultset, strSql As String
    Dim strOldPreCode As String, strOldPreName As String
    Dim strNewPreCode As String, strNewPreName As String

    strSql = "SELECT * FROM " & strTable & " WHERE " & strCodeField & " LIKE '" & _
        strOldCode & "-%' AND intLevel=" & intLevel + 1 & " ORDER BY " & strCodeField
    Set recX = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If recX.EOF Then
        recX.Close
        ChangeLowerCardCodeAndFullName = True
        Exit Function
    End If
    Do Until recX.EOF
        lngID = recX.rdoColumns(strIDField)
        strOldPreCode = recX.rdoColumns(strCodeField)
        strOldPreName = recX.rdoColumns(strFullNameField)
        strNewPreCode = strNewCode & strAftFix(strOldCode, recX.rdoColumns(strCodeField))
        strNewPreName = strNewName & strAftFix(strOLdName, recX.rdoColumns(strFullNameField))
        strSql = "UPDATE " & strTable & " SET " & strCodeField & "='" & strNewPreCode _
            & "'," & strFullNameField & "='" & strNewPreName _
            & "',intLevel=" & intNewLevel + 1 & " WHERE " & strIDField & "=" & lngID
        If Not gclsBase.ExecSQL(strSql) Then
            recX.Close
            ChangeLowerCardCodeAndFullName = False
            Exit Function
        End If
        ChangeLowerCardCodeAndFullName = ChangeLowerCardCodeAndFullName(strTable, _
            strCodeField, strFullNameField, strIDField, strOldPreCode, strOldPreName, _
            strNewPreCode, strNewPreName, intLevel + 1, intNewLevel + 1)
        recX.MoveNext
    Loop
    recX.Close
End Function
'改变上级卡片的末级属性
Public Function ChangeHigherCardDetail(strTable As String, strField As String, _
    ByVal strCode As String) As Boolean
    Dim recX As rdoResultset
    Dim strPCode As String, strSql As String
    
    ChangeHigherCardDetail = False
    
    strPCode = CodePrefix(Trim$(strCode))
    
    If strPCode <> "" Then
        strSql = "SELECT * FROM " & strTable & " WHERE " & strField & " LIKE '" & strPCode & "-%'"
        Set recX = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If recX.EOF Then
            strSql = "UPDATE " & strTable & " SET blnIsDetail=1 WHERE " & strField & "='" _
                & strPCode & "'"
            If Not gclsBase.ExecSQL(strSql) Then
                Exit Function
            End If
        End If
    End If
    ChangeHigherCardDetail = True
End Function
'改变上级卡片的活动属性
Public Function ChangeHigherActive(strTable As String, strField As String, _
    strCode As String) As Boolean
    Dim recX As rdoResultset, strPCode As String, strSql As String
    
    ChangeHigherActive = True
    strPCode = CodePrefix(strCode)
    strSql = "SELECT * FROM " & strTable & " WHERE " & strField & "='" & strPCode & "'"
    Set recX = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    Do Until strPCode = "" Or recX.EOF
        If recX!blnIsInActive = 0 Then Exit Do
        recX.Close
        strSql = "UPDATE " & strTable & " SET blnIsInActive=0" & " WHERE " _
            & strField & "='" & strPCode & "'"
        If Not gclsBase.ExecSQL(strSql) Then
            ChangeHigherActive = False
            Exit Function
        Else
            strPCode = CodePrefix(strPCode)
            strSql = "SELECT * FROM " & strTable & " WHERE " & strField & "='" _
                & strPCode & "'"
            Set recX = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        End If
    Loop
    recX.Close
End Function

'改变下级卡片的活动属性
Public Function ChangeLowerActive(strTable As String, strField As String, _
    strCode As String) As Boolean
    Dim strSql As String
    
    strSql = "UPDATE " & strTable & " SET blnIsInActive=1" & " WHERE " _
        & strField & " LIKE '" & strCode & "-%'" & " AND " & strField _
        & "<>'" & strCode & "'"
    ChangeLowerActive = gclsBase.ExecSQL(strSql)
End Function

'代码合并时转移业务
Public Function DisplaceActivity(ByVal strTable As String, ByVal strField As String, _
    lngDID As Long, lngSID As Long) As Boolean
    Dim strSql As String
    
    strSql = "UPDATE " & strTable & " SET " & strField & "=" & lngDID & " WHERE " _
        & strField & "=" & lngSID
    DisplaceActivity = gclsBase.ExecSQL(strSql)
End Function

Private Function GetPreRecID(m_strCode As String, TName As String, FCodeName As String) As Long
  Dim strSql As String
  Dim strCode As String
  Dim strTemp As String
  Dim recTemp As rdoResultset

  
  strCode = CodePrefix(m_strCode)
  If strCode = "" Then
    GetPreRecID = 0                   '无上级编码
  Else
    strSql = "SELECT * FROM " & TName & " WHERE " & FCodeName & "='" & strCode & "'"
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
'    Set recTemp = m_dbTest.openresultset(strSQL, rdopenstatic)   'test
    If recTemp.EOF = True Then
       GetPreRecID = -1            '错误上级编码
    Else
       GetPreRecID = recTemp!lngEmployeeTypeID   '正确上级编码
    End If
    recTemp.Close
  End If
End Function

Public Function GetNextCode(ByVal strCur As String) As String
    Dim strCode As String
    Dim strTemp As String
    Dim i As Integer
    Dim iLen As Integer
    Dim vntNumble As Variant
    Dim strLeft As String
    
    If strCur = "" Then
        GetNextCode = ""
    Else
        strCode = strCur
        iLen = Len(strCode)
        strTemp = Mid(strCode, iLen, 1)
        If IsNumeric(strTemp) Then
        '数字的处理
            For i = iLen To 1 Step -1
                strTemp = Mid(strCode, i, 1)
                If Not IsNumeric(strTemp) Then Exit For
            Next
            strTemp = Right(strCode, iLen - i)
            strLeft = Left(strCode, i)
            vntNumble = CDec(strTemp) + 1
            If Left(strTemp, 1) = "0" Then
                iLen = Len(strTemp)
                strTemp = Right(String(iLen, "0") & CStr(vntNumble), iLen)
            Else
                strTemp = CStr(vntNumble)
            End If
            GetNextCode = strLeft & strTemp
        Else
        '字符的处理
            strLeft = Left(strCode, iLen - 1)
            strTemp = Mid(strCode, iLen, 1)
            Select Case strTemp
            Case "z"
                strTemp = "za"
            Case "Z"
                strTemp = "ZA"
            Case Else
                strTemp = Chr(Asc(strTemp) + 1)
            End Select
            GetNextCode = strLeft & strTemp
        End If
    End If
End Function

Private Function ConSQL(ByVal strField As String, ByRef dftX() As dftKey) As String
    Dim i As Integer, strSql As String
    
    For i = 0 To UBound(dftX)
        If dftX(i).strName <> strField Then
            strSql = strSql & " AND " & dftX(i).strName & "=" & dftX(i).lngID
        End If
    Next i
    ConSQL = strSql
End Function

Private Function GetOperator(ByVal lngPID As Long, ByVal lngID As Long) As String
    Dim recA As rdoResultset, strSql As String, intDire As Integer
    
    On Error GoTo ErrHandle
    GetOperator = "+"
    strSql = "SELECT * FROM Account WHERE lngAccountID=" & lngPID _
        & " OR lngAccountID=" & lngID
    Set recA = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    intDire = recA("intDirection")
    recA.MoveNext
    If intDire <> recA("intDirection") Then GetOperator = "-"
ErrHandle:
    recA.Close
End Function

'合并记录
Public Sub MergeRecord(ByVal strTable As String, ByVal strSqlS As String, ByVal strSqlD As String, Optional ByVal strOP As String = "+")
    Dim recS As rdoResultset, recD As rdoResultset, fieX As rdoColumn
    
    Set recS = gclsBase.BaseDB.OpenResultset(strSqlS, rdOpenStatic)
    If recS.EOF Then
        recS.Close
        Exit Sub
    End If
    
    Set recD = gclsBase.BaseDB.OpenResultset(strSqlD, rdOpenDynamic, 4)
    If recD.EOF Then
        recD.Close
        recS.Close
        Exit Sub
    End If
    recD.Edit
    
    For Each fieX In recD.rdoColumns
        If Left(fieX.Name, 3) = "DBL" Then
            If strOP = "+" Then
                recD(fieX.Name).Value = recD(fieX.Name).Value + recS(fieX.Name).Value
            Else
                recD(fieX.Name).Value = recD(fieX.Name).Value - recS(fieX.Name).Value
            End If
        End If
    Next fieX
    
    recD.Update
    recS.Close
    recD.Close
End Sub

'合并科目发生额
Public Function MergeAccountDaily(ByVal lngPID As Long, ByVal lngID As Long, ByVal strField As String) As Boolean
    Dim recAB As rdoResultset, strSql As String, strSql1 As String
    Dim strCon As String, strDate As String, dftAB(6) As dftKey
    
    On Error Resume Next
    MergeAccountDaily = True