First, thanks to all who have already assisted in the first iteration of this message. After looking around at other sites I found a better method for searching messages for URLs using regular expressions on this page, Open All Hyperlinks in an Outlook Email Message, on slipstick.com.
The my personal tweaking of the code is:
Option Explicit
Public Sub OpenLinksMessage()
Dim olMail As Outlook.MailItem
Dim Reg1 As RegExp
Dim AllMatches As MatchCollection
Dim M As Match
Dim strURL As String
Dim oApp As Object
Set oApp = CreateObject("InternetExplorer.Application")
Set olMail = ActiveExplorer.Selection(1)
Set Reg1 = New RegExp
'Set the Regular Expression to search for any http:// or https:// format URL
'The Global feature says to look through the entire message text being tested
With Reg1
.Pattern = "(https?[:]//([0-9a-z=\?:/\.&-^!#$;_])*)"
.Global = True
.IgnoreCase = True
End With
' If the regular expression test for URLs comes back true
If Reg1.test(olMail.Body) Then
' Use the RegEx to return all instances that match it to the AllMatches group
Set AllMatches = Reg1.Execute(olMail.Body)
For Each M In AllMatches
strURL = M.SubMatches(0)
' Don't activate any URLs that are for unsubscribing; skip them
If InStr(strURL, "unsubscribe") Then GoTo NextURL
' If the URL ends with a > from being enclosed in darts, strip that > off
If Right(strURL, 1) = ">" Then strURL = Left(strURL, Len(strURL) - 1)
' We now have a URL that we want to open in a new tab in IE
oApp.navigate strURL, CLng(2048)
oApp.Visible = True
' wait for page to load before passing the web URL
Do While oApp.Busy
DoEvents
Loop
NextURL:
Next
End If
Set Reg1 = Nothing
End Sub
Private Sub TestLaunchURL()
OpenLinksMessage
End Sub
This will be running under Windows 10, and I am wondering if there is some way to substitute the statement:
Set oApp = CreateObject("InternetExplorer.Application")
with its equivalent but snagging the application that the user has chosen as their default web browser? I'm also not certain of what, if any change, would be necessary to the Clng(2048) to communicate that I'd like the URL to be opened in a new tab of that browser rather than the one that currently has focus.
Would:
Set olMail = ActiveExplorer.Selection(1)
be the correct syntax for the "message I've just received" when this is being triggered by a rule for an incoming message? If not, what is?
Is that DO loop really necessary? I am trying to get a handle on what it does but really don't have it yet.
There should only be a single link in messages received from a specific e-mail address that should be parsed for the link and opened, but the test for that should be in the rule that invokes this subroutine rather than in the VBA code itself. I may have some additional filtering logic, but I think it will be a matter of adding an IF statement or two.
If anyone sees any glaring error in this adapted code please do let me know. It seems to be working on tests on individual messages, as IE opens and every link that's in the message is being opened in its own tab. I'd really like to make it open in the user's default web browser if at all possible.
Thanks in advance for your assistance. It has been invaluable already.
Phase 2: The script is thoroughly tested and works. It has been installed under Outlook 2016, we signed it with a certificate created with selfcert, the Trust Center Macro permissions are still at "Notifications for digitally signed macros, all other macros disabled."
When the the rule that invokes the script is run, and the script is triggered, the following error message box appears:
Any theories on what went wrong and how to fix it? I have not yet created a second certificate with selfcert and signed this again because I wanted to know if this error message might pop up for other reasons, as sometimes happens.
Also, am I correct in believing that signed, user created macros will run, if signed, regardless of what the macro security is set to unless the setting is "all macros disabled"?
Phase 3.5 (sort of)
It appears the root of the problem is that the script itself is not being run at all when a new message arrives. I set up a testing rule that initially was to play a sound and invoke the script when a message arrives with either of two addresses in the sender's address. The sound would consistently play, but nothing else happened. So, I thought, let's take the sound playing out of the Outlook rule and put it in the script itself, with one sound playing unconditionally at the start of the script. Well, nada. Here is the latest code (some of which is taken directly from prior threads here on stackoverflow):
Option Explicit
Private Declare Function ShellExecute _
Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hWnd As Long, _
ByVal Operation As String, _
ByVal Filename As String, _
Optional ByVal Parameters As String, _
Optional ByVal Directory As String, _
Optional ByVal WindowStyle As Long = vbMinimizedFocus _
) As Long
Private Declare Function sndPlaySound32 _
Lib "winmm.dll" _
Alias "sndPlaySoundA" ( _
ByVal lpszSoundName As String, _
ByVal uFlags As Long) As Long
Sub PlayTheSound(ByVal WhatSound As String)
If Dir(WhatSound, vbNormal) = "" Then
' WhatSound is not a file. Get the file named by
' WhatSound from the Windows\Media directory.
WhatSound = Environ("SystemRoot") & "\Media\" & WhatSound
If InStr(1, WhatSound, ".") = 0 Then
' if WhatSound does not have a .wav extension,
' add one.
WhatSound = WhatSound & ".wav"
End If
If Dir(WhatSound, vbNormal) = vbNullString Then
Beep ' Can't find the file. Do a simple Beep.
Exit Sub
End If
Else
' WhatSound is a file. Use it.
End If
sndPlaySound32 WhatSound, 0& ' Finally, play the sound.
End Sub
Public Sub OpenLinksMessage(olMail As Outlook.MailItem)
Dim Reg1 As RegExp
Dim AllMatches As MatchCollection
Dim M As Match
Dim strURL As String
Dim RetCode As Long
Set Reg1 = New RegExp
With Reg1
.Pattern = "(https?[:]//([0-9a-z=\?:/\.&-^!#$;_])*)"
.Global = True
.IgnoreCase = True
End With
PlayTheSound "chimes.wav"
' If the regular expression test for URLs in the message body finds one or more
If Reg1.test(olMail.Body) Then
' Use the RegEx to return all instances that match it to the AllMatches group
Set AllMatches = Reg1.Execute(olMail.Body)
For Each M In AllMatches
strURL = M.SubMatches(0)
' Don't activate any URLs that are for unsubscribing; skip them
If InStr(1, strURL, "unsubscribe") Then GoTo NextURL
' If the URL ends with a > from being enclosed in darts, strip that > off
If Right(strURL, 1) = ">" Then strURL = Left(strURL, Len(strURL) - 1)
' The URL to activate to accept must contain both of the substrings in the IF statement
If InStr(1, strURL, ".com") Then
PlayTheSound "TrainWhistle.wav"
' Activate that link to accept the job
RetCode = ShellExecute(0, "Open", "http://nytimes.com")
Set Reg1 = Nothing
Exit Sub
End If
NextURL:
Next
End If
Set Reg1 = Nothing
End Sub
Private Sub TestLaunchURL()
Dim currItem As MailItem
Set currItem = ActiveExplorer.Selection(1)
OpenLinksMessage currItem
End Sub
If I trigger the above code either by using the TestLaunch subroutine via the debugger, or create a rule and at the end say "Run on messages already in the inbox," it functions perfectly.
The only thing I can't do right now is get this to be triggered using the "run script" feature of an Outlook Rule when a new message arrives.
Any theories or assistance regarding how to get over this last hurdle would be very much appreciated.
