正确排序数组中的文件
Sorting Files in Array Correctly
我正在尝试按正确的 A - Z 顺序对图像进行排序，但无论我尝试哪种方法，我都会遇到问题，因为它排序为 f1、f10、f100、f101、f5、f40 而不是 f1， f5、f10、f40、f100、f101 - 有人知道我哪里出错了吗？
Sub InsertImages()
Dim prs As PowerPoint.Presentation
Dim sld As PowerPoint.Slide
Dim shp As PowerPoint.Shape
Dim txt As PowerPoint.Shape
Dim tmp As PowerPoint.PpViewType
Dim fol As Object, f As Object
Dim fol_path As String
Dim ImageMaxSize
'Store open presentation in prs
Set prs = ActivePresentation
'Cancel if slide show mode
If SlideShowWindows.Count > 0 Then prs.SlideShowWindow.View.Exit
With ActiveWindow
tmp = .ViewType 'Remember window display mode
.ViewType = ppViewSlide
End With
'Choose the path of the folder where our images are.
Dim fileExplorer As FileDialog
Set fileExplorer = Application.FileDialog(msoFileDialogFolderPicker)
'To allow or disable to multi select
fileExplorer.AllowMultiSelect = False
With fileExplorer
If .Show = -1 Then 'Any folder is selected
fol_path = .SelectedItems.Item(1) & "\"
Else ' else dialog is cancelled
MsgBox "You have cancelled the dialogue"
fol_path = "" ' when cancelled set blank as file path.
End If
End With
Dim oFSO As Object, oFolder As Object, list As Object, listItem As Variant, strExt As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(fol_path)
Set list = CreateObject("System.Collections.ArrayList")
For Each f In oFolder.Files
If LCase(oFSO.GetExtensionName(f)) = "png" Or LCase(oFSO.GetExtensionName(f)) = "jpg" Or LCase(oFSO.GetExtensionName(f)) = "gif" Or LCase(oFSO.GetExtensionName(f)) = "jpeg" Then
list.Add oFSO.GetBaseName(f) & "." & oFSO.GetExtensionName(f)
End If
Next f
'Sort list a - z
list.Sort
Dim arr As Variant
arr = list.ToArray
'Call QuickSort(arr)
'Call Array_BubbleSort(arr)
Debug.Print Join(arr, ", ")
End Sub
上面的评论正确地指出了问题。在对字母数字值进行排序时，排序器实质上是从左到右迭代比较值。
我实际上 运行 遇到了与您的问题非常相似的问题，因此我将 post 我的解决方案，希望您可以采用它来满足您的项目需求。我的实现中的主要区别在于 Partition 函数作为 QuickSort 的一部分。 Partition 函数不是使用简单的运算符（例如 element1 < element2）比较两个元素，而是调用包含自定义逻辑的 Comparer(element1, element2) 函数。
在我的实现中，Comparer 将两个元素拆分为字符串和数字部分，然后分别进行比较。
尝试完成下面的代码，看看是否对您的具体情况有所帮助。我采取了一些捷径（例如，我没有测试我的正则表达式是否真的匹配任何东西）因为我知道我的传入值的结构。你可能不会。如果您有任何问题，请告诉我。
'Test Function
Sub TesterWithStringArrays()
Dim arr(0 To 9) As String
arr(0) = "f5"
arr(1) = "f10"
arr(2) = "f7"
arr(3) = "f45"
arr(4) = "f13"
arr(5) = "f3"
arr(6) = "f27"
arr(7) = "f62"
arr(8) = "f9"
arr(9) = "f4"
QuickSort arr, 0, 9
PrintArray arr
End Sub
'''
' Quicksort implementation below
'''
Sub QuickSort(ByRef arr() As String, leftIndex As Integer, rightIndex As Integer)
Dim partitionIndex As Integer
If rightIndex < leftIndex Then
Exit Sub
End If
partitionIndex = Partition(arr, leftIndex, rightIndex)
QuickSort arr, leftIndex, partitionIndex - 1
QuickSort arr, partitionIndex + 1, rightIndex
End Sub
Function Partition(ByRef arr() As String, leftIndex As Integer, rightIndex As Integer) As Integer
Dim pivot As String
Dim leftIter As Integer
Dim rightIter As Integer
Dim condition1 As Boolean
Dim condition2 As Boolean
pivot = arr(rightIndex)
leftIter = leftIndex - 1
rightIter = rightIndex
While leftIter < rightIter
leftIter = leftIter + 1
''' Because VBA doesn't short circuit AND operators, we have to
''' create this chain below. Without it, we can run into issues
''' where we index beyond the boundaries of the array
condition1 = leftIter < rightIter
If condition1 Then
condition1 = condition1 And Comparer(arr(leftIter), pivot) = -1
End If
While condition1
leftIter = leftIter + 1
condition1 = leftIter < rightIter
If condition1 Then
condition1 = condition1 And Comparer(arr(leftIter), pivot) = -1
End If
Wend
rightIter = rightIter - 1
condition2 = rightIter > leftIter
If condition2 Then
condition2 = condition2 And Comparer(arr(rightIter), pivot) >= 0
End If
While condition2
rightIter = rightIter - 1
condition2 = rightIter > leftIter
If condition2 Then
condition2 = condition2 And Comparer(arr(rightIter), pivot) >= 0
End If
Wend
'Debug.Print Str(leftIter) + ", "; Str(rightIter)
If leftIter < rightIter Then
Swap arr, leftIter, rightIter
End If
Wend
Swap arr, leftIter, rightIndex
'PrintArray arr
Partition = leftIter
End Function
'''
' Helper function to print the array
'''
Private Sub PrintArray(ByRef arr() As String)
Dim output As String
For i = LBound(arr) To UBound(arr)
output = output + ", " + arr(i)
Next i
Debug.Print Mid(output, 2, 100)
End Sub
'''
' Helper function to swap two elements in an array
'''
Private Sub Swap(ByRef arr() As String, idx1 As Integer, idx2 As Integer)
Dim t As String
t = arr(idx1)
arr(idx1) = arr(idx2)
arr(idx2) = t
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''
' Returns:
' -1 if element1 is less than element2
' 1 if element1 is greater than element2
' 0 if the two elements are equal
''''''''''''''''''''''''''''''''''''''''''''''''
Private Function Comparer(element1 As String, element2 As String) As Integer
Dim oReg As Object
Dim matches1 As Object
Dim matches2 As Object
Set oReg = CreateObject("VBScript.RegExp")
With oReg
.Global = False
.MultiLine = False
.ignorecase = True
.Pattern = "([A-Za-z]+)(\d+)"
End With
' NOTE: Should test that the regular expression returns a match
' before executing to prevent errors.
Set matches1 = oReg.Execute(element1)
Set matches2 = oReg.Execute(element2)
'The string portion of the regular expression match
Dim string1 As String
Dim string2 As String
string1 = matches1(0).submatches(0)
string2 = matches2(0).submatches(0)
If string1 < string2 Then
Comparer = -1
Exit Function
ElseIf string1 > string2 Then
Comparer = 1
Exit Function
End If
'The string portions match, must compare the number portions
Dim number1 As Integer
Dim number2 As Integer
number1 = matches1(0).submatches(1)
number2 = matches2(0).submatches(1)
If number1 < number2 Then
Comparer = -1
Exit Function
ElseIf number1 > number2 Then
Comparer = 1
Exit Function
Else ' Still equal
Comparer = 0
Exit Function
End If
End Function
我 运行 遇到了一个问题，我需要一个类似但更通用的比较函数。
花了几个小时寻找但没有找到任何东西，所以我采用了@basodre 的 Comparer 函数并对其进行了修改，以便能够解析任意数量的 alpha/numeric 组合，并包括小数和负数以及区分大小写的切换。
如果有人发现他们需要一个通用的比较工具，请使用您自己的排序函数或将@basodre 的 Comparer 函数替换为我的以下代码
Private Function Comparer(element1 As String, element2 As String, Optional boolIgnoreCase As Boolean = True, Optional boolConsiderDecimalPlace As Boolean = False, Optional boolConsiderNegativeSign As Boolean = False) As Integer
''''''''''''''''''''''''''''''''''''''''''''''''
' Returns:
' -1 if element1 is less than element2
' 1 if element1 is greater than element2
' 0 if the two elements are equal
''''''''''''''''''''''''''''''''''''''''''''''''
Dim oReg As Object
Dim matches1 As Object, matches2 As Object
Dim str1 As String, str2 As String
strNumericPattern = "\d+"
If boolConsiderDecimalPlace Then strNumericPattern = "[" & strNumericPattern & "\.]+"
If boolConsiderNegativeSign Then strNumericPattern = "-?" & strNumericPattern
strFullPattern = "[A-Za-z]+|" & strNumericPattern & "|\W" '"[A-Za-z]+|\d+|\W"
Set oReg = CreateObject("VBScript.RegExp")
With oReg
.Global = True
.MultiLine = False
.IgnoreCase = boolCaseSensitive
'.Pattern = strNumericPattern
.Pattern = strFullPattern
End With
' NOTE: Should test that the regular expression returns a match
' before executing to prevent errors.
Set matches1 = oReg.Execute(element1)
Set matches2 = oReg.Execute(element2)
If matches1.Count = 0 Then Comparer = -1
If matches2.Count = 0 Then Comparer = 1
iCnt = IIf(matches1.Count <= matches2.Count, matches1.Count, matches2.Count) - 1
For i = 0 To iCnt
str1 = CStr(matches1(i))
str2 = CStr(matches2(i))
If IsNumeric(str1) And IsNumeric(str2) Then
If CLng(str1) < CLng(str2) Then
Comparer = -1
Exit Function
ElseIf CLng(str1) > CLng(str2) Then
Comparer = 1
Exit Function
End If
ElseIf IsNumeric(str1) Or IsNumeric(str2) Then
If IsNumeric(str1) Then Comparer = 1 Else Comparer = -1 'because number comes after alpha
Else
If str1 > str2 Then
Comparer = -1
Exit Function
ElseIf str1 < str2 Then
Comparer = 1
Exit Function
End If
End If
Next i
'strings are equal
Comparer = 0
End Function
'''
我正在尝试按正确的 A - Z 顺序对图像进行排序，但无论我尝试哪种方法，我都会遇到问题，因为它排序为 f1、f10、f100、f101、f5、f40 而不是 f1， f5、f10、f40、f100、f101 - 有人知道我哪里出错了吗？
Sub InsertImages()
Dim prs As PowerPoint.Presentation
Dim sld As PowerPoint.Slide
Dim shp As PowerPoint.Shape
Dim txt As PowerPoint.Shape
Dim tmp As PowerPoint.PpViewType
Dim fol As Object, f As Object
Dim fol_path As String
Dim ImageMaxSize
'Store open presentation in prs
Set prs = ActivePresentation
'Cancel if slide show mode
If SlideShowWindows.Count > 0 Then prs.SlideShowWindow.View.Exit
With ActiveWindow
tmp = .ViewType 'Remember window display mode
.ViewType = ppViewSlide
End With
'Choose the path of the folder where our images are.
Dim fileExplorer As FileDialog
Set fileExplorer = Application.FileDialog(msoFileDialogFolderPicker)
'To allow or disable to multi select
fileExplorer.AllowMultiSelect = False
With fileExplorer
If .Show = -1 Then 'Any folder is selected
fol_path = .SelectedItems.Item(1) & "\"
Else ' else dialog is cancelled
MsgBox "You have cancelled the dialogue"
fol_path = "" ' when cancelled set blank as file path.
End If
End With
Dim oFSO As Object, oFolder As Object, list As Object, listItem As Variant, strExt As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(fol_path)
Set list = CreateObject("System.Collections.ArrayList")
For Each f In oFolder.Files
If LCase(oFSO.GetExtensionName(f)) = "png" Or LCase(oFSO.GetExtensionName(f)) = "jpg" Or LCase(oFSO.GetExtensionName(f)) = "gif" Or LCase(oFSO.GetExtensionName(f)) = "jpeg" Then
list.Add oFSO.GetBaseName(f) & "." & oFSO.GetExtensionName(f)
End If
Next f
'Sort list a - z
list.Sort
Dim arr As Variant
arr = list.ToArray
'Call QuickSort(arr)
'Call Array_BubbleSort(arr)
Debug.Print Join(arr, ", ")
End Sub
上面的评论正确地指出了问题。在对字母数字值进行排序时，排序器实质上是从左到右迭代比较值。
我实际上 运行 遇到了与您的问题非常相似的问题，因此我将 post 我的解决方案，希望您可以采用它来满足您的项目需求。我的实现中的主要区别在于 Partition 函数作为 QuickSort 的一部分。 Partition 函数不是使用简单的运算符（例如 element1 < element2）比较两个元素，而是调用包含自定义逻辑的 Comparer(element1, element2) 函数。
在我的实现中，Comparer 将两个元素拆分为字符串和数字部分，然后分别进行比较。
尝试完成下面的代码，看看是否对您的具体情况有所帮助。我采取了一些捷径（例如，我没有测试我的正则表达式是否真的匹配任何东西）因为我知道我的传入值的结构。你可能不会。如果您有任何问题，请告诉我。
'Test Function
Sub TesterWithStringArrays()
Dim arr(0 To 9) As String
arr(0) = "f5"
arr(1) = "f10"
arr(2) = "f7"
arr(3) = "f45"
arr(4) = "f13"
arr(5) = "f3"
arr(6) = "f27"
arr(7) = "f62"
arr(8) = "f9"
arr(9) = "f4"
QuickSort arr, 0, 9
PrintArray arr
End Sub
'''
' Quicksort implementation below
'''
Sub QuickSort(ByRef arr() As String, leftIndex As Integer, rightIndex As Integer)
Dim partitionIndex As Integer
If rightIndex < leftIndex Then
Exit Sub
End If
partitionIndex = Partition(arr, leftIndex, rightIndex)
QuickSort arr, leftIndex, partitionIndex - 1
QuickSort arr, partitionIndex + 1, rightIndex
End Sub
Function Partition(ByRef arr() As String, leftIndex As Integer, rightIndex As Integer) As Integer
Dim pivot As String
Dim leftIter As Integer
Dim rightIter As Integer
Dim condition1 As Boolean
Dim condition2 As Boolean
pivot = arr(rightIndex)
leftIter = leftIndex - 1
rightIter = rightIndex
While leftIter < rightIter
leftIter = leftIter + 1
''' Because VBA doesn't short circuit AND operators, we have to
''' create this chain below. Without it, we can run into issues
''' where we index beyond the boundaries of the array
condition1 = leftIter < rightIter
If condition1 Then
condition1 = condition1 And Comparer(arr(leftIter), pivot) = -1
End If
While condition1
leftIter = leftIter + 1
condition1 = leftIter < rightIter
If condition1 Then
condition1 = condition1 And Comparer(arr(leftIter), pivot) = -1
End If
Wend
rightIter = rightIter - 1
condition2 = rightIter > leftIter
If condition2 Then
condition2 = condition2 And Comparer(arr(rightIter), pivot) >= 0
End If
While condition2
rightIter = rightIter - 1
condition2 = rightIter > leftIter
If condition2 Then
condition2 = condition2 And Comparer(arr(rightIter), pivot) >= 0
End If
Wend
'Debug.Print Str(leftIter) + ", "; Str(rightIter)
If leftIter < rightIter Then
Swap arr, leftIter, rightIter
End If
Wend
Swap arr, leftIter, rightIndex
'PrintArray arr
Partition = leftIter
End Function
'''
' Helper function to print the array
'''
Private Sub PrintArray(ByRef arr() As String)
Dim output As String
For i = LBound(arr) To UBound(arr)
output = output + ", " + arr(i)
Next i
Debug.Print Mid(output, 2, 100)
End Sub
'''
' Helper function to swap two elements in an array
'''
Private Sub Swap(ByRef arr() As String, idx1 As Integer, idx2 As Integer)
Dim t As String
t = arr(idx1)
arr(idx1) = arr(idx2)
arr(idx2) = t
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''
' Returns:
' -1 if element1 is less than element2
' 1 if element1 is greater than element2
' 0 if the two elements are equal
''''''''''''''''''''''''''''''''''''''''''''''''
Private Function Comparer(element1 As String, element2 As String) As Integer
Dim oReg As Object
Dim matches1 As Object
Dim matches2 As Object
Set oReg = CreateObject("VBScript.RegExp")
With oReg
.Global = False
.MultiLine = False
.ignorecase = True
.Pattern = "([A-Za-z]+)(\d+)"
End With
' NOTE: Should test that the regular expression returns a match
' before executing to prevent errors.
Set matches1 = oReg.Execute(element1)
Set matches2 = oReg.Execute(element2)
'The string portion of the regular expression match
Dim string1 As String
Dim string2 As String
string1 = matches1(0).submatches(0)
string2 = matches2(0).submatches(0)
If string1 < string2 Then
Comparer = -1
Exit Function
ElseIf string1 > string2 Then
Comparer = 1
Exit Function
End If
'The string portions match, must compare the number portions
Dim number1 As Integer
Dim number2 As Integer
number1 = matches1(0).submatches(1)
number2 = matches2(0).submatches(1)
If number1 < number2 Then
Comparer = -1
Exit Function
ElseIf number1 > number2 Then
Comparer = 1
Exit Function
Else ' Still equal
Comparer = 0
Exit Function
End If
End Function
我 运行 遇到了一个问题，我需要一个类似但更通用的比较函数。 花了几个小时寻找但没有找到任何东西，所以我采用了@basodre 的 Comparer 函数并对其进行了修改，以便能够解析任意数量的 alpha/numeric 组合，并包括小数和负数以及区分大小写的切换。
如果有人发现他们需要一个通用的比较工具，请使用您自己的排序函数或将@basodre 的 Comparer 函数替换为我的以下代码
Private Function Comparer(element1 As String, element2 As String, Optional boolIgnoreCase As Boolean = True, Optional boolConsiderDecimalPlace As Boolean = False, Optional boolConsiderNegativeSign As Boolean = False) As Integer
''''''''''''''''''''''''''''''''''''''''''''''''
' Returns:
' -1 if element1 is less than element2
' 1 if element1 is greater than element2
' 0 if the two elements are equal
''''''''''''''''''''''''''''''''''''''''''''''''
Dim oReg As Object
Dim matches1 As Object, matches2 As Object
Dim str1 As String, str2 As String
strNumericPattern = "\d+"
If boolConsiderDecimalPlace Then strNumericPattern = "[" & strNumericPattern & "\.]+"
If boolConsiderNegativeSign Then strNumericPattern = "-?" & strNumericPattern
strFullPattern = "[A-Za-z]+|" & strNumericPattern & "|\W" '"[A-Za-z]+|\d+|\W"
Set oReg = CreateObject("VBScript.RegExp")
With oReg
.Global = True
.MultiLine = False
.IgnoreCase = boolCaseSensitive
'.Pattern = strNumericPattern
.Pattern = strFullPattern
End With
' NOTE: Should test that the regular expression returns a match
' before executing to prevent errors.
Set matches1 = oReg.Execute(element1)
Set matches2 = oReg.Execute(element2)
If matches1.Count = 0 Then Comparer = -1
If matches2.Count = 0 Then Comparer = 1
iCnt = IIf(matches1.Count <= matches2.Count, matches1.Count, matches2.Count) - 1
For i = 0 To iCnt
str1 = CStr(matches1(i))
str2 = CStr(matches2(i))
If IsNumeric(str1) And IsNumeric(str2) Then
If CLng(str1) < CLng(str2) Then
Comparer = -1
Exit Function
ElseIf CLng(str1) > CLng(str2) Then
Comparer = 1
Exit Function
End If
ElseIf IsNumeric(str1) Or IsNumeric(str2) Then
If IsNumeric(str1) Then Comparer = 1 Else Comparer = -1 'because number comes after alpha
Else
If str1 > str2 Then
Comparer = -1
Exit Function
ElseIf str1 < str2 Then
Comparer = 1
Exit Function
End If
End If
Next i
'strings are equal
Comparer = 0
End Function
'''