How do I copy an e-mail address from an outlook e-mail body and insert it into the recipient field of a new e-mail?

Question

Every day I receive several automated e-mails which contain some information that needs to be forwarded to another e-mail address(es).

This e-mail address is in the automated e-mail, and will not always be the same. This e-mail address is located in a table, under the row labeled "Remarks". I've inserted a picture to illustrate this.

An example

I would like to automate this process using Outlook VBA Macros. Some additional information: 1) I cannot use the "run a script" function under Rules. 2) The incoming e-mails are automated and will always be the same format.

What I need help is in: 1) Copying the e-mail address in the next column of the "remarks" row.

I have already managed to automate the process of recognizing the incoming e-mail (by its subject title) and auto-forwarding it to a predefined e-mail address and changing the forwarded email subject title.

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("[email protected]")
myForward.Subject = "FW: Success"
myForward.Save
myForward.Send
EndIf

EndIf

ProgramExit: Exit Sub

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

End Sub

Alina Li Alina Li · Accepted Answer · 2018-10-15T06:43:02

According to my understand, You want to get address in email body.

You could use the below code:

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

For more information, you could refer to this link:

Extract Email address from a table in .HTMLbody

How do I copy an e-mail address from an outlook e-mail body and insert it into the recipient field of a new e-mail?

1 Answers