costtoshare.frm

金算盘软件代码

    End If
    If mintIsListActivate = 2 Then
         If mblnIsProcurementChangeEmpoty Then
            intCol = GetColNO(msgProcurementChange, "本次分摊费用")
            With msgProcurementChange
                For intCount = 1 To .Rows - 1
                    .TextMatrix(intCount, 1) = ""
                    .TextMatrix(intCount, intCol) = "0"
                Next
                txtShare1Set
                .Row = 1
            End With
        End If
    End If
    If mintIsListActivate = 3 Then
        If mblnIsAddCostEmpoty Then
            intCol = GetColNO(msgAddCost, "本次分摊费用")
            With msgAddCost
                For intCount = 1 To .Rows - 1
                    .TextMatrix(intCount, 1) = ""
                    .TextMatrix(intCount, intCol) = "0"
                Next
            txtShare2Set
            .Row = 1
            End With
        End If
    End If
    If mintIsListActivate = 4 Then
        If mblnIsAddChangeEmpoty Then
            intCol = GetColNO(msgAddChange, "本次分摊费用")
            With msgAddChange
                For intCount = 1 To .Rows - 1
                    .TextMatrix(intCount, 1) = ""
                    .TextMatrix(intCount, intCol) = "0"
                Next
                txtShare2Set
                .Row = 1
            End With
        End If
    End If
End Sub

'全部选择
Private Sub Allselect_Click()
    Dim intCount As Integer
    Dim strDate1 As String
    Dim strDate2 As String
    Dim intCol As Integer
    Dim intCol1 As Integer
    Dim intCol2 As Integer
    Dim A As Integer
    strDate1 = Format(GACalendar1.Text, "yyyy-mm-dd")
    If mintIsListActivate = 1 Then
        If mblnIsProcurementCostEmpoty Then
            With msgProcurementCost
                intCol = GetColNO(msgProcurementCost, "日期")
                intCol1 = GetColNO(msgProcurementCost, "未分摊费用")
                intCol2 = GetColNO(msgProcurementCost, "本次分摊费用")
                For intCount = 1 To .Rows - 1
                    strDate2 = Format(.TextMatrix(intCount, intCol), "yyyy-mm-dd")
                    If .RowHeight(intCount) > 0 And strDate2 <= strDate1 Then            '保证隐藏行不再选择
                        .TextMatrix(intCount, 1) = "√"                                  '打上选取标志
                        .TextMatrix(intCount, intCol2) = .TextMatrix(intCount, intCol1)  '重写修改列的值
                    End If
                Next
            txtShare1Set
            .Row = .Rows - 1
            End With
        End If
    End If
    If mintIsListActivate = 2 Then
        If mblnIsProcurementChangeEmpoty Then
            With msgProcurementChange
                intCol = GetColNO(msgProcurementChange, "日期")
                For intCount = 1 To .Rows - 1
                    strDate2 = Format(.TextMatrix(intCount, intCol), "yyyy-mm-dd")
                    If .RowHeight(intCount) > 0 And strDate2 <= strDate1 Then    '保证隐藏行不再选择
                        .TextMatrix(intCount, 1) = "√"                          '打上选取标志
                    End If
                Next
                .Row = .Rows - 1
            End With
        End If
    End If
    If mintIsListActivate = 3 Then
        If mblnIsAddCostEmpoty Then
            With msgAddCost
                intCol = GetColNO(msgAddCost, "日期")
                intCol1 = GetColNO(msgAddCost, "未分摊费用")
                intCol2 = GetColNO(msgAddCost, "本次分摊费用")
                For intCount = 1 To .Rows - 1
                    strDate2 = Format(.TextMatrix(intCount, intCol), "yyyy-mm-dd")
                    If .RowHeight(intCount) > 0 And strDate2 <= strDate1 Then    '保证隐藏行不再选择
                        .TextMatrix(intCount, 1) = "√"
                        .TextMatrix(intCount, intCol2) = .TextMatrix(intCount, intCol1)
                    End If
                Next
            txtShare2Set
            .Row = .Rows - 1
            End With
        End If
    End If
    If mintIsListActivate = 4 Then
        If mblnIsAddChangeEmpoty Then
            With msgAddChange
                intCol = GetColNO(msgAddChange, "日期")
                For intCount = 1 To .Rows - 1
                    strDate2 = Format(.TextMatrix(intCount, intCol), "yyyy-mm-dd")
                    If .RowHeight(intCount) > 0 And strDate2 <= strDate1 Then    '保证隐藏行不再选择
                        .TextMatrix(intCount, 1) = "√"
                    End If
                Next
                .Row = .Rows - 1
            End With
        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
        NoCostToShare_Click     '取消费用分摊
    Case 5
        RailSet_Click           '栏目设置
    Case 6
        Filt_Click              '筛选
    Case 7
        Allselect_Click         '全部选择
    Case 8
        ConditionSelect_Click   '条件选择
    Case 9
        AllCancel_Click         '全部取消
    End Select
    

