frmalisttemplate.frm

金算盘软件代码

End Property
'自定义菜单有效页面
Public Property Let SpEnableOnPageNo(ByVal Index As Integer, ByVal vNewValue As Integer)
    mintEnableOnPageNo(Index) = vNewValue
End Property
'自定义菜单有效的特性（一致有效或跟随有效）
Public Property Let blnConstant(ByVal Index As Integer, ByVal vNewValue As Boolean)
    mblnConstant(Index) = vNewValue
End Property
'制作SQL
Private Function MakeListSql(ByVal intPageNo As Integer) As Boolean
    Dim recRecordset As rdoResultset
    Dim strSelectOfSql As String
    Dim strFromOfSql As String
    Dim strWhereOfSql As String
    Dim strOrderBy As String
    Dim strSql As String
    Dim strCSql As String
    Dim strGroup As String
    Dim strHavingofsql As String
    
    Debug.Print "ExeSQLStart: " & Timer
    strOrderBy = " Order By " & mclsList.SortCol + 2 & Choose(mclsList.SortType, " Asc ", " Desc ")
    strSelectOfSql = mclsList.ListSet.GetSelect
    strFromOfSql = mclsList.ListSet.FromOfSql
    strWhereOfSql = mclsList.ListSet.WhereOfSql
    strHavingofsql = mclsList.ListSet.HavingOfSql
    
    If Trim(mstrSelect(intPageNo)) <> "" Then
        strSelectOfSql = "Select " & mstrSelect(intPageNo) & "," & strSelectOfSql
    End If
    If Trim(strWhereOfSql) <> "" Then
        If mstrWhere(intPageNo) <> "" Then
            strWhereOfSql = strWhereOfSql & " and " & mstrWhere(intPageNo)
        End If
    Else
        If mstrWhere(intPageNo) <> "" Then
            strWhereOfSql = mstrWhere(intPageNo)
        End If
    End If
     Debug.Print "ExeSQLWhereStart: " & Timer
'    If Not mclsList.ShowAll Then
'        If Trim(mstrShowAllWhere(intPageNo)) <> "" Then
'            If Trim(strWhereOfSql) <> "" Then
'                strWhereOfSql = strWhereOfSql & " and " & mstrShowAllWhere(intPageNo)
'            Else
'                strWhereOfSql = mstrShowAllWhere(intPageNo)
'            End If
'        End If
'    End If
    If Trim(strWhereOfSql) <> "" Then
        strWhereOfSql = " Where " & strWhereOfSql
    End If
    
    If Trim(strHavingofsql) <> "" Then
        If mstrHaving(intPageNo) <> "" Then
            strHavingofsql = " Having " & strHavingofsql & " and " & mstrHaving(intPageNo)
        Else
            strHavingofsql = " Having " & strHavingofsql
        End If
    Else
        If mstrHaving(intPageNo) <> "" Then
            strHavingofsql = " Having " & mstrHaving(intPageNo)
        End If
    End If
    
    If Trim(mstrGroupby(intPageNo)) <> "" Then
        strGroup = " Group By " & mstrGroupby(intPageNo)
    End If
     
    Dim lngRecCount As Long
    Debug.Print "ExeSQLGetRowReusltSetStart: " & Timer
    If Trim(strGroup) = "" Then
        'strSql = strSelectOfSql & strFromOfSql & strReplace(strWhereOfSql, "*", "%") & strOrderBy
        strSql = strSelectOfSql & strFromOfSql & strWhereOfSql & strOrderBy
        strCSql = " Select Count(*)  As Num " & strFromOfSql & strWhereOfSql
        Set recRecordset = gclsBase.BaseDB.OpenResultset(strCSql, rdOpenForwardOnly) 'dbOpenForwardOnly
        'recRecordset.Open strCSql, gclsBase.AdoConnect, adOpenForwardOnly
        If Not recRecordset.EOF Then lngRecCount = recRecordset!Num
    Else
        'strSql = strSelectOfSql & strFromOfSql & strReplace(strWhereOfSql, "*", "%") & strGroup & strHavingofsql & strOrderBy
        strSql = strSelectOfSql & strFromOfSql & strWhereOfSql & strGroup & strHavingofsql & strOrderBy
        strCSql = " Select Count(*)  As Num " & strFromOfSql & strWhereOfSql & strGroup & strHavingofsql
        Set recRecordset = gclsBase.BaseDB.OpenResultset(strCSql, rdOpenStatic) 'dbOpenForwardOnly
        'recRecordset.Open strCSql, gclsBase.AdoConnect, adOpenStatic
        If Not recRecordset.EOF Then recRecordset.MoveLast
        lngRecCount = recRecordset.RowCount
    End If
    recRecordset.Close
    Set recRecordset = Nothing
     Debug.Print "ExeSQLGetRowReusltSetEnd: " & Timer
    'Set recRecordset = gclsBase.BaseDB.OpenRecordset(strCSql, dbOpenSnapshot) 'dbOpenForwardOnly
