frmexpenseamount.frm

金算盘软件代码

                        End If
                    End If
                Next
            txtShare1Set
            If lngTmpRow > 0 Then
                .Row = lngTmpRow
            Else
                .Row = .Rows - 1
            End If
            End With
            On Error Resume Next
            msgProcurementCost.SetFocus
            On Error GoTo 0
        End If
    End If
    If mintIsListActivate = 2 Then
        If mblnIsProcurementChangeEmpoty Then
            With msgProcurementChange
                intCol = GetColNO(msgProcurementChange, "日期", mintProcurementChangeViewId)
                lngCustomerID = 0
                For intCount = 1 To .Rows - 1
                    If .TextMatrix(intCount, 1) = "√" Then
                        lngCustomerID = .TextMatrix(intCount, 2)
                        If Trim(.TextMatrix(intCount, intCol1)) <> "" Then
                            dblTmp = CDbl(.TextMatrix(intCount, intCol1))
                        End If
                        Exit For
                    End If
                Next
'                If lngCustomerID = 0 Then
'                    For intCount = 0 To msgProcurementCost.Rows - 1
'                        If msgProcurementCost.TextMatrix(intCount, 1) = "√" Then
'                            lngCustomerID = msgProcurementCost.TextMatrix(intCount, 2)
'                            Exit For
'                        End If
'                    Next
'                End If
                For intCount = 1 To .Rows - 1
                    .TextMatrix(intCount, 1) = ""
                Next
'                If lngCustomerID = 0 And .Row > 0 And .Row < .Rows Then
'                    lngCustomerID = .TextMatrix(.Row, 2)
'                End If
                lngTmpRow = 0
                For intCount = 1 To .Rows - 1
                    strDate2 = Format(.TextMatrix(intCount, intCol), "yyyy-mm-dd")
                    If .RowHeight(intCount) > 0 And strDate2 <= strDate1 Then    '保证隐藏行不再选择
'                        If lngCustomerID > 0 Then
'                            If .TextMatrix(intCount, 2) = lngCustomerID Then
                                .TextMatrix(intCount, 1) = "√"
                                lngTmpRow = intCount
'                            End If
'                        Else
'                            .TextMatrix(intCount, 1) = "√"
'                            lngCustomerID = .TextMatrix(intCount, 2)
'                            lngTmpRow = intCount
'                        End If
                    End If
                Next
                If lngTmpRow > 0 Then
                    .Row = lngTmpRow
                Else
                    .Row = .Rows - 1
                End If
            End With
            On Error Resume Next
            msgProcurementChange.SetFocus
            On Error GoTo 0
            txtShare1Set
        End If
    End If
End Sub

Private Sub Cancel_Click()
    Unload Me
End Sub

Private Sub cmdArr_Click(Index As Integer)
    Select Case Index
    Case 0
        Ok_click                '确定
    Case 1
        Cancel_Click            '取消
    Case 2
        Related_Click           '关联
    Case 3
        CostToShare_Click       '计算分摊费用
    Case 4
        If txtProcurementCost.Visible = True Then txtProcurementCost.Visible = False
        If txtProcurementChange.Visible = True Then txtProcurementChange.Visible = False
        NoCostToShare_Click     '取消费用分摊
    Case 5
        RailSet_Click           '栏目设置
    Case 6
        Filt_Click              '筛选
    Case 7
        Allselect_Click         '全部选择
    Case 8
        ConditionSelect_Click   '条件选择
    Case 9
        AllCancel_Click         '全部取消
    Case 10
        Del_OldCost             '清除分摊
        On Error Resume Next
        msgProcurementCost.SetFocus
        On Error GoTo 0
    End Select
End Sub