End Sub

'条件选择
Private Sub ConditionSelect_Click()
    Dim intCol As Integer
    Dim Strsql As String
    Dim recRecordset As rdoResultset
    Dim blnTmp As Boolean
    
    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
        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
        End If
    End If
    If mintIsListActivate = 3 Then
        If mblnIsAddCostEmpoty Then
            mclsAddCostGrid.ListSet.SaveList
            Filter.ShowFilter mclsAddCostGrid.ListSet.ListID, 1, , , , , blnTmp, , "条件选择"
            If blnTmp Then
                mclsAddCostGrid.ListSet.SaveList
                mclsAddCostGrid.ListSet.ViewId = mintAddCostViewID
                RefashConditionSelect                               '刷新条件选择并为符合条件选择的记录打上标志
            End If
        End If
    End If
    If mintIsListActivate = 4 Then
        If mblnIsAddChangeEmpoty Then
            mclsAddChangeGrid.ListSet.SaveList
            Filter.ShowFilter mclsAddChangeGrid.ListSet.ListID, 1, , , , , blnTmp, , "条件选择"
            If blnTmp Then
                mclsAddChangeGrid.ListSet.SaveList
                mclsAddChangeGrid.ListSet.ViewId = mintAddChangeViewID
                RefashConditionSelect                             '刷新条件选择并为符合条件选择的记录打上标志
            End If
        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
    
    If mintIsListActivate = 1 Then
        With mclsProcurementCostGrid.ListSet
            strSelectOfSql = "select ProcurementCostQuery.ID 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.OpenRecordset(Strsql, dbOpenSnapshot)
        If Not recRecordset.EOF Then
            recRecordset.MoveLast
            recRecordset.MoveFirst
            intCol1 = GetColNO(msgProcurementCost, "本次分摊费用")
            intCol2 = GetColNO(msgProcurementCost, "未分摊费用")
            With msgProcurementCost
                For intCount1 = 1 To .Rows - 1
                    .TextMatrix(intCount1, 1) = ""       '清除选择费用项目标志
                    .TextMatrix(intCount1, intCol1) = 0
                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
                                .TextMatrix(intCount2, 1) = "√"     '选择费用项目打上标志
                                .TextMatrix(intCount2, intCol1) = .TextMatrix(intCount2, intCol2)
                                blnTmp = True
                            End If
                        End If
                    Next
                    recRecordset.MoveNext
                Next
                txtShare1Set                         '待分摊费用，已分摊费用设置
            End With
            If Not blnTmp Then
               ShowMsg msgProcurementCost.hwnd, "没有符合条件选择的采购费用记录。", vbInformation, Me.Caption
            End If
        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 ProcurementChangeQuery.ID 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.OpenRecordset(Strsql, dbOpenSnapshot)
        If Not recRecordset.EOF Then
            recRecordset.MoveLast
            recRecordset.MoveFirst
            intCol1 = GetColNO(msgProcurementChange, "本次分摊费用")
            With msgProcurementChange
                For intCount1 = 1 To .Rows - 1
                    .TextMatrix(intCount1, 1) = ""       '清除选择商品项目标志
                    .TextMatrix(intCount1, intCol1) = 0
                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
                                .TextMatrix(intCount2, 1) = "√"     '选择商品项目打上标志
                                blnTmp = True
                            End If
                        End If
                    Next
                    recRecordset.MoveNext
                Next
                txtShare1Set             '待分摊费用，已分摊费用设置
            End With
            If Not blnTmp Then
               ShowMsg msgProcurementChange.hwnd, "没有符合条件选择的采购商品记录。", vbInformation, Me.Caption
            End If
        Else
            ShowMsg msgProcurementChange.hwnd, "没有符合条件选择的采购商品记录。", vbInformation, Me.Caption   '显示对话框