'     If m_Connect.State = 1 Then
'        m_Connect.Close
'     End If
'     m_Connect.Open
'    If mclsList.Resultset(intPageNo).State = 1 Then
'        mclsList.Resultset(intPageNo).Close
'    End If
    
     Debug.Print "ExeSQLGetReusltSetStart: " & Timer
    'mclsList.Resultset(intPageNo).Open strSql, m_Connect, adOpenStatic 'adOpenDynamic, adLockOptimistic 'adOpenStatic
    Set mclsList.Resultset(intPageNo) = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
   ' Debug.Print "End:" & Timer
    Debug.Print "ExeSQLGetReusltSetEnd: " & Timer
    mclsList.TotalRow(intPageNo) = lngRecCount
     
    mclsList.intTab = intPageNo
    If lngRecCount = 0 Then
        cmdAgain.Enabled = False
    Else
        cmdAgain.Enabled = True
    End If
     Debug.Print "ExeSQLEnd: " & Timer
End Function
'获得ID值
Public Function ListID() As Long
'    With mclsList.DbTabCtrl
'        If .CellValue(.Row, 0) <> "" Then
'            ListID = CLng(.CellValue(.Row, 0))
'        Else
'            ListID = 0
'        End If
'    End With
    Dim lngID As Long
    ListID = 0
    With mclsList
        If .TotalRow(.intTab) < 1 Then Exit Function
        If .DbTabCtrl.Row > .TotalRow(.intTab) + 1 Then .DbTabCtrl.Row = .TotalRow(.intTab) + 1
        .Resultset(.intTab).AbsolutePosition = .DbTabCtrl.Row
        lngID = IIf(IsNull(.Resultset(.intTab).rdoColumns(0).Value), 0, .Resultset(.intTab).rdoColumns(0).Value)
        If Trim(lngID) <> "" Then
            ListID = CLng(lngID)
        Else
            ListID = 0
        End If
    End With
End Function
'当前行是否停用
Public Function IsInActive() As Boolean
    With mclsList.DbTabCtrl
        If Trim(.CellValue(.Row, 1)) <> "" Then
            IsInActive = IIf(Trim(.CellValue(.Row, 1)) = "√", True, False)
        Else
            IsInActive = False
        End If
    End With
End Function

'初始查找列
Public Sub intcboFindKind()
    Dim intSortCol As Integer
    Dim intCount As Integer
    Dim intItem As Integer
    
    cboFindKind.Clear
    mclsList.SortCol = 0
    mclsList.SortType = 1
    For intCount = 1 To mclsList.ListSet.Columns
        If mclsList.ListSet.ColumnIsFind(intCount) Then
            cboFindKind.AddItem mclsList.ListSet.ColumnDesc(intCount)
            Select Case UCase(mclsList.ListSet.ColumnFieldType(intCount))
                Case "INTEGER", "LONG", "DOUBLE"
                    cboFindKind.ItemData(intItem) = 1
                Case Else
                    cboFindKind.ItemData(intItem) = 10 + mclsList.ListSet.ColumnFieldSize(intCount)
            End Select
            
            If mclsList.ListSet.ColumnOrderType(intCount) <> 0 Then
                intSortCol = intItem
                mclsList.SortCol = intCount + 1
                mclsList.FindColName = mclsList.ListSet.ColumnFieldName(intCount)
                'ozj注释
                If mclsList.ListSet.ColumnOrderType(intCount) = 1 Then
                    mclsList.ListSet.ColumnOrderType(intCount) = 1
                    mclsList.SortType = 1
                Else
                    mclsList.ListSet.ColumnOrderType(intCount) = 2
                    mclsList.SortType = 2
                End If
            End If
            intItem = intItem + 1
        End If
    Next
    cboFindKind.ListIndex = intSortCol
