将文件名添加到数组并将其作为字符串参数传递给排序函数
Add filenames to an array and pass it to a sorting function as a string argument
目标是提供一个文件夹选择对话框来读取文件名并将它们粘贴到打开的Word文档中，文件名是标题（图片上方）。这是为了简化 Word 中的分步文档，其样式为“1. 做这个”、“2. 做那个”....“10. 然后那个”、“11. 然后这个”（它是排序错误，即 1, 10, 11, 13, 2, 3, 4, 5, 6, 7, 8, 9 没有排序功能）。
我无法克服类型不匹配错误，以下 VBA 代码生成（这似乎是 String 与 Array 类型的错误）：
函数：
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 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
这里有一个稍微不同的方法：
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
目标是提供一个文件夹选择对话框来读取文件名并将它们粘贴到打开的Word文档中，文件名是标题（图片上方）。这是为了简化 Word 中的分步文档，其样式为“1. 做这个”、“2. 做那个”....“10. 然后那个”、“11. 然后这个”（它是排序错误，即 1, 10, 11, 13, 2, 3, 4, 5, 6, 7, 8, 9 没有排序功能）。
我无法克服类型不匹配错误，以下 VBA 代码生成（这似乎是 String 与 Array 类型的错误）：
函数：
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 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
这里有一个稍微不同的方法：
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