強制文件和文件夾按字母順序處理

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