account.bas

金算盘软件代码

        Case 34, 35
            EmployeeRight = IIf(recTmp("blnAP") = 0, False, True)
        Case 36, 37, 38
            EmployeeRight = IIf(recTmp("blnAR") = 0, False, True)
        Case 39, 40
            EmployeeRight = IIf(recTmp("blnCash") = 0, False, True)
        Case 41
            EmployeeRight = IIf(recTmp("blnAccount") = 0, False, True)
        Case Else
            EmployeeRight = True
        End Select
    End If
    recTmp.Close
    Set recTmp = Nothing
    Exit Function
ErrH:
    Set recTmp = Nothing
End Function

Public Function GetReceiptNo(ByVal ReceiptTypeID As Long, ByVal lngActivityID As Long) As String
    '根据单据ID取单据号
    Dim strSql As String
    Dim recTmp As rdoResultset
    On Error GoTo ErrH
    
    Select Case ReceiptTypeID
        Case 41
            strSql = "SELECT LPAD(intVoucherNo,4,'0') FROM Voucher" & _
                   " WHERE lngVoucherID=" & lngActivityID
        Case 34 To 40
            strSql = "SELECT strReceiptNo || LPAD(lngReceiptNO,4,'0') FROM Activity" & _
                   " WHERE lngActivityID=" & lngActivityID
        Case 2 To 11, 13 To 24, 26, 28, 29, 30, 31, 42 To 47, 52
            strSql = "SELECT strReceiptNo || LPAD(lngReceiptNO,4,'0') FROM ItemActivity" & _
                   " WHERE lngActivityID=" & lngActivityID
        Case Else
            strSql = "SELECT strReceiptNo || LPAD(lngReceiptNO,4,'0') FROM ItemActivity" & _
                   " WHERE lngActivityID=" & lngActivityID
    End Select
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    strSql = ""
    If recTmp.EOF Then
    Else
        strSql = recTmp(0)
    End If
    recTmp.Close
    Set recTmp = Nothing
    GetReceiptNo = Trim(strSql)
    Exit Function
ErrH:
    Set recTmp = Nothing
End Function
Public Function GetReceiptDate(ByVal ReceiptTypeID As Long, ByVal lngActivityID As Long) As String
    '根据单据ID取单据日期
    Dim strSql As String
    Dim recTmp As rdoResultset
    On Error GoTo ErrH
    
    GetReceiptDate = Format$(gclsBase.BeginDate, "yyyy-mm-dd")
    If lngActivityID <= 0 Then Exit Function
    
    Select Case ReceiptTypeID
        Case 41
            strSql = "SELECT strDate FROM Voucher" & _
                   " WHERE lngVoucherID=" & lngActivityID
        Case 34 To 40
            strSql = "SELECT strDate FROM Activity" & _
                   " WHERE lngActivityID=" & lngActivityID
        Case 2 To 11, 13 To 24, 26, 28, 29, 30, 31, 42 To 47, 52
            strSql = "SELECT strDate FROM ItemActivity" & _
                   " WHERE lngActivityID=" & lngActivityID
        Case Else
            strSql = "SELECT strDate FROM ItemActivity" & _
                   " WHERE lngActivityID=" & lngActivityID
    End Select
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    strSql = ""
    If recTmp.EOF Then
    Else
        strSql = recTmp(0)
    End If
    recTmp.Close
    Set recTmp = Nothing
    If Trim(strSql) = "" Then Exit Function
    GetReceiptDate = Format$(strSql, "yyyy-mm-dd")
    Exit Function
ErrH:
    Set recTmp = Nothing
End Function
 

Public Function DeleteCash(ByVal lngItemActivityID As Long, ByVal hwnd As Long, ByVal ReceiptType As Long, ByRef strErrMsg As String) As Boolean
    Dim lngID() As Long '存贮须删除单据ID
    Dim strSql As String
    Dim recTmp As rdoResultset
    Dim clsLstMethod As clsListMethod
    Set clsLstMethod = New clsListMethod
    Dim blnHaveVoucher As Boolean
    Dim blnClosed As Boolean
    Dim lngOperatorID As Long
    Dim i As Long
    ReDim lngID(0)
    On Error GoTo ErrH
    blnHaveVoucher = False
    lngOperatorID = gclsBase.OperatorID
    strSql = "SELECT lngActivityID,lngVoucherID,lngOperatorID,blnIsDiscount,intYear,bytPeriod FROM Activity" & _
           " WHERE lngItemActivityID=" & lngItemActivityID
    
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    strSql = ""
    If recTmp.EOF Then
        recTmp.Close
        Set recTmp = Nothing
        DeleteCash = True
        Exit Function
    Else
        Do While recTmp.EOF = False
            blnHaveVoucher = blnHaveVoucher Or IIf(recTmp("lngVoucherID") <= 0, False, True)
            blnClosed = blnClosed Or gclsBase.PeriodIsClosed(recTmp("intYear"), recTmp("bytPeriod"))
            lngOperatorID = recTmp("lngOperatorID")
            If recTmp("blnIsDiscount") = 0 Then
                ReDim Preserve lngID(UBound(lngID) + 1)
                lngID(UBound(lngID)) = recTmp(0)
            End If
            recTmp.MoveNext
        Loop
    End If
    recTmp.Close
    Set recTmp = Nothing
    If blnClosed Then
        strErrMsg = "本单据的现款结算单据已结帐，不能删除！"
        GoTo ErrH
    End If
    If blnHaveVoucher Then
        strErrMsg = "本单据的现款结算单据已生成凭证，不能删除！"
        GoTo ErrH
    End If
    If lngOperatorID <> gclsBase.OperatorID Then
        strErrMsg = "本单据已由他人制了现款结算单据，不能删除！"
        GoTo ErrH
    End If
    clsLstMethod.SethWnd hwnd
    clsLstMethod.theType = IIf(ReceiptType < 12, 2, 1)
    
    For i = 1 To UBound(lngID)
        If clsLstMethod.DeleteRow(lngID(i), False, False, True) = False Then
            strErrMsg = "本单据的现款结算单据已被冲销，冲销单据已生成凭证，不能删除！"
            GoTo ErrH
        End If
    Next
        
    Set clsLstMethod = Nothing
    DeleteCash = True
    Exit Function
