0

I receive emails that contain a link. That link does not work since I am not on that company's network. I can change part of the link for external use to get it to work.

For example the email has this link:

https://ipdms.web.companyname.com/ipdms/itemlocation

I change it to:

https://companyVPN.companyname.com/ipdms/itemlocation

I was able to create a script but I need to open the email, run the macro, and then hit save on the email.

Sub Change2VPN()

Application.ActiveInspector.CurrentItem.body = _
  Replace(Application.ActiveInspector.CurrentItem.body, "ipdms.web", "companyVPN")

End Sub

I searched but have not been able to get anything to work. Is there a way I can either accomplish this on all items in a folder and save the email where it is or at least do it from the reading pane?

I can add the macro button to the ribbon.
I cannot run scripts as a rule on incoming emails due to corporate policies.

Community
  • 1
  • 1
J.D.S.
  • 1
  • Did you search anything? I found [this](https://stackoverflow.com/questions/24321752/outlook-vba-how-to-loop-through-inbox-and-list-from-email-email-address-if-subje) in less than about 5 seconds. – Scott Holtzman Apr 30 '20 at 20:16

1 Answers1

0

Basically you need to get the currently selected folder where a ribbon button was clicked and iterate over all items in the folder to get the job done:

Sub Change2VPN()

Dim olFolder As Outlook.Folder
Dim Item As Object
Dim explorer as Outlook.Explorer


Set explorer = Application.ActiveExplorer()
Set olFolder = explorer.CurrentFolder

For Each Item In olFolder.Items
    If TypeOf Item Is Outlook.MailItem Then 
        Dim oMail As Outlook.MailItem: Set oMail = Item
        oMail.HTMLBody = Replace(oMail.HTMLBody, "ipdms.web", "companyVPN")
        oMail.Save()
    End If
Next

End Sub

Eugene Astafiev
  • 47,483
  • 3
  • 24
  • 45