account.bas

金算盘软件代码

Public Function ShowBox(frmName As Form, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long
    If Trim(lpText) = "" Then Exit Function
    If frmName.Visible Then
        If lpCaption = "" Then
            lpCaption = frmName.Caption
        End If
        ShowBox = MessageBox(frmName.hwnd, lpText, lpCaption, wType)
    Else
        lpText = FilterString(lpText, "！")
        lpText = FilterString(lpText, "。")
        AddStrError lpText & "."
    End If
End Function

Public Sub AddStrError(ByVal lpText As String)
    If InStr(1, ListModule.strError, lpText) = 0 Then
        ListModule.strError = ListModule.strError & lpText
    End If
End Sub
Public Function ReceiptNOIsOk(ByVal frmName As Form, ByVal strDate As String, _
                              ByVal ReceiptType As Long, ByVal strAlpha As String, _
                              ByVal lngDigit As Long, ByVal lngActivityID As Long _
                              , Optional ByVal blnShowMsg As Boolean = True) As Integer
    '0 ：OK
    '-1：比已前天的最大号码小
    '+1：比已后天的最大号码大
    ReceiptNOIsOk = 0
    If gclsBase.NoOrder = False Then Exit Function
    
    Dim strErrMsg As String
    Dim strSql As String
    Dim recTmp As rdoResultset
    Dim intY As Long
    Dim bytP As Long
    strErrMsg = ""
    If IsDate(strDate) = False Then Exit Function
    strAlpha = Trim(strAlpha)
    If strAlpha = "" Then strAlpha = " "
    intY = gclsBase.FYearOfDate(CDate(strDate))
    bytP = gclsBase.PeriodOfDate(CDate(strDate))
    
    Select Case ReceiptType
    Case 41 '记帐凭证
        strSql = "SELECT strDate,intVoucherNO " & _
                 " FROM Voucher" & _
                 " WHERE ROWNUM<=1 AND lngVoucherID<> " & lngActivityID & " AND lngVoucherTypeID=" & C2lng(strAlpha) & _
                        " AND intYear=" & intY & " AND bytPeriod=" & bytP & " AND (" & _
                        "strDate<'" & strDate & "' AND intVoucherNO>=" & lngDigit & _
                        " OR strDate>'" & strDate & "' AND intVoucherNO<=" & lngDigit & _
                        ")"
    Case 34 To 40 '应收/应付、收/付
        strSql = "SELECT strDate,lngReceiptNO " & _
                 " FROM Activity" & _
                 " WHERE ROWNUM<=1 AND lngActivityID<>" & lngActivityID & " AND lngReceiptTypeID=" & ReceiptType & " AND strReceiptNO='" & strAlpha & "'" & _
                        " AND intYear=" & intY & " AND bytPeriod=" & bytP & " AND (" & _
                        "strDate<'" & strDate & "' AND lngReceiptNO>=" & lngDigit & _
                        " OR strDate>'" & strDate & "' AND lngReceiptNO<=" & lngDigit & _
                        ")"
    Case 2 To 11, 13 To 24, 26, 28, 29, 30, 31, 42 To 47, 52 '商品业务
        strSql = "SELECT strDate,lngReceiptNO " & _
                 " FROM ItemActivity" & _
                 " WHERE ROWNUM<=1 AND lngActivityID<>" & lngActivityID & " AND lngReceiptTypeID=" & ReceiptType & " AND strReceiptNO='" & strAlpha & "'" & _
                        " AND intYear=" & intY & " AND bytPeriod=" & bytP & " AND (" & _
                        "strDate<'" & strDate & "' AND lngReceiptNO>=" & lngDigit & _
                        " OR strDate>'" & strDate & "' AND lngReceiptNO<=" & lngDigit & _
                        ")"
    Case 1
        strSql = "SELECT strDate,lngReceiptNO " & _
                 " FROM PurchaseOrder" & _
                 " WHERE ROWNUM<=1 AND lngPurchaseOrderID<>" & lngActivityID & " AND strReceiptNO='" & strAlpha & "'" & _
                        " AND intYear=" & intY & " AND bytPeriod=" & bytP & " AND (" & _
                        "strDate<'" & strDate & "' AND lngReceiptNO>=" & lngDigit & _
                        " OR strDate>'" & strDate & "' AND lngReceiptNO<=" & lngDigit & _
                        ")"
    Case 12
        strSql = "SELECT strDate,lngReceiptNO " & _
                 " FROM SaleOrder" & _
                 " WHERE ROWNUM<=1 AND lngSaleOrderID<>" & lngActivityID & " AND strReceiptNO='" & strAlpha & "'" & _
                        " AND intYear=" & intY & " AND bytPeriod=" & bytP & " AND (" & _
                        "strDate<'" & strDate & "' AND lngReceiptNO>=" & lngDigit & _
                        " OR strDate>'" & strDate & "' AND lngReceiptNO<=" & lngDigit & _
                        ")"
    Case 32
        strSql = "SELECT strDate,lngReceiptNO " & _
                 " FROM CostPrice" & _
                 " WHERE ROWNUM<=1 AND lngCostPriceID<>" & lngActivityID & " AND strReceiptNO='" & strAlpha & "'" & _
                        " AND intYear=" & intY & " AND bytPeriod=" & bytP & " AND (" & _
                        "strDate<'" & strDate & "' AND lngReceiptNO>=" & lngDigit & _
                        " OR strDate>'" & strDate & "' AND lngReceiptNO<=" & lngDigit & _
                        ")"
    Case 33
        strSql = "SELECT strDate,lngReceiptNO " & _
                 " FROM StockTaking" & _
                 " WHERE ROWNUM<=1 AND lngStockTakingID<>" & lngActivityID & " AND strReceiptNO='" & strAlpha & "'" & _
                        " AND intYear=" & intY & " AND bytPeriod=" & bytP & " AND (" & _
                        "strDate<'" & strDate & "' AND lngReceiptNO>=" & lngDigit & _
                        " OR strDate>'" & strDate & "' AND lngReceiptNO<=" & lngDigit & _
                        ")"
    Case Else
        Exit Function
    End Select
    
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    If recTmp.EOF Then
        ReceiptNOIsOk = 0
    ElseIf recTmp(0) < strDate Then
        ReceiptNOIsOk = -1
        strErrMsg = "在日期" & recTmp(0) & "已有编号为" & Format$(recTmp(1), "0000") & "的" & IIf(ReceiptType = 41, "凭证", "单据") & "，比当前编号" & Format$(lngDigit, "0000") & "大，在当前日期" & strDate & "只能选用更大的编号。"
    Else
        ReceiptNOIsOk = 1
        strErrMsg = "在日期" & recTmp(0) & "已有编号为" & Format$(recTmp(1), "0000") & "的" & IIf(ReceiptType = 41, "凭证", "单据") & "，比当前编号" & Format$(lngDigit, "0000") & "小，在当前日期" & strDate & "只能选用更小的编号。"
    End If
    recTmp.Close
    Set recTmp = Nothing
    If blnShowMsg = False Then Exit Function
    If strErrMsg <> "" Then
        ShowMessage frmName, strErrMsg, MB_OK + MB_ICONEXCLAMATION, frmName.Caption
    End If
End Function
Public Function GetActivityID(ByVal ReceiptTypeID As Long, ByVal Year As Long, ByVal Period As Long, ByVal strReceiptNo As String, Optional ByVal ReceiptNo As Long = 0) As Long
    '根据单据号取单据ID
    Dim strSql As String
    Dim recTmp As rdoResultset
    On Error GoTo ErrH
    
    If strReceiptNo = "" Then strReceiptNo = " "
    Select Case ReceiptTypeID
        Case 41
            strSql = "SELECT lngVoucherID FROM Voucher" & _
                   " WHERE intYear=" & Year & " AND bytPeriod=" & Period & _
                   " AND lngVoucherTypeID=" & C2lng(strReceiptNo) & " AND intVoucherNO=" & ReceiptNo
        Case 34 To 40
            strSql = "SELECT lngActivityID FROM Activity" & _
                   " WHERE intYear=" & Year & " AND bytPeriod=" & Period & _
                   " AND lngReceiptTypeID=" & ReceiptTypeID & _
                   " AND strReceiptNo='" & strReceiptNo & "'" & " AND lngReceiptNO=" & ReceiptNo
        Case 2 To 11, 13 To 24, 26, 28, 29, 30, 31, 42 To 47, 52
            strSql = "SELECT lngActivityID FROM ItemActivity" & _
                   " WHERE intYear=" & Year & " AND bytPeriod=" & Period & _
                   " AND lngReceiptTypeID=" & ReceiptTypeID & _
                   " AND strReceiptNo='" & strReceiptNo & "'" & " AND lngReceiptNO=" & ReceiptNo
        Case Else
            Exit Function
    End Select
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    If recTmp.EOF Then
    Else
        GetActivityID = recTmp(0)
    End If
    recTmp.Close
    Set recTmp = Nothing
    Exit Function
ErrH:
    Set recTmp = Nothing
End Function
 
Public Function GetLastActivityID(ByVal ReceiptTypeID As Long, Optional ByVal SpecialReceive As Boolean = False, Optional SeeOther As Boolean = True) As Long
    '取最大单据ID
    Dim strSql As String
    Dim recTmp As rdoResultset
    Dim strCond As String
    On Error GoTo ErrH
    If SeeOther Then
        strCond = ""
    Else
        strCond = " lngOperatorID=" & gclsBase.OperatorID
    End If
    Select Case ReceiptTypeID
        Case 34, 35
            strSql = "SELECT MAX(lngActivityID) FROM Activity" & _
                   " WHERE lngReceiptTypeID IN (34,35)" & IIf(strCond = "", "", " AND " & strCond)
        Case 36, 37, 38
            strSql = "SELECT MAX(lngActivityID) FROM Activity" & _
                   " WHERE lngReceiptTypeID IN (36,37,38)" & IIf(strCond = "", "", " AND " & strCond)
        Case 39, 40
            strSql = "SELECT MAX(lngActivityID) FROM Activity" & _
                   " WHERE lngReceiptTypeID =" & ReceiptTypeID & IIf(strCond = "", "", " AND " & strCond)
            If SpecialReceive Then
                strSql = strSql & " AND blnIsSpecial=1"
            Else
                strSql = strSql & " AND blnIsSpecial=0"
            End If
        Case 41
            strSql = "SELECT MAX(lngVoucherID) FROM Voucher" & _
                IIf(strCond = "", "", " WHERE " & strCond)
        Case 30, 31
            strSql = "SELECT MAX(lngActivityID) FROM ItemActivity" & _
                   " WHERE lngReceiptTypeID IN (30,31)" & IIf(strCond = "", "", " AND " & strCond)
        Case 2 To 11, 13 To 24, 26, 28, 29, 42 To 47, 52
            strSql = "SELECT MAX(lngActivityID) FROM ItemActivity" & _
                   " WHERE lngReceiptTypeID =" & ReceiptTypeID & IIf(strCond = "", "", " AND " & strCond)
        Case Else
    End Select
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    If recTmp.EOF Then
    ElseIf Not IsNull(recTmp(0)) Then
        GetLastActivityID = recTmp(0)
    End If
    recTmp.Close
    Set recTmp = Nothing
    Exit Function
ErrH:
    Set recTmp = Nothing
End Function

Public Function FindMaxNo(ByVal ReceiptType As Long, ByVal intYear As Long, ByVal bytPeriod As Long, ByVal strReceiptNo As String) As String
    '取最大单据号
    Dim strSql As String
    Dim recTmp As rdoResultset
    On Error GoTo ErrH
    If strReceiptNo = "" Then strReceiptNo = " "
    Select Case ReceiptType
        Case 34 To 40
            strSql = "SELECT MAX(lngReceiptNo) FROM Activity" & _
                   " WHERE lngReceiptTypeID =" & ReceiptType & _
                   " AND intYear=" & intYear & " AND bytPeriod=" & bytPeriod & " AND strReceiptNo='" & strReceiptNo & "'"
        Case 41
            strSql = "SELECT MAX(intVoucherNo) FROM Voucher" & _
                     " WHERE intYear=" & intYear & " AND bytPeriod=" & bytPeriod & " AND lngVoucherTypeID=" & C2lng(strReceiptNo)
        Case 30, 31
            strSql = "SELECT MAX(lngReceiptNo) FROM ItemActivity" & _
                   " WHERE lngReceiptTypeID =" & ReceiptType & _
                   " AND intYear=" & intYear & " AND bytPeriod=" & bytPeriod & " AND strReceiptNo='" & strReceiptNo & "'"
        Case 2 To 11, 13 To 24, 26, 28, 29, 42 To 47, 52
            strSql = "SELECT MAX(lngReceiptNo) FROM ItemActivity" & _
                   " WHERE lngReceiptTypeID =" & ReceiptType & _
                   " AND intYear=" & intYear & " AND bytPeriod=" & bytPeriod & " AND strReceiptNo='" & strReceiptNo & "'"
        Case Else
    End Select
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    If recTmp.EOF Then
        FindMaxNo = Format(1, "0000")
    ElseIf Not IsNull(recTmp(0)) Then
        FindMaxNo = Format(recTmp(0) + 1, "0000")
    Else
        FindMaxNo = Format(1, "0000")
    End If
    recTmp.Close
    Set recTmp = Nothing
    Exit Function
ErrH:
    Set recTmp = Nothing
End Function
Public Function FindVolume(ByVal VoucherType As Long, ByVal intYear As Long, ByVal bytPeriod As Long, ByVal intVoucherNO As Long) As String
    '取某一凭证号的册号
    Dim strSql As String
    Dim recTmp As rdoResultset
    On Error GoTo ErrH
    strSql = "SELECT strVolume FROM VoucherVolume" & _
             " WHERE intYear=" & intYear & " AND bytPeriod=" & bytPeriod & " AND lngVoucherTypeID=" & VoucherType & _
             " AND intNoStart<=" & intVoucherNO & " AND intNoEnd>=" & intVoucherNO
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    If recTmp.EOF Then
        FindVolume = "00"
    ElseIf IsNull(recTmp(0)) Then
        FindVolume = "00"
    ElseIf Trim(recTmp(0)) = "" Then
        FindVolume = "00"
    Else
        FindVolume = recTmp(0)
    End If
    recTmp.Close
    Set recTmp = Nothing
    Exit Function
ErrH:
    Set recTmp = Nothing
End Function

Public Function EmployeeRight(ByVal ReceiptType As Long, ByVal lngEmployeeID As Long) As Boolean
    '取某一凭证号的册号
    Dim strSql As String
    Dim recTmp As rdoResultset
    On Error GoTo ErrH
    strSql = "SELECT blnAccount,blnAR,blnAP,blnCash,blnPurchase,blnSale,blnStock,blnEntrust FROM Employee" & _
             " WHERE lngEmployeeID=" & lngEmployeeID
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    If recTmp.EOF Then
        EmployeeRight = False
    ElseIf IsNull(recTmp(0)) Then
        EmployeeRight = False
    ElseIf Trim(recTmp(0)) = "" Then
        EmployeeRight = False
    Else
        Select Case ReceiptType