costtoshare.frm

金算盘软件代码

            mclsAddChangeGrid.SetupStyle
            intCol = GetColNO(msgAddChange, "单据号")
            mclsAddChangeGrid.ColSort(intCol) = True
            mclsAddChangeGrid.Sort intCol, 1
            msgAddChange.Refresh
        End If
    End If
    UpdateMenuStatus    '设置菜单可用属性
End Sub

'计算分摊费用
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
    
    If SSTab1.Tab = 0 Then
         With msgProcurementCost
            intCol1 = GetColNO(msgProcurementCost, "本次分摊费用")
            For intCount = 1 To .Rows - 1
                If .TextMatrix(intCount, 1) = "√" Then
                    dblCostToshare = dblCostToshare + CDbl(.TextMatrix(intCount, intCol1))  '统计待分摊费用
                End If
            Next
         End With
         lblShare(0).Caption = "待分摊费用："
         lblShare(0).Caption = lblShare(0).Caption & dblCostToshare & " - 已分摊费用：" & dblCostToshare
         lblShare(0).Caption = lblShare(0).Caption & " = 0"
        With msgProcurementChange
            intCostToShareCol = GetColNO(msgProcurementChange, "本次分摊费用")
            intCostCol = GetColNO(msgProcurementChange, "金额")
            intAmountCol = GetColNO(msgProcurementChange, "数量")
            For intCount = 1 To .Rows - 1
                If .TextMatrix(intCount, 1) = "√" Then
                    dblAmount = dblAmount + .TextMatrix(intCount, intAmountCol)        '统计数量总量
                    dblCost = dblCost + .TextMatrix(intCount, intCostCol)              '统计金额总量
                End If
            Next
            If dblCostToshare <> 0 And dblCost <> 0 And dblAmount <> 0 Then
                If mblnIsoptAmount Then
                    dblAmountTemp = dblCostToshare / dblAmount
                End If
                If mblnIsoptMoney Then
                    dblCostTemp = dblCostToshare / dblCost
                End If
                dblLastShare = 0#
                dblCostToShareSum = 0#
                For intCount = 1 To .Rows - 1
                    If .TextMatrix(intCount, 1) = "√" Then
                        If mblnIsoptAmount Then                                       '按数量分摊
                            dblLastShare = dblAmountTemp * CDbl(.TextMatrix(intCount, intAmountCol))
                            dblTemp = Format(dblLastShare, "0.000")
                            dblTemp = Int(dblTemp * 100 + 0.5) / 100                  '四舍五入保留两位小数
                            dblLastShare = dblTemp
                            dblCostToShareSum = dblCostToShareSum + dblTemp
                            .TextMatrix(intCount, intCostToShareCol) = str(dblLastShare)
                        End If
                        If mblnIsoptMoney Then                                        '按金额分摊
                            dblLastShare = dblCostTemp * CDbl(.TextMatrix(intCount, intCostCol))
                            dblTemp = Format(dblLastShare, "0.000")
                            dblTemp = Int(dblTemp * 100 + 0.5) / 100                    '四舍五入保留两位小数
                            dblLastShare = dblTemp
                            dblCostToShareSum = dblCostToShareSum + dblTemp
                            .TextMatrix(intCount, intCostToShareCol) = str(dblLastShare)
                        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) = dblLastShare
                             txtProcurementChange.Text = .TextMatrix(intCount, intCostToShareCol)
                             Exit For
                         End If
                     Next
                 End If
             Else
                 lblShare(0).Caption = "待分摊费用："
                 lblShare(0).Caption = lblShare(0).Caption & dblCostToshare & " - 已分摊费用：0"
                 lblShare(0).Caption = lblShare(0).Caption & " = " & dblCostToshare
            End If
         End With
   End If
   
    If SSTab1.Tab = 1 Then
        With msgAddCost
            intCol1 = GetColNO(msgAddCost, "本次分摊费用")
            For intCount = 1 To .Rows - 1
                If .TextMatrix(intCount, 1) = "√" Then
                    dblCostToshare = dblCostToshare + CDbl(.TextMatrix(intCount, intCol1))  '统计待分摊费用
                End If
            Next
        End With
        lblShare(1).Caption = "待分摊费用："
        lblShare(1).Caption = lblShare(1).Caption & dblCostToshare & " - 已分摊费用：" & dblCostToshare
        lblShare(1).Caption = lblShare(1).Caption & " = 0"
        With msgAddChange
            intCostToShareCol = GetColNO(msgAddChange, "本次分摊费用")
            intCostCol = GetColNO(msgAddChange, "金额")
            intAmountCol = GetColNO(msgAddChange, "数量")
            For intCount = 1 To .Rows - 1
                If .TextMatrix(intCount, 1) = "√" Then
                     dblAmount = dblAmount + .TextMatrix(intCount, intAmountCol)        '统计金额总量
                     dblCost = dblCost + .TextMatrix(intCount, intCostCol)               '统计金额总量
                End If
            Next
             If dblCostToshare <> 0 And dblCost <> 0 And dblAmount <> 0 Then
                 If mblnIsoptAmount Then
                     dblAmountTemp = dblCostToshare / dblAmount
                 End If
                 If mblnIsoptMoney Then
                     dblCostTemp = dblCostToshare / dblCost
                 End If
                 dblLastShare = 0#
                 dblCostToShareSum = 0#
                 For intCount = 1 To .Rows - 1
                     If .TextMatrix(intCount, 1) = "√" Then
                         If mblnIsoptAmount Then                                       '按数量分摊
                             dblLastShare = dblAmountTemp * CDbl(.TextMatrix(intCount, intAmountCol))
                             dblTemp = Format(dblLastShare, "0.000")
                             dblTemp = Int(dblTemp * 100 + 0.5) / 100                  '四舍五入保留两位小数
                             dblLastShare = dblTemp
                             dblCostToShareSum = dblCostToShareSum + dblTemp
                             .TextMatrix(intCount, intCostToShareCol) = str(dblLastShare)
                         End If
                         If mblnIsoptMoney Then                                        '按金额分摊
                             dblLastShare = dblCostTemp * CDbl(.TextMatrix(intCount, intCostCol))
                             dblTemp = Format(dblLastShare, "0.000")
                             dblTemp = Int(dblTemp * 100 + 0.5) / 100                  '四舍五入保留两位小数
                             dblLastShare = dblTemp
                             dblCostToShareSum = dblCostToShareSum + dblTemp
                             .TextMatrix(intCount, intCostToShareCol) = str(dblLastShare)
                         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) = dblLastShare
                              Exit For
                          End If
                      Next
                  End If
              Else
                  lblShare(1).Caption = "待分摊费用："
                  lblShare(1).Caption = lblShare(1).Caption & dblCostToshare & " - 已分摊费用：0"
                  lblShare(1).Caption = lblShare(1).Caption & " = " & dblCostToshare
             End If
         End With
   End If
