frmpositionlist.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 frmPositionList 
   Caption         =   "商品货位"
   ClientHeight    =   3660
   ClientLeft      =   105
   ClientTop       =   345
   ClientWidth     =   6825
   LinkTopic       =   "Form1"
   MDIChild        =   -1  'True
   ScaleHeight     =   3660
   ScaleWidth      =   6825
   Begin MSRDC.MSRDC datTerm 
      Height          =   330
      Left            =   5640
      Top             =   3240
      Visible         =   0   'False
      Width           =   1200
      _ExtentX        =   2117
      _ExtentY        =   582
      _Version        =   327681
      Options         =   0
      CursorDriver    =   1
      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.TextBox txtFind 
      Height          =   300
      Left            =   3360
      TabIndex        =   8
      Text            =   "Text1"
      Top             =   90
      Width           =   2925
   End
   Begin VB.ComboBox cboFindKind 
      Height          =   300
      ItemData        =   "frmPositionList.frx":0000
      Left            =   900
      List            =   "frmPositionList.frx":0002
      Style           =   2  'Dropdown List
      TabIndex        =   2
      Top             =   90
      Width           =   1515
   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            =   6285
      Style           =   1  'Graphical
      TabIndex        =   1
      Tag             =   "1017"
      ToolTipText     =   "再找"
      Top             =   90
      UseMaskColor    =   -1  'True
      Width           =   300
   End
   Begin VB.CheckBox chkShowAll 
      Caption         =   "全部显示"
      Height          =   350
      Left            =   4140
      TabIndex        =   0
      Top             =   3210
      Width           =   1095
   End
   Begin MSFlexGridLib.MSFlexGrid msgTerm 
      Bindings        =   "frmPositionList.frx":0004
      Height          =   2565
      Left            =   195
      TabIndex        =   3
      Tag             =   "ctPayMethod////101"
      Top             =   540
      Width           =   6495
      _ExtentX        =   11456
      _ExtentY        =   4524
      _Version        =   65541
      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 MSForms.CommandButton cmdPosition 
      Height          =   350
      Index           =   0
      Left            =   50
      TabIndex        =   7
      Tag             =   "1018"
      Top             =   3210
      WhatsThisHelpID =   5010
      Width           =   1215
      Caption         =   "编辑"
      PicturePosition =   196613
      Size            =   "2143;617"
      FontName        =   "宋体"
      FontHeight      =   180
      FontCharSet     =   134
      FontPitchAndFamily=   34
      ParagraphAlign  =   3
   End
   Begin MSForms.CommandButton cmdPosition 
      Height          =   345
      Index           =   1
      Left            =   1260
      TabIndex        =   6
      Tag             =   "1018"
      Top             =   3210
      WhatsThisHelpID =   5010
      Width           =   1215
      Caption         =   "报表"
      PicturePosition =   196613
      Size            =   "2143;609"
      FontName        =   "宋体"
      FontHeight      =   180
      FontCharSet     =   134
      FontPitchAndFamily=   34
      ParagraphAlign  =   3
   End
   Begin VB.Label lblFindKind 
      AutoSize        =   -1  'True
      Caption         =   "查找(&F)"
      Height          =   180
      Left            =   50
      TabIndex        =   5
      Top             =   150
      Width           =   630
   End
   Begin VB.Label lblFind 
      AutoSize        =   -1  'True
      Caption         =   "内容(&C)"
      Height          =   180
      Left            =   2595
      TabIndex        =   4
      Top             =   150
      Width           =   630
   End
End
Attribute VB_Name = "frmPositionList"
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 mblnFormNoRezise As Boolean                             '不需要响应form_Rezise事件

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                                        '列表对象
Private mblnIsSaveListset As Boolean                           'Whether or not save lngViewID in List

Private Const intViewID = 53                                   '视图ID
'Private Const intFormWidth = 5100                               '窗体最小宽度
'Private Const intFormHeight = 3000                              '窗体最小高度

'
'方法及函数
'

Public Property Let IsShowCard(ByVal vNewValue As Boolean)
   mIsShowCard = vNewValue
