frmloglist.frm

金算盘软件代码

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
        PopupMenu frmMain.mnuListEdit
    End If
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    If UnloadMode = vbFormControlMenu And mIsShowCard Then
        MsgBox "请先关闭清除卡片！", vbExclamation
        Cancel = True
        frmClearLog.Show
        frmClearLog.ZOrder 0
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    mclsList.SaveListSet
    frmMain.mnuToolLog.Tag = 0
    Set mclsSubClass = Nothing
    Set mclsSubClassform = Nothing
    Set mclsList = Nothing
    gclsSys.MainControls.Remove Me
    Set mclsMainControl = Nothing
End Sub

Private Sub Form_Resize()
    On Error Resume Next
    If Me.WindowState = 1 Then Exit Sub
    If Me.Left + Me.width < 0 Or Me.Left > Screen.width Then
       Me.Left = 300
    End If
    RedrawForm
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer)
    On Error Resume Next
    If KeyAscii = vbKeyEscape Then
        Unload Me
    ElseIf KeyAscii = vbKeyReturn Then
        BKKEY Me.ActiveControl.hwnd, vbKeyTab
    End If
End Sub
Private Sub Form_Activate()
    SetHelpID Me.HelpContextID
    gclsSys.CurrFormName = Me.hwnd
    mclsMainControl_ChildActive
'    If msgTerm.Enabled Then msgTerm.SetFocus
    msgTerm.Redraw = True
    UpdateMenuStatus
    If (Me.Left + Me.width < 0 Or Me.Left > Screen.width) Then Me.Left = 300
    If Me.WindowState = 1 Then Me.WindowState = 0
End Sub

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

Private Sub mclsMainControl_ChildActive()
    Dim vntMessage As Variant
    
    SetHelpID Me.HelpContextID
    '响应消息
    For Each vntMessage In mclsMainControl.Messages
        If vntMessage = Message.msglog Then '接收到付款条件改变消息
            mclsMainControl_ToolRefresh
            mclsMainControl.Messages.Remove CStr(vntMessage) '清除付款条件改变消息
        End If
    Next
    mclsMainControl.Messages.Clear
    UpdateMenuStatus
End Sub

Private Sub mclsMainControl_FilePrintSetup()
    Dim MyPrintSet As PrintClass
    Set MyPrintSet = New PrintClass
    MyPrintSet.PrintSetUp gclsBase.BaseDB, mclsList.FlexGrid, , , , 34, " " & Chr(1) & gclsBase.BaseName & Chr(1) & gclsBase.OperatorName
    Set MyPrintSet = Nothing
End Sub

Private Sub mclsMainControl_ListReportMenu(ByVal intIndex As Integer)
    Report.ShowListReport 1381, 34
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

Private Sub msgTerm_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = vbRightButton Then
        Form_MouseDown Button, Shift, x, y
    End If
End Sub

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

Private Sub txtFind_KeyDown(KeyCode As Integer, Shift As Integer)
    Dim intSelLen As Integer
    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 mclsMainControl_EditDel()
    Dim lngID As Long
    Dim recRecordset As rdoResultset
    lngID = TermID
    If mIsShowCard Then
'        If lngID = frmTermCard.TermID Then
'            MsgBox "不能删除当前编辑的付款条件！", vbExclamation
'            frmTermCard.SetFocus
'            Exit Sub
'        End If
    End If
    
    Set recRecordset = GetByTermID(lngID)
    'If recRecordset.RecordCount = 0 Then    '当前付款条件已被其他用户删除
    '    mclsMainControl_ToolRefresh
    'Else
        If IsUseTermID(lngID) Then
            MsgBox "当前编辑的付款条件正在使用，不能删除！", vbExclamation
        Else
            If recRecordset!blnIsDetail Then
                If DelByTermID(lngID) Then
                   ' mclsMainControl_ToolRefresh
                   With msgTerm
                    .RowHeight(.Row) = 0
                    .RowData(.Row) = 1
                    mclsList.SetFlexRow
                   End With
                   gclsSys.SendMessage CStr(Me.hwnd), Message.msglog
                End If
                
            Else
                ShowMsg "不是末级编码，不能删除！", vbCritical, Me.Caption
            End If
        End If
    'End If
    recRecordset.Close
End Sub

