card.bas

金算盘软件代码

Public Function AccountCurrencyIsUsed(ByVal lngAcnID As Long, ByVal lngCurID As Long) As Boolean
    
    If lngAcnID = 0 Then
        AccountCurrencyIsUsed = False
        Exit Function
    End If
    AccountCurrencyIsUsed = True
    If AccountCurrencyUsed("AccountDaily", lngAcnID, lngCurID) Then Exit Function
    If AccountCurrencyUsed("ActivityDetail", lngAcnID, lngCurID) Then Exit Function
    If AccountCurrencyUsed("ItemActivity", lngAcnID, lngCurID) Then Exit Function
    If AccountCurrencyUsed("VoucherDetail", lngAcnID, lngCurID) Then Exit Function
    If AccountCurrencyUsed("VoucherDetail", lngAcnID, lngCurID) Then Exit Function
    If AccountCurrencyUsed("ARAPInit", lngAcnID, lngCurID) Then Exit Function
    If AccountCurrencyUsed("BankDetail", lngAcnID, lngCurID) Then Exit Function
    If AccountCurrencyUsed("BankInit", lngAcnID, lngCurID) Then Exit Function
    If AccountCurrencyUsed("Check1", lngAcnID, lngCurID) Then Exit Function
    AccountCurrencyIsUsed = False
End Function

Private Function AccountCurrencyUsed(ByVal TName As String, lngAcnID As Long, lngCurID As Long) As Boolean
    Dim recX As rdoResultset, strSql As String
    
    If TName = "AccountDaily" Then
        strSql = "SELECT * FROM " & TName & " WHERE lngAccountID=" & lngAcnID _
            & " AND lngCurrencyID=" & lngCurID & " AND ABS(dblUnVoucherDebit)" _
            & "+ABS(dblUnPostedDebit)+ABS(dblPostedDebit)+ABS(dblUnVoucherCredit)" _
            & "+ABS(dblUnPostedCredit)+ABS(dblPostedCredit)+ABS(dblCurrencyUnVoucherDebit)" _
            & "+ABS(dblCurrencyUnPostedDebit)+ABS(dblCurrencyPostedDebit)" _
            & "+ABS(dblCurrencyUnVoucherCredit)+ABS(dblCurrencyUnPostedCredit)" _
            & "+ABS(dblCurrencyPostedCredit)+ABS(dblQuantityUnVoucherDebit)" _
            & "+ABS(dblQuantityUnPostedDebit)+ABS(dblQuantityPostedDebit)" _
            & "+ABS(dblQuantityUnVoucherCredit)+ABS(dblQuantityUnPostedCredit)" _
            & "+ABS(dblQuantityPostedCredit)>0"
    Else
        strSql = "SELECT * FROM " & TName & " WHERE lngAccountID=" & lngAcnID & " AND lngCurrencyID=" & lngCurID
    End If
    Set recX = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    AccountCurrencyUsed = Not recX.EOF
    recX.Close
End Function

