frmcustomlist.frm

金算盘软件代码

        Case 5
            If strofWhere <> "" Then
                strofWhere = " where " & strofWhere & " and Custom5.lngCustomID=" & lngID
            Else
                strofWhere = " where Custom5.lngCustomID=" & lngID
            End If
    End Select
    strSql = strSql & strofFrom & strofWhere
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    With recTemp
        If .RowCount > 0 Then
            txtFind.Text = recTemp(strSortDec)   '查找
            With mclsList(intTab).FlexGrid
                If .TextMatrix(.Row, 0) = lngID Then      '是否找到
                    Showlist = True
                Else
                    Showlist = False
                End If
            End With
        Else
            Showlist = False
        End If
        .Close
    End With
End Function

'反映是否有卡片存在
Public Property Let IsShowCard(ByVal vNewValue As Boolean)
   mIsShowCard = vNewValue
End Property
Public Property Get IsShowCard() As Boolean
   IsShowCard = mIsShowCard
End Property

'按照部门职员ID提取记录
Public Function GetbyListID(ByVal intTab As Integer, ByVal lngID As Long) As rdoResultset
    Dim recRecordset As rdoResultset
    Dim strSql As String
    
    Select Case intTab
        Case 0
            strSql = "Select * From Custom0 Where lngCustomID = " & lngID
        Case 1
            strSql = "Select * From Custom1 Where lngCustomID = " & lngID
        Case 2
            strSql = "Select * From Custom2 Where lngCustomID = " & lngID
        Case 3
            strSql = "Select * From Custom3 Where lngCustomID = " & lngID
        Case 4
            strSql = "Select * From Custom4 Where lngCustomID = " & lngID
        Case 5
            strSql = "Select * From Custom5 Where lngCustomID = " & lngID
    End Select
    Set recRecordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    Set GetbyListID = recRecordset
End Function

'按照部门职员ID更新停用标志
Private Function UpdateListInActive(ByVal intTab As Integer, ByVal lngID As Long, ByVal blnIsInActive As Boolean) As Boolean
    Dim strSql As String
    
    Select Case intTab
        Case 0
            strSql = "UPDATE Custom0 SET blnIsInActive = " & IIf(blnIsInActive, 1, 0) & " WHERE lngCustomID = " & lngID
        Case 1
            strSql = "UPDATE Custom1 SET blnIsInActive = " & IIf(blnIsInActive, 1, 0) & " WHERE lngCustomID = " & lngID
        Case 2
            strSql = "UPDATE Custom2 SET blnIsInActive = " & IIf(blnIsInActive, 1, 0) & " WHERE lngCustomID = " & lngID
        Case 3
            strSql = "UPDATE Custom3 SET blnIsInActive = " & IIf(blnIsInActive, 1, 0) & " WHERE lngCustomID = " & lngID
        Case 4
            strSql = "UPDATE Custom4 SET blnIsInActive = " & IIf(blnIsInActive, 1, 0) & " WHERE lngCustomID = " & lngID
        Case 5
            strSql = "UPDATE Custom5 SET blnIsInActive = " & IIf(blnIsInActive, 1, 0) & " WHERE lngCustomID = " & lngID
    End Select
    UpdateListInActive = gclsBase.ExecSQL(strSql)
End Function

'删除部门职员ID指定记录
Private Function DelByPaymentMethodID(ByVal lngID As Long, ByVal intTab As Integer) As Boolean
    Dim strSql As String
    
    Select Case intTab
        Case 0
            strSql = "Delete  From Custom0 WHERE lngCustomID = " & lngID
        Case 1
            strSql = "Delete  From Custom1 WHERE lngCustomID = " & lngID
        Case 2
            strSql = "Delete  From Custom2 WHERE lngCustomID = " & lngID
        Case 3
            strSql = "Delete  From Custom3 WHERE lngCustomID = " & lngID
        Case 4
            strSql = "Delete  From Custom4 WHERE lngCustomID = " & lngID
        Case 5
            strSql = "Delete  From Custom5 WHERE lngCustomID = " & lngID
    End Select
    DelByPaymentMethodID = gclsBase.ExecSQL(strSql)
End Function

