billpublic.bas

金算盘软件代码

                    Case 58
                        strSQL = strSQL & "Repair WHERE intYear=" & intY & " and bytPeriod=" & bytP & " and ' '||Ltrim(strReceiptNO)='" & " " & LTrim(strAlpha) & "'"
                    Case 59
                        strSQL = strSQL & "AccOpen WHERE intYear=" & intY & " and bytPeriod=" & bytP & " and ' '||Ltrim(strReceiptNO)='" & " " & LTrim(strAlpha) & "'"
                    Case 60
                        strSQL = strSQL & "AccClose WHERE intYear=" & intY & " and bytPeriod=" & bytP & " and ' '||Ltrim(strReceiptNO)='" & " " & LTrim(strAlpha) & "'"
                    Case 61
                        strSQL = strSQL & "Move WHERE intYear=" & intY & " and bytPeriod=" & bytP & " and ' '||Ltrim(strReceiptNO)='" & " " & LTrim(strAlpha) & "'"
                    Case 62
                        strSQL = strSQL & "Halt WHERE intYear=" & intY & " and bytPeriod=" & bytP & " and ' '||Ltrim(strReceiptNO)='" & " " & LTrim(strAlpha) & "'"
                    Case 63
                        strSQL = strSQL & "Enable WHERE intYear=" & intY & " and bytPeriod=" & bytP & " and ' '||Ltrim(strReceiptNO)='" & " " & LTrim(strAlpha) & "'"
'                    Case 64
'                    Case 65
                    Case Else
                        strSQL = strSQL & "ItemActivity WHERE lngReceiptTypeID = " & lngTypeID & " AND intYear=" & intY & " and bytPeriod=" & bytP & " and ' '||Ltrim(strReceiptNO)='" & " " & LTrim(strAlpha) & "'"
                    End Select
'                    strSql = strSql & " intYear=" & intY & _
'                        " and bytPeriod=" & bytP & _
'                        " and strReceiptNO='" & strAlpha & "'"
                    Set recMaxNoTmp = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
                    If recMaxNoTmp Is Nothing Then
'                        strSql = "DELETE FROM ReceiptMaxNo WHERE " & strCriteria
                        .Delete
                    ElseIf recMaxNoTmp.BOF And recMaxNoTmp.EOF Then
'                        strSql = "DELETE FROM ReceiptMaxNo WHERE " & strCriteria
                        .Delete
                    ElseIf IsNull(recMaxNoTmp(0)) Then
'                        strSql = "DELETE FROM ReceiptMaxNo WHERE " & strCriteria
                        .Delete
                    Else
'                        strSql = "UPDATE ReceiptMaxNo SET lngReceiptNo =" & recMaxNoTmp(0) & " WHERE " & strCriteria
                        .Edit
                        If recMaxNoTmp(0) > 0 Then
                            !lngReceiptNo = recMaxNoTmp(0)
                        Else
                            !lngReceiptNo = 0
                        End If
                        .Update
                    End If
'                    Debug.Print strSql
'                    gclsBase.BaseDB.Execute strSql
                End If
            
            End If
        End With
SubOne:
    blnMaxNODecrease = True
EndProc:
    If Not recMaxNoTmp Is Nothing Then
        recMaxNoTmp.Close
        Set recMaxNoTmp = Nothing
    End If
    If Not recMaxNo Is Nothing Then
        recMaxNo.Close
        Set recMaxNo = Nothing
    End If
    Exit Function
ErrorHandler:
    blnMaxNODecrease = False
    Resume EndProc
End Function

'//////////////////////////////////////////////////////////////////////////////////////
Public Function lngCharLength(ByVal strReceiptNo As String) As Long
'判断一个由字符和数字组成的字串的左边字母部分长度
'入口参数 :字符串
'返 回 值 :左边字符部分长度
    Dim strAlpha As String
    Dim lngNo As Long
    Call StrSeprate(strReceiptNo, strAlpha, lngNo)
    lngCharLength = strLen1(strAlpha)
