frmmutidepartment.frm

金算盘软件代码

                    For lngRow1 = 1 To .Rows - 1
                        If .RowHeight(lngRow1) > 100 And GetValue(lngRow1, mlngColDpm, "String") = strDpm And lngRow1 <> lngRow Then
                            DataIsVoid = False
                            Msg = "固定资产使用部门不能重复！"
                            Exit For
                        End If
                    Next lngRow1
                End If
            End If
            If Msg = "" Then
                If blnCheckAfterSave And strDpm <> "" Then
                    strSql = "SELECT blnIsDetail FROM Department WHERE lngDepartmentID=" & C2lng(.TextMatrix(lngRow, mlngColDpmID))
                    Set recDpm = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
                    If Not recDpm.EOF Then
                        If recDpm!blnIsDetail = 0 Then
                            Msg = "使用部门必须是明细部门！"
                        End If
                    Else
                        Msg = "使用部门不存在或已作废或已被删除！"
                    End If
                    recDpm.Close
                End If
            End If
            If Msg <> "" Then Exit For
        Next lngRow
        Set recDpm = Nothing
    End With
    
    If DataIsVoid Then
        If lngCnt = 0 Then
            DataIsVoid = False
            Msg = "部门不能为空！"
        End If
    End If
    
    If DataIsVoid Then
        If dblTotalRate <> 100 Then
            DataIsVoid = False
            Msg = "各部门分摊比例之和必须为100%！"
        End If
    End If
    
End Function

'按钮数组的Click事件处理
Private Sub cmdOK_Click(Index As Integer)
    Dim strMsg As String
    Select Case Index
        Case 0 '确定
            mclsList.Save
            If Not mblnLocked Then
                If DataIsVoid(strMsg) Then
                    Save -1
                    Hide
                Else
                    ShowMsg hwnd, strMsg, vbInformation, Caption
                End If
            Else
                Hide
            End If
        Case 1 '取消
            mclsList.CancelSave
            Hide
            RefreshGrid
    End Select
End Sub

Private Sub Form_Activate()
    On Error Resume Next
    SetHelpID HelpContextID
    frmMain.SetEditUnEnabled
    msgMutiDpm.SetFocus
End Sub

Private Sub Form_Load()
    mlngAlterID = -1
    mblnLocked = True
    mblnChanged = False
    RefreshLtxtDpm
    Set mclsList = New Grid
    Set mclsList.Grid = msgMutiDpm
    mclsList.SetupStyle
    Me.HelpContextID = 60132
    Utility.LoadFormResPicture Me
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    If UnloadMode = 0 Then
        Cancel = True
        cmdOK_Click 1
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Dim strSql As String
    On Error Resume Next
    strSql = "DELETE FROM FixedDepartment WHERE lngFixedAlterID=-1"
    gclsBase.ExecSQL strSql
    Utility.UnLoadFormResPicture Me
    If Not ltxtDpm.Recordset Is Nothing Then
        Set ltxtDpm.Recordset = Nothing
    End If
End Sub

Private Sub ltxtDpm_AddNew()
    Dim lngID As Long
    lngID = Card.AddCard(msgDepartment) '调用卡片
    RefreshLtxtDpm lngID
    ltxtDpm.Visible = True
End Sub

'部门参照
Private Sub ltxtDpm_Choose()
    Dim strSql As String
    Dim recTmp As rdoResultset
    
    With ltxtDpm
        If .ID > 0 Then
            strSql = "SELECT * FROM Department WHERE lngDepartmentID=" & .ID
            Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
            If Not recTmp.EOF Then
                If recTmp!blnIsDetail = 1 Then
                    mlngDpmID = .ID
                    mclsList_BeforeSave False
                Else
                    ShowMsg hwnd, "您选择了一个非末级部门,请重新选择", vbExclamation, Me.Caption
                    .Text = ""
                End If
            End If
            recTmp.Close
        End If
    End With
End Sub

Private Sub ltxtDpm_Delete()
    If mlngDpmID = 0 Then
        ShowMsg hwnd, "没有可供删除的项目", vbExclamation, Me.Caption
    Else
        ltxtDpm.Visible = True
        Card.DelCard msgDepartment, mlngDpmID, Me.hwnd
        RefreshLtxtDpm mlngDpmID
    End If
