frmentrustamount.frm

金算盘软件代码

        intCol1 = GetColNO(msgAddCost, "本次分摊费用", mintAddCostViewID)
        intCol = GetColNO(msgAddCost, "未分摊费用", mintAddCostViewID)
        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 msgAddChange
        intCostToShareCol = GetColNO(msgAddChange, "本次分摊费用", mintAddChangeViewID)
        intCostCol = GetColNO(msgAddChange, "金额", mintAddChangeViewID)
        intAmountCol = GetColNO(msgAddChange, "数量", mintAddChangeViewID)
        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
             If mblnIsoptAmount Then
                If dblAmount <> 0 Then
                    dblAmountTemp = dblCostToshare / dblAmount
                Else
                    dblAmountTemp = 0
                    lblShare.Caption = "待分摊费用："
                    lblShare.Caption = lblShare.Caption & Format(dblCostToshare, "0.00") & " - 已分摊费用：0"
                    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"
                    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")
                          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 WriteAddRecord(mstrArrAddCostId(), mdblArrAddcost(), mstrArrAddChangeID(), mdblArrAddChange()) 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
        Me.MousePointer = vbDefault
        ShowMsg Me.hWnd, "已选择的加工费用分摊不平衡！", vbInformation, Me.Caption
        If mintIsListActivate = 1 Then
            On Error Resume Next
            intCol = GetColNO(msgAddCost, "本次分摊费用", mintAddCostViewID)
            msgAddCost.col = intCol
            msgAddCost.SetFocus
            On Error GoTo 0
        Else
            On Error Resume Next
            intCol = GetColNO(msgAddChange, "本次分摊费用", mintAddChangeViewID)
            msgAddChange.col = intCol
            msgAddChange.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 msgAddCost
        intCol1 = GetColNO(msgAddCost, "未分摊费用", mintAddCostViewID)
        intCol2 = GetColNO(msgAddCost, "本次分摊费用", mintAddCostViewID)
        intCol3 = GetColNO(msgAddCost, "加工费用单号", mintAddCostViewID)
        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 msgAddChange
        intCol2 = GetColNO(msgAddChange, "本次分摊费用", mintAddChangeViewID)
        intCol3 = GetColNO(msgAddChange, "加工入库单号", mintAddChangeViewID)
        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 & "的本次分摊费用值不能为正数，请重新输入。"
                        ShowMsg Me.hWnd, strMsg, vbInformation, Me.Caption
                        VaildOneChangeIsRight = False
                        Exit Function
                    End If
                End If
            End If
        Next
    End With
    VaildOneChangeIsRight = True
End Function
'判断本次分摊费用的值是否超过未分摊费用
Private Function getCostIsRight() As Boolean
    Dim intCol1 As Integer
    Dim intCol2 As Integer
    Dim i As Integer
    Dim dblTmp1 As Double
    Dim dblTmp2 As Double
    Dim strMsg As String
    Dim intCol3 As Integer
    
    intCol1 = GetColNO(msgAddCost, "未分摊费用", mintAddCostViewID)
    intCol2 = GetColNO(msgAddCost, "本次分摊费用", mintAddCostViewID)
    intCol3 = GetColNO(msgAddCost, "加工费用单号", mintAddCostViewID)
    With msgAddCost
        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 Abs(dblTmp2) > Abs(dblTmp1) And Sgn(dblTmp1) = Sgn(dblTmp2) Then
                    strMsg = "加工费用单号为“" &