如何利用Outlook VBA‧轉發收到的特定新郵件

01. 同事每星期也會收到一個包含附件電郵，需要將電郵轉寄到140+人士。而140+人士中，有100多人已儲存在O365通訊錄中一個public group中，另外40多人則是一個電郵地址。

02. 最簡單的方法，當然是設定郵件規則(mail rule)。但問題就出來了，設定郵件規則時，一直也沒有問題，但收件者就是永遠收不到轉發的電郵。

03. 看過網上資料，提及O365 E3郵件規則轉寄的一堆限制。

04. 先不論Microsoft題及的限制是否真確，但既然原始方法用不到，就不如用最傳統的VBA macro。所以就出現以下的內容。

05. 在Outlook中，按鍵盤『ALT + F11』，打開VBA editor。

06. 在『ThisOutlookSession』位置，貼上以下內容。

Option Explicit
Private WithEvents inboxItems As Outlook.Items
Private Sub Application_Startup()
Dim outlookApp As Outlook.Application
Dim objectNS As Outlook.NameSpace

Set outlookApp = Outlook.Application
Set objectNS = outlookApp.GetNamespace("MAPI")
Set inboxItems = objectNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub inboxItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim objForward As Outlook.MailItem
Dim destFolder As Outlook.Folder
Dim subject As String
Dim email As String
Dim exEmail As String

subject = "test001"
email = "test@example"

If (TypeOf Item Is MailItem) Then
If Item.SenderEmailType = "EX" Then
exEmail = Item.Sender.GetExchangeUser.PrimarySmtpAddress
Else
exEmail = Item.SenderEmailAddress
End If
If (InStr(Item.subject, subject) > 0 And email = LCase(exEmail)) Then
Set objForward = Item.Forward
With objForward
.subject = "Custom title: " & Item.subject
.HTMLBody = "Your content here. " & objForward.HTMLBody
.Recipients.Add ("newsgroup001")
.Recipients.ResolveAll
.Display
End With
objForward.Send

Set destFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("Forwarded")
Item.Move destFolder
End If
End If

ExitNewItem:
Exit Sub

ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ExitNewItem
End Sub

07. 當Outlook執行時，程式會檢查每一個收到的新電郵，如果主旨是『test001』時，就轉寄到Outlook通訊錄中『newsgroup001』group中，再將郵件移到收件匣下的『Forwarded』資料夾內。

08. 測試一下，先建立一個新電郵，主旨是『test001』。