frmvoucherlist.frm

金算盘软件代码

                " and Voucher.lngVoucherID = VoucherDetail.lngVoucherID"
    
    strSql = strSelect & strFromOfMe & strWhere
    
    Debug.Print "SqlExlbegine:" & time
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    Debug.Print "SqlExlend:" & time
    '列表是否为空
    If recTemp.RowCount = 0 Then
        grdList.HighLight = flexHighlightNever      '光标亮条消失
        cmdAgain.Enabled = False
    Else
        grdList.HighLight = flexHighlightAlways     '光标亮条显示
        cmdAgain.Enabled = True
    End If
    Set datGrid.Resultset = recTemp
    If Not datGrid.Resultset.EOF Then datGrid.Resultset.MoveLast
    datGrid.Resultset.Close
    mclsList.ShowAll = True
    'Set GetList = recTemp
    Debug.Print "Getlist:" & time
End Function

'根据列表中记录数，设置菜单可用属性
Private Sub UpdateMenuStatus()
    Dim i As Integer
    Dim lngVoucherID As Long
    Dim blnIsnotEmpty As Boolean
    Dim blnFindNoChange As Boolean
    Dim blnHaveRows As Boolean

On Error Resume Next
    
    If grdList.Rows = 1 Then
        blnHaveRows = False
    Else
        blnHaveRows = True
    End If
    
    If grdList.Rows > 1 And grdList.ColSel <> 0 And grdList.RowHeight(grdList.Row) > 0 Then
        blnIsnotEmpty = True
    Else
        blnIsnotEmpty = False
    End If
    
    
    If Not blnMenuBuilded Then
        MakeListEditMenu
    End If
    With frmMain
                        
        '注意：《修改》《删除》《作废》永远可见
        
        .mnuEditCopy.Enabled = blnIsnotEmpty
        .mnuEditEdit.Enabled = blnIsnotEmpty And blnEdit
        .mnuEditNew.Enabled = blnEdit
        .mnuEditDel.Enabled = blnIsnotEmpty And blnEdit ' And blnEdit
        
                
        .mnuEditInActive.Checked = False
        .mnuEditInActive.Enabled = blnIsnotEmpty And blnEdit  'And Trim(grdList.TextMatrix(grdList.Row, 1)) = ""
        If chkShowAll.Value = 1 Then
            .mnuEditShowAll.Checked = True
        Else
            .mnuEditShowAll.Checked = False
        End If
        If chkShowAll.Enabled = True Then
            .mnuEditShowAll.Enabled = True
        Else
            .mnuEditShowAll.Enabled = False
        End If
        .mnuEditColumn.Enabled = True
        .mnuEditFilter.Enabled = True
        .mnuFilePrint.Enabled = True
        .mnuFilePrintReceipt.Enabled = True
        .mnuReportQuick.Enabled = blnIsnotEmpty
        .mnuToolRefresh.Enabled = True
                
        
        If mclsVoucher.CheckRights Then
            .mnuListEditMenu(9).Enabled = blnIsnotEmpty ''复核/取消复核
            .mnuListEditMenu(12).Enabled = blnHaveRows  '多张复核
            .mnuListEditMenu(13).Enabled = blnHaveRows  '多张取消
        Else
            .mnuListEditMenu(9).Enabled = False
            .mnuListEditMenu(12).Enabled = False
            .mnuListEditMenu(13).Enabled = False
        End If
        If mclsVoucher.PostRights Then
            .mnuListEditMenu(10).Enabled = blnIsnotEmpty ''记帐/取消记帐
            .mnuListEditMenu(15).Enabled = blnHaveRows ''多张记帐
            .mnuListEditMenu(16).Enabled = blnHaveRows ''多张取消
        Else
            .mnuListEditMenu(10).Enabled = False ''记帐/取消记帐
            .mnuListEditMenu(15).Enabled = False ''多张记帐
            .mnuListEditMenu(16).Enabled = False ''多张取消
        End If
        
        .mnuEditEdit.Caption = "修改(&E)"
        .mnuEditNew.Caption = "新增(&N)"
        .mnuEditDel.Caption = "删除(&D)"
        
        .mnuEditInActive.Caption = "作废(&H)"
        .mnuEditShowAll.Caption = "全部显示(&W)"
        .mnuEditInActive.Visible = False
        
        '设置按纽菜单/右键菜单
        Utility.CloneMenu .mnuEditEdit, .mnuListEditMenu(0)       '修改
        Utility.CloneMenu .mnuEditNew, .mnuListEditMenu(1)        '新增
        Utility.CloneMenu .mnuEditDel, .mnuListEditMenu(2)        '删除
        Utility.CloneMenu .mnuEditBar2, .mnuListEditMenu(3)       '----
        .mnuListEditMenu(4).Caption = "冲销(&S)"                  '冲销
        .mnuListEditMenu(4).Enabled = blnIsnotEmpty
        .mnuListEditMenu(4).Visible = True
        Utility.CloneMenu .mnuEditBar2, .mnuListEditMenu(5)       '----
        Utility.CloneMenu .mnuEditInActive, .mnuListEditMenu(6)   '作废
        .mnuListEditMenu(6).Visible = True
        Utility.CloneMenu .mnuEditShowAll, .mnuListEditMenu(7)    '显示所有/显示非作废
        .mnuListEditMenu(7).Visible = True
        Utility.CloneMenu .mnuEditBar2, .mnuListEditMenu(8)       '----
        .mnuListEditMenu(8).Visible = True
        .mnuListEditMenu(9).Caption = "复核(&A)"                  '复核/取消复核
        .mnuListEditMenu(10).Caption = "记帐(&B)"                  '记帐/取消记帐
        Utility.CloneMenu .mnuEditBar2, .mnuListEditMenu(11)       '----
        .mnuListEditMenu(12).Caption = "多张复核(&I)"             '多张复核
        .mnuListEditMenu(13).Caption = "多张取消(&J)"             '多张取消
        Utility.CloneMenu .mnuEditBar2, .mnuListEditMenu(14)      '----
        .mnuListEditMenu(15).Caption = "多张记帐(&K)"             '多张记帐
        .mnuListEditMenu(16).Caption = "多张取消(&L)"             '多张取消
        Utility.CloneMenu .mnuEditBar2, .mnuListEditMenu(17)      '----
        Utility.CloneMenu .mnuEditFilter, .mnuListEditMenu(18)    '筛选
        Utility.CloneMenu .mnuEditColumn, .mnuListEditMenu(19)    '栏目设置
        Utility.CloneMenu .mnuEditBar2, .mnuListEditMenu(20)      '----
        Utility.CloneMenu .mnuToolRefresh, .mnuListEditMenu(21)   '刷新
        Utility.CloneMenu .mnuFilePrintReceipt, .mnuListEditMenu(22)
        Utility.CloneMenu .mnuFilePrint, .mnuListEditMenu(23)     '打印
        .mnuFilePrintSetup.Enabled = True
    End With
    
    If grdList.ColSel = 0 Then  '无当前选定行
        blnFindNoChange = mclsList.FindNoChange
        mclsList.FindNoChange = True
        txtfind.Text = ""
        mclsList.FindNoChange = blnFindNoChange
        cmdAgain.Enabled = False
    Else
        If grdList.Rows = 1 Then
            txtfind.Text = ""
        Else
            cmdAgain.Enabled = True
            txtfind.Text = grdList.TextMatrix(grdList.Row, intFindCol)
        End If
    End If
    frmMain.SetToolBar