'筛选
Private Sub mclsMainControl_EditFilter()
   
    If mclsList.ListSet.ListID < 1 Then mclsList.ListSet.SaveList
    Filter.ShowFilter mclsList.ListSet.ListID, 1, , , , , mblnFlage
    If Not mblnFlage Then Exit Sub
    mclsList.SaveListSet
    mclsList.ListSet.ViewId = intViewID
    msgTerm.Cols = 0
    Set datTerm.Resultset = GetList(True)
    If Not datTerm.Resultset.EOF Then datTerm.Resultset.MoveLast
    datTerm.Resultset.Close
    'Set datTerm.Recordset = Nothing
    mclsList.SetFlexGrid
    UpdateMenuStatus
    '初始化查找复合列表框
    mclsList.InitcboFindKind
    'If chkShowAll.Value = 0 Then
    mclsList.DoShowAll False
    
End Sub

'栏目设置
Private Sub mclsMainControl_EditColumn()
    Dim strFind As String
    Dim strSort As String
    Dim intCount As Integer
    
    With msgTerm
        strFind = .TextMatrix(.Row, mclsList.SortCol)
        strSort = cboFindKind.Text
        If mclsList.ListSet.ShowListSet(intViewID) Then
            .Redraw = False
            msgTerm.Cols = 0
            Set datTerm.Resultset = GetList(True)
            If Not datTerm.Resultset.EOF Then datTerm.Resultset.MoveLast
            datTerm.Resultset.Close
            'Set datTerm.Recordset = Nothing
            mclsList.SetFlexGrid
            UpdateMenuStatus
            '初始化查找复合列表框
            mclsList.InitcboFindKind
            For intCount = 0 To cboFindKind.ListCount - 1
                If cboFindKind.list(intCount) = strSort Then
                    txtFind.Text = strFind
                    Exit For
                End If
            Next intCount
            'If chkShowAll.Value = 0 Then
            mclsList.DoShowAll False
            .Redraw = True
        End If
    End With
End Sub

'刷新
Private Sub mclsMainControl_ToolRefresh()
    Dim strOldSort As String
    Dim strOldText As String
    Me.MousePointer = vbHourglass
    With msgTerm
        '保存当前排序列
        strOldSort = cboFindKind.Text
        strOldText = .TextMatrix(.Row, mclsList.SortCol)
        mclsList.SaveListColWidth
        .Redraw = False
        '刷新列表记录
        .Cols = 0
        Set datTerm.Resultset = GetList(True)
        If Not datTerm.Resultset.EOF Then datTerm.Resultset.MoveLast
        datTerm.Resultset.Close
        'Set datTerm.Recordset = Nothing
        mclsList.SetFlexGrid
        '恢复以前排序列
        cboFindKind.Text = strOldSort
        cboFindKind.Text = strOldSort
        .Redraw = False
        If .Rows > 1 Then
            txtFind.Text = strOldText
        End If
        mclsList.DoShowAll False
        '更新菜单状态
        UpdateMenuStatus
        .Redraw = True
        '发出付款条件消息
    
    End With
    Me.MousePointer = vbDefault
End Sub

'打印
Private Sub mclsMainControl_FilePrint()
    Dim myPrintclass As PrintClass
    Set myPrintclass = New PrintClass
    mclsList.ReGetColCaption
    myPrintclass.PrintList gclsBase.BaseDB, mclsList.FlexGrid, 34, Me.Caption & Chr(1) & gclsBase.BaseName & Chr(1) & gclsBase.OperatorName
    mclsList.AddReGetColCaption
    Set myPrintclass = Nothing
End Sub

'响应“编辑”菜单
Private Sub mclsMainControl_ListEditMenu(ByVal intIndex As Integer)
    Select Case intIndex
        Case 0:
            frmClearLog.ClearLog TermID, FilterTerm
            Me.ZOrder 0
        Case 2:
            'DoClear
            mclsMainControl_EditFilter
        Case 4:
            mclsMainControl_EditColumn
        Case 6
            mclsMainControl_ToolRefresh
        Case 7:
            mclsMainControl_FilePrint
    End Select
