I'm trying to sort images in the correct A - Z order but no matter which method I try I keep coming up stumps as it sorts as f1, f10, f100, f101, f5, f40 rather than f1, f5, f10, f40, f100, f101 - does anyone have some points as to where I am going wrong please?
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
The comments above correctly identified the problem. When sorting alphanumeric values, the sorter essentially iterates from left to right comparing values.
I actually ran into a very similar problem as yours, so I'll post my solution that you can hopefully adapt to meet your project needs. The major difference in my implementation occurs in the Partition function as part of QuickSort. Rather than compare two elements using a simple operater (e.g. element1 < element2), the Partition function calls a Comparer(element1, element2) function that contains custom logic.
In my implementation, Comparer splits the two elements into string and numeric portions, and then compares them individually.
Try working through my code below and see if that helps you in your specific case. I took some shortcuts (for example, I didn't test to see if my regular expression actually matches anything) because I knew the structure of my incoming values. You might not. Let me know if you have any questions.
'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