frminvoicesettle.frm

金算盘软件代码

        '汇总
        For i = 1 To lngFirstReceiptRow - 1
            If RowDatas(i).lngItemID > 0 Then
                If RowDatas(i).blnIsBatch = False Then
                    For j = i + 1 To .Rows - 1
                        If RowDatas(j).lngItemID = RowDatas(i).lngItemID Then
                            If j < lngFirstReceiptRow Then
                                RowDatas(i).dblInvoiceAmount = RowDatas(i).dblInvoiceAmount + RowDatas(j).dblInvoiceAmount
                            Else
                                For k = j - 1 To lngFirstReceiptRow Step -1
                                    If RowDatas(k).lngActivityDetailID = RowDatas(j).lngActivityDetailID Then
                                        Exit For
                                    End If
                                Next
                                If k = lngFirstReceiptRow - 1 Then
                                    RowDatas(i).dblQuantity = RowDatas(i).dblQuantity + RowDatas(j).dblQuantity
                                    RowDatas(i).dblReceiptAmount = RowDatas(i).dblReceiptAmount + RowDatas(j).dblReceiptAmount
                                End If
                                RowDatas(i).dblSettleAmount = RowDatas(i).dblSettleAmount + RowDatas(j).dblSettleAmount
                            End If
                            RowDatas(j).lngItemID = 0
                        End If
                    Next
                    RowDatas(i).lngInvoiceDetailID = RowDatas(i).lngActivityDetailID
                Else
                    dblTotalQuantity = 0
                    For j = lngFirstReceiptRow To .Rows - 1
                        If RowDatas(j).lngItemID = RowDatas(i).lngItemID Then
                            For k = j + 1 To .Rows - 1
                                If RowDatas(j).lngItemID = RowDatas(k).lngItemID _
                                    And RowDatas(j).strProduceNum = RowDatas(k).strProduceNum _
                                    And RowDatas(j).intValidDay = RowDatas(k).intValidDay _
                                    And RowDatas(j).lngCustomID0 = RowDatas(k).lngCustomID0 _
                                    And RowDatas(j).lngCustomID1 = RowDatas(k).lngCustomID1 _
                                    And RowDatas(j).lngCustomID2 = RowDatas(k).lngCustomID2 _
                                    And RowDatas(j).lngCustomID3 = RowDatas(k).lngCustomID3 _
                                    And RowDatas(j).lngCustomID4 = RowDatas(k).lngCustomID4 _
                                    And RowDatas(j).lngCustomID5 = RowDatas(k).lngCustomID5 _
                                    And RowDatas(j).lngJobID = RowDatas(k).lngJobID Then
                                                     
                                    For l = k - 1 To lngFirstReceiptRow Step -1
                                        If RowDatas(k).lngActivityDetailID = RowDatas(l).lngActivityDetailID Then
                                            Exit For
                                        End If
                                    Next
                                    If l = lngFirstReceiptRow - 1 Then
                                        RowDatas(j).dblQuantity = RowDatas(j).dblQuantity + RowDatas(k).dblQuantity
                                        RowDatas(j).dblReceiptAmount = RowDatas(j).dblReceiptAmount + RowDatas(k).dblReceiptAmount
                                        RowDatas(j).lngUnitID = RowDatas(i).lngUnitID
                                        RowDatas(j).dblFactor = RowDatas(i).dblFactor
                                    End If
                                    RowDatas(j).dblSettleAmount = RowDatas(j).dblSettleAmount + RowDatas(k).dblSettleAmount
                                    RowDatas(k).lngItemID = 0
                                End If
                            Next
                            dblTotalQuantity = dblTotalQuantity + RowDatas(j).dblQuantity
                        End If
                    Next
                    '分摊
                    For j = lngFirstReceiptRow To .Rows - 1
                        If RowDatas(j).lngItemID = RowDatas(i).lngItemID Then
                            RowDatas(j).dblInvoiceAmount = RowDatas(j).dblInvoiceAmount + (RowDatas(i).dblInvoiceAmount * RowDatas(j).dblQuantity / dblTotalQuantity)
                        End If
                    Next
                    RowDatas(i).lngItemID = 0
                End If
            End If
        Next
        
        For i = .Rows - 1 To 1 Step -1
            If RowDatas(i).lngItemID = 0 Then
                .RemoveItem i
            Else
                '数据回写
                .TextMatrix(i, 3) = DisplayData(Me.hWnd, NumberConvert(RowDatas(i).dblQuantity, RowDatas(i).dblFactor, False), RowDatas(i).dblFactor)
                .TextMatrix(i, 4) = Format(RowDatas(i).dblReceiptAmount, strCurrDec)
                RowDatas(i).dblReceiptAmount = .TextMatrix(i, 4)
                .TextMatrix(i, 5) = Format(RowDatas(i).dblInvoiceAmount, strCurrDec)
                RowDatas(i).dblInvoiceAmount = .TextMatrix(i, 5)
                .TextMatrix(i, 6) = Format(RowDatas(i).dblInvoiceAmount - RowDatas(i).dblReceiptAmount, strCurrDec)
                .TextMatrix(i, 7) = Format(RowDatas(i).dblSettleAmount, strCurrDec)
            End If
        Next
        .Cols = 8
        ReDim strColName(.Cols - 1)
        ReDim xlngColNo(.Cols - 1)
        For i = 0 To 1
            .ColAlignment(i) = flexAlignLeftCenter
            strColName(i) = .TextMatrix(0, i)
            xlngColNo(i) = i
        Next
        For i = 2 To .Cols - 1
            .ColAlignment(i) = flexAlignRightCenter
            strColName(i) = .TextMatrix(0, i)
            xlngColNo(i) = i
        Next
        mclsGrid.ColOfs = 2
        mclsGrid.SetupStyle
        LoadGrdColWidth
        If .ColWidth(0) <> 0 Then
            .ColWidth(0) = 0
        End If
        .Redraw = True
    End With
    Me.MousePointer = vbDefault
