frmloglist.frm

金算盘软件代码

VERSION 5.00
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX"
Object = "{0D452EE1-E08F-101A-852E-02608C4D0BB4}#2.0#0"; "FM20.DLL"
Object = "{F6125AB1-8AB1-11CE-A77F-08002B2F4E98}#2.0#0"; "MSRDC20.OCX"
Begin VB.Form frmLogList 
   Caption         =   "上机日志"
   ClientHeight    =   3672
   ClientLeft      =   60
   ClientTop       =   348
   ClientWidth     =   6876
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form2"
   LockControls    =   -1  'True
   MDIChild        =   -1  'True
   ScaleHeight     =   3672
   ScaleWidth      =   6876
   Begin MSRDC.MSRDC datTerm 
      Height          =   324
      Left            =   5136
      Top             =   3192
      Visible         =   0   'False
      Width           =   1164
      _ExtentX        =   2053
      _ExtentY        =   572
      _Version        =   393216
      Options         =   0
      CursorDriver    =   0
      BOFAction       =   0
      EOFAction       =   0
      RecordsetType   =   1
      LockType        =   3
      QueryType       =   0
      Prompt          =   3
      Appearance      =   1
      QueryTimeout    =   30
      RowsetSize      =   100
      LoginTimeout    =   15
      KeysetSize      =   0
      MaxRows         =   0
      ErrorThreshold  =   -1
      BatchSize       =   15
      BackColor       =   -2147483643
      ForeColor       =   -2147483640
      Enabled         =   -1  'True
      ReadOnly        =   0   'False
      Appearance      =   -1  'True
      DataSourceName  =   ""
      RecordSource    =   ""
      UserName        =   ""
      Password        =   ""
      Connect         =   ""
      LogMessages     =   ""
      Caption         =   "MSRDC1"
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin VB.CheckBox chkShowAll 
      Caption         =   "全部显示"
      Height          =   255
      Left            =   3960
      TabIndex        =   7
      Top             =   3210
      Visible         =   0   'False
      Width           =   1095
   End
   Begin VB.CommandButton cmdAgain 
      BeginProperty Font 
         Name            =   "Arial"
         Size            =   9
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   300
      Left            =   6255
      Style           =   1  'Graphical
      TabIndex        =   4
      Tag             =   "1017"
      ToolTipText     =   "再找"
      Top             =   90
      UseMaskColor    =   -1  'True
      Width           =   300
   End
   Begin VB.ComboBox cboFindKind 
      Height          =   300
      ItemData        =   "frmLogList.frx":0000
      Left            =   870
      List            =   "frmLogList.frx":0002
      Style           =   2  'Dropdown List
      TabIndex        =   1
      Top             =   90
      Width           =   1515
   End
   Begin VB.TextBox txtFind 
      Height          =   300
      Left            =   3330
      TabIndex        =   3
      Text            =   "Text1"
      Top             =   90
      Width           =   2925
   End
   Begin MSFlexGridLib.MSFlexGrid msgTerm 
      Bindings        =   "frmLogList.frx":0004
      Height          =   2475
      Left            =   90
      TabIndex        =   5
      Tag             =   "ctPayMethod////101"
      Top             =   480
      Width           =   6495
      _ExtentX        =   11451
      _ExtentY        =   4360
      _Version        =   393216
      Rows            =   20
      Cols            =   3
      FixedCols       =   0
      BackColor       =   16777215
      BackColorFixed  =   -2147483644
      BackColorSel    =   -2147483646
      BackColorBkg    =   16777215
      Redraw          =   -1  'True
      AllowBigSelection=   0   'False
      FocusRect       =   0
      SelectionMode   =   1
      AllowUserResizing=   1
   End
   Begin VB.Label lblFind 
      AutoSize        =   -1  'True
      Caption         =   "内容(&C)"
      Height          =   180
      Left            =   2565
      TabIndex        =   2
      Top             =   150
      Width           =   630
   End
   Begin VB.Label lblFindKind 
      AutoSize        =   -1  'True
      Caption         =   "查找(&B)"
      Height          =   180
      Left            =   45
      TabIndex        =   0
      Top             =   150
      Width           =   630
   End
   Begin MSForms.CommandButton cmdPosition 
      Height          =   345
      Index           =   0
      Left            =   50
      TabIndex        =   6
      Tag             =   "1018"
      Top             =   3240
      WhatsThisHelpID =   5010
      Width           =   1215
      Caption         =   "编辑"
      PicturePosition =   196613
      Size            =   "2143;609"
      FontName        =   "宋体"
      FontHeight      =   180
      FontCharSet     =   134
      FontPitchAndFamily=   34
      ParagraphAlign  =   3
   End
   Begin MSForms.CommandButton cmdPosition 
      Height          =   345
      Index           =   1
      Left            =   1140
      TabIndex        =   8
      TabStop         =   0   'False
      Tag             =   "1018"
      Top             =   3780
      Visible         =   0   'False
      WhatsThisHelpID =   5010
      Width           =   1215
      Caption         =   "报表"
      PicturePosition =   196613
      Size            =   "2143;609"
      TakeFocusOnClick=   0   'False
      FontName        =   "宋体"
      FontHeight      =   180
      FontCharSet     =   134
      FontPitchAndFamily=   34
      ParagraphAlign  =   3
   End
