frmexpenseamount.frm

金算盘软件代码

'计算分摊费用
Private Sub CostToShare_Click()
    Dim dblCostToshare As Double
    Dim dblOldCostToShare As Double
    Dim intCount As Integer
    Dim intAmountCol As Integer
    Dim intCostCol As Integer
    Dim intCostToShareCol As Integer
    Dim dblAmount As Double
    Dim dblCost As Double
    Dim dblCostTemp As Double
    Dim dblAmountTemp As Double
    Dim intCol1 As Integer
    Dim dblCostToShareSum As Double
    Dim dblLastShare As Double
    Dim dblTemp As Double
    Dim dblTmpShare As Double
    Dim intCol As Integer
    Dim dblTmp1 As Double
    Dim dblTmp2 As Double
    
    With msgProcurementCost
        If txtProcurementCost.Visible = True Then
            .col = 2
        End If
        If txtProcurementChange.Visible = True Then
            msgProcurementChange.col = 2
        End If
        intCol = GetColNO(msgProcurementCost, "未分摊费用", mintProcurementCostViewID)
        intCol1 = GetColNO(msgProcurementCost, "本次分摊费用", mintProcurementCostViewID)
        For intCount = 1 To .Rows - 1
            If .TextMatrix(intCount, 1) = "√" Then
                If Trim(.TextMatrix(intCount, intCol)) <> "" Then
                    dblTmp1 = CDbl(.TextMatrix(intCount, intCol))
                Else
                    dblTmp1 = 0
                End If
                If Trim(.TextMatrix(intCount, intCol1)) <> "" Then
                    dblTmp2 = CDbl(.TextMatrix(intCount, intCol1))
                Else
                    dblTmp2 = 0
                End If
                If Abs(dblTmp2) > Abs(dblTmp1) And Sgn(dblTmp1) = Sgn(dblTmp2) Then
                    ShowMsg Me.hWnd, "采购费用的本次分摊费用值不能超过未分摊费用值。", vbInformation, Me.Caption
                    Exit For
                End If
            End If
        Next
        For intCount = 1 To .Rows - 1
            If .TextMatrix(intCount, 1) = "√" Then
                If Trim(.TextMatrix(intCount, intCol1)) <> "" Then
                    dblTmpShare = CDbl(.TextMatrix(intCount, intCol1))
                Else
                    dblTmpShare = 0
                End If
                dblCostToshare = dblCostToshare + dblTmpShare  '统计待分摊费用
            End If
        Next
     End With
     lblShare.Caption = "待分摊费用："
     lblShare.Caption = lblShare.Caption & Format(dblCostToshare, "0.00") & " - 已分摊费用：" & Format(dblCostToshare, "0.00")
     lblShare.Caption = lblShare.Caption & " = 0.00"
    With msgProcurementChange
        intCostToShareCol = GetColNO(msgProcurementChange, "本次分摊费用", mintProcurementChangeViewId)
        intCostCol = GetColNO(msgProcurementChange, "金额", mintProcurementChangeViewId)
        intAmountCol = GetColNO(msgProcurementChange, "数量", mintProcurementChangeViewId)
        For intCount = 1 To .Rows - 1
            If .TextMatrix(intCount, 1) = "√" Then
                If Trim(.TextMatrix(intCount, intAmountCol)) <> "" Then
                    dblTmpShare = CDbl(.TextMatrix(intCount, intAmountCol))
                Else
                    dblTmpShare = 0
                End If
                dblAmount = dblAmount + dblTmpShare       '统计数量总量
                If Trim(.TextMatrix(intCount, intCostCol)) <> "" Then
                    dblTmpShare = CDbl(.TextMatrix(intCount, intCostCol))
                Else
                    dblTmpShare = 0
                End If
                dblCost = dblCost + dblTmpShare             '统计金额总量
            End If
        Next
        If dblCostToshare <> 0 Then          'And dblCost <> 0 And dblAmount <> 0
            If mblnIsoptAmount Then
                If dblAmount <> 0 Then
                    dblAmountTemp = dblCostToshare / dblAmount
                Else
                    dblAmountTemp = 0
                    lblShare.Caption = "待分摊费用："
                    lblShare.Caption = lblShare.Caption & Format(dblCostToshare, "0.00") & " - 已分摊费用：0.00"
                    lblShare.Caption = lblShare.Caption & " = " & Format(dblCostToshare, "0.00")
                    For intCount = 1 To .Rows - 1
                        If .TextMatrix(intCount, 1) = "√" Then
                            .TextMatrix(intCount, intCostToShareCol) = ""
                        End If
                    Next
                    ShowMsg Me.hWnd, "已选采购商品数量总计为零,不能按数量分摊.", vbInformation, Me.Caption
                    Exit Sub
                End If
             End If
             If mblnIsoptMoney Then
                If dblCost <> 0 Then
                    dblCostTemp = dblCostToshare / dblCost
                Else
                    dblCostTemp = 0
                    lblShare.Caption = "待分摊费用："
                    lblShare.Caption = lblShare.Caption & Format(dblCostToshare, "0.00") & " - 已分摊费用：0.00"
                    lblShare.Caption = lblShare.Caption & " = " & Format(dblCostToshare, "0.00")
                    For intCount = 1 To .Rows - 1
                        If .TextMatrix(intCount, 1) = "√" Then
                            .TextMatrix(intCount, intCostToShareCol) = ""
                        End If
                    Next
                    ShowMsg Me.hWnd, "已选采购商品金额总计为零,不能按金额分摊.", vbInformation, Me.Caption
                    Exit Sub
                End If
             End If
            dblLastShare = 0#
            dblCostToShareSum = 0#
            For intCount = 1 To .Rows - 1
                If .TextMatrix(intCount, 1) = "√" Then
                    If mblnIsoptAmount Then                                       '按数量分摊
                        If Trim(.TextMatrix(intCount, intAmountCol)) <> "" Then
                            dblTmpShare = CDbl(.TextMatrix(intCount, intAmountCol))
                        Else
                            dblTmpShare = 0
                        End If
                        dblLastShare = dblAmountTemp * dblTmpShare
                        dblTemp = Format(dblLastShare, "0.000")
                        dblTemp = Int(dblTemp * 100 + 0.5) / 100                  '四舍五入保留两位小数
                        dblLastShare = dblTemp
                        dblCostToShareSum = dblCostToShareSum + dblTemp
                        .TextMatrix(intCount, intCostToShareCol) = Format(str(dblLastShare), "0.00")
                    End If
                    If mblnIsoptMoney Then                                        '按金额分摊
                        If Trim(.TextMatrix(intCount, intCostCol)) <> "" Then
                            dblTmpShare = CDbl(.TextMatrix(intCount, intCostCol))
                        Else
                            dblTmpShare = 0
                        End If
                        dblLastShare = dblCostTemp * dblTmpShare
                        dblTemp = Format(dblLastShare, "0.000")
                        dblTemp = Int(dblTemp * 100 + 0.5) / 100                    '四舍五入保留两位小数
                        dblLastShare = dblTemp
                        dblCostToShareSum = dblCostToShareSum + dblTemp
                        .TextMatrix(intCount, intCostToShareCol) = Format(str(dblLastShare), "0.00")
                    End If
                 End If
             Next
             If dblCostToShareSum - dblCostToshare <> 0 Then           '调整分摊费用计算误差调整到最后一个选取商品上
                 If dblCostToShareSum - dblCostToshare < 0 Then
                     dblLastShare = dblLastShare + Abs(dblCostToShareSum - dblCostToshare)
                 Else
                     dblLastShare = dblLastShare - Abs(dblCostToShareSum - dblCostToshare)
                 End If
                 dblLastShare = Format(dblLastShare, "0.00")
                 For intCount = .Rows - 1 To 1 Step -1
                     If .TextMatrix(intCount, 1) = "√" Then
                         .TextMatrix(intCount, intCostToShareCol) = Format(str(dblLastShare), "0.00")
                         txtProcurementChange.Text = .TextMatrix(intCount, intCostToShareCol)
                         Exit For
                     End If
                 Next
             End If
         Else
             lblShare.Caption = "待分摊费用："
             lblShare.Caption = lblShare.Caption & Format(dblCostToshare, "0.00") & " - 已分摊费用：0.00"
             lblShare.Caption = lblShare.Caption & " = " & Format(dblCostToshare, "0.00")
        End If
     End With
