standardreport.bas

金算盘软件代码

                intLoc = intIndex
            Else
                intLoc = intIndex + 1
            End If
        Case Else
            intLoc = 255
        End Select
    End If
    
    If intLoc = 0 Then
        GetAddFCAlign = 255
    Else
        GetAddFCAlign = intLoc
    End If
End Function

'自定义字段公式除法分析
Public Function DivideAnalyse(ByVal strFormula As String) As String
Dim i As Integer, intLeft As Integer, intRight As Integer, intLoc As Integer
Dim strDestin As String, strCond As String, strTemp As String
Dim blnDeal As Boolean

    strCond = ""
    i = InStr(1, strFormula, "/")
    Do While i > 0    '除法
        If Mid(strFormula, i + 1, 1) = "(" Then
            '组合表达式
            intLeft = 1
            intRight = 0
            intLoc = i + 1
            Do While intLoc <= Len(strFormula)
                Select Case Mid(strFormula, intLoc, 1)
                Case "("
                    intLeft = intLeft + 1
                    intLoc = intLoc + 1
                Case ")"
                    intRight = intRight + 1
                    If intRight = intLeft Then
                    '括号匹配,生成IIF条件,退出内层循环
                    strTemp = Mid(strFormula, i + 1, intLoc - i)
                        If strTemp <> "" Then
                            If strCond = "" Then
                                strCond = strTemp & ",0"
                            Else
                                strCond = strCond & " Or " & strTemp & ",0"
                            End If
                        End If
                        i = InStr(i + 2, strFormula, "/")
                        Exit Do
                    End If
                Case Else
                    intLoc = intLoc + 1
                End Select
            Loop
        Else
            '单一表达式
            blnDeal = False
            intLoc = i + 1
            Do While intLoc <= Len(strFormula)
                Select Case Mid(strFormula, intLoc, 1)
                Case "+", "-", "*", "/", "(", ")", ","
                    '生成IIF条件,退出内层循环
                    strTemp = Mid(strFormula, i + 1, intLoc - 1 - i)
                    If strTemp <> "" Then
                        If strCond = "" Then
                            strCond = strTemp & ",0"
                        Else
                            strCond = strCond & " Or " & strTemp & ",0"
                        End If
                    End If
                    blnDeal = True
                    i = InStr(intLoc + 1, strFormula, "/")
                    Exit Do
                Case Else
                    intLoc = intLoc + 1
                End Select
            Loop
            '除数结尾
            If Not blnDeal Then
                strTemp = Mid(strFormula, i + 1, intLoc - i)
                If strTemp <> "" Then
                    If strCond = "" Then
                        strCond = strTemp & ",0"
                    Else
                        strCond = strCond & " Or " & strTemp & ",0"
                    End If
                End If
                i = 0
            End If
        End If
    Loop
    If strCond = "" Then
        DivideAnalyse = strFormula
    Else
        DivideAnalyse = "Decode(" & strCond & ",0," & strFormula & ")"
    End If