End Sub

'重新刷新当前页
Public Function ToolRefresh() As Boolean
    Dim strSql As String
    mclsList.DbTabCtrl.Clear
    MakeListSql mclsList.intTab
    mclsList.SetGridFormate
    mclsList.DbTabCtrl.Refresh
    mclsList.frmDoShowAll
    UpdateEditMenuStatus
    
End Function
'重新构造数据
Private Function ReMakeData()
     With mclsList
        .ListSet.ViewId = mintViewId(.intTab)
        intcboFindKind
        mclsList.DbTabCtrl.Clear
        MakeListSql .intTab
        mclsList.SetGridFormate
        mclsList.DbTabCtrl.Refresh
    End With
    UpdateEditMenuStatus
End Function
'重画窗体
Private Sub RedrawForm()
Dim blnisWanVersion As Boolean
Dim blnIsItemInit As Boolean
On Error Resume Next
#If conWan <> 1 Then
    blnisWanVersion = False
#Else
    blnisWanVersion = True
#End If
Select Case mclsList.ListSet.ViewId
    Case 529, 530, 531, 532, 533, 534, 535
        blnIsItemInit = True
    Case Else
        blnIsItemInit = False
End Select

cmdEAR(2).Visible = blnIsItem

'#If conQSH = 1 Then         '强生专版
#If conVersionType = 1 Then  '标准版
    cmdEAR(3).Visible = blnIsEmployee
#Else
    cmdEAR(3).Visible = False
#End If

If Not blnReceptionList Or blnIsItemInit Then
    lblEdit(0).Visible = False
    lblEdit(1).Visible = False
    cmdEAR(0).Visible = True
    cmdEAR(1).Visible = False
Else
    If blnisWanVersion Then
        cmdEAR(0).Visible = False
        cmdEAR(1).Visible = False
        If Not blnIsHavingReport Then
            lblEdit(0).Visible = True
            lblEdit(1).Visible = False
        Else
            lblEdit(0).Visible = True
            lblEdit(1).Visible = True
        End If
    Else
        lblEdit(0).Visible = False
        lblEdit(1).Visible = False
        If Not blnIsHavingReport Then
            cmdEAR(0).Visible = True
            cmdEAR(1).Visible = False
        Else
            cmdEAR(0).Visible = True
            cmdEAR(1).Visible = True
        End If
    End If
End If
    
If blnisWanVersion And blnReceptionList And Not blnIsItemInit Then
    With pctDataGrid
        .top = 500
        .Left = ListFormLeft
        .width = Me.ScaleWidth - ListFormLeft - ListFormRight
        .Height = Me.ScaleHeight - ListUpAreaHeight - ListDownAreaHeight + 300
    End With
    lblEdit(0).top = txtFind.top '+ lblFindKind.Height + 200 ' Me.ScaleHeight - cmdEdit.Height - ListFormBottom
    lblEdit(0).Left = ListFormLeft
    If blnIsHavingReport Then
        lblEdit(1).top = lblEdit(0).top
        lblEdit(1).Left = lblEdit(0).Left + lblEdit(0).width
        lblFindKind.Left = lblEdit(1).Left + lblEdit(1).width + 100
    Else
        lblFindKind.Left = lblEdit(0).Left + lblEdit(0).width + 100
    End If
    
    cboFindKind.Left = lblFindKind.Left + lblFindKind.width
    lblFind.Left = cboFindKind.Left + cboFindKind.width + 200
    txtFind.Left = lblFind.Left + lblFind.width
    txtFind.width = Me.ScaleWidth - txtFind.Left - ListFormBottom - cmdAgain.width - 100 - chkShowall.width
    cmdAgain.Left = txtFind.Left + txtFind.width
    chkShowall.top = cmdAgain.top
    chkShowall.Left = Me.ScaleWidth - chkShowall.width - ListFormRight ' ListFormBottom