'条件选择
Private Sub ConditionSelect_Click()
    Dim intCol As Integer
    Dim strSql As String
    Dim blnTmp As Boolean
    
    If mintIsListActivate <> 1 And mintIsListActivate <> 2 Then
        mintIsListActivate = 1
    End If
    If mintIsListActivate = 1 Then
        If mblnIsProcurementCostEmpoty Then
            mclsProcurementCostGrid.ListSet.SaveList
            Filter.ShowFilter mclsProcurementCostGrid.ListSet.ListID, 1, , , , , blnTmp, , "条件选择"  '调用筛选
            If blnTmp Then
                mclsProcurementCostGrid.ListSet.SaveList                                    '保存筛选条件
                mclsProcurementCostGrid.ListSet.ViewId = mintProcurementCostViewID
                RefashConditionSelect                                '刷新条件选择并为符合条件选择的记录打上标志
            End If
            On Error Resume Next
            msgProcurementCost.SetFocus
            On Error GoTo 0
        End If
    End If
    If mintIsListActivate = 2 Then
        If mblnIsProcurementChangeEmpoty Then
            mclsProcurementChangeGrid.ListSet.SaveList
            Filter.ShowFilter mclsProcurementChangeGrid.ListSet.ListID, 1, , , , , blnTmp, , "条件选择"
            If blnTmp Then
                mclsProcurementChangeGrid.ListSet.SaveList
                mclsProcurementChangeGrid.ListSet.ViewId = mintProcurementChangeViewId
                RefashConditionSelect                                '刷新条件选择并为符合条件选择的记录打上标志
            End If
            On Error Resume Next
            msgProcurementChange.SetFocus
            On Error GoTo 0
        End If
    End If
End Sub

'刷新条件选择并为符合条件选择的记录打上标志
Private Sub RefashConditionSelect()
    Dim recRecordset As rdoResultset
    Dim strSelectOfSql As String
    Dim strFromOfSql As String
    Dim strWhereOfSql As String
    Dim strSql As String
    Dim intCount1 As Integer
    Dim intCount2 As Integer
    Dim lngTmpID As Long
    Dim intCol1 As Integer
    Dim intCol2 As Integer
    Dim blnTmp As Boolean
    Dim dblCost As Double
    Dim dblTmp As Double
    Dim blnIsFirst As Boolean
    Dim lngCustomerID As Long
    
    If mintIsListActivate = 1 Then
        With mclsProcurementCostGrid.ListSet
            strSelectOfSql = "select ItemActivityDetail.lngActivityDetailID as ID,'' as 选取," & .SelectOfSql
            strFromOfSql = .FromOfSql
            strWhereOfSql = .WhereOfSql
        End With
        strSql = strSelectOfSql & strFromOfSql
        strWhereOfSql = Trim(strWhereOfSql)
        If strWhereOfSql <> "" Then
            strSql = strSql & " Where " & strWhereOfSql
        End If
        Set recRecordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If Not recRecordset.EOF Then
            recRecordset.MoveLast
            recRecordset.MoveFirst
            intCol1 = GetColNO(msgProcurementCost, "本次分摊费用", mintProcurementCostViewID)
            intCol2 = GetColNO(msgProcurementCost, "未分摊费用", mintProcurementCostViewID)
            dblCost = 0
            dblTmp = 0
            lngCustomerID = 0
            With msgProcurementCost
                For intCount1 = 1 To .Rows - 1
                    If .TextMatrix(intCount1, 1) = "√" Then
                        If Trim(.TextMatrix(intCount1, intCol1)) <> "" Then
                            dblTmp = CDbl(.TextMatrix(intCount1, intCol1))
                        End If
                        Exit For
                    End If
                Next
'                If lngCustomerID = 0 Then
'                    For intCount1 = 0 To msgProcurementChange.Rows - 1
'                        If msgProcurementChange.TextMatrix(intCount1, 1) = "√" Then
'                            lngCustomerID = msgProcurementChange.TextMatrix(intCount1, 2)
'                            Exit For
'                        End If
'                    Next
'                End If
                For intCount1 = 1 To .Rows - 1
                    .TextMatrix(intCount1, 1) = ""       '清除选择费用项目标志
                    .TextMatrix(intCount1, intCol1) = ""
                Next
                blnTmp = False
                blnIsFirst = True
                For intCount1 = 0 To recRecordset.RowCount - 1
                    lngTmpID = recRecordset!ID
                    For intCount2 = 1 To .Rows - 1
                        If .RowHeight(intCount2) <> 0 Then
                            If .TextMatrix(intCount2, 0) = lngTmpID Then
                                If Trim(.TextMatrix(intCount2, intCol2)) <> "" Then
                                    If blnIsFirst Then
