智能地将 Outlook 电子邮件转发到另一个帐户

引言

我一直在寻找一种工具或方法，以便在我的工作电脑收到任何新电子邮件时，通过手机收到通知。我只想在我不在办公室时收到通知，所以我编写了一个 Outlook VBA 宏来完成此操作。该宏的作用是检查电脑是否已锁定，这意味着您不在办公室或办公桌前，然后它将撰写一封新电子邮件并将其发送到您的其他电子邮件地址。此外，此宏还允许您从手机帐户回复，然后当 Outlook 宏中的代码检测到电子邮件来自您的手机电子邮件时，它会自动将其转发给原始发送者，并去除之前插入的任何控制文本。

代码

Private Const FORWARD_TO_EMAIL As String = "your_email@your_domain.com "

Private Const START_MESSAGE_HEADER As String = "--------StartMessageHeader--------"
Private Const END_MESSAGE_HEADER As String = "--------EndMessageHeader--------"
Private Const FROM_MESSAGE_HEADER As String = "From: "

Private Const DESKTOP_SWITCHDESKTOP As Long = &H100
Private Declare Sub LockWorkStation Lib "User32.dll" ()
Private Declare Function SwitchDesktop Lib "user32" _
    (ByVal hDesktop As Long) As Long
Private Declare Function OpenDesktop _
    Lib "user32" Alias "OpenDesktopA" _
    (ByVal lpszDesktop As Any, _
    ByVal dwFlags As Long, _
    ByVal fInherit As Long, _
    ByVal dwDesiredAccess As Long) As Long
    
Sub ForwardEmail(MyMail As MailItem)
    On Error GoTo EndSub
    
    Dim strBody As String
    Dim objMail As Outlook.MailItem
    Dim MailItem As Outlook.MailItem
       
    Set objMail = Application.Session.GetItemFromID(MyMail.EntryID)
    
    ' Initialize email to send
    Set MailItem = Application.CreateItem(olMailItem)
    MailItem.Subject = objMail.Subject
    
    If (objMail.SenderEmailAddress <> FORWARD_TO_EMAIL) Then
        ' Only forward emails when the workstation is locked
        If (Not IsWorkstationLocked()) Then
            Return
        End If
    
        ' Compose email and send it to your other email
        strBody = START_MESSAGE_HEADER + Chr$(13) + _
            FROM_MESSAGE_HEADER + objMail.SenderEmailAddress + Chr$(13) + _
            "Name: " + objMail.SenderName + Chr$(13) + _
            "To: " + objMail.To + Chr$(13) + _
            "CC: " + objMail.CC + Chr$(13) + _
            END_MESSAGE_HEADER + Chr$(13) + Chr$(13) + _
            objMail.body
        MailItem.Recipients.Add (FORWARD_TO_EMAIL)
        
        ' Do not keep email sent to your mobile account
        MailItem.DeleteAfterSubmit = True
    Else
        ' Parse the original mesage and reply to the sender
        strBody = objMail.body
        Dim posStartHeader As Integer
        posStartHeader = InStr(strBody, START_MESSAGE_HEADER)
        Dim posEndHeader As Integer
        posEndHeader = InStr(strBody, END_MESSAGE_HEADER)
        
        'Remove the message header from the body
        strBody = Mid(strBody, 1, posStartHeader - 1) + _
            Mid(strBody, posEndHeader + Len(END_MESSAGE_HEADER) + 4)

        Dim originalEmailFrom As String
        originalEmailFrom = GetOriginalFromEmail(posStartHeader, _
                                                 posEndHeader, objMail.body)
        If (originalEmailFrom = "") Then
            Return
        End If
        
        MailItem.Recipients.Add (originalEmailFrom)
        
        ' Delete email received from your mobile account
        objMail.Delete
    End If
    
    ' Send email
    MailItem.body = strBody
    MailItem.Send
    
    
    ' Set variables to null to prevent memory leaks
    Set MailItem = Nothing
    Set Recipient = Nothing
    Set objMail = Nothing
    Exit Sub
    
EndSub:
    'MsgBox "Unexpected error. Type: " & Err.Description
End Sub


Private Function GetOriginalFromEmail(posStartHeader As Integer, _
        posEndHeader As Integer, strBody As String) As String
    GetOriginalFromEmail = ""
    If (posStartHeader < posEndHeader And posStartHeader > 0) Then
        posStartHeader = posStartHeader + Len(START_MESSAGE_HEADER) + 1
        Dim posFrom As Integer
        posFrom = InStr(posStartHeader, strBody, FROM_MESSAGE_HEADER)
        If (posFrom < posStartHeader) Then
            Return
        End If
        posFrom = posFrom + Len(FROM_MESSAGE_HEADER)
        Dim posReturn As Integer
        posReturn = InStr(posFrom, strBody, Chr$(13))
        If (posReturn > posFrom) Then
            GetOriginalFromEmail = _
                Mid(strBody, posFrom, posReturn - posFrom)
        End If
    End If
End Function

Private Function IsWorkstationLocked() As Boolean
    IsWorkstationLocked = False
    On Error GoTo EndFunction

    Dim p_lngHwnd As Long
    Dim p_lngRtn As Long
    Dim p_lngErr As Long
    
    p_lngHwnd = OpenDesktop(lpszDesktop:="Default", _
        dwFlags:=0, _
        fInherit:=False, _
        dwDesiredAccess:=DESKTOP_SWITCHDESKTOP)
    
    If p_lngHwnd <> 0 Then
        p_lngRtn = SwitchDesktop(hDesktop:=p_lngHwnd)
        p_lngErr = Err.LastDllError
        
        If p_lngRtn = 0 Then
            If p_lngErr = 0 Then
                IsWorkstationLocked = True
            End If
        End If
    End If
EndFunction:
End Function

使用代码

以下是安装和使用此宏的步骤

1. 创建一个证书，以便您的宏在没有警告的情况下运行
1. 转到：开始 > 所有程序 > Microsoft Office > Microsoft Office 工具 > VBA 项目的数字证书
2. 输入证书名称，例如：MyOutlookMacro
3. 单击“确定”
2. 打开 Microsoft Outlook
3. 转到工具 / 宏 / Visual Basic 编辑器
4. 复制上面的代码并将其粘贴到 VB 编辑器中
5. 将 your_email@your_domain.com 替换为您希望在 Outlook 中转发收件箱电子邮件的电子邮件地址
6. 保存
7. 单击工具 > 数字签名
8. 单击 [选择] 并选择您在步骤 1 中创建的证书
9. 单击确定，然后单击保存按钮并关闭 Visual Basic 编辑器
10. 从 Outlook，单击工具 / 规则和提醒
11. 单击新建规则
12. 选择 <消息到达时检查消息>
13. 单击 [下一步]，然后会弹出一个窗口，询问您是否希望将此规则应用于您收到的每条消息，单击 [是]
14. 在选择操作中，选中 [运行脚本]
15. 然后，单击一个脚本并选择我们刚刚创建的宏
16. 单击 [完成]
17. 设置完成！