End Sub
Private Sub Ok_click()
    Me.MousePointer = vbHourglass
    If Not getCostIsRight() Then
        Me.MousePointer = vbDefault
        Exit Sub
    End If
    If Not VaildCostToShareIsRight() Then
        Me.MousePointer = vbDefault
        Exit Sub
    End If
    If Not VaildOneChangeIsRight() Then
        Me.MousePointer = vbDefault
        Exit Sub
    End If
    GetSelectIDArr         '得到已经选择项目ID号和分摊费用值数组
    '回写采购费用, 商品数据
    If Not WriteProcurementRecord(mstrArrProcurementCostID(), mdblArrProcurementCost(), mstrArrProcurementChangeID(), mdblArrProcurementChange()) Then
        Me.MousePointer = vbDefault
        Exit Sub
    End If
    Me.MousePointer = vbDefault
    Unload Me
End Sub
'判断采购费用分摊是否平衡
Private Function VaildCostToShareIsRight() As Boolean
    Dim strTmp As String
    Dim strRight  As String
    Dim dblTmp As Double
    Dim intStart As Integer
    Dim intCol As Integer
    
    strTmp = Trim(lblShare.Caption)
    intStart = InStr(strTmp, "=")
    strRight = Right(strTmp, Len(strTmp) - intStart)
    If Trim(strRight) <> "" Then
        dblTmp = CDbl(strRight)
    Else
        dblTmp = 0
    End If
    If dblTmp <> 0 Then
        ShowMsg Me.hWnd, "已选择的采购费用分摊不平衡！", vbInformation, Me.Caption
        If mintIsListActivate = 1 Then
            On Error Resume Next
            intCol = GetColNO(msgProcurementCost, "本次分摊费用", mintProcurementCostViewID)
            msgProcurementCost.col = intCol
            msgProcurementCost.SetFocus
            On Error GoTo 0
        Else
            On Error Resume Next
            intCol = GetColNO(msgProcurementChange, "本次分摊费用", mintProcurementChangeViewId)
            msgProcurementChange.col = intCol
            msgProcurementChange.SetFocus
            On Error GoTo 0
        End If
        VaildCostToShareIsRight = False
    Else
        VaildCostToShareIsRight = True
    End If