End Sub

'重画Form
Private Sub RedrawForm()
    txtfind.width = Me.ScaleWidth - txtfind.Left - ListFormBottom - cmdAgain.width - 15
    cmdAgain.Left = txtfind.Left + txtfind.width
    cmdEdit.top = Me.ScaleHeight - cmdEdit.Height - ListFormBottom
    cmdReport.top = cmdEdit.top
    chkShowAll.top = cmdEdit.top
    chkShowAll.Left = Me.ScaleWidth - chkShowAll.width - ListFormBottom
    With grdList
        .Left = ListFormLeft
        .width = Me.ScaleWidth - ListFormLeft - ListFormRight
        .Height = Me.ScaleHeight - ListUpAreaHeight - ListDownAreaHeight
    End With
End Sub

'字符串过滤函数
Private Function FilterString(ByVal strText As String, Optional ByVal strFilt As String = ",") As String
    Dim nLen As Integer
    Dim nBit As Integer
    Dim strFlt As String
    Dim nFBit As Integer
    Dim intStart As Integer
    
    nLen = Len(strText)
    nFBit = Len(strFilt)
    strFlt = strText
    intStart = 1
    Do While InStr(intStart, strFlt, strFilt) <> 0
      nBit = InStr(intStart, strFlt, strFilt)
      If nBit = 0 Then Exit Do
        '如果在第一个位置出现
        If nBit = 1 Then
          strFlt = Mid(strFlt, nFBit + 1)
        Else
          strFlt = Left(strFlt, nBit - 1) & Right(strFlt, nLen - nBit - (nFBit - 1))
        End If
        nLen = Len(strFlt)
      If Trim(Mid(strFlt, nBit + nFBit, 1)) = "" Or Trim(Mid(strFlt, nBit + nFBit, 1)) = "," Then
      Else
        intStart = nBit + nFBit
      End If
    Loop
    FilterString = strFlt
