VBA_移動複製檔案_檢查日期

下面的代碼是當初整理相片時網路上找到然後修改，印象中花瞭半小時處理1萬個以上的相片檔，現在想要用在批次整理新公司的檔案，不過還不夠簡單，但先存一下做個紀錄。

 主要功能，透過檢查日期的方式，以檔案的修改日、建立日、授權日中最小的日期當作檔案一開始的日期(如果同一天會做備份，這部分需要自己檢查有沒有依樣)，然後做分類，算是比較花時間的方式，但比自己去分類相片簡單多了。

Sub 移動檔案___改()

    '2017/10/14 2017/10/16改

    Application.ScreenUpdating = False

    

    Dim objFile As File, 目的_File As File

    Dim objFolder As Folder, 目的_folder As Folder

    Dim D_檔案檢查 As Object

    

    

    ' DateLastModified DateCreated DateLastAccessed

    Dim objFSO As FileSystemObject

    

    Dim current_path ' As String 在namespace那邊抓不到

    

    

    current_path = "D:\照片\2016\新增資料夾" '應該可以用dic 方式把所有資料夾丟到Arr or 參考取得檔案名稱的方式修改

    

    Set objFSO = New FileSystemObject

    Set objFolder = objFSO.GetFolder(current_path)

    Set D_檔案檢查 = CreateObject("scripting.dictionary")

    

    mypath = "D:\照片\"

    On Error Resume Next

    For Each objFile In objFolder.Files

            in_修改日 = Format(objFile.DateLastModified, "yyyymm")

            in_建立日 = Format(objFile.DateCreated, "yyyymm")

            in_授權日 = Format(objFile.DateLastAccessed, "yyyymm")

            

            With CreateObject("shell.application").Namespace(current_path)

                in_文字 = Split(Split(.getdetailsof(.Items.Item(objFile.Name), -1), vbLf)(1), ":")(1)  'objFile.Name

                in_拍攝日 = Right(Split(in_文字, "/")(0), 4) & Format(Mid(Split(in_文字, "/")(1), 2, Len(Split(in_文字, "/")(1)) - 1), "00")

                

            End With

            

            If in_拍攝日 <> "" Then

                目的_path = mypath & Left(in_拍攝日, 4) & "\" & in_拍攝日 & "\"

                Set 目的_folder = objFSO.GetFolder(目的_path)

                For Each 目的_File In 目的_folder.Files

                    D_檔案檢查(目的_File.Name) = 目的_File.Name

                Next

                If D_檔案檢查(objFile.Name) = False Then ' And Format(objFile.DateLastModified, "yyyymm") = in_年度 & Format(i_月, "00") Then

                    objFile.Move (目的_path & "\" & objFile.Name)

                Else

         '           Do While D_檔案檢查(Split(objFile.Name, ".")(0) & "_1." & Split(objFile.Name, ".")(1))=false

                    objFile.Move (目的_path & "\" & Split(objFile.Name, ".")(0) & "_1." & Split(objFile.Name, ".")(1)) '備分確認用

                    

                End If

            Else

                in_最小日 = Application.Min(in_修改日, in_建立日, in_授權日)

                目的_path = mypath & Left(in_最小日, 4) & "\" & in_最小日 & "\"

                Set 目的_folder = objFSO.GetFolder(目的_path)

                For Each 目的_File In 目的_folder.Files

                    D_檔案檢查(目的_File.Name) = 目的_File.Name

                Next

                If D_檔案檢查(objFile.Name) = False Then ' And Format(objFile.DateLastModified, "yyyymm") = in_年度 & Format(i_月, "00") Then

                    objFile.Move (目的_path & "\" & objFile.Name)

                Else

                    objFile.Move (目的_path & "\" & Split(objFile.Name, ".")(0) & "_1." & Split(objFile.Name, ".")(1)) '備分確認用

                End If

              '  Set D_檔案檢查 = Nothing '***************

            End If

            

            

    Next objFile

                Set D_檔案檢查 = Nothing '***************

End Sub