Public Function CodeCheck(ByVal strTable As String, ByVal strFieldCode As String, _
    ByVal strFieldID As String, ByVal blnIsNew As Boolean, _
    ByVal strCode As String, ByVal strName As String, ByVal strOldCode As String, _
    ByVal strOldFullName As String, strFullName As String, lngPCodeID As Long, _
    blnPIsDetail As Boolean, blnPIsInActive As Boolean, blnIsDetail As Boolean) As Integer
    Dim recX As rdoResultset
    Dim strSql As String, strPre As String
    
    strPre = CodePrefix(strCode)
    If strPre <> "" Then    '取上级停用标志
        strSql = "SELECT * FROM " & strTable & " WHERE " & strFieldCode & "='" & strPre & "'"
        Set recX = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If Not recX.EOF Then
            blnPIsInActive = (recX!blnIsInActive = 1)
        End If
        recX.Close
    End If
    If Not blnIsNew Then
        If strOldCode = strCode Then
            strPre = CodePrefix(strOldFullName)
            If strPre = "" Then
                strFullName = Trim$(strName)
            Else
                strFullName = strPre & "-" & Trim$(strName)
            End If
            CodeCheck = 1
            Exit Function
        Else
            strSql = "SELECT * FROM " & strTable & " WHERE " & strFieldCode & " LIKE '" _
                & strOldCode & "*'"
            Set recX = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
            If Not recX.EOF Then
                recX.MoveLast
                If Len(Trim$(recX.rdoColumns(strFieldCode))) + Len(strCode) - _
                    Len(strOldCode) > 16 Then
                    CodeCheck = -3   '编码超长
                    Exit Function
                End If
            End If
            recX.Close
        End If
    End If

    strSql = "SELECT * FROM " & strTable & " WHERE " & strFieldCode & "='" & strCode & "'"
    Set recX = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recX.EOF Then
        CodeCheck = -2             '当前编码已存在
        lngPCodeID = recX.rdoColumns(strFieldID)
        blnPIsDetail = (recX!blnIsDetail = 1)
        blnPIsInActive = (recX!blnIsInActive = 1)
        strFullName = CodePrefix(Trim$(recX!strFullName)) & "-" _
            & Trim$(strName)
        Exit Function
    End If
    recX.Close

    strPre = CodePrefix(strCode)
    If strPre <> "" Then
        strSql = "SELECT * FROM " & strTable & " WHERE " & strFieldCode & "='" & strPre & "'"
        Set recX = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If recX.EOF Then
            CodeCheck = -1           '上级编码不存在
            Exit Function
        Else
'            mintLevel = strCount(strCode, "-") + 1
            blnIsDetail = True
            strFullName = Trim$(recX!strFullName) & "-" _
                & Trim$(strName)
            lngPCodeID = recX.rdoColumns(strFieldID)
            blnPIsDetail = (recX!blnIsDetail = 1)
            blnPIsInActive = (recX!blnIsInActive = 1)
        End If
        recX.Close
    ElseIf Left(strCode, 1) = "-" Then
        CodeCheck = -1
        Exit Function
    Else
'        mintLevel = 1
        blnIsDetail = True
        strFullName = Trim$(strName)
        lngPCodeID = 0
        blnPIsDetail = False
    End If
    CodeCheck = 1
End Function

Public Sub BKKEY(ByVal lhwnd As Long, Optional ByVal KeyValue As Integer = vbKeyBack)
    PostMessage lhwnd, WM_KEYDOWN, KeyValue, 0
End Sub

Public Function CheckIDUsed(ByVal TName As String, ByVal Fname As String, lngID As Long) As Boolean
    Dim recX As rdoResultset, strSql As String
    
    strSql = "SELECT * FROM " & TName & " WHERE " & Fname & "=" & lngID
    Set recX = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    CheckIDUsed = Not recX.EOF
    recX.Close
End Function

Public Function CodePrefix(ByVal strCode As String, Optional strSeparator As String = "-") As String
    Dim i As Integer
    
    CodePrefix = ""
    If stringCount(strCode, strSeparator) = 0 Then Exit Function
    For i = 1 To StrLen(strCode)
        If stringCount(strRight(strCode, i), strSeparator) = 1 Then Exit For
    Next i
    CodePrefix = strLeft(strCode, StrLen(strCode) - i)
End Function