End Function
 
Private Sub cmdAgain_Click()
    Dim i As Long
    Dim blnFound As Boolean
    Dim strTextFind  As String
    
    blnFound = False
    strTextFind = txtfind.Text
    With grdList
        If .Rows = 2 Then Exit Sub
        If .Row <> .Rows - 1 Then '当前行不是最后一行
            For i = .Row + 1 To .Rows - 1
            'For i = 1 To .Rows - 1
                If IsNumeric(strTextFind) Then
                   If Val(FilterString(strTextFind, ",")) = Val(IIf(IsNumeric(.TextMatrix(i, intFindCol)), FilterString(.TextMatrix(i, intFindCol), ","), 0)) Then
                      blnFound = True
                      cmdAgain.Enabled = True
                      GotoRow (i)
                      Exit For
                   End If
                Else
                   If StrComp(Trim(.TextMatrix(i, intFindCol)), Trim(strTextFind), vbTextCompare) = 0 Then  '       Left$(.TextMatrix(i, intFindCol), Len(strTextFind)), strTextFind, vbTextCompare) = 0 Then
                      blnFound = True
                      cmdAgain.Enabled = True
                      GotoRow (i)
                      Exit For
                   End If
                End If
            Next i
        End If
        If Not blnFound Then
            For i = 1 To .Row - 1
                If IsNumeric(strTextFind) Then
                   If Val(FilterString(strTextFind, ",")) = Val(IIf(IsNumeric(.TextMatrix(i, intFindCol)), FilterString(.TextMatrix(i, intFindCol), ","), 0)) Then
                      blnFound = True
                      cmdAgain.Enabled = True
                      GotoRow (i)
                      Exit For
                   End If
                Else
                   If StrComp(Trim(.TextMatrix(i, intFindCol)), Trim(strTextFind), vbTextCompare) = 0 Then  '       Left$(.TextMatrix(i, intFindCol), Len(strTextFind)), strTextFind, vbTextCompare) = 0 Then
                      blnFound = True
                      cmdAgain.Enabled = True
                      GotoRow (i)
                      Exit For
                   End If
                End If
            Next
        End If
        
        If blnFound Then
           cmdAgain.Enabled = True
        Else
           cmdAgain.Enabled = False
        End If
    End With
End Sub

Private Sub Form_Deactivate()
     frmMain.mnuEditInActive.Caption = strOldMenuCaption
     blnMenuBuilded = False
     frmMain.mnuEditSearch.Enabled = False
     frmMain.mnuFilePrintReceipt.Enabled = False
     frmMain.SetEditUnEnabled
End Sub

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

Private Sub mclsMainControl_FilePrintReceipt()
    frmPrintReceipt.ShowfrmPrintReceipt 29
End Sub

Private Sub mclsMainControl_FilePrintSetup()
    Dim myPrintclass As PrintClass
    Set myPrintclass = New PrintClass
    myPrintclass.PrintSetUp gclsBase.BaseDB, mclsList.FlexGrid, , , , 50, Me.Caption & Chr(1) & Trim(gclsBase.BaseName) & Chr(1) & gclsBase.OperatorName '记帐凭证
    Set myPrintclass = Nothing