End
Attribute VB_Name = "frmLogList"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'上机日志模块
'      作者：欧中建
'      日期：1998.6.10
'1.1 所用类模块：List
'1.2 所用钩子函数：mclsSubClass，mclsSubClassForm。

Option Explicit

Private mIsShowCard As Boolean                                  '卡片窗口显示标志
Private mblnCheckNoChange As Boolean                            '不需要响应chkshowAll控件Change事件
Private WithEvents mclsMainControl As MainControl               '主控对象
Attribute mclsMainControl.VB_VarHelpID = -1
Private WithEvents mclsSubClass As SubClass32.SubClass          '“钩子”对象
Attribute mclsSubClass.VB_VarHelpID = -1
Private WithEvents mclsSubClassform As SubClass32.SubClass
Attribute mclsSubClassform.VB_VarHelpID = -1
Private mclsList As list                                        '列表对象
Dim mblnFlage As Boolean
Private Const intViewID = 34                                   '视图ID

'
'方法及函数
'

Public Property Let IsShowCard(ByVal vNewValue As Boolean)
   mIsShowCard = vNewValue
End Property

'产生付款条件列表记录集
Public Function GetList(blnCondition As Boolean) As rdoResultset
    Dim recRecordset As rdoResultset
    Dim strSelectOfSql As String
    Dim strFromOfSql As String
    Dim strWhereOfSql As String
    Dim strSql As String
    
    strSelectOfSql = mclsList.ListSet.GetSelect
    strFromOfSql = mclsList.ListSet.FromOfSql
    strWhereOfSql = mclsList.ListSet.WhereOfSql
    strSelectOfSql = "Select Log.lngLogID As id,''As ""停用""," & strSelectOfSql
    If Trim(strWhereOfSql) <> "" Then
        strWhereOfSql = " Where  " & strWhereOfSql
    End If
    
    If blnCondition Then
        strSql = strSelectOfSql & strFromOfSql & strWhereOfSql
    Else
        strSql = strSelectOfSql & strFromOfSql
    End If
    Set recRecordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    
    '列表是否为空
    If recRecordset.RowCount = 0 Then
        msgTerm.HighLight = flexHighlightNever      '光标亮条消失
        cmdAgain.Enabled = False
    Else
        msgTerm.HighLight = flexHighlightAlways     '光标亮条显示
        cmdAgain.Enabled = True
    End If
    mclsList.ShowAll = True
    Set GetList = recRecordset
End Function

'按照付款条件ID提取记录
Public Function GetByTermID(ByVal lngID As Long) As rdoResultset
    Dim recRecordset As rdoResultset
    Dim strSql As String
    
    strSql = "Select * From Log Where lngLogID = " & lngID
    Set recRecordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    Set GetByTermID = recRecordset
End Function

'按照付款条件ID更新停用标志
Private Function UpdateTermInActive(ByVal lngID As Long, ByVal blnIsInActive As Boolean) As Boolean
    Dim strSql As String
    
    strSql = "UPDATE Log SET blnIsInActive = " & IIf(blnIsInActive, 1, 0) & " WHERE lngLogID = " & lngID
    UpdateTermInActive = gclsBase.ExecSQL(strSql)
End Function

'删除付款条件ID指定记录
Private Function DelByTermID(ByVal lngID As Long) As Boolean
    Dim strSql As String
    
    strSql = "Delete  From Log Where lngLogID = " & lngID
    DelByTermID = gclsBase.ExecSQL(strSql)
End Function

