【vba源码】连续窗体排序不再麻烦，快看这里！

hi，大家好！

天气渐渐放凉，大家最近都在忙点啥呢？

今天我们来讲点啥呢？今天给大家分享一个排序示例。

相应大家在平时开发中，都会用到连续窗体，但我们在用连续窗体时，如果遇到排序问题，对于连续窗体就比较麻烦，不像数据表窗体，可以直接下拉选择排序，OK，那我们来看看怎么实现。

01、表设计

首先，我们还是一样，先来创建一张表，当然如果你有现成的表，可以跳过这一步。

表创建后，我们还需要添加一些测试数据。

02、创建窗体

这里，我们就需要用我们刚刚创建的表做为数据源来创建一个连续窗体了。

接着，我们再添加一个按钮，放一个排序按钮，按钮名称为：btnSort

03、添加类

这里我们封装了一个类，我们把这个源码给到大家，大家复制一下代码，把下面的代码放到类模块里面就可以了。

Option Explicit

Private m_frmCurrentForm As Object

Private m_ctlCurrentSortField As Control

Private m_ctlCurrentSortButton As Control

Private m_ctlPrevSortField As Control

Private m_ctlPrevSortButton As Control




Const SORT_DESC = "D"    'Created for easy code reading of

Const SORT_ASC = "A"      'sort status (numbers were random chosen)

Const SORT_NONE = "N"     'Status stored in sorted field's .Tag property





Public Property Get CurrentForm() As Object

    On Error GoTo Property_Err





    Set CurrentForm = m_frmCurrentForm

    Exit Property





Property_Exit:

    Exit Property





Property_Err:

    MsgBox "The following error occurred In Property Get CurrentForm: " & Error$

    Resume Property_Exit





End Property





Public Property Set CurrentForm(frm As Object)

    On Error GoTo Property_Err





    Set m_frmCurrentForm = frm





    Exit Property





Property_Exit:

    Exit Property





Property_Err:

    MsgBox "The following error occurred In Property Set CurrentForm: " & Error$

    Resume Property_Exit









End Property

Public Sub GoSort()

    On Error GoTo GoSort_Err

    Const NAVY = 10040115    'Default button caption color (not sorted)

    Const RED = 255       'Sorted Ascending button caption color

    Const GREEN = 32768   'Sorted Descending button caption color





    Dim fFirstSort As Boolean

    Dim fChangeSortColumn As Boolean





    'If no data to sort the exit

    If Me.CurrentForm.RecordsetClone.RecordCount = 0 Then

        Exit Sub

    End If

    'Initialize booleans

    fFirstSort = False

    fChangeSortColumn = False

    On Error Resume Next

    If PrevSortField <> Me.CurrentSortField Then

        'Sort is on a new column

        If Err <> 0 Then

            Err.Clear

            fFirstSort = True

        Else

            fChangeSortColumn = True

            With PrevSortButton

                .ForeColor = NAVY

                .ControlTipText = ""

            End With

        End If

    End If





    On Error GoTo GoSort_Err

    Select Case Me.CurrentSortField.Tag    'Choices are 'D', 'A', or 'N'

    Case SORT_ASC

        Me.CurrentForm.Form.OrderBy = "[" & Me.CurrentSortField.ControlSource & "]" & " DESC"

        Me.CurrentSortField.Tag = SORT_DESC

        With Me.CurrentSortButton

            .ForeColor = GREEN

            .ControlTipText = "Sorted Descending by " & .Caption

        End With





    Case SORT_DESC

        Me.CurrentForm.Form.OrderBy = "[" & Me.CurrentSortField.ControlSource & "]"

        Me.CurrentSortField.Tag = SORT_ASC

        With Me.CurrentSortButton

            .ForeColor = RED

            .ControlTipText = "Sorted Ascending by " & .Caption

        End With





    Case Else    'Not sorted or .Tag = ""

        Me.CurrentForm.OrderBy = "[" & Me.CurrentSortField.ControlSource & "]"

        Me.CurrentSortField.Tag = SORT_ASC

        With Me.CurrentSortButton

            .ForeColor = RED

            .ControlTipText = "Sorted Ascending by " & .Caption

        End With

    End Select

    If fChangeSortColumn Then

        PrevSortField.Tag = SORT_NONE

    End If





    Set PrevSortField = Me.CurrentSortField

    Set PrevSortButton = Me.CurrentSortButton


    Exit Sub