End Function
'得到参数查询
Public Sub GetParaSql(ByVal pqtType As ParaQueryType, strReturn As String)
Dim strTemp As String
    Select Case pqtType
    Case pqtRLastSale               '上次销售ID
        strTemp = "(SELECT Max(ItemActivityDetail.lngActivityDetailID) AS lngActivityDetailID, ItemActivityDetail.lngItemID" _
                & " FROM ItemActivityDetail, ItemActivity" _
                & " WHERE ItemActivityDetail.dblQuantity>0 And To_Date(ItemActivity.strDate,'YYYY-MM-DD')<=To_Date('JZRQ','YYYY-MM-DD') And ItemActivity.lngReceiptTypeID IN (13,14,16,19) AND ItemActivityDetail.lngActivityID = ItemActivity.lngActivityID" _
                & " GROUP BY ItemActivityDetail.lngItemID) RLASTSALE "
    Case pqtRQReceive               '到货数量
        strTemp = "(SELECT ItemActivityDetail.lngOrderDetailID AS ITraceID, SUM(ItemActivityDetail.dblQuantity) AS ReceiveQ" _
                & " FROM ItemActivityDetail, ItemActivity" _
                & " WHERE ItemActivityDetail.lngOrderDetailID>0 And  ItemActivity.lngReceiptTypeID IN (2,3,4) And  To_Date('JZRQ','YYYY-MM-DD')>=To_Date(ItemActivity.strDate,'YYYY-MM-DD' ) AND ItemActivityDetail.lngActivityID = ItemActivity.lngActivityID" _
                & " GROUP BY ItemActivityDetail.lngOrderDetailID) RQRECEIVE "
    Case pqtRQSend                  '发货数量
        strTemp = "(SELECT ItemActivityDetail.lngOrderDetailID AS ITraceID, SUM(ItemActivityDetail.dblQuantity) AS SendQ" _
                & " FROM ItemActivityDetail, ItemActivity" _
                & " WHERE ItemActivityDetail.lngOrderDetailID>0 And  ItemActivity.lngReceiptTypeID IN (13,14,15,18) And  To_Date('JZRQ','YYYY-MM-DD')>=To_Date(ItemActivity.strDate,'YYYY-MM-DD' ) AND ItemActivityDetail.lngActivityID = ItemActivity.lngActivityID" _
                & " GROUP BY ItemActivityDetail.lngOrderDetailID) RQSEND "
    Case pqtRSaleQ                  '销售数量
        strTemp = "(SELECT ItemActivityDetail.lngItemID, Sum(ItemActivityDetail.dblQuantity) AS SaleQuantity, Decode(Sign(To_Date('KSRQ','YYYY-MM-DD') - To_Date('JZRQ','YYYY-MM-DD')),1,Sum(ItemActivityDetail.dblQuantity)/(To_Date('KSRQ','YYYY-MM-DD') - To_Date('JZRQ','YYYY-MM-DD')),0) AS AverQuantity, Sum(Decode(Sign(ItemActivityDetail.dblQuantity),1,1,0)) AS SaleCount" _
                & " FROM ItemActivity, ItemActivityDetail" _
                & " WHERE ItemActivity.lngReceiptTypeID In (13,14,16,19) And (To_Date(ItemActivity.strDate,'YYYY-MM-DD') Between To_Date('KSRQ','YYYY-MM-DD') And To_Date('JZRQ','YYYY-MM-DD')) And ItemActivity.blnIsVoid=0 AND ItemActivity.lngActivityID = ItemActivityDetail.lngActivityID" _
                & " GROUP BY ItemActivityDetail.lngItemID) RSALEQ "
    Case pqtRStockQ                 '库存数量
        strTemp = "(SELECT ItemDaily2.lngItemID, Sum(Decode(Sign(To_Date(ItemDaily2.strDate,'YYYY-MM-DD')-To_Date('JZRQ','YYYY-MM-DD')),1,0," _
                & " (ItemDaily2.dblPurchaseQuantity +ItemDaily2.dblBorrowPurchaseQuantity+ItemDaily2.dblEntrustInQuantity+ItemDaily2.dblInQuantity+ItemDaily2.dblCheckUpQuantity" _
                & " -(ItemDaily2.dblSaleQuantity+ItemDaily2.dblLendQuantity+ItemDaily2.dblStageQuantity+ItemDaily2.dblEntrustOutQuantity+ItemDaily2.dblOutQuantity+ItemDaily2.dblCheckDownQuantity))" _
                & " )) AS StockQuantity," _
                & " Sum(Decode(Sign(To_Date(ItemDaily2.strDate,'YYYY-MM-DD')-To_Date('JZRQ','YYYY-MM-DD')),1,0," _
                & " (ItemDaily2.dblPurchaseAmount+ItemDaily2.dblPurchaseExpense+ItemDaily2.dblBorrowPurchaseAmount+ItemDaily2.dblEntrustInAmount+ItemDaily2.dblEntrustExpense+ItemDaily2.dblInAmount+ItemDaily2.dblCostInAmount+ItemDaily2.dblCheckUpAmount+ItemDaily2.dblAdjPriceAdd" _
                & " -(ItemDaily2.dblSaleCost+ItemDaily2.dblLendCost+ItemDaily2.dblStageCost+ItemDaily2.dblEntrustOutAmount+ItemDaily2.dblCheckDownAmount+ItemDaily2.dblAdjPriceDec+ItemDaily2.dblCostCostAdj))" _
                & " )) AS StockCost FROM ItemDaily2 " _
                & "  GROUP BY ItemDaily2.lngItemID) RSTOCKQ "
    End Select
    strReturn = strTemp
