Office中国论坛/Access中国论坛

标题: 【原创 / 源码】多功能排序函数 [打印本页]

---

作者: LucasLynn    时间: 2005-9-10 17:24
标题: 【原创 / 源码】多功能排序函数
用途：

　　这是我在学习VB指针函数时候的一个习作，其作用是对于一个二维数组进行排序，其特点在于排序的规则由用户定义，因此具有很强的扩展性，几乎可以认为这个排序函数支持二维数组（数据表）的任意排序方式。排序的结果采用索引方式，因此排序速度极快。

使用说明：

　　用户自行编写记录比较函数，并将这个函数的地址作为参数传递给排序函数，排序函数将遵照用户定义的比较规则对多维数组进行排序。

　　为便于理解，调用例程中附带一个我编写的多列排序的记录比较函数，用户也可以使用自己的记录比较函数，以实现更多样的数据排序规则。

排序模块：

Public Declare Function CallFuncPtr Lib "user32" Alias "CallWindowProcA" (ByVal ptrFunc As Long, _

    ByVal ptrElem1 As Long, ByVal ptrElem2 As Long, ByVal ptrElem3 As Long, ByVal ptrElem4 As Long) As Boolean

Type SortParams

    Data() As Variant   '二维数组

    Index() As Long     '索引数组

End Type

Public Sub mcSort(ByVal FuncPtr As Long, ByRef Params As SortParams)

    Dim nRow As Long

    Dim nRow2 As Long

    Dim nCol As Long

    Dim tmpSwap As Variant

    Dim unused As Long

    Dim i As Long, j As Long

   

    '建立索引

    ReDim Params.Index(UBound(Params.Data) - LBound(Params.Data) + 1)

    For i = LBound(Params.Data) To UBound(Params.Data)

        Params.Index(j) = i

        j = j + 1

    Next i

   

    '冒泡排序

    For nRow = LBound(Params.Index) To UBound(Params.Index) - 1

        For nRow2 = UBound(Params.Index) To nRow + 1 Step -1

            If CallFuncPtr(ByVal FuncPtr, ByVal VarPtr(Params), ByVal VarPtr(Params.Index(nRow2 - 1)), ByVal VarPtr(Params.Index(nRow2)), ByVal VarPtr(unused)) Then '调用用户自定义比较规则进行两条记录比较

                tmpSwap = Params.Index(nRow2)

                Params.Index(nRow2) = Params.Index(nRow2 - 1)

                Params.Index(nRow2 - 1) = tmpSwap

            End If

        Next nRow2

    Next nRow

End Sub

调用范例：

<DIV class=quote>

Option Compare Database

Option Explicit

Public Sub Test()

    Const RowsLimit = 1000

    Dim Params As SortParams

   

    Dim adoConn As ADODB.Connection

    Dim adoRs As ADODB.Recordset

    Dim nCol As Long

    Dim nCol2 As Long

    Dim nRow As Long

    Dim nRow2 As Long

      

    '从数据表中读出数据到二维数组

    Set adoConn = CurrentProject.Connection

    Set adoRs = CreateObject("ADODB.RecordSet")

    adoRs.Open "select * from 表2", adoConn, adOpenKeyset

   

    If adoRs.RecordCount <= RowsLimit Then

        ReDim Params.Data(adoRs.RecordCount - 1, adoRs.Fields.Count - 1)

    Else

        ReDim Params.Data(RowsLimit - 1, adoRs.Fields.Count - 1)

    End If

    nRow = 0

    Do Until adoRs.EOF

        For nCol = 0 To adoRs.Fields.Count - 1

            Params.Data(nRow, nCol) = adoRs(nCol)

        Next nCol

        nRow = nRow + 1

        adoRs.MoveNext

        If nRow >= RowsLimit Then Exit Do

    Loop

   

    adoRs.Close

   

    '数组排序

    mcSort AddressOf GreaterThanSample, Params

   

    '输出结果

    For nRow = LBound(Params.Index) To UBound(Params.Index)

        For nCol = 0 To UBound(Params.Data, 2)

            Debug.Print Params.Data(Params.Index(nRow), nCol);

        Next nCol

        Debug.Print

    Next nRow

End Sub

'一个多列排序的比较范例。

Public Function GreaterThanSample(Params As SortParams, nRow1 As Long, nRow2 As Long, unused As Long) As Boolean

    Dim SelectedColumns() As Long

    ReDim SelectedColumns(3)

    SelectedColumns(0) = 1

    SelectedColumns(1) = 2

    SelectedColumns(2) = 3

    SelectedColumns(3) = 4

   

    GreaterThanSample = False

    Dim nCol As Long

   

    For nCol = LBound(SelectedColumns) To UBound(SelectedColumns)

        If Params.Data(nRow1, SelectedColumns(nCol)) > Params.Data(n

---

作者: 喳喳林    时间: 2005-9-10 18:30
好东西，谢谢。

---

作者: accessone1    时间: 2005-9-11 02:07
good

---

作者: chaojianan    时间: 2009-10-24 10:56
支持

---

作者: c101    时间: 2009-10-24 11:23
谢谢分享

---

欢迎光临 Office中国论坛/Access中国论坛 (http://www.office-cn.net/)

Powered by Discuz! X3.3