强制文件和文件夹按字母顺序处理 [英] Forcing files and folders to be dealt with in alphabetical order

问题描述

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

但是有时它会按字母顺序AZ处理图片，因此重命名正确地，有时它似乎是在日期修改订单处理它们。最旧的，最新的。这会导致文件的顺序变得错误。我们在同一台电脑上都有两个结果，我对下一步要做的事情完全感到困惑。

有谁知道如何更改下面的代码，以便它总是使用字母顺序订单AZ。

请帮助。

完整的代码如下：SUB1

  Sub TestListFilesInFolder（）
'Workbooks.Add'为文件列表创建一个新的工作簿
'添加标题
 
 Dim fldr As FileDialog 
 Dim sItem As String 
设置fldr = Application.FileDialog（msoFileDialogFolderPicker）
使用fldr 
 .Title =选择文件夹
 .AllowMultiSelect = False 
 .InitialFileName = strPath 
如果.Show<> -1然后
 sItem =没有项目选择
 Else 
 sItem = .SelectedItems（1）
结束如果
结束
 
与范围（A1）
 .Formula =文件夹内容：
 .Font.Bold = True 
 .Font.Size = 12 
结束
范围（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 
'ListFilesInFolderL：\Pictures\\ \\ ABC\B526 GROUP，True 
 ListFilesInFolder sItem，True 
 
'列出包含子文件夹的所有文件
 End Sub 
  pre> 
 
 
 SUB2 
  Sub ListFilesInFolder（SourceFolderName As String，IncludeSubfolders As Boolean）
'列出有关SourceFolder 
中的文件的信息示例：ListFilesInFolderC：\FolderName，True 
 Dim fso As Object 
 Dim SourceFolder As Object，SubFolder A s 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 
 
设置fso = CreateObject（Scripting.FileSystemObject）
设置SourceFolder = fso.GetFolder（SourceFolderName）
r = Range（A65536）。End（xlUp）.Row + 1 
p = 1 
对于每个FileItem在SourceFolder.Files 
'显示文件属性
细胞（r ，1）.Formula = FileItem.Path 
 fFile = FileItem.Path 
 Cells（r，2）.Formula = FileItem.Type 
 Cells（r，3）.Formula = FileItem.Name 
 fName = FileItem.Name 
如果FileItem.Type =JPEG Image然后
 oldName = Left（FileItem.Name，InStrRev（FileItem.Name，。） -  1）
 fPath = Left（FileItem.Path，InStrRev（FileItem.Path，\） -  1）
 
 strVal = fPath 
 Dim arrVal As Variant 
 arrVal = Split （strVa l，\）
 strVal2 = arrVal（UBound（arrVal））
 strVal3 = arrVal（UBound（arrVal） -  1）
 
 newName =替换（FileItem.Name ，oldName，strVal3& _& strVal2& _& Pic& p& _&格式（日期，ddmmyyyy））
 
名称fFile As fPath& \& newName 
 Cells（r，4）.Formula = fPath& \& newName 
p = p + 1 
 Else 
 End If 
 
r = r + 1'下一行号
下一个FileItem 
如果IncludeSubfolders Then 
对于SourceFolder.subfolders中的每个子文件夹
 ListFilesInFolder SubFolder.Path，True 
 Next SubFolder 
 End If 
列（A：H）。AutoFit 
设置FileItem = Nothing 
设置SourceFolder = Nothing 
设置fso = Nothing 
 ActiveWorkbook.Saved = True 
设置fldr = Nothing 
 End Sub 
  
任何帮助将不胜感激。
 
 
 
 Sam 
解决方案
所以在此链接，由@SkipIntro提供，有一个函数和一个子。
 
 
 
 
 
 
首先， quicksort 功能将排序列表，只要您提供最小和最大值。
 
 
 
 
其次， sortedfiles  
 
 
 
 
 
如果您使用以下内容排序您在发布之前将其命名，然后按字母顺序排列，例如
  quicksort myfilenames，1，ubound（myfilenames，1） 
  
  quicksort： 
 '使用Quicksort对字符串列表进行排序。 
'
'该代码来自Rod Stephens的准备运行
'Visual Basic算法一书。 
'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 
 
'如果列表中有0或1项，
 '这个子列表被排序。 
如果min> = max Then Exit Sub 
 
'选择一个分割值。 
 i = Int（（max  -  min + 1）* Rnd + min）
 mid_value = list（i）
 
'将分割值交换到前端。 
 list（i）= list（min）
 
 lo = min 
 hi = max 
 Do 
' mid_value。 
 Do While list（hi）> = mid_value 
 hi = hi  -  1 
如果hi< = lo然后退出Do 
循环
如果hi< =然后
列表（lo）= mid_value 
退出Do 
结束如果
 
'交换lo和hi值。 
 list（lo）= list（hi）
 
'从lo查找值> = mid_value。 
 lo = lo + 1 
 Do While list（lo）< mid_value 
 lo = lo + 1 
如果lo> = hi然后退出Do循环
如果lo> = hi然后
 lo = hi 
列表（嗨） = mid_value 
退出Do 
 End If 
 
'交换lo和hi值。 
 list（嗨）= list（lo）
循环
 
'排序这两个子列表。 
 Quicksort列表，min，lo  -  1 
 Quicksort列表，lo + 1，max 
 End Sub 
  
 
I have a problem with a application that I have. It is a app to rename all pictures in a selected folder and the sub folders within the folder.

However sometimes it deals with the pictures in alphabetical order A-Z, therefore renaming them correctly and sometimes it seems to be dealing with them in Date Modified Order. Oldest first, newest last. This causes the order of the files to become wrong. We have had both results on the same PC and I am totally confused on what to try next.

Does anyone know how to alter the below code so that it always uses alphabetical order A-Z.

Please help.

The full code is as follows: 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
Any help would be really appreciated.

Regards,

Sam
解决方案
So in this link, as provided by @SkipIntro, there is a function and a sub.


Firstly the quicksort function will sort a list providing you supply the min and max.
Secondly the sortedfiles being the main one will return the list of files in alphabetical order.


If you use the following to sort you file names before they are published then they will be in alphabetical order e.g.
quicksort myfilenames, 1, ubound(myfilenames, 1)     
quicksort:
' 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


                        
这篇关于强制文件和文件夹按字母顺序处理的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！