End Sub

Private Sub mclsSubClass_WndProc(Msg As Long, wParam As Long, lParam As Long, Result As Long)
    mclsList.HookProc Msg, wParam, lParam, mclsSubClass
End Sub

Private Sub mclsSubClassForm_WndProc(Msg As Long, wParam As Long, lParam As Long, Result As Long)
    Dim MinMax As MINMAXINFO

    If Msg = WM_GETMINMAXINFO Then
        CopyMemory MinMax, ByVal lParam, Len(MinMax)
        
        MinMax.ptMinTrackSize.x = 350
        MinMax.ptMinTrackSize.y = 250
        
        CopyMemory ByVal lParam, MinMax, Len(MinMax)
        Result = 0
    End If
End Sub

'//////////////////////////////////////////////////////////////
'///////        窗体 Form 控件
'//////////////////////////////////////////////////////////////

Private Sub Form_Load()
    Dim i As Integer
    Dim arrCombox As String
    
    On Error GoTo ErrHandle
    MsgForm.PleaseWait       '显示等待窗体
    Screen.MousePointer = vbHourglass
    
    lngOldOperatorID = gclsBase.OperatorID
    
    '热键帮助(F1)
    Me.HelpContextID = 60014 ' 36003
    frmMain.mnuAccountVoucher.Tag = Me.hwnd
    blnEdit = IsCanDo(frmRightsID.frmVoucherListID)  '判断有无编辑权限
    
    intFindCol = 0
    txtfind.Text = ""
    
    Set mclsVoucher = New clsVoucherMethod
    mclsVoucher.SethWnd Me.hwnd
    Set theEditForm = FrmVoucher
    
    
    '付款条件列表窗体初始化
    
    Set mclsList = New list
    Set mclsList.Parent = Me
    mclsList.NoSort = True
    mclsList.FlexNoChange = True
    mclsList.FindNoChange = True
    Set mclsList.FlexGrid = grdList
    Set mclsList.FindKind = cboFindKind
    mclsList.ListSet.ViewId = intViewID
    
    mclsList.InitFlexGrid
    
'    '得到付款条件列表记录集
'    'Set datGrid.Recordset =
'        GetList
''    If Not datGrid.Recordset.EOF Then datGrid.Recordset.MoveLast
''    datGrid.Recordset.Close
'
'    mclsList.SetFlexGrid
'    '初始化查找复合列表框
'    mclsList.InitcboFindKind
'    mclsList.FlexNoChange = False
'    mclsList.FindNoChange = False
'    '设置第一行为选定行
'    With grdList
'        If .Rows > 1 Then grdList.Row = 1
'        .col = 0
'        .ColSel = .Cols - 1
'    End With
'    If chkShowAll.Value = 0 Then mclsList.DoShowAll False
'
'    UpdateMenuStatus
    Set mclsMainControl = gclsSys.MainControls.Add(Me)
    
    '设置钩子对象
    Set mclsSubClass = New SubClass32.SubClass
    mclsSubClass.hwnd = grdList.hwnd
    mclsSubClass.Messages(WM_PAINT) = True
    mclsSubClass.Messages(WM_LBUTTONUP) = True
    mclsSubClass.Messages(WM_LBUTTONDOWN) = True
    mclsSubClass.Messages(WM_MOUSEMOVE) = True
    Set mclsSubClassform = New SubClass32.SubClass
    mclsSubClassform.hwnd = Me.hwnd
    mclsSubClassform.Messages(WM_GETMINMAXINFO) = True
    Unload MsgForm
    Screen.MousePointer = vbDefault
    Exit Sub
    Dim edtErrReturn As ErrDealType
ErrHandle:
    edtErrReturn = Errors.ErrorsDeal
    
    If edtErrReturn = edtResume Then
         Resume
    Else
         On Error Resume Next
         Unload MsgForm
         Unload Me
    End If
End Sub

'右键菜单
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = vbRightButton And frmMain.ActiveForm Is Me Then
        MakeListEditMenu
        UpdateMenuStatus
        PopupMenu frmMain.mnuListEdit
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next