End Sub

Private Function DataValid() As Boolean
    
    If Not IsCanDo(EditNO(2)) Then
        cMsgBox "操作员" & gclsBase.OperatorName & "没有新增商品采购单的权限，不能核销！"
        Exit Function
    End If
    If gclsBase.PeriodClosed(Format(gclsBase.BaseDate, "yyyy-mm-dd")) Then
        cMsgBox "登录日期所属期间已结帐，不能核销！"
        Exit Function
    End If
    DataValid = True
End Function
Private Function SaveBill() As Boolean
    Dim strSql As String
    Dim recTmp As rdoResultset
    Dim i As Long
    
    If chkAuto.Value = 0 Then
        SaveBill = True
        Exit Function
    End If
    
    Me.MousePointer = vbHourglass
    
    On Error GoTo ErrHandle
    
    strSql = "SELECT lngPositionID FROM Position WHERE ROWNUM<=1 AND blnIsDetail<>0 " & _
        " AND blnIsInActive=0 ORDER BY strPositionCode"
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    If Not (recTmp.BOF And recTmp.EOF) Then
        mlngDefaultPositionID = recTmp(0)
    End If
    gclsBase.BaseWorkSpace.BeginTrans
    If blnNotMaking() Then
        For i = 1 To GrdCol.Rows - 1
            If blnOnlySettle(i) = False Then
                gclsBase.BaseWorkSpace.RollBacktrans
                GoTo EndProc
            End If
        Next
        GoTo Proc1
        SaveBill = True
        GoTo EndProc
    End If
    If DataValid() = False Then
        GoTo EndProc
    End If
    If OptSelect(0).Value Then
        For i = 1 To GrdCol.Rows - 1
            If C2Dbl(GrdCol.TextMatrix(i, xlngColNo(6))) = 0 Then
                If blnOnlySettle(i) = False Then
                    gclsBase.BaseWorkSpace.RollBacktrans
                    GoTo EndProc
                End If
            End If
        Next
        mlngNewActivityID = 0
        If MakeNewBill() = False Then
            gclsBase.BaseWorkSpace.RollBacktrans
            GoTo EndProc
        End If
        If MakeWriteOffBills() = False Then
            gclsBase.BaseWorkSpace.RollBacktrans
            GoTo EndProc
        End If
    Else
        If MakeAdjustBill() = False Then
            gclsBase.BaseWorkSpace.RollBacktrans
            GoTo EndProc
        End If
    End If
    
Proc1:
    strSql = "UPDATE ItemActivityDetail SET dblCurrInvoiceAmount=dblCurrAmount+dblCurrTaxAmount WHERE lngActivityID=" & mlngActivityID
    If gclsBase.ExecSQL(strSql) = False Then
        gclsBase.BaseWorkSpace.RollBacktrans
        GoTo EndProc
    End If
    strSql = "UPDATE ItemActivity SET blnInvoiceClose=1 WHERE lngActivityID=" & mlngActivityID
    If gclsBase.ExecSQL(strSql) = False Then
        gclsBase.BaseWorkSpace.RollBacktrans
        GoTo EndProc
    End If
    gclsBase.BaseWorkSpace.CommitTrans
    SaveBill = True