Public Function ContainErrorChar(ByVal strSource As String, Optional strErr As String = "") As Boolean
    Dim Count As Integer
    Dim strErrorChar As String
    
    strErrorChar = IIf(strErr = "", "`~!@#$^&*=+' "";:,./?|\", strErr)
    ContainErrorChar = False
    For Count = 1 To Len(strSource)
        If InStr(1, strErrorChar, Mid(strSource, Count, 1)) <> 0 Then
            ContainErrorChar = True
            Exit For
        End If
    Next Count
    
End Function

Public Function ContainSpecifyChar(ByVal strSource As String, Optional strSpecify As String = "0123456789") As Boolean
    Dim Count As Integer
    
    ContainSpecifyChar = True
    For Count = 1 To Len(strSource)
        If InStr(1, strSpecify, Mid(strSource, Count, 1)) = 0 Then
            ContainSpecifyChar = False
            Exit For
        End If
    Next Count
    
End Function

'Public Sub CheckCode(Result() As Integer, ByVal TName As String, ByVal FCodeName As String, ByVal FIDName As String, ByVal strCode As String, Optional CodeLengh As Integer, Optional lngID As Long = 0)
'  Dim strSql As String
'  Dim recTemp As rdoResultset
'  Dim lngSign As Long
'  Dim strOldCode As String
'  Dim i As Integer
'  Dim strCodeTemp As String
'
'  If lngID = 0 Then
'    '新增的情况
'     strSql = "SELECT *  FROM " & TName & " WHERE " & FCodeName & " = '" & strCode & "'"
'     Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
''     Set recTemp = m_dbTest.openresultset(strSQL, rdopenstatic)   'test
'      If strCode = "" Then
'          Result(1) = 6
'          Exit Sub
'      End If
'      If recTemp.EOF = True Then
'
'         lngSign = GetPreRecID(strCode, TName, FCodeName)
'         Select Case lngSign
'          Case -1
'               '错误上级编码
'              Result(1) = 3
'
'          Case 0
'              '无上级编码
'              Result(1) = 1
'              Result(2) = 1
'
'          Case Else
'              '正确上级编码
'              Result(1) = 5
'              Result(3) = lngSign
'              strSql = "SELECT * FROM " & TName & "WHERE " & FIDName & "=" & lngSign
'              Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
''                Set recTemp = m_dbTest.openresultset(strSQL, rdopenstatic)   'test
'
'              If Not IsNull(recTemp!blnIsDetail) Then
'                 Result(4) = IIf(recTemp!blnIsDetail, 1, 0)
'              Else
'                 Result(4) = 0
'              End If
'              Result(2) = recTemp!intLevel + 1
'         End Select
'
'
'      Else
'         '编码已存在
'         Result(1) = 2
'         Exit Sub
'      End If
'  Else
'   '编辑的情况
'      If strCode = "" Then
'          Result(1) = 6
'          Exit Sub
'      End If
'   '判断是否超长
'
'    '得到旧的代码
'    strSql = "SELECT * FROM " & TName & " WHERE " & FIDName & "=" & lngID
'   Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
''    Set recTemp = m_dbTest.openresultset(strSQL, rdopenstatic)   'test
'    strOldCode = recTemp(FCodeName)
'   '判断是否下级超长
'    strSql = "SELECT " & FCodeName & " FROM " & TName & " WHERE " & FCodeName & " LIKE  '" & strOldCode & "-%'"
'    Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
''    Set recTemp = m_dbTest.openresultset(strSQL, rdopenstatic)   'test
'    If recTemp.EOF = False Then
'        recTemp.MoveLast
'
'        For i = 0 To recTemp.RowCount - 1
'             strCodeTemp = strReplace(recTemp(FCodeName), strOldCode, strCode)
'             If Len(strCodeTemp) > CodeLengh Then
'                 Result(1) = 4
'                 Exit Sub
'             End If
'        recTemp.MovePrevious
'        Next
'     End If
'
'      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
'          '普通编辑
'            lngSign = GetPreRecID(strCode, TName, FCodeName)
'            Select Case lngSign
'             Case 0
'              Result(1) = 1
'             Case -1
'              Result(1) = 3
'
'             Case Else
'              Result(1) = 5
'              Result(3) = lngSign
'              strSql = "SELECT * FROM " & TName & " WHERE " & FIDName & "=" & lngSign
'             Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
''           Set recTemp = m_dbTest.openresultset(strSQL, rdopenstatic)   'test
'              If Not IsNull(recTemp!blnIsDetail) Then