Add filenames to an array and passing it to a sorting function as a string argument-CodePudding

The main goal is to have a script that provides a folder choosing dialogue to read file names and paste them into the open document in word with the file names being the title (above the picture) to ease the process of step by step documentations in Word with a file name style of "1. Do this", "2. Do that" .... "10. And then that", "11. And then this" (with it obviously being sorted wrong, i.e. 1, 10, 11, 13, 2, 3, 4, 5, 6, 7, 8, 9 as per result without the sorting function).

I have gotten this far, however I can't seem to overcome the type mismatch error, that the following VBA sub below function generates (it seems to be the error of String vs. Array type):

Function:

    Function QuickSortNaturalNum(strArray() As String, intBottom As Integer, intTop As Integer)
Dim strPivot As String, strTemp As String
Dim intBottomTemp As Integer, intTopTemp As Integer

    intBottomTemp = intBottom
    intTopTemp = intTop

    strPivot = strArray((intBottom   intTop) \ 2)

    Do While (intBottomTemp <= intTopTemp)
        ' < comparison of the values is a descending sort
        Do While (CompareNaturalNum(strArray(intBottomTemp), strPivot) < 0 And intBottomTemp < intTop)
            intBottomTemp = intBottomTemp   1
        Loop
        Do While (CompareNaturalNum(strPivot, strArray(intTopTemp)) < 0 And intTopTemp > intBottom)
            intTopTemp = intTopTemp - 1
        Loop
        If intBottomTemp < intTopTemp Then
            strTemp = strArray(intBottomTemp)
            strArray(intBottomTemp) = strArray(intTopTemp)
            strArray(intTopTemp) = strTemp
        End If
        If intBottomTemp <= intTopTemp Then
            intBottomTemp = intBottomTemp   1
            intTopTemp = intTopTemp - 1
        End If
    Loop

    'the function calls itself until everything is in good order
    If (intBottom < intTopTemp) Then QuickSortNaturalNum strArray, intBottom, intTopTemp
    If (intBottomTemp < intTop) Then QuickSortNaturalNum strArray, intBottomTemp, intTop
End Function

Sub:

    Sub PicWithCaption()
    Dim xFileDialog As FileDialog
    Dim xPath, xFile, xFileNameOnly As String
    Dim xFileNameOnlySorted, xFileNameOnlyUnsorted As Variant
    Dim xFileNameOnlyUnsortedAsString As String
    Dim i, k, l As Integer
    
    l = 1
    m = 100
    
    On Error Resume Next
    
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    
    If xFileDialog.Show = -1 Then
        xPath = xFileDialog.SelectedItems.Item(i)
        If xPath <> "" Then
            xFile = Dir(xPath & "\*.*")
            For i = 0 To 100
            Do While xFile <> ""
            xFileNameOnly = Left(xFile, Len(xFile) - 4)
            xFileNameOnlyUnsorted(i) = xFileNameOnly
            ReDim Preserve xFileNameOnlyUnsorted(0 To i) As Variant
            xFileNameOnlyUnsorted(i) = xFileNameOnlyUnsorted(i).Value
            Loop
            Next i
            xFileNameOnlySorted = Module1.QuickSortNaturalNum(xFileNameOnlyUnsorted, l, m)
            For xFileNameOnlySorted(k) = 1 To 100
            If UCase(Right(xFileNameOnlySorted(k), 3)) = "PNG" Or _
                UCase(Right(xFileNameOnlySorted(k), 3)) = "TIF" Or _
                UCase(Right(xFileNameOnlySorted(k), 3)) = "JPG" Or _
                UCase(Right(xFileNameOnlySorted(k), 3)) = "GIF" Or _
                UCase(Right(xFileNameOnlySorted(k), 3)) = "BMP" Then
                With Selection
                    .Text = xFileNameOnlySorted(k)
                    .MoveDown wdLine
                    .InlineShapes.AddPicture xPath & "\" & xFile, False, True
                    .InsertAfter vbCrLf
                    .MoveDown wdLine
                End With
            End If
            Next xFileNameOnlySorted(k)
            xFile = Dir()
        End If
    End If
End Sub

Any help would be much appreciated!

CodePudding user response：

Here's a slightly different approach:

Sub PicWithCaption()
    
    Dim xPath As String, colImages As Collection, arrFiles, f
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select a folder with files to insert"
        .AllowMultiSelect = False
        If .Show = -1 Then xPath = .SelectedItems(1) & "\"
    End With
    If Len(xPath) = 0 Then Exit Sub
    
    Set colImages = ImageFiles(xPath) 'get a Collection of image file names
    
    If colImages.Count > 0 Then 'found some files ?
         arrFiles = CollectionToArray(colImages) 'get array from Collection
         SortSpecial arrFiles, "SortVal"         'sort files using `Val()`
         For Each f In arrFiles                  'loop the sorted array
            With Selection
                .Text = f
                .MoveDown wdLine
                .InlineShapes.AddPicture xPath & f, False, True
                .InsertAfter vbCrLf
                .MoveDown wdLine
            End With
         Next f
    Else
        MsgBox "No image files found in selected folder"
    End If

End Sub

'return a Collection of image files given a folder location
Function ImageFiles(srcFolder As String) As Collection
    Dim col As New Collection, f As String
    f = Dir(srcFolder & "*.*")
    Do While f <> ""
        Select Case UCase(Right(f, 3))
            Case "PNG", "TIF", "JPG", "GIF", "BMP"
                col.Add f
        End Select
        f = Dir()
    Loop
    Set ImageFiles = col
End Function

'create and return a string array from a Collection
Function CollectionToArray(col As Collection) As String()
    Dim arr() As String, i As Long
    ReDim arr(1 To col.Count)
    For i = 1 To col.Count
        arr(i) = col(i)
    Next i
    CollectionToArray = arr
End Function

'Sorts an array using some specific translation defined in `func`
Sub SortSpecial(list, func As String)
    Dim First As Long, Last As Long, i As Long, j As Long, tmp, arrComp()
    First = LBound(list)
    Last = UBound(list)
    'fill the "compare array...
    ReDim arrComp(First To Last)
    For i = First To Last
        arrComp(i) = Application.Run(func, list(i))
    Next i
    'now sort by comparing on `arrComp` not `list`
    For i = First To Last - 1
        For j = i   1 To Last
            If arrComp(i) > arrComp(j) Then
                tmp = arrComp(j)          'swap positions in the "comparison" array
                arrComp(j) = arrComp(i)
                arrComp(i) = tmp
                tmp = list(j)             '...and in the original array
                list(j) = list(i)
                list(i) = tmp
            End If
        Next j
    Next i
End Sub

'a function to allow comparing values based on the initial numeric part...
Function SortVal(v)
    SortVal = Val(v) ' "1 day" --> 1, "11 days" --> 11 etc
End Function