'判断部门职员ID是否使用
Private Function IsUsePaymentMethodID(ByVal lngID As Long) As Boolean
    Dim recRecordset As rdoResultset
    Dim strSql As String
    
    Select Case sstCustom.Tab
            Case 0
                strSql = "Select lngCustomID From Custom0 " & strPartofSQL("lngCustomID0", lngID)
            Case 1
                strSql = "Select lngCustomID From Custom1 " & strPartofSQL("lngCustom1", lngID)
            Case 2
                strSql = "Select lngCustomID From Custom2 " & strPartofSQL("lngCustom2", lngID)
            Case 3
                strSql = "Select lngCustomID From Custom3 " & strPartofSQL("lngCustom3", lngID)
            Case 4
                strSql = "Select lngCustomID From Custom4 " & strPartofSQL("lngCustom4", lngID)
            Case 5
                strSql = "Select lngCustomID From Custom5 " & strPartofSQL("lngCustom5", lngID)
    End Select
    
    Set recRecordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    IsUsePaymentMethodID = (recRecordset.RowCount >= 1)
    recRecordset.Close
End Function

' 部门职员ID
Public Property Get ListID(ByVal intTab As Integer) As Long
    With mclsList(intTab).FlexGrid
        If .TextArray(.Row * .Cols) <> "" And .Row > 0 Then
            ListID = CLng(.TextArray(.Row * .Cols))
        Else
            ListID = 0
        End If
    End With
End Property

' 部门职员停用标志
Public Property Get ListIsInActive(ByVal intTab As Integer) As Boolean
    If chkShowall.Value Then
        With mclsList(intTab).FlexGrid
            ListIsInActive = Not (.TextArray(.Row * .Cols + 1) = "")
        End With
    Else
        ListIsInActive = False
    End If
End Property

'根据列表中记录数，设置菜单可用属性
Private Sub UpdateMenuStatus()
    Dim blnIsnotEmpty As Boolean
    Dim blnFindNoChange As Boolean
    Dim IsHaveRight As Boolean
    
    IsHaveRight = IsCanDo(17, gclsBase.OperatorID)
    With mclsList(sstCustom.Tab).FlexGrid
        If .Rows > 1 And .ColSel <> 0 And .RowHeight(.Row) > 0 Then
            blnIsnotEmpty = True
        Else
            blnIsnotEmpty = False
        End If
    End With
    With frmMain
        .mnuEditEdit.Caption = "修改(&E)"
        .mnuEditNew.Caption = "新增(&N)"
        .mnuEditDel.Caption = "删除(&D)"
        .mnuEditCopy.Enabled = blnIsnotEmpty
        .mnuEditEdit.Enabled = blnIsnotEmpty And IsHaveRight
        .mnuEditNew.Enabled = True And IsHaveRight
        .mnuEditDel.Enabled = blnIsnotEmpty And IsHaveRight
        .mnuEditInActive.Checked = False
        .mnuEditInActive.Visible = False
        .mnuEditInActive.Enabled = blnIsnotEmpty And IsHaveRight
        .mnuEditShowAll.Checked = chkShowall.Value
        .mnuEditShowAll.Enabled = True
        .mnuEditUse.Enabled = blnIsnotEmpty
        .mnuEditNotepad.Enabled = blnIsnotEmpty
        .mnuEditSearch.Enabled = True
        .mnuEditColumn.Enabled = True
        .mnuEditFilter.Enabled = True
        .mnuFilePrint.Enabled = True
        .mnuReportQuick.Enabled = blnIsnotEmpty
        .mnuToolRefresh.Enabled = True
        .mnuFilePrintSetup.Enabled = True
    End With
    
    If mclsList(sstCustom.Tab).FlexGrid.ColSel = 0 Then  '无当前选定行
        blnFindNoChange = mclsList(sstCustom.Tab).FindNoChange
        mclsList(sstCustom.Tab).FindNoChange = True
        txtFind.Text = ""
        mclsList(sstCustom.Tab).FindNoChange = blnFindNoChange
        cmdAgain.Enabled = False
    End If
    frmMain.SetToolBar
End Sub

'重画Form
Private Sub RedrawForm()
    On Error Resume Next
    With sstCustom
        .Left = ListFormLeft
        .width = Me.ScaleWidth - ListFormLeft - ListFormRight
        .Height = Me.ScaleHeight - ssTabUpAreaHeight - ListDownAreaHeight
    End With
    
    '重画MS FlexGrid 控件
    With mclsList(sstCustom.Tab).FlexGrid
        .Left = ListGridLeft
        .width = sstCustom.width - ListGridLeft - ListGridRight
        .Height = sstCustom.Height - sstCustom.TabHeight - ListGridTop - ListGridBottom
    End With
    
    '重画其余控件
    txtFind.width = Me.ScaleWidth - txtFind.Left - ListFormBottom - cmdAgain.width - 15
    cmdAgain.Left = txtFind.Left + txtFind.width
    cmdEAR(0).top = Me.ScaleHeight - cmdEAR(0).Height - ListFormBottom
    cmdEAR(1).top = cmdEAR(0).top
   
    chkShowall.top = cmdEAR(0).top
    chkShowall.Left = Me.ScaleWidth - chkShowall.width - ListFormBottom
