求一排序函数
有一列表内数据如下
1.JPG
4.JPG
22.JPG
3.JPG
8.JPG
11.JPG
16.JPG
2.JPG
。。。
如何将这类的数据进行排序呢。
[解决办法]
本帖最后由 bcrun 于 2013-07-23 16:10:14 编辑
Option Explicit
Private Declare Function GetTickCount Lib "kernel32" () As Long
' 生成数据到一个文本文件
Private Sub Command1_Click()
Dim test As String
Dim i As Long
Dim savetime As Long
savetime = GetTickCount
Open App.Path & "" & Text1.Text For Output As #1
For i = 1 To 100000
test = String(8 - Len(Hex(i)), "0") & Hex(i)
Print #1, test
Next i
Close #1
MsgBox "耗时：" & GetTickCount - savetime & " 毫秒"
End Sub
' 读取文本文件的每一行数据对其进行排序输出
Private Sub Command2_Click()
Dim ReadArray() As String
Dim lngArraySize As Long
Dim strTmp As String
Dim fs As Integer
Dim row As Long
Dim i As Long
Dim j As Long
Dim index As Long
Dim IsCompositor As Boolean
Dim savetime As Long
savetime = GetTickCount
'========== 把文本文件以行为单位读入字符串数组 ==========
row = 0
ReDim ReadArray(row)
fs = FreeFile
Open App.Path & "" & Text1.Text For Input As #fs
Do While Not EOF(fs)
Line Input #fs, strTmp
ReadArray(row) = strTmp
row = row + 1
ReDim Preserve ReadArray(row)
Loop
Close #fs
lngArraySize = row - 1
ReDim Preserve ReadArray(lngArraySize)
'========== 对数组进行排序 ==========
'快速法
Call compositor_quick(ReadArray, 0, lngArraySize)
'========== 将排序好的数组输出 ==========
For i = 0 To lngArraySize
List1.AddItem ReadArray(i)
Next i
Dim overtime As Long
overtime = GetTickCount
MsgBox "耗时：" & GetTickCount - savetime & " 毫秒"
End Sub
' 数组排序函数
Private Sub compositor_quick(strArray() As String, i As Long, j As Long)
Dim m As Long, _
n As Long, _
temp As String, _
strTmp As String
m = i
n = j
strTmp = strArray((m + n) / 2)
Do
' 从左到右找比k大的元素
Do While (strArray(m) < strTmp And m < j)
m = m + 1
Loop
' 从右到左找比k小的元素
Do While (strArray(n) > strTmp And n > i)
n = n - 1
Loop
If m <= n Then
' 若找到且满足条件，则交换
temp = strArray(m)
strArray(m) = strArray(n)
strArray(n) = temp
m = m + 1
n = n - 1
End If
Loop While m <= n
If m < j Then compositor_quick strArray, m, j '/*运用递归*/
If n > i Then compositor_quick strArray, i, n
End Sub
Redim Files(1,3)
Files(0,0) = "4.jpg"
Files(0,1) = #2013-7-21 00:58:00#
Files(0,2) = "jpg"
Files(0,3) = 3000000
Files(1,0) = "2.jpg"
Files(1,1) = #2013-7-21 00:58:00#
Files(1,2) = "jpg"
Files(1,3) = 132701
' 调用排序过程
Call CompositorArray(Files,"2:asc,1:desc,0:asc,3:asc")
...
' 定义排序函数
Sub CompositorArray(ByRef arr() as Variant,ByVal PRI As String)
...
End Sub
Private Sub Command6_Click()
Dim DriverObject As Object, _
FileObject As Object, _
fObject As Object, _
NowPath As String, _
FileArray() As String, _
FileCount As Long, _
TempName As String, _
TempTime As Date, _
i As Long, _
j As Long, _
is_compositor As Boolean
List1.Clear
NowPath = App.Path
' 用 fso 查询路径得到指定路径下的文件
Set DriverObject = CreateObject("Scripting.FileSystemObject")
If DriverObject.FolderExists(NowPath) Then
Set FileObject = DriverObject.GetFolder(NowPath).Files
FileCount = FileObject.count
ReDim FileArray(FileCount - 1, 1)
i = 0
For Each fObject In FileObject
FileArray(i, 0) = fObject.Name
FileArray(i, 1) = fObject.DateLastModified
i = i + 1
Next
Set FileObject = Nothing
End If
If FileCount >= 1 Then
' 简单的冒泡法排序,效率很低，不过作为数据不多的文件处理够用了，最主要的是容易理解
For i = 0 To FileCount - 1
For j = 0 To FileCount - 1
If Len(FileArray(i, 0)) < Len(FileArray(j, 0)) Then
is_compositor = True
Else
If FileArray(i, 0) < FileArray(j, 0) Then
is_compositor = True
Else
is_compositor = False
End If
End If
If is_compositor Then
TempName = FileArray(j, 0)
TempTime = FileArray(j, 1)
FileArray(j, 0) = FileArray(i, 0)
FileArray(j, 1) = FileArray(i, 1)
FileArray(i, 0) = TempName
FileArray(i, 1) = TempTime
End If
Next
Next
For i = 0 To FileCount - 1
List1.AddItem FileArray(i, 0)
Next
End If
End Sub