ErrH:
    Set clsLstMethod = Nothing
    Set recTmp = Nothing
End Function

Public Function blnCurrencyErr(ByVal lngAccountID As Long, ByVal lngCurrencyID As Long, ByRef account1 As AccountblnOther) As Boolean
    Dim strSql As String
    Dim recTmp As rdoResultset
    If lngAccountID <= 0 Then
        blnCurrencyErr = False
        Exit Function
    End If
    If lngAccountID > 0 And lngCurrencyID <= 0 Then
        blnCurrencyErr = True
        Exit Function
    End If
    If account1.lngAccountID <> lngAccountID Then account1 = blnOther(lngAccountID)
    If account1.blnIsAllCurrency Then
        blnCurrencyErr = False
        Exit Function
    ElseIf Not account1.blnIsMultiCurrency Then
        If lngCurrencyID <> gclsBase.NaturalCurId Then
            blnCurrencyErr = True
        Else
            blnCurrencyErr = False
        End If
        Exit Function
    End If
    strSql = "SELECT * FROM AccountCurrency WHERE lngAccountID=" & lngAccountID & " AND lngCurrencyID =" & lngCurrencyID
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    If recTmp.EOF And recTmp.BOF Then
        blnCurrencyErr = True
    Else
        blnCurrencyErr = False
    End If
    recTmp.Close
    Set recTmp = Nothing
End Function

Public Sub PrintReceipt(ByVal ReceiptType As Long)
    Dim lngPrintNo As Integer
    Select Case ReceiptType
    Case 1 To 10
        lngPrintNo = ReceiptType + 1
    Case 11 To 22
        lngPrintNo = ReceiptType + 2
    Case 23
        lngPrintNo = 1
    Case 24
        lngPrintNo = 12
    Case 36, 37, 38
        lngPrintNo = 25
    Case 34, 35
        lngPrintNo = 26
    Case 40
        lngPrintNo = 27
    Case 39
        lngPrintNo = 28
    Case 41, 54, 55
        lngPrintNo = 29
    Case 28
        lngPrintNo = 30
    Case 29
        lngPrintNo = 31
    Case 30, 31
        lngPrintNo = 32
    Case 33
        lngPrintNo = 33
    Case 32
        lngPrintNo = 34
    Case 26
        lngPrintNo = 35
    Case 53
        lngPrintNo = 38
    Case 42, 43, 44, 45, 46, 47
        lngPrintNo = ReceiptType - 3
    Case 52
        lngPrintNo = 45
    Case 56 To 63
        lngPrintNo = ReceiptType - 10
    Case 140 '销售收款   ： 56
        lngPrintNo = 56
    Case 139 '采购付款   ： 57
        lngPrintNo = 57
    End Select
    
    frmPrintReceipt.ShowfrmPrintReceipt lngPrintNo
End Sub

Public Function RightSubStr(ByVal strOld As String) As String
    Dim strNew As String
    Dim i As Long
    strNew = Trim(strOld)
    If strNew = "" Then
        RightSubStr = strOld
        Exit Function
    End If
    For i = Len(strNew) To 1 Step -1
        If Mid(strNew, i, 1) = " " Then Exit For
    Next
    strNew = Mid(strNew, i + 1)
    RightSubStr = strNew
End Function

Public Function Security(ByVal strTmp As String) As String
    '字符串加/解密程序（strTmp最长8BYTE）
    Dim i As Long
    Dim strNew As String
    Dim strT As String
    Dim lngT As Long
    Const strPassKey = "pamrt}wshmspoikj;_+10293485asdf"
    
'    If StrLen(strTmp) < 8 Then
'        strTmp = strTmp & Space(8 - StrLen(strTmp))
'    End If
    strTmp = SubStr(strTmp, 1, 8)
    
    For i = 1 To StrLen(strTmp)
        lngT = Asc(Mid(strPassKey, i, 1)) Xor Asc(Mid(strPassKey, i + 8, 1))
        Debug.Print Chr(lngT) & "--" & lngT
        lngT = lngT Xor Asc(SubStr(strTmp, i, 1))
        strNew = strNew & Chr(lngT)
    Next i
    
    Security = strNew
End Function