變更OST,PST資料檔的預設路徑

因為工作需要，所以找了一下變更預設路徑的方式

參考來源：
 https://dotblogs.com.tw/dotjason/2014/01/15/140196


一、執行登錄編輯程式
二、展開至 \HEY_Current_User\Software\Microsoft\Office\15.0\Outlook 下
三、新增可擴充字串值，本例為D:\Mail
　　 ForcePSTPath → D:\Mail
　　 ForceOSTPath→ D:\Mail

Outlook VBA Outlook通訊錄

以下Outlook VBA 的作用在於將特定目錄下的連絡人資料夾，顯示為電子郵件通訊錄

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

Set myNameSpace = Application.GetNamespace("MAPI")

myNameSpace.AddStore "D:\Mail\通訊錄.pst" '開啟預設通訊錄檔案
Set mySourFolder = myNameSpace.Folders("通訊錄").Folders("G-SPEC 連絡人")  '來源資料檔"收件匣"物件

    For i = 1 To mySourFolder.Folders.Count
        Set thisFolder = mySourFolder.Folders(i)
   
        If thisFolder.ShowAsOutlookAB = False Then '判斷是否未選擇顯示該連絡人目錄
            thisFolder.ShowAsOutlookAB = True '將此資料夾顯示為電子郵件通訊錄
            MsgBox ("顯示通訊錄  " & thisFolder.Name)
           
        End If     
    Next i

 Set myNameSpace = Nothing  
End Sub

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