End Sub

Private Sub Ok_click()
    Dim blnTmp As Boolean
    Dim strTmp As String
    Dim strRight  As String
    Dim dblTmp As Double
    Dim intStart As Integer
    
    strTmp = Trim(lblShare(0).Caption)
    intStart = InStr(strTmp, "=")
    strRight = Right(strTmp, Len(strTmp) - intStart)
    dblTmp = CDbl(strRight)
    If dblTmp <> 0# Then
       ShowMsg frmCostToShare.hwnd, "已选择的采购费用分摊还有余额！", vbInformation, Me.Caption
       SSTab1.Tab = 0
       Exit Sub
    End If
    strTmp = Trim(lblShare(1).Caption)
    intStart = InStr(strTmp, "=")
    strRight = Right(strTmp, Len(strTmp) - intStart)
    dblTmp = CDbl(strRight)
    If dblTmp <> 0# Then
       ShowMsg frmCostToShare.hwnd, "已选择的加工费用分摊还有余额！", vbInformation, Me.Caption
       SSTab1.Tab = 1
       Exit Sub
    End If
    GetSelectIDArr         '得到已经选择项目ID号和分摊费用值数组
    '回写加工费用, 商品数据
    blnTmp = WriteAddRecord(mstrArrAddCostId(), mdblArrAddcost(), mstrArrAddChangeID(), mdblArrAddChange())
    If Not blnTmp Then
        Exit Sub
    End If
    '回写采购费用, 商品数据
    blnTmp = WriteProcurementRecord(mstrArrProcurementCostID(), mdblArrProcurementCost(), mstrArrProcurementChangeID(), mdblArrProcurementChange())
    If Not blnTmp Then
        Exit Sub
    End If
    Unload Me
End Sub

