frmvoucherlist.frm

金算盘软件代码

    
    If mclsList.ListSet.ListID < 1 Then
       mclsList.SaveListSet
       DefaultCurrentDate mclsList.ListSet.ListID, 9975
    Else
       mclsList.SaveListSet
    End If
    blnMenuBuilded = False
    frmMain.mnuAccountVoucher.Tag = 0
    Set datGrid.Resultset = Nothing
    Set mclsSubClassform = Nothing
    Set mclsSubClass = Nothing
    Set theEditForm = Nothing
    Set mclsList = Nothing
    Set mclsVoucher = Nothing
    gclsSys.MainControls.Remove Me
    Set mclsMainControl = Nothing
End Sub

Private Sub Form_Resize()
    On Error Resume Next
    If (Me.Left + Me.width < 0 Or Me.Left > Screen.width) And Me.WindowState <> 2 Then
        Me.Left = 300
    End If
    RedrawForm
End Sub


Private Sub Form_Activate()
    
    
    'grdList.SetFocus
    SetHelpID Me.HelpContextID
    If (Me.Left + Me.width) < 0 Or Me.Left > Screen.width Then
        Me.Left = 300
    End If
    grdList.Redraw = True
    
    strOldMenuCaption = frmMain.mnuEditInActive.Caption
    frmMain.mnuEditNew.Caption = "新增(&N)"
    frmMain.mnuEditDel.Caption = "删除(&D)"
    frmMain.mnuEditInActive.Caption = "作废(&H)"
    frmMain.mnuEditShowAll.Caption = "全部显示(&W)"
    MakeListEditMenu
    MakeListReportMenu
    gclsSys.CurrFormName = Me.hwnd
    mclsMainControl_ChildActive
    UpdateMenuStatus
    blnMenuBuilded = True
    frmMain.mnuEditSearch.Enabled = False
End Sub

Private Sub mclsMainControl_ChildActive()
    '消息响应
    Dim vntMessage As Variant
    
    SetHelpID Me.HelpContextID
'    If gclsBase.OperatorID <> lngOldOperatorID Then '系统重新登录（更换了操作员）
'        lngOldOperatorID = gclsBase.OperatorID
'        blnEdit = IsCanDo(frmRightsID.frmVoucherListID) '判断有无编辑权限
'        mclsVoucher.HaveRights
'    End If
    
    '响应消息: msgReceipt41 = 71                            '记帐凭证
    For Each vntMessage In mclsMainControl.Messages
        If vntMessage = Message.msgReceipt41 Or vntMessage = Message.msgTrans Or vntMessage = Message.msgAccount Then
            mclsMainControl_ToolRefresh
            mclsMainControl.Messages.Remove CStr(vntMessage) '清除消息
        End If
    Next
    mclsMainControl.Messages.Clear
    UpdateMenuStatus
End Sub

'查找条件类型 ComboBox 控件
Private Sub cboFindKind_Click()
    Dim i As Integer
    Dim intWidth As Integer
    Dim strFind As String
    Dim intSortCol As Integer
    
    If grdList.Rows = 1 Then
        txtfind.Text = ""
        Exit Sub
    End If
    
    With grdList
        .Redraw = False
        For i = 1 To .Cols - 1
            If .TextMatrix(0, i) = cboFindKind.Text Then
                '保存新排序列内容
                If .RowHeight(.Row) > 0 Then
                   strFind = .TextMatrix(.Row, i)
                Else
                   strFind = ""
                End If
                '重新排序
                'mclsList.FixrowSortBold i
                Exit For
            End If
       Next
    End With
    '设置新的“查找内容”控件
    
    '恢复以前选定行
    If txtfind.Text = strFind Then
        txtFind_Change
    Else
        If grdList.Rows > 1 Then
           txtfind.Text = strFind
        End If
    End If
    
    With grdList
        For i = 1 To .Cols - 1
            If Trim(cboFindKind.list(cboFindKind.ListIndex)) = Trim(.TextArray(i)) Then
                intFindCol = i
                Exit For
            End If
        Next i
    End With
        
    grdList.Redraw = True
    
End Sub

'
'查找内容 TextBox 控件
'
Private Sub txtFind_Change()
    
'    mclsList.TextFind txtFind.Text
     If mblnFindTextFocus Then cmdAgain_Click
     
End Sub

Private Sub txtfind_GotFocus()
    mblnFindTextFocus = True
End Sub