End Sub

'根据视图ID返回职员标志
Public Function GetEmployeeTag(ByVal lngViewId As Long) As Long
    Select Case lngViewId
    Case 553      '总帐
        GetEmployeeTag = 1
    Case 212, 746, 1008, 1010, 1141     '应收
        GetEmployeeTag = 2
    Case 214, 747, 1012, 1013   '应付
        GetEmployeeTag = 4
    Case 1142       '应收'应付
        GetEmployeeTag = 6
    Case 500, 540, 572, 633, 634, 635, 1015, 1017, 1018, 1019, 1020, 1021, 1022, 1149, 1150, 1195 '现金银行
        GetEmployeeTag = 8
    Case 684, 685, 686, 687, 688, 693, 694, 695, 696, 697, 698, 699, 700, 701, 702, 703, 704, 705, 706, 707, 708, 709, 710, 711, 712, 713, 801, 802, 1209 '采购
        GetEmployeeTag = 16
    Case 714, 715, 716, 717, 718, 719, 720, 721, 722, 723, 724, 725, 726, 727, 728, 729, 730, 731, 732, 733, 734, 735, 736, 737, 738, 739, 740, 741, 742, 743, 744, 745, 778, 803, 804, 805, 806, 1210 '销售
        GetEmployeeTag = 32
    Case 541, 549, 550, 568, 570, 571, 579, 580, 761, 762, 763, 764, 1000, 1001, 1030, 1100, 1101, 1102, 1106, 1179, 1188, 1189, 1216, 1217, 1219, 1220, 1221, 1222, 1223 '库存
        GetEmployeeTag = 64
    Case 567, 578, 689, 691, 749, 750, 751, 752, 1103, 1145 '委托加工
        GetEmployeeTag = 128
    Case Else
        GetEmployeeTag = -1
    End Select
End Function
'根据分组号返回职员条件
Public Function GetEmployeeCond(ByVal lngViewId As Long) As String
    Select Case lngViewId
    Case 553      '总帐
        GetEmployeeCond = " And Employee.blnAccount=1"
    Case 212, 746, 1008, 1010, 1141     '应收
        GetEmployeeCond = " And Employee.blnAR=1"
    Case 214, 747, 1012, 1013   '应付
        GetEmployeeCond = " And Employee.blnAP=1"
    Case 1142       '应收'应付
        GetEmployeeCond = " And (Employee.blnAR=1 Or Employee.blnAP=1)"
    Case 500, 540, 572, 633, 634, 635, 1015, 1017, 1018, 1019, 1020, 1021, 1022, 1149, 1150, 1195 '现金银行
        GetEmployeeCond = " And Employee.blnCash=1"
    Case 684, 685, 686, 687, 688, 693, 694, 695, 696, 697, 698, 699, 700, 701, 702, 703, 704, 705, 706, 707, 708, 709, 710, 711, 712, 713, 801, 802, 1209 '采购
        GetEmployeeCond = " And Employee.blnPurchase=1"
    Case 714, 715, 716, 717, 718, 719, 720, 721, 722, 723, 724, 725, 726, 727, 728, 729, 730, 731, 732, 733, 734, 735, 736, 737, 738, 739, 740, 741, 742, 743, 744, 745, 778, 803, 804, 805, 806, 1210 '销售
        GetEmployeeCond = " And Employee.blnSale=1"
    Case 541, 549, 550, 568, 570, 571, 579, 580, 761, 762, 763, 764, 1000, 1001, 1030, 1100, 1101, 1102, 1106, 1179, 1188, 1189, 1216, 1217, 1219, 1220, 1221, 1222, 1223 '库存
        GetEmployeeCond = " And Employee.blnStock=1"
    Case 567, 578, 689, 691, 749, 750, 751, 752, 1103, 1145 '委托加工
        GetEmployeeCond = " And Employee.blnEntrust=1"
    Case Else
        GetEmployeeCond = ""
    End Select