End Sub

Private Sub ltxtDpm_Edit()
    Dim lngRow As Long
    Dim rec As rdoResultset
    
    lngRow = msgMutiDpm.Row
    mlngDpmID = ltxtDpm.ID
    If mlngDpmID = 0 Then
        ShowMsg hwnd, "没有可供修改的项目", vbExclamation, Me.Caption
    Else
        Card.EditCard msgDepartment, mlngDpmID
        RefreshLtxtDpm mlngDpmID
        Dim strSql As String
        strSql = "SELECT strDepartMentCode , strDepartMentName FROM DepartMent WHERE lngDepartMentID = " & mlngDpmID
        Set rec = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If Not rec.EOF Then
            With msgMutiDpm
                For lngRow = 1 To .Rows - 1
                    If Val(.TextMatrix(lngRow, 1)) = mlngDpmID Then
                        .TextMatrix(lngRow, 2) = rec(0).Value & " " & rec(1).Value
                    End If
                Next lngRow
            End With
        End If
        mclsList.BeginEdit
    End If
End Sub

Private Sub ltxtDpmItemNotExist()
    Dim lngID As Long
    
    If frmMsgAdd.MsgAddShow(Me.Caption, "部门“" & ltxtDpm.Text & "”不存在或不可用，是否新增?") = vbOK Then
        lngID = Card.AddCard(msgDepartment) '调用卡片
        RefreshLtxtDpm lngID
    Else
        ltxtDpm.Text = ""
        msgMutiDpm.TextMatrix(msgMutiDpm.Row, msgMutiDpm.col) = ""
    End If
End Sub

'刷新部门参照
Private Sub RefreshLtxtDpm(Optional lngID As Long)
    Dim strSql As String
    Dim lngRow As Long
    Dim i As Byte
    On Error Resume Next
    
    strSql = "SELECT lngDepartmentID,strDepartmentCode,strDepartmentName " _
        & "FROM Department WHERE blnIsInActive = 0 " _
        & " ORDER BY strDepartmentCode"
    With ltxtDpm
        .ClearRefer
        Set .Recordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        .Comparts = 2
        .AddRefer "<新增>"
        .AddRefer "<修改>"
        .AddRefer "<删除>"
        '.CodeSort = True
        '.SeekCol = "1,2,3"
        .AutoPop = True
    End With
    If lngID > 0 Then
        ltxtDpm.SeekId lngID
        If ltxtDpm.ID <> lngID Then
            lngRow = 1
            Do While lngRow <= msgMutiDpm.Rows - 1
                If C2lng(msgMutiDpm.TextMatrix(lngRow, mlngColDpmID)) = lngID Then
                    If mlngAlterID = 0 Then
                        strSql = "DELETE FROM FixedDepartment WHERE lngFixedAlterID=-1 AND lngDepartmentID=" & lngID
                    Else
                        strSql = "DELETE FROM FixedDepartment WHERE lngFixedAlterID=" & mlngAlterID & " AND lngDepartmentID=" & lngID
                    End If
                    gclsBase.ExecSQL strSql
                    If msgMutiDpm.Rows = 2 Then
                        With msgMutiDpm
                            For i = 0 To .Cols - 1
                                .TextMatrix(lngRow, i) = ""
                            Next i
                        End With
                    Else
                        msgMutiDpm.RemoveItem lngRow
                        lngRow = lngRow - 1
                    End If
                End If
                lngRow = lngRow + 1
            Loop
        End If
    End If
End Sub

Private Sub mclsList_BeforeSave(blnCancel As Boolean)
    If msgMutiDpm.Row = msgMutiDpm.Rows - 1 Then
        If msgMutiDpm.col = mlngColRate Then
            If msgMutiDpm.TextMatrix(msgMutiDpm.Row, mlngColDpm) <> "" Then
                msgMutiDpm.Rows = msgMutiDpm.Rows + 1
            End If
        ElseIf msgMutiDpm.col = mlngColDpm Then
            If C2Dbl(msgMutiDpm.TextMatrix(msgMutiDpm.Row, mlngColRate)) > 0 Then
                msgMutiDpm.Rows = msgMutiDpm.Rows + 1
            End If
        End If
    End If
    If ltxtDpm.Visible Then
        msgMutiDpm.TextMatrix(msgMutiDpm.Row, mlngColDpmID) = ltxtDpm.ID
    End If
    mblnChanged = True
