如何从 Outlook 电子邮件正文中复制电子邮件地址并将其插入新电子邮件的收件人字段中？

Question

每天我都会收到几封自动发送的电子邮件，其中包含一些需要转发到另一个电子邮件地址的信息。

此电子邮件地址在自动电子邮件中，并不总是相同。此电子邮件地址位于表中标有“备注”的行下。我插入了一张图片来说明这一点。

我想使用 Outlook VBA 宏自动执行此过程。一些附加信息： 1) 我无法使用规则下的“运行脚本”功能。 2) 收到的电子邮件是自动发送的，格式始终相同。

我需要帮助的是： 1) 复制“备注”行下一列的邮箱地址。

我已经设法自动识别收到的电子邮件（通过其主题标题）并将其自动转发到预定义的电子邮件地址并更改转发的电子邮件主题标题。

Private WithEvents Items as Outlook.Items
Private Sub application_startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNameSpace("MAPI")

'Setting target folder as inbox
Set Items = objectNS.GetDefaultFolder(olFolderInbox).Items

End Sub


Private Sub Items_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.Mailitem

'act only if it is a mail item
If TypeName(Item) = "MailItem" Then
Set Msg = Item

'Detect emails with specified subject title
If Msg.Subject = "Test" Then
Set myForward = Item.Forward
myForward.Recipients.Add("test@gmail.com")
myForward.Subject = "FW: Success"
myForward.Save
myForward.Send
EndIf

EndIf

ProgramExit: Exit Sub

ErrorHandler:
MsgBox Err.Number & "-" & Err.Description
Resume ProgramExit

End Sub

Answer 1

据我了解，您想在电子邮件正文中获取地址。

您可以使用以下代码：

Option Explicit
Sub Example()
    Dim Item As MailItem
    Dim RegExp As Object
    Dim Search_Email As String
    Dim Pattern As String
    Dim Matches As Variant
    Dim len1 As String
    Dim result As String
    Set RegExp = CreateObject("VbScript.RegExp")
    Pattern = "remarks\s+(\b[A-Z0-9._%+-]+\b)"

    For Each Item In ActiveExplorer.Selection

        Search_Email = Item.Body
        With RegExp
            .Global = False
            .Pattern = Pattern
            .IgnoreCase = True
            Set Matches = .Execute(Search_Email)
        End With
        If Matches.Count > 0 Then
             len1 = Matches(0).Length() - 8
             result = Mid(Matches(0), 12, len1)
             result = result + "@gmail.com"
             MsgBox result
             Debug.Print Matches(0)
        Else
             Debug.Print "Not Found "
        End If

    Next

    Set RegExp = Nothing

End Sub

更多信息，你可以参考这个链接：

Extract Email address from a table in .HTMLbody