End Function
'根据旧打印设置ID复制一个新的,并返回新设置ID:返回0表示出错
'调用它时已处于事物处理与错误陷阱中
Public Function GetPrintSetupID(ByVal TypeIndex As Integer, ByVal lngReportID As Long) As Long
Dim rstSource As rdoResultset
Dim rstTarget As rdoResultset
Dim strSql As String
Dim intCount As Integer
Dim lngPrintSetupID As Long
Dim lngFontID(5) As Long
Dim fldField As rdoColumn
    
    strSql = "Select lngPrintSetupID From Report Where lngReportID =" & lngReportID
    Set rstSource = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    lngPrintSetupID = rstSource!lngPrintSetupID
    '找字体设置ID
    If lngPrintSetupID = 0 Then lngPrintSetupID = 60 + TypeIndex
    strSql = "Select * From PrintSetup Where lngPrintSetupID =" & lngPrintSetupID
    Set rstSource = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    With rstSource
        lngFontID(0) = !lngTitleFontID
        lngFontID(1) = !lngTextFontID
        lngFontID(2) = !lngPageHeaderFontID
        lngFontID(3) = !lngTableHFooterFontID
        lngFontID(4) = !lngColumnCaptionFontID
    End With
    
     '关闭表触发器
    strSql = "Alter Table Font Disable All Triggers"
    gclsBase.BaseDB.Execute (strSql)
    
    '复制打印字体设置表
    strSql = "Select * From Font Where lngFontID =-1"
    Set rstTarget = gclsBase.BaseDB.OpenResultset(strSql, rdOpenDynamic, rdConcurValues)
    With rstTarget
        For intCount = 0 To 4
            strSql = "Select * From Font Where lngFontID =" & lngFontID(intCount)
            Set rstSource = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
            .AddNew
            For Each fldField In rstSource.rdoColumns
                If UCase(fldField.Name) = UCase("lngFontID") Then
                    lngFontID(intCount) = BillPublic.GetNewID("Font")
                    .rdoColumns(fldField.Name).Value = lngFontID(intCount)
                Else
                    .rdoColumns(fldField.Name).Value = fldField.Value
                End If
            Next
            .Update
        Next intCount
    End With
    
     '打开表触发器
    strSql = "Alter Table Font Enable All Triggers"
    gclsBase.BaseDB.Execute (strSql)
     '关闭表触发器
    strSql = "Alter Table PrintSetup Disable All Triggers"
    gclsBase.BaseDB.Execute (strSql)
    
    '复制打印设置表
    strSql = "Select * From PrintSetup Where lngPrintSetupID =" & lngPrintSetupID
    Set rstSource = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    strSql = "Select * From PrintSetup Where lngPrintSetupID =-1"
    Set rstTarget = gclsBase.BaseDB.OpenResultset(strSql, rdOpenDynamic, rdConcurValues)
    With rstTarget
        .AddNew
        For Each fldField In rstSource.rdoColumns
            Select Case UCase(fldField.Name)
            Case UCase("lngPrintSetupID")
                 lngPrintSetupID = BillPublic.GetNewID("PrintSetup")
                 .rdoColumns(fldField.Name).Value = lngPrintSetupID
            Case UCase("lngTitleFontID")
                .rdoColumns(fldField.Name).Value = lngFontID(0)
            Case UCase("lngTextFontID")
                .rdoColumns(fldField.Name).Value = lngFontID(1)
            Case UCase("lngPageHeaderFontID")
                .rdoColumns(fldField.Name).Value = lngFontID(2)
            Case UCase("lngTableHFooterFontID")
                .rdoColumns(fldField.Name).Value = lngFontID(3)
            Case UCase("lngColumnCaptionFontID")
                .rdoColumns(fldField.Name).Value = lngFontID(4)
            Case Else
                .rdoColumns(fldField.Name).Value = fldField.Value
            End Select
        Next
        .Update
    End With
     '打开表触发器
    strSql = "Alter Table PrintSetup Enable All Triggers"
    gclsBase.BaseDB.Execute (strSql)
    gclsBase.BaseDB.CommitTrans
    
    GetPrintSetupID = lngPrintSetupID
    Erase lngFontID
    rstSource.Close
    rstTarget.Close
    Set rstSource = Nothing
    Set rstTarget = Nothing
End Function