VBA：OUTLOOK 指定收件夾轉存信件

 這幾天想要透過outlook弄自動化，寫了個簡單的vba，

目的是指定特定收件夾，將郵件轉存到指定資料夾，以利excel存取。

架構：設定存取outlook收件夾>迴圈執行存檔>檢查檔案是否存在>寫檔

啟用outlook 的vba編輯視窗，找到thisoutlooksession，然後貼上vba code即可

圖1.編輯

圖2.執行

圖3.巨集執行。

圖4.執行結果

	Sub Save_mial_Body_main()
	'會將收件匣中 "特定資料匣" 裡，所有信件的全部另存到程式裡設定的路徑去
	Dim my_Name_Space As Outlook.NameSpace
	Dim my_Folder, my_Inbox As Outlook.MAPIFolder
	Dim my_Items As Outlook.Items
	Dim i As Integer
	Set fs = CreateObject("Scripting.FileSystemObject")
	Set my_Name_Space = Application.GetNamespace("MAPI")
	Set my_Inbox = my_Name_Space.GetDefaultFolder(olFolderInbox) 'myFolder 代表 "收件匣 Inbox"
	Set my_Folder = my_Inbox.Folders("xxxx") 'XXX 是 "特定資料匣"，是在收件匣中
	Set my_Items = my_Folder.Items 'myItems 代表 "特定資料匣" 中所有信件 (的集合)
	For Each mail In my_Items '檢查每一封信
	Call Save_mial_Body_sub(mail)
	Next mail
	End Sub
	Sub Save_mial_Body_sub(Item) 'Item　As Object
	On Error GoTo line1
	'存檔副程式，於存檔時引用FileSystemObject 檢查檔案是否存在，沒有才寫資料
	Set fs = CreateObject("Scripting.FileSystemObject")
	Const olMsg As Long = 3
	Dim m As MailItem
	Dim savePath As String
	If TypeName(Item) <> "MailItem" Then Exit Sub
	Set m = Item
	savePath = "d:\測試區\ "
	MailDate = Year(Item.SentOn) & Month(Item.SentOn) & Day(Item.SentOn)
	savePath = savePath & m.Subject & MailDate '’Format(Now(), "yyyy-mm-dd-hhNNss")
	savePath = savePath & ".msg"
	SFName = savePath
	If fs.FileExists(SFName) = False Then
	savePath = Replace(savePath, "　", "")
	savePath = Replace(savePath, "?", "")
	m.SaveAs Replace(savePath, "?", ""), olMsg
	End If
	Exit Sub
	line1:
	MsgBox "ｅｒｒｏｒ"
	End Sub

view raw gistfile1.txt hosted with ❤ by GitHub