Else
    If mTabs > 1 Then
        With sstPages
            .top = 600
            .Left = ListFormLeft
            .width = Me.ScaleWidth - ListFormLeft - ListFormRight
            .Height = Me.ScaleHeight - ssTabUpAreaHeight - ListDownAreaHeight
        End With
        '重画MS DataGrid 控件
        With pctDataGrid
            .Left = ListGridLeft
            .width = sstPages.width - ListGridLeft - ListGridRight
            .Height = sstPages.Height - sstPages.TabHeight - ListGridTop - ListGridBottom
        End With
    Else
        With pctDataGrid
            .top = 500
            .Left = ListFormLeft
            .width = Me.ScaleWidth - ListFormLeft - ListFormRight
            .Height = Me.ScaleHeight - ListUpAreaHeight - ListDownAreaHeight
        End With
    End If
    '重画其余控件
    If blnIsItem Then
        cmdEAR(2).Left = cmdEAR(0).Left + cmdEAR(0).width
    Else
        cmdEAR(1).Left = cmdEAR(0).Left + cmdEAR(0).width
    End If
    If blnIsEmployee Then
        cmdEAR(3).Left = cmdEAR(0).Left + cmdEAR(0).width
    Else
        cmdEAR(1).Left = cmdEAR(0).Left + cmdEAR(0).width
    End If
    
    txtFind.width = Me.ScaleWidth - txtFind.Left - ListFormBottom - cmdAgain.width - 15
    cmdAgain.Left = txtFind.Left + txtFind.width
    cmdEAR(0).Left = ListFormLeft
    cmdEAR(1).Left = cmdEAR(0).Left + cmdEAR(0).width
    cmdEAR(0).top = Me.ScaleHeight - cmdEAR(0).Height - ListFormBottom
    cmdEAR(1).top = cmdEAR(0).top
    cmdEAR(2).top = cmdEAR(0).top
    cmdEAR(3).top = cmdEAR(0).top
    chkShowall.top = cmdEAR(0).top
    chkShowall.Left = Me.ScaleWidth - chkShowall.width - ListFormBottom
End If
End Sub
'查找列
Private Sub cboFindKind_Click()
    Dim intCount As Integer
    Dim blnFindKindIsChange As Boolean
    Dim strOldText As String
    
    blnFindKindIsChange = False
    strOldText = txtFind.Text
    
    With mclsList.ListSet
        For intCount = 1 To .Columns
            If mclsList.ListSet.ColumnIsFind(intCount) Then
                If .ColumnDesc(intCount) = cboFindKind.Text Then
                    If mclsList.SortCol <> intCount Then
                        .ColumnOrderType(mclsList.SortCol) = 0
                         .ColumnOrderType(intCount) = 1
                         mclsList.SortCol = intCount
                         mclsList.FindColName = .ColumnDesc(intCount)
                         blnFindKindIsChange = True
                         Exit For
                    Else
                        If mclsList.SortType = 1 Then
                            mclsList.SortType = 2
                        Else
                            mclsList.SortType = 1
                        End If
                         blnFindKindIsChange = True
                         Exit For
                    End If
                End If
            End If
        Next
    End With
    If blnFindKindIsChange And mclsList.intTab = sstPages.Tab And IsFind Then
        ToolRefresh 'ReSortGrid '重新排序查找
        With mclsList
        If .DbTabCtrl.Row < .DbTabCtrl.Rows Then
            If Not .Resultset(.intTab).EOF And Not .Resultset(.intTab).BOF Then
                '.Resultset(.intTab).MoveFirst
                '.Resultset(.intTab).Move .DbTabCtrl.Row - 1, 1
                .Resultset(.intTab).AbsolutePosition = .DbTabCtrl.Row '- 1
            End If
        Else
            .DbTabCtrl.Row = .DbTabCtrl.Rows - 1
            If Not mclsList.Resultset(.intTab).EOF And Not mclsList.Resultset(.intTab).BOF Then
                '.Resultset(.intTab).MoveFirst
                '.Resultset(.intTab).Move .DbTabCtrl.Row - 1, 1
                .Resultset(.intTab).AbsolutePosition = .DbTabCtrl.Row '- 1
            End If
        End If
    
        If Not .Resultset(.intTab).EOF And Not .Resultset(.intTab).BOF Then txtFind.Text = IIf(IsNull(.Resultset(.intTab).rdoColumns(.SortCol + 1).Value), "", .Resultset(.intTab).rdoColumns(.SortCol + 1).Value)
        End With
    End If
End Sub
'全部显示
Private Sub chkShowAll_Click()
    mclsList.ShowAll = Not mclsList.ShowAll
    RaiseEvent ListShowAll
    mclsList.frmDoShowAll
End Sub