'判断付款条件ID是否使用
Private Function IsUseTermID(ByVal lngID As Long) As Boolean
    Dim recRecordset As rdoResultset
    Dim strSql As String
    
    strSql = "Select lngLogID From Item Where lngLogID = " & lngID
    Set recRecordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    IsUseTermID = (recRecordset.RowCount >= 1)
    recRecordset.Close
End Function

'得到付款条件ID
Public Property Get TermID() As Long
    With msgTerm
        If .TextArray(.Row * .Cols) <> "" And .Row > 0 Then
            If .TextMatrix(.Row, 0) <> "" Then TermID = CLng(.TextArray(.Row * .Cols))
        End If
    End With
End Property

'得到付款条件停用标志
Public Property Get TermIsInActive() As Boolean
    If chkShowAll.Value Then
        With msgTerm
            TermIsInActive = Not (.TextArray(.Row * .Cols + 1) = "")
        End With
    Else
        TermIsInActive = False
    End If
End Property

'根据列表中记录数，设置菜单可用属性
Private Sub UpdateMenuStatus()
    Dim blnIsnotEmpty As Boolean
    Dim blnFindNoChange As Boolean
    
    If msgTerm.Rows > 1 And msgTerm.ColSel <> 0 And msgTerm.RowHeight(msgTerm.Row) > 0 Then
        blnIsnotEmpty = True
    Else
        blnIsnotEmpty = False
    End If
    With frmMain
        .mnuEditFilter.Enabled = True
        .mnuEditColumn.Enabled = True
        
        .mnuFilePrint.Enabled = True
        .mnuFilePrintSetup.Enabled = True
       ' .mnuReportQuick.Enabled = blnIsNotEmpty
        .mnuToolRefresh.Enabled = True
    End With
        
    If msgTerm.ColSel = 0 Then  '无当前选定行
        blnFindNoChange = mclsList.FindNoChange
        mclsList.FindNoChange = True
        txtFind.Text = ""
        mclsList.FindNoChange = blnFindNoChange
        cmdAgain.Enabled = False
    End If
    frmMain.SetToolBar
End Sub

'重画Form
Private Sub RedrawForm()
    '重画MS FlexGrid 控件
    On Error Resume Next
    With msgTerm
        .Left = ListFormLeft
        .width = Me.ScaleWidth - ListFormLeft - ListFormRight
        .Height = Me.ScaleHeight - ListUpAreaHeight - ListDownAreaHeight
    End With
    
    '重画其余控件
    txtFind.width = Me.ScaleWidth - txtFind.Left - ListFormBottom - cmdAgain.width - 15
    cmdAgain.Left = txtFind.Left + txtFind.width
    cmdPosition(0).top = Me.ScaleHeight - cmdPosition(0).Height - ListFormBottom
    cmdPosition(1).top = cmdPosition(0).top
'    chkShowAll.Top = cmdPosition(0).Top
 '   chkShowAll.Left = Me.ScaleWidth - chkShowAll.Width - ListFormBottom
End Sub

Private Sub cmdPosition_Click(Index As Integer)
    Select Case Index
        Case 0
             MakeListEditMenu
             PopupMenu frmMain.mnuListEdit, , cmdPosition(0).Left, cmdPosition(0).top + cmdPosition(0).Height
        Case 1
            MakeListReportMenu
            PopupMenu frmMain.mnuListReport, , cmdPosition(1).Left, cmdPosition(1).top + cmdPosition(1).Height
    End Select
End Sub

Private Sub Form_Deactivate()
    frmMain.SetEditUnEnabled
End Sub

'
'窗体 Form 控件
'
Private Sub Form_Load()
    Dim i As Integer
    Dim intSortCol As Integer
    On Error GoTo ErrHandle
'    Me.Hide
'    Me.Left = -30000
    MsgForm.PleaseWait
    Me.HelpContextID = 80004
    frmMain.mnuToolLog.Tag = Me.hwnd
    '付款条件列表窗体初始化
    Debug.Print "Load Start: ", Timer
    Set mclsList = New list
    mclsList.FlexNoChange = True
    mclsList.FindNoChange = True
    Set mclsList.FlexGrid = msgTerm
    Set mclsList.FindKind = cboFindKind
    Set mclsList.Find = txtFind
    Set mclsList.Again = cmdAgain
    mclsList.ListSet.ViewId = intViewID
    mclsList.InitFlexGrid
'    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
    
    Set mclsMainControl = gclsSys.MainControls.Add(Me)
 
    '设置钩子对象
    Set mclsSubClass = New SubClass32.SubClass
    mclsSubClass.hwnd = msgTerm.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
     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