2024年6月2日 星期日

用VBA針對相片及影片以日期重分類

 

針對資料夾內所有子資料夾所有照片及影片檔案都移到最上層資料夾用VBA寫一個針對相片及影片的建立日、修改日、存取日判斷,以這三個日期中最小的日期依年月資料夾分類,如果該資料夾不存在就新建,當檔案名稱如果重複時就自動在檔案名稱依序給予 _+流水號


分類結果4436個影片及照片自動移到最上層資料夾,只花不到1分鐘

分類結果
分類結果

同一時間處理完畢
同一時間處理完畢



Sub OrganizePhotosAndVideosByDate()

    Dim topFolderPath As String

    Dim fso As Object

    Dim topFolder As Object

    Dim subFolder As Object

    Dim file As Object

    Dim earliestDate As Date

    Dim yearMonth As String

    Dim targetFolder As String

    Dim fileExtensions As Variant

    Dim i As Integer

    Dim fileName As String

    Dim newFileName As String

    Dim counter As Integer


    ' 設置要處理的頂層資料夾路徑

    topFolderPath = "C:\Your\Path\To\PhotosAndVideos" ' 替換為實際的路徑

    

    ' 要處理的文件副檔名

    fileExtensions = Array("jpg", "jpeg", "png", "gif", "bmp", "mp4", "avi", "mov", "wmv", "mkv")

    

    ' 創建 FileSystemObject

    Set fso = CreateObject("Scripting.FileSystemObject")

    Set topFolder = fso.GetFolder(topFolderPath)

    

    ' 遍歷頂層資料夾及其所有子資料夾中的每個檔

    Call ProcessFolder(topFolder, fso, topFolderPath, fileExtensions)

    

    MsgBox "Files have been organized by date.", vbInformation

End Sub


Sub ProcessFolder(folder As Object, fso As Object, topFolderPath As String, fileExtensions As Variant)

    Dim file As Object

    Dim subFolder As Object

    Dim earliestDate As Date

    Dim yearMonth As String

    Dim targetFolder As String

    Dim fileName As String

    Dim newFileName As String

    Dim counter As Integer


    ' 遍歷資料夾中的每個檔

    For Each file In folder.Files

        ' 檢查檔副檔名是否在目標副檔名清單中

        If IsInArray(LCase(fso.GetExtensionName(file.Path)), fileExtensions) Then

            ' 獲取檔的創建日期、修改日期和訪問日期

            earliestDate = GetEarliestDate(file.DateCreated, file.DateLastModified, file.DateLastAccessed)

            

            ' 格式化為 "YYYY-MM" 格式

            yearMonth = Format(earliestDate, "YYYY-MM")

            

            ' 設置目的檔案夾路徑

            targetFolder = topFolderPath & "\" & yearMonth

            

            ' 如果目的檔案夾不存在,則創建新資料夾

            If Not fso.FolderExists(targetFolder) Then

                fso.CreateFolder(targetFolder)

            End If

            

            ' 設置初始檔案名

            fileName = fso.GetBaseName(file.Name) & "." & fso.GetExtensionName(file.Name)

            newFileName = fileName

            counter = 1

            

            ' 如果目的檔案夾中已存在同名檔,則添加序號

            Do While fso.FileExists(targetFolder & "\" & newFileName)

                newFileName = fso.GetBaseName(file.Name) & "_" & counter & "." & fso.GetExtensionName(file.Name)

                counter = counter + 1

            Loop

            

            ' 移動文件到目的檔案夾

            file.Move targetFolder & "\" & newFileName

        End If

    Next file

    

    ' 遞迴處理子資料夾

    For Each subFolder In folder.SubFolders

        Call ProcessFolder(subFolder, fso, topFolderPath, fileExtensions)

    Next subFolder

End Sub


' 函數:檢查陣列中是否包含指定值

Function IsInArray(value As Variant, arr As Variant) As Boolean

    Dim element As Variant

    IsInArray = False

    For Each element In arr

        If element = value Then

            IsInArray = True

            Exit Function

        End If

    Next element

End Function


' 函數:獲取最早的日期

Function GetEarliestDate(date1 As Date, date2 As Date, date3 As Date) As Date

    GetEarliestDate = Application.WorksheetFunction.Min(date1, date2, date3)

End Function

代碼說明:


頂層資料夾路徑和檔副檔名:topFolderPath 變數指定要處理的頂層資料夾路徑,請將其替換為實際的路徑。fileExtensions 陣列包含要處理的檔案類型副檔名。


遍歷資料夾和文件:ProcessFolder 副程式遞迴遍歷指定資料夾及其所有子資料夾中的每個檔,並調用 IsInArray 函數檢查檔副檔名是否在目標副檔名清單中。


日期比較和分類:對於每個檔,獲取其創建日期、修改日期和訪問日期,並計算最早的日期。然後按 YYYY-MM 格式分類到對應的資料夾中。如果目的檔案夾不存在,則創建新的資料夾。


處理檔案名衝突:如果目的檔案夾中已存在同名檔,則添加序號以避免檔案名衝突。


輔助函數:IsInArray 函數用於檢查檔副檔名是否在目標副檔名清單中,GetEarliestDate 函數用於獲取三個日期中的最早日期。


運行此宏後,指定頂層資料夾及其所有子資料夾中的所有照片和視頻檔將移到最上層資料夾,並按最早日期的年月分類到對應的資料夾中。如果檔案名重複,將自動在檔案名後添加序號。


沒有留言:

張貼留言

用GPT修改M語法_以日期列處理

在2023年GPT開始使用時我就詢問過GPT,可能當時的GPT還不夠聰明,給予的答案無法運行,我認為原始的語法應該可以更聰明點,詢問過Power BI社群的人,但沒有人提供答案,終於在現在再度詢問GPT給予的答案與我思考的方向依樣,只是我懂得語法不多,透過GPT幫忙解答,我也學到...