End Sub

Private Sub mclsList_DataValid(blnCancel As Boolean)
    Dim lngRow As Long
    
    If ltxtDpm.Visible Then
        If ltxtDpm.ID = 0 Then
            blnCancel = True
            If Trim$(ltxtDpm.Text) <> "" Then
                msgMutiDpm.TextMatrix(msgMutiDpm.Row, msgMutiDpm.col) = ""
                ltxtDpmItemNotExist
            End If
        End If
    ElseIf txtEdit.Visible Then
        If txtEdit.Value < 0 Or txtEdit.Value > 100 Then
            blnCancel = True
            ShowMsg hwnd, "部门分摊比例必须大于0，小于100！", vbExclamation, Me.Caption
        End If
    Else
        For lngRow = 1 To msgMutiDpm.Rows - 1
            If lngRow <> msgMutiDpm.Row And GetValue(lngRow, mlngColDpm, "String") = Trim(ltxtDpm.Text) Then
                blnCancel = True
                ShowMsg hwnd, "部门重复,请重新输入！", vbExclamation, Me.Caption
                msgMutiDpm.TextMatrix(msgMutiDpm.Row, mlngColDpm) = ""
                Exit For
            End If
        Next lngRow
    End If
End Sub

Private Function GetValue(lngRow As Long, intCol As Integer, Optional strType As String = "Double") As Variant
    GetValue = GetGridValue(lngRow, intCol, strType, msgMutiDpm)
End Function


Private Sub RefreshGrid()
    msgMutiDpm.FixedCols = 0
    Set datDpm.Resultset = GetDpm()
    If Not mblnCopyMode Then
        mclsList.SetupStyle
        With msgMutiDpm
            .Rows = .Rows + 1
            .ColWidth(1) = 0
            .ColWidth(2) = 0.6 * .width
            .ColWidth(3) = 0.3 * .width
            .ColAlignment(3) = flexAlignRightCenter
            mclsList.SetEditText "使用部门", , , , ltxtDpm
            mclsList.SetEditText "分摊比例(%)", , , , txtEdit
            .Row = 1
            .col = mlngColDpm
        End With
    End If
    datDpm.Resultset.Close
    Set datDpm.Resultset = Nothing
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = vbRightButton And (Not mblnLocked) Then
        If msgMutiDpm.Row >= 1 And Trim(msgMutiDpm.TextMatrix(msgMutiDpm.Row, mlngColDpm)) <> "" Then
            mnuDelete.Enabled = True
        Else
            mnuDelete.Enabled = False
        End If
        PopupMenu MenuPopup, vbPopupMenuLeftAlign, x, y
    End If
End Sub

Private Sub msgMutiDpm_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = vbRightButton And (Not mblnLocked) Then
        If msgMutiDpm.Row >= 1 And Trim(msgMutiDpm.TextMatrix(msgMutiDpm.Row, mlngColDpm)) <> "" Then
            mnuDelete.Enabled = True
        Else
            mnuDelete.Enabled = False
        End If
        PopupMenu MenuPopup, , x, y
    End If
End Sub

Private Sub mnuNew_Click()
    mblnChanged = True
    With msgMutiDpm
        If .TextMatrix(.Rows - 1, mlngColDpm) <> "" And C2Dbl(.TextMatrix(.Rows - 1, mlngColRate)) > 0 Or .RowHeight(.Rows - 1) < 100 Then
            .AddItem .Row
        Else
            .Row = .Rows - 1
        End If
        .col = mlngColDpm
        mclsList.BeginEdit
    End With
End Sub

Private Sub mnuDelete_Click()
    If msgMutiDpm.Rows > msgMutiDpm.FixedRows Then
        mblnChanged = True
        msgMutiDpm.TextMatrix(msgMutiDpm.Row, mlngColRate) = 0
        msgMutiDpm.RowHeight(msgMutiDpm.Row) = 0
        If msgMutiDpm.Row > msgMutiDpm.FixedRows Then
            msgMutiDpm.Row = msgMutiDpm.Row - 1
        End If
    End If
End Sub