Private Sub txtFind_LostFocus()
    mblnFindTextFocus = False
End Sub

Private Sub txtFind_KeyDown(KeyCode As Integer, Shift As Integer)
    Dim intSelLen As Integer
    
    cmdAgain.Enabled = True
    If txtfind.Text = "" Then Exit Sub
    If KeyCode = 8 Then
        intSelLen = txtfind.SelLength
        If txtfind.SelStart > 0 Then txtfind.SelStart = txtfind.SelStart - 1
        txtfind.SelLength = intSelLen + 1
    End If
End Sub

Private Sub grdList_Click()
    mblnFindTextFocus = False
    With grdList
        If .Row >= 1 And .ColSel <> 0 Then
            txtfind.Text = .TextMatrix(.Row, intFindCol)
            cmdAgain.Enabled = True
        Else
            txtfind.Text = ""
            cmdAgain.Enabled = False
        End If
    End With
    
End Sub

Private Sub grdList_DblClick()
    If grdList.MouseRow = 0 Then Exit Sub
    
    If grdList.Row > 0 And grdList.MouseRow > 0 And grdList.ColSel > 0 And grdList.MouseCol > 1 And grdList.RowHeight(grdList.Row) > 0 Then
        bDblClick = True
        SetCapture theEditForm.hwnd
        mclsMainControl_EditEdit
    End If
    
End Sub

'弹出右键菜单
Private Sub grdlist_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    With grdList
        If Button = vbRightButton Then
            Form_MouseDown Button, Shift, x, y
        End If
    End With
    
End Sub

'鼠标左键弹起时，更新菜单
Private Sub grdList_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    mblnFindTextFocus = False
    With grdList
        If Button = vbLeftButton Then
            If chkShowAll.Value = 1 And .ColSel > 0 Then
                If x > .ColPos(1) And x < .ColPos(2) Then
                    mclsMainControl_EditInActive
                End If
            End If
            UpdateMenuStatus
        End If
    End With
End Sub

'显示全部记录/未停用记录 CheckBox 控件
Private Sub chkShowAll_Click()
    grdList.Redraw = False
    mclsList.DoShowAll chkShowAll.Value
    grdList.Redraw = True
    frmMain.mnuEditShowAll.Checked = Not frmMain.mnuEditShowAll.Checked
    UpdateMenuStatus
End Sub

Private Sub cmdEdit_Click()
    MakeListEditMenu
    UpdateMenuStatus
    PopupMenu frmMain.mnuListEdit, , cmdEdit.Left, cmdEdit.top + cmdEdit.Height
End Sub

Private Sub cmdReport_Click()
    MakeListReportMenu
    PopupMenu frmMain.mnuListReport, , cmdReport.Left, cmdReport.top + cmdReport.Height
End Sub

'/////////////////////////////////////////////////////////////////////////////////
'////////
'////////
'////////                            按纽菜单
'////////
'////////
'/////////////////////////////////////////////////////////////////////////////////

Private Sub MakeListEditMenu()
    Dim intCnt As Integer
    Dim i As Integer
    With frmMain
        For intCnt = .mnuListEditMenu.Count - 1 To 1 Step -1
            Unload .mnuListEditMenu(intCnt)
        Next
        For i = 1 To 23
            Load .mnuListEditMenu(i)
        Next i
    End With
End Sub