'关联
Private Sub Related_Click()
    Dim Strsql As String
    Dim recZ As rdoResultset
    Dim lngTypeID As Long
    Dim lngID As Long
    Dim strX As String
    Dim recX As rdoResultset
    
    If mintIsListActivate = 1 Then
        With msgProcurementCost
            If .Row > 0 Then
                lngID = .TextMatrix(.Row, 0)
                strX = "SELECT ItemActivity.lngActivityID FROM ItemActivity INNER JOIN ItemActivityDetail ON " & _
                       "ItemActivity.lngActivityID = ItemActivityDetail.lngActivityID " & _
                       " where ItemActivityDetail.lngActivityDetailID = " & lngID
                Set recX = gclsBase.BaseDB.OpenRecordset(strX, dbOpenSnapshot)     '据明细ID取得业务ID
                Strsql = "SELECT ItemActivity.lngActivityTypeID FROM ItemActivity INNER JOIN ItemActivityDetail ON  " & _
                         " ItemActivity.lngActivityID = ItemActivityDetail.lngActivityID " & _
                         " where ItemActivityDetail.lngActivityDetailID = " & lngID
                Set recZ = gclsBase.BaseDB.OpenRecordset(Strsql, dbOpenSnapshot)    '据明细ID取得业务类型ID
                If Not recZ.EOF And Not recX.EOF Then
                    lngTypeID = recZ!lngActivityTypeID
                    BillPublic.ShowBill lngTypeID, recX!lngActivityID
                End If
                recZ.Close
                Set recZ = Nothing
                recX.Close
                Set recX = Nothing
            End If
        End With
    End If
    If mintIsListActivate = 2 Then
        With msgProcurementChange
            If .Row > 0 Then
                lngID = .TextMatrix(.Row, 0)
                strX = "SELECT ItemActivity.lngActivityID FROM ItemActivity INNER JOIN ItemActivityDetail ON " & _
                       "ItemActivity.lngActivityID = ItemActivityDetail.lngActivityID " & _
                       " where ItemActivityDetail.lngActivityDetailID = " & lngID
                Set recX = gclsBase.BaseDB.OpenRecordset(strX, dbOpenSnapshot)          '据明细ID取得业务ID
                Strsql = "SELECT ItemActivity.lngActivityTypeID FROM ItemActivity INNER JOIN ItemActivityDetail ON  " & _
                         " ItemActivity.lngActivityID = ItemActivityDetail.lngActivityID " & _
                         " where ItemActivityDetail.lngActivityDetailID = " & lngID
                Set recZ = gclsBase.BaseDB.OpenRecordset(Strsql, dbOpenSnapshot)      '据明细ID取得业务类型ID
                If Not recZ.EOF And Not recX.EOF Then
                    lngTypeID = recZ!lngActivityTypeID
                    BillPublic.ShowBill lngTypeID, recX!lngActivityID
                End If
                recZ.Close
                Set recZ = Nothing
                recX.Close
                Set recX = Nothing
            End If
        End With
    End If
    If mintIsListActivate = 3 Then
        If msgAddCost.Row > 0 Then
            lngID = msgAddCost.TextMatrix(msgAddCost.Row, 0)
            strX = "SELECT ItemActivity.lngActivityID FROM ItemActivity INNER JOIN ItemActivityDetail ON " & _
                       "ItemActivity.lngActivityID = ItemActivityDetail.lngActivityID " & _
                       " where ItemActivityDetail.lngActivityDetailID = " & lngID
            Set recX = gclsBase.BaseDB.OpenRecordset(strX, dbOpenSnapshot)      '据明细ID取得业务ID
            BillPublic.ShowBill 6, recX!lngActivityID
            recX.Close
            Set recX = Nothing
        End If
    End If
    If mintIsListActivate = 4 Then
        If msgAddChange.Row > 0 Then
            lngID = msgAddChange.TextMatrix(msgAddChange.Row, 0)
            strX = "SELECT ItemActivity.lngActivityID FROM ItemActivity INNER JOIN ItemActivityDetail ON " & _
                       "ItemActivity.lngActivityID = ItemActivityDetail.lngActivityID " & _
                       " where ItemActivityDetail.lngActivityDetailID = " & lngID
            Set recX = gclsBase.BaseDB.OpenRecordset(strX, dbOpenSnapshot)     '据明细ID取得业务ID
            BillPublic.ShowBill 5, recX!lngActivityID
            recX.Close
            Set recX = Nothing
        End If
    End If
End Sub

Private Sub Form_Activate()
    UpdateMenuStatus    '设置菜单可用属性
End Sub

Private Sub Form_Load()
    Dim intCol As Integer
    Dim intCoun