强制文件和文件夹按字母顺序处理

Question

我有一个应用程序，我有问题。这是一个应用程序来重命名所选文件夹中的所有图片和文件夹中的子文件夹。

但是有时它会按照字母顺序A-Z处理图片，因此将它们重新命名为正确，有时似乎是在修改日期顺序中处理它们。最早的，最新的。这会导致文件的顺序出错。我们在同一台个人电脑上都有结果，我对接下来要尝试的内容感到困惑。

有谁知道如何改变下面的代码，以便它总是使用字母顺序A-Z。

请帮忙。

完整的代码如下：SUB1

Sub TestListFilesInFolder() 
'Workbooks.Add ' create a new workbook for the file list 
' add headers 

Dim fldr As FileDialog 
Dim sItem As String 
Set fldr = Application.FileDialog(msoFileDialogFolderPicker) 
With fldr 
    .Title = "Select a Folder" 
    .AllowMultiSelect = False 
    .InitialFileName = strPath 
    If .Show <> -1 Then 
     sItem = "No item selected" 
    Else 
     sItem = .SelectedItems(1) 
    End If 
End With 

With Range("A1") 
    .Formula = "Folder contents:" 
    .Font.Bold = True 
    .Font.Size = 12 
End With 
Range("A3").Formula = "Old File Path:" 
Range("B3").Formula = "File Type:" 
Range("C3").Formula = "File Name:" 
Range("D3").Formula = "New File Path:" 
Range("A3:H3").Font.Bold = True 
'ListFilesInFolder "L:\Pictures\A B C\B526 GROUP", True 
ListFilesInFolder sItem, True 

' list all files included subfolders 
    End Sub 

SUB2

Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean) 
    ' lists information about the files in SourceFolder 
    ' example: ListFilesInFolder "C:\FolderName", True 
    Dim fso As Object 
    Dim SourceFolder As Object, SubFolder As Object 
    Dim FileItem As Object 
    Dim r As Long, p As Long 
    Dim fPath As String, fName As String, oldName As String, newName As String 
    Dim strVal As String, strVal2 As String, strVal3 As String, strVal4 As String, iSlashPos As Integer 

Set fso = CreateObject("Scripting.FileSystemObject") 
Set SourceFolder = fso.GetFolder(SourceFolderName) 
r = Range("A65536").End(xlUp).Row + 1 
p = 1 
For Each FileItem In SourceFolder.Files 
    ' display file properties 
    Cells(r, 1).Formula = FileItem.Path 
    fFile = FileItem.Path 
    Cells(r, 2).Formula = FileItem.Type 
    Cells(r, 3).Formula = FileItem.Name 
    fName = FileItem.Name 
    If FileItem.Type = "JPEG Image" Then 
    oldName = Left(FileItem.Name, InStrRev(FileItem.Name, ".") - 1) 
    fPath = Left(FileItem.Path, InStrRev(FileItem.Path, "\") - 1) 

    strVal = fPath 
    Dim arrVal As Variant 
    arrVal = Split(strVal, "\") 
    strVal2 = arrVal(UBound(arrVal)) 
    strVal3 = arrVal(UBound(arrVal) - 1) 

    newName = Replace(FileItem.Name, oldName, strVal3 & "_" & strVal2 & "_" & "Pic" & p & "_" & Format(Date, "ddmmyyyy")) 

    Name fFile As fPath & "\" & newName 
    Cells(r, 4).Formula = fPath & "\" & newName 
    p = p + 1 
    Else 
    End If 

    r = r + 1 ' next row number 
Next FileItem 
If IncludeSubfolders Then 
    For Each SubFolder In SourceFolder.subfolders 
     ListFilesInFolder SubFolder.Path, True 
    Next SubFolder 
End If 
Columns("A:H").AutoFit 
Set FileItem = Nothing 
Set SourceFolder = Nothing 
Set fso = Nothing 
ActiveWorkbook.Saved = True 
Set fldr = Nothing 
    End Sub 

任何帮助将非常感激。

问候，

山姆

Answer 1

所以在this link，由@SkipIntro提供的，有一个函数和子。

• 首先在快速排序功能将一个列表排序，提供您提供的最小值和最大值。

• 其次，sortedfiles是主要的一个将返回按字母顺序排列的文件列表。

如果您使用以下排序你的文件名发布之前那么他们将按照字母顺序例如

quicksort myfilenames, 1, ubound(myfilenames, 1)  

快速排序：

' Use Quicksort to sort a list of strings. 
' 
' This code is from the book "Ready-to-Run 
' Visual Basic Algorithms" by Rod Stephens. 
' http://www.vb-helper.com/vba.htm 
Private Sub Quicksort(list() As String, ByVal min As Long, ByVal max As Long) 
Dim mid_value As String 
Dim hi As Long 
Dim lo As Long 
Dim i As Long 

' If there is 0 or 1 item in the list, 
' this sublist is sorted. 
If min >= max Then Exit Sub 

' Pick a dividing value. 
i = Int((max - min + 1) * Rnd + min) 
mid_value = list(i) 

' Swap the dividing value to the front. 
list(i) = list(min) 

lo = min 
hi = max 
Do 
' Look down from hi for a value < mid_value. 
Do While list(hi) >= mid_value 
hi = hi - 1 
If hi <= lo Then Exit Do 
Loop 
If hi <= lo Then 
list(lo) = mid_value 
Exit Do 
End If 

' Swap the lo and hi values. 
list(lo) = list(hi) 

' Look up from lo for a value >= mid_value. 
lo = lo + 1 
Do While list(lo) < mid_value 
lo = lo + 1 
If lo >= hi Then Exit Do Loop 
If lo >= hi Then 
lo = hi 
list(hi) = mid_value 
Exit Do 
End If 

' Swap the lo and hi values. 
list(hi) = list(lo) 
Loop 

' Sort the two sublists. 
Quicksort list, min, lo - 1 
Quicksort list, lo + 1, max 
End Sub