outlook資料檔案變大後會新建一個數據檔案，但如果之前建立了大量規則，那麼新建和修改這些檔案和規則會是件讓人頭痛的事

經過一天的摸索，完成了資料夾的複製，規則的目標資料夾的替換，以下是程式碼

Sub testMacro()




Dim defaultStore As Store
Dim defaultFolder As Folder
Dim sourceStore As Store
Dim dataStores As Stores
Dim dataStore As Store
Dim loopFolder As Folder
Dim inputFolder As Folder
Dim customerFolders As Folders
Dim customerFolder As Folder
Dim customerFolder2 As Folder
Dim customerFolder3 As Folder
Dim sourceFolder As String
Dim targetFolder As Folder
Dim targetFolder2 As Folder




Dim loopCollection




sourceFolder = InputBox("請輸入要拷貝的資料檔案的資料夾")








Set defaultStore = Session.defaultStore '當前資料檔案
Set defaultFolder = defaultStore.GetRootFolder '個人資料夾
For Each loopFolder In defaultFolder.Folders
    If loopFolder.Name = "收件箱" Then
        Set defaultFolder = loopFolder
    End If
Next
Set dataStores = Session.Stores
For Each dataStore In dataStores '迴圈所有資料檔案並根據名稱取得所有資料夾
    If dataStore.DisplayName = sourceFolder Then
        Set sourceStore = dataStore
        Set Folders = dataStore.GetRootFolder.Folders
        For Each loopFolder In Folders
            If loopFolder.Name = "收件箱" Then
                Set inputFolder = loopFolder
                ReDim loopCollection(0) As Folder
                Set loopCollection(0) = inputFolder
                Exit For
            End If
        Next
    End If
Next




Dim countNum As Integer
countNum = 0
Dim loopOutFolder As Folder
Dim loopInnerFolder As Folder




'MsgBox (loopCollection(countNum))




'開始迴圈遍歷
Do
Set loopOutFolder = loopCollection(countNum)
If loopOutFolder.Folders.Count > 0 Then
    For Each loopInnerFolder In loopOutFolder.Folders
        Dim newArray
        ReDim newArray(UBound(loopCollection)) As Folder
        For i = 0 To UBound(newArray)
            Set newArray(i) = loopCollection(i)
        Next
        ReDim loopCollection(UBound(loopCollection) + 1) As Folder
        For i = 0 To UBound(newArray)
            Set loopCollection(i) = newArray(i)
        Next
        Set loopCollection(UBound(loopCollection)) = loopInnerFolder
    Next
Else
    'do something
End If
countNum = countNum + 1
Loop While countNum < UBound(loopCollection)




Set loopCollection(0) = Nothing
Dim targetFolderCollection
ReDim targetFolderCollection(UBound(loopCollection)) As Folder
Dim targetIdCollection
ReDim targetIdCollection(UBound(loopCollection)) As String
Dim parentFolder As Folder
Dim targetParentFolder As Folder
Dim sourceLoopFolder As Folder




For i = 1 To UBound(loopCollection)
    Set loopFolder = loopCollection(i)
    If (loopFolder.Parent = "收件箱") Then
        defaultFolder.Folders.Add (loopFolder.Name)
        Set targetFolderCollection(i) = defaultFolder.Folders.GetLast()
        targetIdCollection(i) = defaultFolder.Folders.GetLast().EntryID
    Else
        For j = 1 To UBound(loopCollection)
            Set sourceLoopFolder = loopCollection(j)
            If sourceLoopFolder Is Nothing Then
            Else
                Set parentFolder = loopFolder.Parent
                If sourceLoopFolder.EntryID = parentFolder.EntryID Then
                    Set targetParentFolder = targetFolderCollection(j)
                End If
            End If
        Next
        If targetParentFolder Is Nothing Then
        Else
            targetParentFolder.Folders.Add (loopFolder.Name)
            Set targetFolderCollection(i) = targetParentFolder.Folders.GetLast()
            targetIdCollection(i) = targetParentFolder.Folders.GetLast().EntryID
        End If
    End If
Next








Dim loopRules As Rules
Dim loopRule As Rule
Dim loopActions As RuleActions '注意類
Dim loopAction As RuleAction '注意類
Dim moveToAction As MoveOrCopyRuleAction '注意類，定義的不對的話在with賦值那不起作用
Dim oldFolderId As String
Set loopRules = defaultStore.GetRules()


For Each loopRule In loopRules
    If loopRule.Actions.MoveToFolder.Folder Is Nothing Then
    
    Else
        oldFolderId = loopRule.Actions.MoveToFolder.Folder.EntryID
        For i = 1 To UBound(loopCollection)
            Set loopFolder = loopCollection(i)
            If loopFolder.EntryID = oldFolderId Then
                Set moveToAction = loopRule.Actions.MoveToFolder
                With moveToAction
                    .Folder = targetFolderCollection(i)
                End With
                Debug.Print moveToAction.Folder.FolderPath
            End If
        Next
    End If
Next
loopRules.Save


MsgBox ("操作成功！")
End Sub