End Sub

'命令控件数组
Private Sub cmdEAR_Click(Index As Integer)
    Dim PosX, PosY As Integer
    
    PosX = cmdEAR(Index).Left
    PosY = cmdEAR(Index).top + cmdEAR(Index).Height
    With frmMain
        Select Case Index
               Case 0
                    MakeListEditMenu
                    PopupMenu .mnuListEdit, , PosX, PosY
               Case 1
                    MakeListReportMenu (getDepEmp())
                    PopupMenu .mnuListReport, , PosX, PosY
        End Select
    End With
End Sub

'取部门职员
Private Function getDepEmp() As String
    Dim strDepEmp As String
    
    Select Case sstCustom.Tab
           Case 0
            strDepEmp = GetNameStr(msgCustom0, "自定项目名称")
'                If msgItemType.Row > 0 And msgItemType.ColSel > 0 Then
'                    With msgItemType
'                      .Redraw = False
'                      For i = 1 To .cols - 1
'                          If .TextMatrix(0, i) = "商品类型名称" Then
'                             strDepEmp = .TextMatrix(.Row, i)
'                             Exit For
'                          End If
'                      Next
'                      .Redraw = True
'                    End With
'                Else
'                   strDepEmp = ""
'
'                End If
            Case 1
                strDepEmp = GetNameStr(msgCustom1, "自定项目名称")
            Case 2
                strDepEmp = GetNameStr(msgCustom2, "自定项目名称")
            Case 3
               strDepEmp = GetNameStr(msgCustom3, "自定项目名称")
            Case 4
                strDepEmp = GetNameStr(msgCustom4, "自定项目名称")
            Case 5
                strDepEmp = GetNameStr(msgCustom5, "自定项目名称")
    End Select
    getDepEmp = strDepEmp
End Function

Private Sub Form_Deactivate()
    frmMain.SetEditUnEnabled
End Sub

'
'窗体 Form 控件
'
Private Sub Form_Load()
    Dim intCount As Integer
    Dim i As Integer
    Dim intSortCol As Integer
    Dim intResponse As Integer
    On Error GoTo ErrHandle
'    Me.Hide
'    Me.Left = -30000

    MsgForm.PleaseWait
    Me.HelpContextID = 30029
    InitsstCustom
    '部门职员列表窗体初始化
    Debug.Print "Load Start: ", Timer
    For i = 0 To 5
    intViewID(i) = 24 + i
   ' intViewID(1) = 55
    Next
    
    For i = 0 To 5
        Set mclsList(i) = New list
        Set mclsList(i).FindKind = cboFindKind
        'Set mclsList(i).Again = cmdAgain
        Set mclsList(i).Find = txtFind
    Next
    Set mclsList(0).FlexGrid = msgCustom0
    Set mclsList(1).FlexGrid = msgCustom1
    Set mclsList(2).FlexGrid = msgCustom2
    Set mclsList(3).FlexGrid = msgCustom3
    Set mclsList(4).FlexGrid = msgCustom4
    Set mclsList(5).FlexGrid = msgCustom5
    Set mclsMainControl = gclsSys.MainControls.Add(Me)
  
    
    '设置钩子对象
    Set mclsSubClass = New SubClass32.SubClass
    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
    
'    For intCount = 0 To 5
'        If sstCustom.TabVisible(intCount) Then Exit For
'    Next
'    If intCount < 6 Then
'        If intCount = sstCustom.Tab Then
'            sstCustom_Click intCount
'        Else
'            sstCustom.Tab = intCount
'        End If
'    End If
Debug.Print "Load End: ", Timer
    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
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
    UpdateMenuStatus
End Sub

Private Sub Form_Paint()
    DrawInSertLine Me.hwnd, ListFormLeft, 500, Me.width - 2 * (ListFormLeft + ListFormRight), 500
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer)
    On Error Resume Next
    If KeyAscii = vbKeyEscape Then
        Unload Me
    ElseIf KeyAscii = vbKeyReturn Then