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

[dreams]

Hi All,

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

I would like to find the original sender's email address from the email chain of the “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 sender's email (need to add in the TO field - boxed in Green) and the remaining email address in the CC field boxed in Pink).

It will be much appreciated. Thank you.

I found the below codes online, and they are working fine. But it is getting email addresses from the "From"" field only. Also, I have no idea how to change this code to get the TO and CC fields of the original email and how to set it to forward the selected email. If someone can help me, It will be much appreciated and will save a 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._%+-]+@[A-Za-z0-9.-]+\.[A-Z|a-z]{2,7}\b"



' 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

 

[house&o]

@dreams. Your question is quite detailed and it's clear you've already done some groundwork with VBA. The code you've provided is a good start, but it's limited to extracting the sender's email address from the "From" field. Let's extend this functionality to also capture the "TO" and "CC" fields of the original email, and then forward the selected email to the original sender, while CC'ing the remaining email addresses.

Modified VBA Code​

Here's a modified version of your code that should meet your requirements:

Sub ForwardEmailToOriginalSender()
    Dim olApp As Outlook.Application
    Dim selectedEmail As Object
    Dim olMailItem As Outlook.MailItem
    Dim senderEmail As String
    Dim internalDomainFound As Boolean
    Dim originalTo As String
    Dim originalCC As String

    Set olApp = New Outlook.Application
    Set selectedEmail = olApp.ActiveExplorer.Selection(1)
    Set olMailItem = selectedEmail

    If TypeOf olMailItem Is Outlook.MailItem Then
        senderEmail = olMailItem.SenderEmailAddress
        internalDomainFound = IsInternalDomain(senderEmail)

        If Not internalDomainFound Then
            originalTo = olMailItem.To
            originalCC = olMailItem.CC

            Dim newMail As Outlook.MailItem
            Set newMail = olApp.CreateItem(olMailItem)
            newMail.Subject = "Fwd: " & olMailItem.Subject
            newMail.To = senderEmail
            newMail.CC = originalCC
            newMail.HTMLBody = olMailItem.HTMLBody
            newMail.Send
        End If
    End If

    Set olApp = Nothing
    Set selectedEmail = Nothing
    Set olMailItem = Nothing
End Sub

Function IsInternalDomain(emailAddress As String) As Boolean
    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

Explanation​

1. olMailItem.SenderEmailAddress: This property directly gives you the sender's email address.
2. olMailItem.To and olMailItem.CC: These properties provide the "TO" and "CC" fields of the email.
3. olApp.CreateItem(olMailItem): Creates a new email item that you can modify and send.

This modified code should be more aligned with your requirements. It captures the "TO" and "CC" fields directly from the Outlook object model and uses them to forward the email to the original sender.

For further reading, you may refer to the Microsoft Outlook VBA documentation.

I hope this provides a comprehensive solution to your question. Feel free to test the code and make any necessary adjustments.

 

[dreams]

@house&o Thank you for your reply. I tried your code and I got a Runtime error "13" (Type mismatch) on the below line. Do you have any idea what I need to change?

Set newMail = olApp.CreateItem(olMailItem)