Private Sub mclsMainControl_ListEditMenu(ByVal intIndex As Integer)
        
    If mclsList.ListSet.ListID < 1 Then
       mclsList.ListSet.SaveList
       DefaultCurrentDate mclsList.ListSet.ListID, 9975
    End If
    frmVoucherMultiList.MuliListID = mclsList.ListSet.ListID
    Select Case intIndex
    Case 0: '修改
    
        blnChange = True
        mclsMainControl_EditEdit
    Case 1: '新增
        blnChange = True
        mclsMainControl_EditNew
    Case 2: '删除
        mclsMainControl_EditDel
    Case 4: '冲销
        Dim lngVoucherID As Long
        
        lngVoucherID = GetlngVoucherID()
        If lngVoucherID = -1 Then lngVoucherID = 0
        lngVoucherID = frmWriteOffBill.WriteOffBill(41, lngVoucherID, Me.hwnd)
        If lngVoucherID > 0 Then theEditForm.GenCacelVoucher lngVoucherID
    Case 6 '作废
        mclsMainControl_EditInActive
    Case 7: '全部显示
        mclsMainControl_EditShowAll
    Case 9: '复核/取消复核
        mclsVoucher.ChangeCheck GetlngVoucherID(), strVoucher
    Case 10: '记帐/取消记帐
        mclsVoucher.ChangePost GetlngVoucherID(), strVoucher
    Case 12: '多张复核
        mclsVoucher.MultiCheckVoucher
        If Me.Visible Then cboFindKind.SetFocus
    Case 13: '多张取消
        mclsVoucher.MultiUnCheckVoucher
        If Me.Visible Then cboFindKind.SetFocus
    Case 15: '多张记帐
        mclsVoucher.MultiPostVoucher
        If Me.Visible Then cboFindKind.SetFocus
    Case 16: '多张取消
        mclsVoucher.MultiUnPostVoucher
        If Me.Visible Then cboFindKind.SetFocus
    Case 18: '筛选
        mclsMainControl_EditFilter
    Case 19: '栏目设置
        mclsMainControl_EditColumn
    Case 21: '刷新
        mclsMainControl_ToolRefresh
    Case 22: '打印
        mclsMainControl_FilePrintReceipt
    Case 23
        mclsMainControl_FilePrint
    End Select
    blnChange = False
End Sub
     
'///////////////////响应主控对象事件////////////////////////////////////////////
'编辑
Private Sub mclsMainControl_EditEdit()
    Dim lngVoucherID As Long
    Me.Enabled = False
    lngVoucherID = GetlngVoucherID()
    If lngVoucherID = -1 Then Exit Sub
    If mIsShowEdit Then
        theEditForm.ShowAOldBill (lngVoucherID)  '调用接口
    Else
        theEditForm.ShowAOldBill (lngVoucherID) '调用接口
        mIsShowEdit = True
    End If
    Me.Enabled = True
End Sub

'新增
Private Sub mclsMainControl_EditNew()
    
    If gclsBase.PeriodClosed(gclsBase.BaseDate) Then
       ShowMsg Me.hwnd, "当前会计期间已经结帐，不能再增加凭证！", vbExclamation + MB_SYSTEMMODAL, Me.Caption
       Exit Sub
    End If
    
    If mIsShowEdit Then
        theEditForm.ShowANewBill
    Else
        theEditForm.ShowANewBill
        mIsShowEdit = True
    End If
End Sub

'删除记录
Private Sub mclsMainControl_EditDel()
    Dim lngVoucherID As Long
    Dim i As Long
    Dim intTop As Long
    Dim lngVoucherID_Cancel As Long
    
'    If gclsBase.PeriodClosed(gclsBase.BaseDate) Then
'       ShowMsg Me.hwnd, "当前会计期间已经结帐，不能再删除凭证！", vbExclamation + MB_SYSTEMMODAL, Me.Caption
'       Exit Sub
'    End If
    lngVoucherID = GetlngVoucherID()
    If lngVoucherID = -1 Then Exit Sub
    lngVoucherID_Cancel = 0
    
    If Not mclsVoucher.DeleteVoucher(lngVoucherID, , strVoucher, lngVoucherID_Cancel) Then Exit Sub
    
    mclsMainControl_ToolRefresh
    '从Grid中删除本凭证对应的行
'    With grdList
'        intTop = 1
'        i = .Row
'        Do While i > 1
'            If CLng(.TextMatrix(i, 0)) = lngVoucherID Then
'                i = i - 1
'            Else
'                intTop = i + 1
'                Exit Do
'            End If
'        Loop
'
'        Do
'            If CLng(.TextMatrix(intTop, 0)) = lngVoucherID Then
'                If .Rows = intTop + 1 Then '要删除的行是GRID 的最末一行
'                    If intTop = 1 Then     '要删除的行是GRID 的最后一行
'                        mclsMainControl_ToolRefresh
'                        Exit Sub
'                    End If
'                    .RemoveItem (intTop)
'                    Exit Do
'                Else
'                    .RemoveItem (intTop)
'                End If
'
'            Else
'                Exit Do
'            End If
'        Loop
'
'        If lngVoucherID_Cancel <> 0 Then '有冲销凭证删除
'            intTop = 1
'            i = .Row
'            Do While i > 1
'                If CLng(.TextMatrix(i, 0)) = lngVoucherID_Cancel Then
'                    i = i - 1
'                Else
'                    intTop = i + 1
'                    Exit Do
'                End If
'            Loop
'            If intTop >= .Rows Then Exit Sub
'            Do