End Property
Public Property Get IsShowCard() As Boolean
   IsShowCard = mIsShowCard
End Property
'产生付款条件列表记录集
Public Function GetList() 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.SelectOfSql
    strFromOfSql = mclsList.ListSet.FromOfSql
    strWhereOfSql = mclsList.ListSet.WhereOfSql
    strSelectOfSql = "Select Position.lngPositionID  id,decode(Position.blnIsInActive,'1','√','0','')  ""停用""," & strSelectOfSql
    If strWhereOfSql <> "" Then
        strWhereOfSql = " Where  " & strWhereOfSql
    
    End If
  
    strSql = strSelectOfSql & strFromOfSql & strWhereOfSql
    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
Public Function ShowList(ByVal lngID As Long) As Boolean
    Dim intCount As Integer
    Dim strSortField As String
    Dim strSortDec As String
    Dim strSql As String
    Dim recTemp As rdoResultset
    Dim strofFrom As String
    Dim strofWhere As String
    Me.Show
    Me.ZOrder 0
    With mclsList.ListSet
        '得到排序字段
        For intCount = 1 To .Columns
            If .ColumnOrderType(intCount) <> 0 Then
                strSortField = .ColumnFieldName(intCount)
                strSortDec = .ColumnDesc(intCount)
                Exit For
            End If
        Next
        If intCount > .Columns Then
            ShowList = False
            Exit Function
        End If
        strofFrom = .FromOfSql
        strofWhere = .WhereOfSql
    End With
    '根据lngID得到排序字段值
    strSql = "Select " & strSortField & " As " & strSortDec
    If strofWhere <> "" Then
        strofWhere = " where " & strofWhere & "and Position.lngPositionID=" & lngID
    Else
        strofWhere = " where Position.lngPositionID=" & lngID
    End If
    strSql = strSql & strofFrom & strofWhere
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    With recTemp
        If .RowCount > 0 Then
            txtFind.Text = recTemp(strSortDec)   '查找
            If msgTerm.TextMatrix(msgTerm.Row, 0) = lngID Then     '是否找到
                ShowList = True
            Else
                ShowList = False
            End If
        Else
            ShowList = False
        End If
        .Close
    End With
End Function

'按照付款条件ID提取记录
Public Function GetByTermID(ByVal lngID As Long) As rdoResultset
    Dim recRecordset As rdoResultset
    Dim strSql As String
    
    strSql = "Select * From Position Where lngPositionID = " & 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 Position SET blnIsInActive = " & blnIsInActive & " WHERE lngPositionID = " & lngID
    
    UpdateTermInActive = gclsBase.ExecSQL(strSql)
End Function

'删除付款条件ID指定记录
Private Function DelByTermID(ByVal lngID As Long) As Boolean
    Dim strSql As String
    
    strSql = "Delete * From Position Where lngPositionID = " & 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 lngPositionID From Item Where lngPositionID = " & 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
        TermID = CLng(.TextArray(.Row * .Cols))
    Else
        TermID = 0
    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
        .mnuEditEdit.Caption = "修改(&N)"
        .mnuEditNew.Caption = "新增(&E)"
        .mnuEditDel.Caption = "删除(&D)"
        .mnuEditCopy.Enabled = blnIsnotEmpty
        .mnuEditEdit.Enabled = blnIsnotEmpty
        .mnuEditNew.Enabled = True
        .mnuEditDel.Enabled = blnIsnotEmpty
        .mnuEditInActive.Enabled = blnIsnotEmpty
        .mnuEditShowAll.Checked = chkShowAll.Value
        .mnuEditShowAll.Enabled = True
        .mnuEditUse.Enabled = blnIsnotEmpty
        .mnuEditColumn.Enabled = True
        .mnuEditFilter.Enabled = True
        .mnuEditSearch.Enabled = True
        .mnuEditNotepad.Enabled = blnIsnotEmpty
        .mnuFilePrint.Enabled = True
        .mnuFilePrintSetup.Enabled = True
       ' .mnuAccountVoucher.Enabled = blnIsnotEmpty
        .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
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