frmlisttrans.frm

金算盘软件代码

            
    strSql = strSelect & strFrom & strWhere & " Order By intTransVoucherNO"
    
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    'Debug.Print "StrSql:", strSQL
    If recTemp.BOF And recTemp.EOF Then
        '列表是否为空
        grdList.HighLight = flexHighlightNever      '光标亮条消失
        cmdAgain.Enabled = False
        cmdChangeIndex(0).Enabled = False
        cmdChangeIndex(1).Enabled = False
    Else
        recTemp.MoveLast
        recTemp.MoveFirst
        grdList.HighLight = flexHighlightAlways     '光标亮条显示
        cmdAgain.Enabled = True
        If recTemp.RowCount = 1 Then             '仅有一条记录，不需要上下移动
            cmdChangeIndex(0).Enabled = False
            cmdChangeIndex(1).Enabled = False
        Else
            cmdChangeIndex(0).Enabled = True
            cmdChangeIndex(1).Enabled = True
        End If
    End If
    
    Set GetList = recTemp
End Function

'根据列表中记录数，设置菜单可用属性
Private Sub UpdateMenuStatus()
    Dim blnIsnotEmpty As Boolean
    Dim blnFindNoChange As Boolean
    
    On Error GoTo ErrHandle
    If grdList.Rows > 1 And grdList.ColSel <> 0 Then
        blnIsnotEmpty = True
    Else
        blnIsnotEmpty = False
    End If
    
    If Not blnMenuBuilded Then
        MakeListEditMenu
    End If
    
    With frmMain
        
        .mnuEditCopy.Enabled = blnIsnotEmpty
        .mnuEditEdit.Enabled = blnIsnotEmpty
        .mnuEditNew.Enabled = blnEdit
        .mnuEditDel.Enabled = blnIsnotEmpty And blnEdit
        .mnuEditColumn.Enabled = True
        .mnuEditFilter.Enabled = True
        .mnuFilePrint.Enabled = True
        .mnuReportQuick.Enabled = blnIsnotEmpty
        .mnuToolRefresh.Enabled = True
        
        Utility.CloneMenu .mnuEditEdit, .mnuListEditMenu(0)       '修改
        .mnuListEditMenu(0).Caption = "修改(&E)"
        Utility.CloneMenu .mnuEditNew, .mnuListEditMenu(1)        '新增
        .mnuListEditMenu(1).Caption = "新增(&N)"
        Utility.CloneMenu .mnuEditDel, .mnuListEditMenu(2)        '删除
        .mnuListEditMenu(2).Caption = "删除(&D)"
        Utility.CloneMenu .mnuEditBar2, .mnuListEditMenu(3)       '----
        Utility.CloneMenu .mnuEditFilter, .mnuListEditMenu(4)     '筛选
        .mnuListEditMenu(4).Caption = "筛选(&F)"
        Utility.CloneMenu .mnuEditColumn, .mnuListEditMenu(5)     '栏目设置
        .mnuListEditMenu(5).Caption = "栏目设置(&M)"
        Utility.CloneMenu .mnuEditBar2, .mnuListEditMenu(6)       '----
        Utility.CloneMenu .mnuToolRefresh, .mnuListEditMenu(7)    '刷新
        Utility.CloneMenu .mnuFilePrint, .mnuListEditMenu(8)      '打印
    End With
    
    If grdList.ColSel = 0 Then  '无当前选定行
        blnFindNoChange = mclsList.FindNoChange
        mclsList.FindNoChange = True
        txtFind.Text = ""
        mclsList.FindNoChange = blnFindNoChange
        cmdAgain.Enabled = False
    Else
        cmdAgain.Enabled = True
        If grdList.Rows > 1 And grdList.Row > 0 Then
            txtFind.Text = grdList.TextMatrix(grdList.Row, intFindCol)
        Else
            txtFind.Text = ""
        End If
    End If
    frmMain.SetToolBar
    Exit Sub
ErrHandle:
End Sub

'重画Form
Private Sub RedrawForm()
    On Error Resume Next
    txtFind.width = Me.ScaleWidth - txtFind.Left - ListFormBottom - cmdAgain.width - 350
    cmdAgain.Left = txtFind.Left + txtFind.width
    cmdEdit.top = Me.ScaleHeight - cmdEdit.Height - ListFormBottom
    cmdReport.top = cmdEdit.top
   
    With grdList
        .Left = ListFormLeft
        .width = cmdAgain.Left + cmdAgain.width - ListFormLeft
        .Height = Me.ScaleHeight - ListUpAreaHeight - ListDownAreaHeight
    End With
    
    cmdChangeIndex(1).Left = grdList.Left + grdList.width + 50
    cmdChangeIndex(1).top = grdList.top + grdList.Height - cmdChangeIndex(1).Height
    cmdChangeIndex(0).Left = cmdChangeIndex(1).Left
    cmdChangeIndex(0).top = cmdChangeIndex(1).top - 30 - cmdChangeIndex(0).Height