End Sub
'
' 编辑菜单
'
Private Sub MakeListEditMenu()
    Dim intCnt As Integer
   
    With frmMain
        For intCnt = .mnuListEditMenu.Count - 1 To 1 Step -1
            Unload .mnuListEditMenu(intCnt)
        Next
        .mnuListEditMenu(0).Caption = "清除"
        .mnuListEditMenu(0).Visible = True
        If mclsList.FlexGrid.Rows > 1 Then
            .mnuListEditMenu(0).Enabled = True
        Else
            .mnuListEditMenu(0).Enabled = False
        End If
        
        Load .mnuListEditMenu(1)
        Utility.CloneMenu .mnuEditBar2, .mnuListEditMenu(1)
        'Utility.CloneMenu .mnuEditColumn, .mnuListEditMenu(1)
'        .mnuListEditMenu(1).Caption = "取消筛选"
'        .mnuListEditMenu(1).Enabled = mblnFlage
'        .mnuListEditMenu(1).Visible = True
        
        Load .mnuListEditMenu(2)
        Utility.CloneMenu .mnuEditFilter, .mnuListEditMenu(2)
        
        Load .mnuListEditMenu(3)
        Utility.CloneMenu .mnuEditBar2, .mnuListEditMenu(3)
        .mnuListEditMenu(3).Visible = False
        
        Load .mnuListEditMenu(4)
        Utility.CloneMenu .mnuEditColumn, .mnuListEditMenu(4)
        
        Load .mnuListEditMenu(5)
        Utility.CloneMenu .mnuEditBar2, .mnuListEditMenu(5)
        
        Load .mnuListEditMenu(6)
        Utility.CloneMenu .mnuToolRefresh, .mnuListEditMenu(6)
        Load .mnuListEditMenu(7)
        Utility.CloneMenu .mnuFilePrint, .mnuListEditMenu(7)
    End With
End Sub
'
' 报表菜单
'
Private Sub MakeListReportMenu()
    Dim intCnt As Integer
    
    With frmMain
        For intCnt = .mnuListReportMenu.Count - 1 To 1 Step -1
            Unload .mnuListReportMenu(intCnt)
        Next
        .mnuListReportMenu(0).Caption = "操作日志表(&T)"
        .mnuListReportMenu(0).Enabled = True
       ' .mnuListReportMenu(0).Visible = False
    End With
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 UndoFilter()
'    'Filter.ShowFilter mclsList.ListSet.ListID, 1
'    mclsList.SaveListSet
'    mclsList.ListSet.ViewId = intViewID
'    msgTerm.Cols = 0
'    Set datTerm.Recordset = GetList(False)
'    If Not datTerm.Recordset.EOF Then datTerm.Recordset.MoveLast
'    datTerm.Recordset.Close
'    'Set datTerm.Recordset = Nothing
'    mclsList.SetFlexGrid
'    UpdateMenuStatus
'    '初始化查找复合列表框
'    mclsList.InitcboFindKind
'    'If chkShowAll.Value = 0 Then
'    mclsList.DoShowAll False
'
'End Sub
'操作日志表
Private Sub OperatorLogTable()

End Sub


'清除
Private Sub DoClear()
    
    
End Sub


Public Property Get FilterTerm() As String
    Dim FromOfSql As String
    Dim strWhereOfSql As String
    Dim strSql As String
    FromOfSql = mclsList.ListSet.FromOfSql
    strWhereOfSql = mclsList.ListSet.WhereOfSql
    If strWhereOfSql <> "" Then
        strSql = "lnglogID In ( Select Log.lngLogid " & FromOfSql & " Where " & strWhereOfSql & ")"
    End If
    FilterTerm = strSql
End Property

Public Function BindingResultSet()
    Me.Hide
    Set datTerm.Resultset = GetList(True)
    If Not datTerm.Resultset.EOF Then datTerm.Resultset.MoveLast
    datTerm.Resultset.Close
    'Set datTerm.Recordset = Nothing
    mclsList.SetFlexGrid
    mclsList.InitcboFindKind
    mclsList.FlexNoChange = False
    mclsList.FindNoChange = False
    
    With msgTerm
        If .Rows > 1 Then msgTerm.Row = 1
        .col = 0
        .ColSel = .Cols - 1
    End With
    Debug.Print "Load End: ", Timer
    mclsList.DoShowAll False
    UpdateMenuStatus
    Me.Show
    Me.ZOrder 0
End Function