End Function

'判断商品的本次分摊费用的值是否费用的未分摊费用同号，费用的本次分摊费用的值是否费用的未分摊费用同号
'保证对照关系的完整牲。
Private Function VaildOneChangeIsRight() As Boolean
    Dim intCol1 As Integer
    Dim intCol2 As Integer
    Dim intCol3 As Integer
    Dim i As Integer
    Dim strMsg As String
    Dim dblTmp1 As Double
    Dim dblTmp2 As Double
    Dim dblTmp As Double
    
    With msgProcurementCost
        intCol1 = GetColNO(msgProcurementCost, "未分摊费用", mintProcurementCostViewID)
        intCol2 = GetColNO(msgProcurementCost, "本次分摊费用", mintProcurementCostViewID)
        intCol3 = GetColNO(msgProcurementCost, "采购单号", mintProcurementCostViewID)
        dblTmp = 0
        For i = 1 To .Rows - 1
            If .TextMatrix(i, 1) = "√" Then
                If Trim(.TextMatrix(i, intCol2)) <> "" Then
                    dblTmp2 = CDbl(Trim(.TextMatrix(i, intCol2)))
                Else
                    dblTmp2 = 0
                End If
                If Trim(.TextMatrix(i, intCol1)) <> "" Then
                    dblTmp1 = CDbl(Trim(.TextMatrix(i, intCol1)))
                Else
                    dblTmp1 = 0
                End If
                If dblTmp = 0 And dblTmp1 <> 0 Then
                    dblTmp = dblTmp1
                End If
                If dblTmp1 > 0 Then
                    If dblTmp2 <> 0 And Sgn(dblTmp2) = -1 Then
                        strMsg = "采购单号为“" & Trim(.TextMatrix(i, intCol3)) & " ”的采购费用"
                        strMsg = strMsg & "的本次分摊费用值不能为负数，请重新输入。"
                        ShowMsg Me.hWnd, strMsg, vbInformation, Me.Caption
                        VaildOneChangeIsRight = False
                        Exit Function
                    End If
                Else
                    If dblTmp2 <> 0 And Sgn(dblTmp2) = 1 Then
                        strMsg = "采购单号为“" & Trim(.TextMatrix(i, intCol3)) & " ”的采购费用"
                        strMsg = strMsg & "的本次分摊费用值不能为正数，请重新输入。"
                        ShowMsg Me.hWnd, strMsg, vbInformation, Me.Caption
                        VaildOneChangeIsRight = False
                        Exit Function
                    End If
                End If
            End If
        Next
    End With
    With msgProcurementChange
        intCol2 = GetColNO(msgProcurementChange, "本次分摊费用", mintProcurementChangeViewId)
        intCol3 = GetColNO(msgProcurementChange, "采购单号", mintProcurementChangeViewId)
        For i = 1 To .Rows - 1
            If .TextMatrix(i, 1) = "√" Then
                If Trim(.TextMatrix(i, intCol2)) <> "" Then
                    dblTmp2 = CDbl(Trim(.TextMatrix(i, intCol2)))
                Else
                    dblTmp2 = 0
                End If
                If dblTmp > 0 Then
                    If dblTmp2 <> 0 And Sgn(dblTmp2) = -1 Then
                        strMsg = "采购单号为“" & Trim(.TextMatrix(i, intCol3)) & " ”的采购商品"
                        strMsg = strMsg & "的本次分摊费用值不能为负数，请重新输入。"
                        ShowMsg Me.hWnd, strMsg, vbInformation, Me.Caption
                        VaildOneChangeIsRight = False
                        Exit Function
                    End If
                Else
                    If dblTmp2 <> 0 And Sgn(dblTmp2) = 1 Then
                        strMsg = "采购单号为“" & Trim(.TextMatrix(i, intCol3)) & " ”的采购商品"
                        strMsg = strMsg & "的本次分摊费用值不能为正数，请重新输入。"