End Function
Public Function strAlphaOfStr(ByVal strReceiptNo As String) As String
'取一个由字符和数字组成的字串的左边字母部分
'入口参数 :字符串
'返 回 值 :左边字符部分
    Dim strAlpha As String
    Dim lngNo As Long
    Dim lngLen As Long
    Call StrSeprate(strReceiptNo, strAlpha, lngNo)
    lngLen = strLen1(strReceiptNo)
    If lngLen - strLen1(strAlpha) > 4 Then
        strAlphaOfStr = SubStr(strReceiptNo, 1, lngLen - 4)
    Else
        strAlphaOfStr = strAlpha
    End If
End Function
Public Function strDigitOfStr(ByVal strReceiptNo As String) As String
'取一个由字符和数字组成的字串的右边数字部分
'入口参数 :字符串
'返 回 值 :右边数字部分
    Dim strAlpha As String
    Dim lngNo As Long
    Dim lngLen As Long
    Call StrSeprate(strReceiptNo, strAlpha, lngNo)
    lngLen = strLen1(strReceiptNo)
    If lngLen - strLen1(strAlpha) > 4 Then
        strDigitOfStr = SubStr(strReceiptNo, lngLen - 4 + 1, 4)
    Else
        strDigitOfStr = CStr(lngNo)
    End If
End Function
Public Function strDetailMsg(ByVal lngID As Long, Optional ByVal blnIsCW As Boolean = False) As String
'客户详细资料
    Dim recTmp As rdoResultset
    Dim strTmp As String
    strTmp = ""
    Set recTmp = gclsBase.BaseDB.OpenResultset("SELECT * FROM Customer WHERE lngCustomerID=" & _
                                                lngID, rdOpenStatic)
    With recTmp
        If Not (.BOF And .EOF) Then
            .MoveFirst
            If blnIsCW Then
'                strTmp = !strCustomerName & Chr(13) & _
                        !strBillToAddress & Chr(13) & _
                        !strOfficePhoneNumber
               strTmp = !strCustomerName
            Else
                strTmp = !strCustomerName
            End If
        Else
            strTmp = ""
        End If
        .Close
    End With
    Set recTmp = Nothing
    strDetailMsg = strTmp
End Function

'-------------------------------------------------------------
'根据控件类型和指定的单据ID号来自动地增加参照内容到参照列表框。
'-------------------------------------------------------------
Public Function AutoAddRefer(ctrlControlType As ComboBox, ByVal ReceiptID As Long) As Boolean
    Dim i As Integer
    
    If Not (TypeOf ctrlControlType Is ComboBox) Then
        AutoAddRefer = False
        Exit Function
    End If
    ctrlControlType.Clear
    
    On Error Resume Next
    Select Case ReceiptID
        Case 14     '应收单
            #If conVersionType = 8 Or conVersionType = 4 Then
                '标准版不加入“应收计息”(38)
                For i = LBound(ReceiptType) To UBound(ReceiptType)
                    If ReceiptType(i).lngReceiptID = ReceiptID And i <> 38 Then
                        ctrlControlType.AddItem ReceiptType(i).strReceiptTypeName
                    End If
                Next i
            #Else
                For i = LBound(ReceiptType) To UBound(ReceiptType)
                    If ReceiptType(i).lngReceiptID = ReceiptID Then
                        ctrlControlType.AddItem ReceiptType(i).strReceiptTypeName
                    End If
                Next i
            #End If
        Case Else
            For i = LBound(ReceiptType) To UBound(ReceiptType)
                If ReceiptType(i).lngReceiptID = ReceiptID Then
                    ctrlControlType.AddItem ReceiptType(i).strReceiptTypeName
                End If
            Next i
    End Select
    AutoAddRefer = True
End Function
'---------------------------------------------------------------
'从ComboBox列表框的内容的名称取出对应的索引号,为-1时表示没有找到
'---------------------------------------------------------------
Public Function ReceiptNameToTypeID(ByVal strName As String) As Integer
    Dim i As Integer
    On Error Resume Next
    ReceiptNameToTypeID = -1
    For i = LBound(ReceiptType) To UBound(ReceiptType)
        If ReceiptType(i).strReceiptTypeName = Trim$(strName) Then
            ReceiptNameToTypeID = ReceiptType(i).lngReceiptTypeID
            Exit Function
        End If
    Next i
