Outlook VBA 取得並建立相同的資料夾結構

以下VBA程式為在Outlook下取得並建立相同的資料夾結構

Sub MailFolder()
Dim myNameSpce As Outlook.NameSpace
Dim mySourFolder, myDestFolder As Outlook.MAPIFolder
Dim subFolder, thisFolder, thismyDestFolder As Outlook.MAPIFolder
Dim uName As String

uName = VBA.Environ("UserName") '取得登入名稱

Set myNameSpace = Application.GetNamespace("MAPI")
Set mySourFolder = myNameSpace.Folders(uName + "_2013").Folders("收件匣") '來源資料檔"收件匣"物件
Set myDestFolder = myNameSpace.Folders(uName + "_2014").Folders("收件匣") '目標資料檔"收件匣"物件

For i = 1 To mySourFolder.Folders.Count
    Set thisFolder = mySourFolder.Folders(i)
    On Error Resume Next '發生錯誤也繼續執行，避免資料夾已存在
    myDestFolder.Folders.Add (thisFolder.Name)  '於目標資料檔下建立資料夾
    Set thismyDestFolder = myDestFolder.Folders(thisFolder.Name)
 
    If thisFolder.Folders.Count <> 0 Then '判斷 "收件匣" 下的 "子資料夾" 下是否還有子資料夾
        Set subFolder = subFolders(thisFolder, thismyDestFolder)
    End If
Next i
 
End Sub

Function subFolders(ByVal mySourFolder As Outlook.MAPIFolder, myDestFolder As Outlook.MAPIFolder) As Outlook.MAPIFolder
Dim subFolder, thisFolder, thismyDestFolder As Outlook.MAPIFolder

For i = 1 To mySourFolder.Folders.Count
    Set thisFolder = mySourFolder.Folders(i)
    On Error Resume Next '發生錯誤也繼續執行，避免資料夾已存在
    myDestFolder.Folders.Add (thisFolder.Name)  '於目標資料檔下建立資料夾
    Set thismyDestFolder = myDestFolder.Folders(thisFolder.Name)
 
    If thisFolder.Folders.Count <> 0 Then '判斷 "收件匣" 下的 "子資料夾" 下是否還有子資料夾
        Set subFolder = subFolders(thisFolder, thismyDestFolder)
    End If
Next i

End Function