GoSort_Exit:

    Exit Sub


GoSort_Err:

    MsgBox "The following error occurred In Sub GoSort: " & Error$

    Resume GoSort_Exit


End Sub

Public Property Set CurrentSortField(ctl As Control)

    On Error GoTo Property_Err


    Set m_ctlCurrentSortField = ctl




    Exit Property


Property_Exit:

    Exit Property

Property_Err:

    MsgBox "The following error occurred In Property Set CurrentSortField: " & Error$

    Resume Property_Exit



End Property




Private Property Set PrevSortField(ctl As Control)

    On Error GoTo Property_Err


    Set m_ctlPrevSortField = ctl



    Exit Property


Property_Exit:

    Exit Property


Property_Err:

    MsgBox "The following error occurred In Property Set PrevSortField: " & Error$

    Resume Property_Exit


End Property



Private Property Set PrevSortButton(ctl As Control)

    On Error GoTo Property_Err


    Set m_ctlPrevSortButton = ctl


    Exit Property


Property_Exit:

    Exit Property


Property_Err:

    MsgBox "The following error occurred In Property Set PrevSortButton: " & Error$

    Resume Property_Exit


End Property


Private Property Get PrevSortField() As Object

    On Error GoTo Property_Err

    Set PrevSortField = m_ctlPrevSortField



    Exit Property



Property_Exit:

    Exit Property





Property_Err:

    MsgBox "The following error occurred In Property Get PrevSortField: " & Error$

    Resume Property_Exit



End Property



Public Property Get CurrentSortField() As Control

    On Error GoTo Property_Err


    Set CurrentSortField = m_ctlCurrentSortField


    Exit Property


Property_Exit:

    Exit Property



Property_Err:

    MsgBox "The following error occurred In Property Get CurrentSortField: " & Error$

    Resume Property_Exit



End Property



Public Property Get CurrentSortButton() As Control

    On Error GoTo Property_Err

    Set CurrentSortButton = m_ctlCurrentSortButton



    Exit Property



Property_Exit:

    Exit Property

Property_Err:

    MsgBox "The following error occurred In Property Get CurrentSortButton: " & Error$

    Resume Property_Exit



End Property


Private Property Get PrevSortButton() As Control

    On Error GoTo Property_Err



    Set PrevSortButton = m_ctlPrevSortButton




    Exit Property

Property_Exit:

    Exit Property



Property_Err:

    MsgBox "The following error occurred In Property Get PrevSortButton: " & Error$

    Resume Property_Exit



End Property



Public Property Set CurrentSortButton(ctl As Control)

    On Error GoTo Property_Err


    Set m_ctlCurrentSortButton = ctl


    Exit Property


Property_Exit:

    Exit Property

Property_Err:

    MsgBox "The following error occurred In Property Set CurrentSortButton: " & Error$

    Resume Property_Exit



End Property


Private Sub Class_Initialize()


    On Error Resume Next

    If Not Me.CurrentForm.Form.OrderByOn Then

        Me.CurrentForm.Form.OrderByOn = True

    End If

End Sub


Private Sub Class_Terminate()

    On Error Resume Next

    Screen.ActiveForm.Form.OrderBy = ""

End Sub

04、调用类

接着，我们就要来调用类了，分几步，具体的代码如下：

Option Explicit

‘先申明

Dim oSort As New clsSort

Private Sub btnSort_Click()

 ‘按钮的单击里去调用

    With oSort

        Set .CurrentSortButton = Me.btnSort

        Set .CurrentSortField = Me!物料代码

        .GoSort

    End With

End Sub

’在加载事件里初始化

Private Sub Form_Load()

    Set oSort = New clsSort

    Set oSort.CurrentForm = Me

End Sub

05、测试使用

最后就是测试了，我们来看一下效果。

好的，大家快去试一下吧！