End Sub


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
                If StrComp(Left$(.TextMatrix(i, intFindCol), Len(strTextFind)), strTextFind, vbTextCompare) = 0 Then
                    blnFound = True
                    GotoRow (i)
                    Exit For
                End If
            Next i
        End If
        If blnFound = False Then
            For i = 1 To .Row - 1
                If StrComp(Left$(.TextMatrix(i, intFindCol), Len(strTextFind)), strTextFind, vbTextCompare) = 0 Then
                    blnFound = True
                    GotoRow (i)
                    Exit For
                End If
            Next i
        End If
    End With
End Sub

Private Sub cmdChangeIndex_Click(Index As Integer)
    Dim arrValue() As String
    Dim i As Integer
    
    With grdList
    
        If .Row = 0 Then Exit Sub
        If .Rows < 3 Then Exit Sub
        
        Select Case Index
        Case 0
            If .Row = 1 Then Exit Sub
            ReDim arrValue(.Cols)
            For i = 0 To .Cols - 1
                arrValue(i) = .TextMatrix(.Row - 1, i)
            Next i
            For i = 0 To .Cols - 1
                .TextMatrix(.Row - 1, i) = .TextMatrix(.Row, i)
                .TextMatrix(.Row, i) = arrValue(i)
            Next i
            GotoRow .Row - 1
        Case 1
            If .Row = .Rows - 1 Then Exit Sub
            ReDim arrValue(.Cols)
            For i = 0 To .Cols - 1
                arrValue(i) = .TextMatrix(.Row + 1, i)
            Next i
            For i = 0 To .Cols - 1
                .TextMatrix(.Row + 1, i) = .TextMatrix(.Row, i)
                .TextMatrix(.Row, i) = arrValue(i)
            Next i
            GotoRow .Row + 1
        End Select
    End With
  
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
   If KeyCode = vbKeyEscape Then
      Unload Me
   End If
End Sub

Private Sub grdList_Click()
     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_EnterCell()
    If grdList.Rows > 1 And grdList.Row > 0 Then
        txtFind.Text = grdList.TextMatrix(grdList.Row, intFindCol)
    Else
        txtFind.Text = ""
    End If
End Sub

Private Sub grdList_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeySpace Then
       If grdList.Rows >= 2 Then
          If grdList.TextMatrix(grdList.Row, 1) = "√" Then
             grdList.TextMatrix(grdList.Row, 1) = ""
          Else
             grdList.TextMatrix(grdList.Row, 1) = "√"
          End If
       End If
    End If
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 = 430
        MinMax.ptMinTrackSize.y = 250
        
        CopyMemory ByVal lParam, MinMax, Len(MinMax)
        Result = 0
    End If
End Sub

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

Public Function ShowTransList()
    Dim i As Integer
    Dim intSortCol As Integer
    Dim edtErrReturn As ErrDealType
    
    On Error GoTo ErrHandle
    
    If Me.Visible Then
       Me.ZOrder
       Exit Function
    End If
    
    MsgForm.PleaseWait
    '热键帮助(F1)
    Me.HelpContextID = 60113
    SetHelpID 60113
    
    blnEdit = IsCanDo(frmRightsID.frmListTransID) '判断有无编辑权限
    
    intFindCol = 0
    
    gclsBase.FYearOfDate gclsBase.BaseDate, BeginDate, EndDate '当前时间对应的会计期间
    
    Set mclsBaseFun = New BaseFunction
    
    mclsBaseFun.Init gclsBase.BaseDB, gclsBase.BaseDate, , gclsBase.OperatorID
    
    Set mclsVoucherMethod = New clsVoucherMethod
    Set theEditForm = frmTransVoucher
    
    Set mclsList = New list
    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.Resultset = GetList()
    On Error Resume Next
    datGrid.Resultset.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
    mclsList.DoShowAll True
    
    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
    
    If grdList.Rows = 1 Then
        cmdAgain.Enabled = False
        txtFind.Text = ""
    End If
    Unload MsgForm
    Me.Show
    GetRateDirect
    Exit Function
ErrHandle:
    edtErrReturn = Errors.ErrorsDeal
    
    If edtErrReturn = edtResume Then
         Resume
    Else
         On Error Resume Next
         Screen.MousePointer = vbDefault
         Unload MsgForm
         Unload Me
    End If
End Function

'右键菜单
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
        UpdateMenuStatus
        PopupMenu frmMain.mnuListEdit
    End If
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
'    If UnloadMode = vbFormControlMenu And mIsShowEdit Then
'        cMsgBox "请先关闭通用转帐的编辑窗口 ！"
'        Cancel = True
'        theEditForm.SetFocus
'    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    mclsList.SaveListSet
    SaveOrder
    Filter.DelSelectedCond mclsList.ListSet.ListID, 1 '删除过滤条件
    Set mcolRateDirect = Nothing
    gclsSys.MainControls.Remove Me
    Set mclsMainControl = Nothing
    mclsBaseFun.TerminateClass
    Set mclsBaseFun = Nothing
End Sub

Private Sub Form_Resize()
    On Error Resume Next