如何从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