'                                        If lngCustomerID > 0 Then
'                                            If .TextMatrix(intCount2, 2) = lngCustomerID Then
                                                dblTmp = CDbl(.TextMatrix(intCount2, intCol2))
                                                blnIsFirst = False
                                                .TextMatrix(intCount2, 1) = "√"                                  '打上选取标志
                                                .TextMatrix(intCount2, intCol1) = .TextMatrix(intCount2, intCol2)  '重写修改列的值
                                                blnTmp = True
'                                            End If
'                                        Else
'                                            dblTmp = CDbl(.TextMatrix(intCount2, intCol2))
'                                            blnIsFirst = False
'                                            .TextMatrix(intCount2, 1) = "√"                                  '打上选取标志
'                                            .TextMatrix(intCount2, intCol1) = .TextMatrix(intCount2, intCol2)  '重写修改列的值
'                                            blnTmp = True
'                                            lngCustomerID = .TextMatrix(intCount2, 2)
'                                        End If
                                    Else
                                        dblCost = CDbl(.TextMatrix(intCount2, intCol2))
                                        If Sgn(dblTmp) = Sgn(dblCost) Then      'And .TextMatrix(intCount2, 2) = lngCustomerID'只选全部为正或全部为负的单据
                                            .TextMatrix(intCount2, 1) = "√"                                  '打上选取标志
                                            .TextMatrix(intCount2, intCol1) = .TextMatrix(intCount2, intCol2)  '重写修改列的值
                                            blnTmp = True
                                        End If
                                    End If
                                End If
                            End If
                        End If
                    Next
                    recRecordset.MoveNext
                Next
                txtShare1Set                         '待分摊费用，已分摊费用设置
            End With
        Else
            ShowMsg msgProcurementCost.hWnd, "没有符合条件选择的采购费用记录。", vbInformation, Me.Caption   '显示对话框
        End If
        recRecordset.Close
        Set recRecordset = Nothing
    End If
    If mintIsListActivate = 2 Then
        With mclsProcurementChangeGrid.ListSet
            strSelectOfSql = "select ItemActivityDetail.lngActivityDetailID as ID,'' as 选取," & .SelectOfSql
            strFromOfSql = .FromOfSql
            strWhereOfSql = .WhereOfSql
        End With
        strSql = strSelectOfSql & strFromOfSql
        strWhereOfSql = Trim(strWhereOfSql)
        If strWhereOfSql <> "" Then
            strSql = strSql & " Where " & strWhereOfSql
        End If
        Set recRecordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If Not recRecordset.EOF Then
            recRecordset.MoveLast
            recRecordset.MoveFirst
            intCol1 = GetColNO(msgProcurementChange, "本次分摊费用", mintProcurementChangeViewId)
'            lngCustomerID = 0
            With msgProcurementChange
                For intCount1 = 1 To .Rows - 1
                    If .TextMatrix(intCount1, 1) = "√" Then
                        If Trim(.TextMatrix(intCount1, intCol1)) <> "" Then
                            dblTmp = CDbl(.TextMatrix(intCount1, intCol1))
                        End If
                        Exit For
                    End If
                Next
'                If lngCustomerID = 0 Then
'                    For intCount1 = 0 To msgProcurementCost.Rows - 1
'                        If msgProcurementCost.TextMatrix(intCount1, 1) = "√" Then
'                            lngCustomerID = msgProcurementCost.TextMatrix(intCount1, 2)
'                            Exit For
'                        End If
'                    Next
'                End If
                For intCount1 = 1 To .Rows - 1
                    .TextMatrix(intCount1, 1) = ""       '清除选择商品项目标志
                    .TextMatrix(intCount1, intCol1) = ""
                Next
                blnTmp = False
                For intCount1 = 0 To recRecordset.RowCount - 1
                    lngTmpID = recRecordset!ID
                    For intCount2 = 1 To .Rows - 1
                        If .RowHeight(intCount2) <> 0 Then
                            If .TextMatrix(intCount2, 0) = lngTmpID Then
'                                If lngCustomerID > 0 Then
'                                    If .TextMatrix(intCount2, 2) = lngCustomerID Then
                                        .TextMatrix(intCount2, 1) = "√"     '选择商品项目打上标志
                                        blnTmp = True
'                                    End If
'                                Else
'                                    .TextMatrix(intCount2, 1) = "√"     '选择商品项目打上标志
'                                    blnTmp = True
'                                    lngCustomerID = .TextMatrix(intCount2, 2)
'                                End If
                            End If