End Function
'---------------------------------
'入口：单据ID号，接受业务类型ID参数，接受业务类型NAME参数
'根据单据的ID找出第一个对应的单据类型ID 和名称
'成功时返回为TRUE，否则返回为FALSE。
'---------------------------------
Public Function FirstReceiptTypeIDAndName(ByVal ReceiptID As Long, ReceiptTypeID As Long, ReceiptTypeName As String) As Boolean
    Dim intI As Integer
    If ReceiptID <= 0 Then
        FirstReceiptTypeIDAndName = False
        ReceiptTypeID = 0
        ReceiptTypeName = ""
        Exit Function
    End If
    For intI = LBound(ReceiptType) To UBound(ReceiptType)
        If ReceiptType(intI).lngReceiptID = ReceiptID Then
                FirstReceiptTypeIDAndName = True
                ReceiptTypeID = ReceiptType(intI).lngReceiptTypeID
                ReceiptTypeName = ReceiptType(intI).strReceiptTypeName
            Exit Function
        End If
    Next intI
End Function
'------------------------------------
'根据单据类型表的ID号转化为对应的名称
'------------------------------------
Public Function ReceiptTypeIdToName(ByVal lngReceiptTypeID As Long) As String
    Dim intI As Integer
    ReceiptTypeIdToName = ""
    For intI = LBound(ReceiptType) To UBound(ReceiptType)
        If ReceiptType(intI).lngReceiptTypeID = lngReceiptTypeID Then
            ReceiptTypeIdToName = ReceiptType(intI).strReceiptTypeName
            Exit Function
        End If
    Next intI
End Function
'-----------------------------------
'查找第一个ID，主要用于设置默认值
'-----------------------------------
Public Function FirstId(ByVal enumTabID As enumTabType, Optional ByVal ConditionID As Long = 0, Optional ByVal lngSpecial As Long = 0) As Variant
    
    Dim strSQL As String
    Dim wret As rdoResultset
    Dim strTabName As String     'TabDef Name
    Dim strFidName As String     'TabDefField Name
    
    On Error Resume Next
    strTabName = TabName(enumTabID)
    strFidName = strTabName
    If strTabName Like "Custom?" Then
        strFidName = "Custom"
    End If
    If strTabName Like "Currency*" Then
        strFidName = "Currency"
    End If
    If strTabName Like "Class?" Then
        strFidName = "Class"
    End If
    Select Case UCase(strTabName)
        Case "RATE"
            strSQL = "SELECT strDate,dblRate FROM " & strTabName & _
                    " WHERE lngCurrencyID=" & ConditionID & " ORDER BY strDate DESC"
            Set wret = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenForwardOnly)
            If wret Is Nothing Then
                FirstId = 0
            Else
                FirstId = wret.rdoColumns(1).Value
            End If
            wret.Close
            Set wret = Nothing

        Case "TEMPLATE"
            If ConditionID > 0 Then
                If lngSpecial = 0 Then
                    strSQL = "SELECT lngTemplateID FROM " & strTabName & " WHERE MOD(bytVersion, 2*" & gVersionType & ")>(" & gVersionType & "-1) AND lngReceiptTypeID=" & ConditionID & " AND BlnIsInActive=0 AND blnBusinessActivity=0 ORDER BY lngTemplateID"
                Else
                    strSQL = "SELECT lngTemplateID FROM " & strTabName & " WHERE MOD(bytVersion, 2*" & gVersionType & ")>(" & gVersionType & "-1) AND lngReceiptTypeID=" & ConditionID & " AND BlnIsInActive=0 AND blnBusinessActivity=1 ORDER BY lngTemplateID"
                End If
            Else
                strSQL = "SELECT lngTemplateID FROM " & strTabName & " WHERE MOD(bytVersion, 2*" & gVersionType & ")>(" & gVersionType & "-1) AND blnIsInActive=0 ORDER BY lngTemplateID"
            End If
            On Error Resume Next
            Set wret = gclsBase.BaseDB