EndProc:
    Me.MousePointer = vbDefault
    Exit Function
ErrHandle:
    On Error Resume Next
    gclsBase.BaseWorkSpace.RollBacktrans
    GoTo EndProc
End Function

Private Function MakeWriteOffBills() As Boolean
    Dim strSql As String
    Dim recTmp As rdoResultset
    Dim lngOldID As Long
    Dim lngNewID As Long
    Dim lngTypeID As Long
    Dim lngRowID As Long
    
    strSql = "SELECT IADR.lngActivityDetailID,IADR.lngActivityID " & _
        " FROM ItemActivityDetail IADR,PurchaseToInvoice,ItemActivityDetail IADI " & _
        " Where IADR.lngActivityDetailID = PurchaseToInvoice.lngReceiptDetailID " & _
        " AND PurchaseToInvoice.lngInvoiceDetailID = IADI.lngActivityDetailID " & _
        "  " & _
        " AND IADR.lngActivityID<>" & mlngNewActivityID & _
        " AND IADI.lngActivityID=" & mlngActivityID & " ORDER BY IADR.lngActivityID,IADR.lngRowID "
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    With recTmp
        Do While Not .EOF
            If lngOldID <> !lngActivityID Then
                If lngNewID <> 0 Then
                    ChangeBalance 2, lngNewID
                End If
                lngOldID = !lngActivityID
                lngNewID = CloneAHead(!lngActivityID, lngTypeID)
                If lngNewID = 0 Then GoTo EndProc
                lngRowID = 0
            End If
            lngRowID = lngRowID + 1
            If CloneADetail(!lngActivityDetailID, 2, lngRowID, lngNewID) = False Then
                GoTo EndProc
            End If
            .MoveNext
        Loop
        If lngNewID <> 0 Then
            ChangeBalance 2, lngNewID
        End If
    End With
    MakeWriteOffBills = True
EndProc:
    If Not recTmp Is Nothing Then
        recTmp.Close
        Set recTmp = Nothing
    End If
End Function

Private Function MakeNewBill() As Boolean
    Dim strSql As String
    Dim recTmp As rdoResultset
    Dim lngNewID As Long
    Dim lngTypeID As Long
    Dim lngRowID As Long
    Dim i As Long
    
    strSql = "UPDATE ItemActivityDetail SET dblCurrInvoiceAmount=0,dblInvoiceQuantity=0 WHERE lngActivityID=" & mlngActivityID
    If gclsBase.ExecSQL(strSql) = False Then GoTo EndProc
    lngNewID = CloneAHead(mlngActivityID, lngTypeID)
    If lngNewID = 0 Then GoTo EndProc
    mlngNewActivityID = lngNewID
    For i = 1 To GrdCol.Rows - 1
        If C2Dbl(GrdCol.TextMatrix(i, xlngColNo(6))) <> 0 Then
            lngRowID = lngRowID + 1
            If CreateANewDetail(i, lngRowID, lngNewID) = False Then
                GoTo EndProc
            End If
        End If
    Next
    ChangeBalance 2, lngNewID
    MakeNewBill = True
EndProc:
    If Not recTmp Is Nothing Then
        recTmp.Close
        Set recTmp = Nothing
    End If
End Function

Private Function MakeAdjustBill() As Boolean
    Dim strSql As String
    Dim recTmp As rdoResultset
    Dim lngNewID As Long
    Dim lngTypeID As Long
    Dim lngRowID As Long
    Dim dblCurrAmount As Double
    Dim i As Long
    
    For i = 1 To GrdCol.Rows - 1
        If blnOnlySettle(i) = False Then
            Exit Function
        End If
    Next
    
    lngNewID = CloneAHead(mlngActivityID, lngTypeID)
    If lngNewID = 0 Then GoTo EndProc
    For i = 1 To GrdCol.Rows - 1
        If C2Dbl(GrdCol.TextMatrix(i, xlngColNo(6))) <> 0 Then
            If CreateAAdjustDetail(i, lngRowID, lngNewID) = False Then
                GoTo EndProc
            End If
        End If
    Next
    
    If lngNewID <> 0 Then
        ChangeBalance 2, lngNewID
    End If
    MakeAdjustBill = True
EndProc:
    If Not recTmp Is Nothing Then
        recTmp.Close
        Set recTmp = Nothing
    End If
End Function

Private Function CloneAHead(ByVal lngSourceID As Long, ByRef lngReceiptTypeID As Long) As Long
    Dim strSql As String
    Dim recS As rdoResultset
    Dim recD As rdoResultset