Outlook VBA forward the selected email to original sender’s email ID (including the email used in TO, CC Field) from the email chain

[rajeshmuthu]

Hi All,

Can someone help me to achieve this VBA? I am not very familiar with VBA.

I would like to find the original senders email address from the email chain of “From:” Field (not from our inside organization emails like “@test.net”, “@testsupport.com” – check the attached image boxed in Green) and get it’s TO, CC fields on that email (including the inside organization emails if available on those TO & CC fields – Boxed in Pink). Then forward that selected email to the original senders email (need to add in TO field – Boxed in Green) and the remaining email address in CC field (Boxed in Pink).

It will be much appreciated. Thank you.

I found the below codes online and it is working fine. But it is getting email addres from "From"" field only. Also I have no idea about how to change this code to get the TO, CC field of the orginal email and how to set to forward the selected email. if someone help me, It will be much appreciated and will save lot of time on my end. Thank you.

Sub GetSenderFromSelectedEmailChainSource()

Dim olApp As Outlook.Application

Dim selectedEmail As Object

Dim olMailItem As Outlook.MailItem

Dim senderEmail As String

Dim internalDomainFound As Boolean



Set olApp = New Outlook.Application

Set selectedEmail = olApp.ActiveExplorer.Selection(1) ' Get the selected email

Set olMailItem = selectedEmail



If TypeOf olMailItem Is Outlook.MailItem Then

' Get the source code of the selected email

Dim sourceCode As String

sourceCode = olMailItem.HTMLBody



' Use regular expressions to find sender email addresses

Dim regex As Object

Set regex = CreateObject("VBScript.RegExp")

regex.Global = True

regex.IgnoreCase = True



' Define the pattern to match email addresses

regex.pattern = "\b[A-Za-z0-9._%+-][EMAIL='+@[A-Za-z0-9.-]+\.%5bA-Z|a-z%5d%7b2,7%7d\b']+@[A-Za-z0-9.-]+\.[A-Z|a-z]{2,7}\b[/EMAIL]"



' Find matches in the source code

Dim matches As Object

Set matches = regex.Execute(sourceCode)



' Iterate through matches to find the sender's email

Dim match As Object

For Each match In matches

senderEmail = match.Value

internalDomainFound = IsInternalDomain(senderEmail)



If Not internalDomainFound Then

Debug.Print "Sender Email from Source: " & senderEmail

Exit For

End If

Next match



If internalDomainFound Then

Debug.Print "No suitable sender email found in the source."

End If

End If



Set olApp = Nothing

Set selectedEmail = Nothing

Set olMailItem = Nothing

End Sub



Function IsInternalDomain(emailAddress As String) As Boolean

' Define your internal domain names here

Dim internalDomains() As String

internalDomains = Split("@test.net,@testsupport.com", ",")



Dim domain As String

domain = Right(emailAddress, Len(emailAddress) - InStr(emailAddress, "@"))



Dim i As Integer

For i = LBound(internalDomains) To UBound(internalDomains)

If LCase(domain) = LCase(internalDomains(i)) Then

IsInternalDomain = True

Exit Function

End If

Next i



IsInternalDomain = False

 End Function