misterbobthetomato
Member
- Outlook version
- Outlook 2013 64 bit
- Email Account
- Exchange Server
Hi folks...
This script does exactly what I want it to do...except...
I'd like it to add the Subject Line from the email as part of the file name.
I saw a possibility somewhere ["newName=itm.subject"] but whatever works is great.
What shall I add and where shall I add it?
Thank you so much.
Bob
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
Sub OpenLinksMessage()
Dim olMail As Outlook.MailItem
Dim Reg1 As RegExp
Dim M1 As MatchCollection
Dim M As Match
Dim strURL As String
Dim lSuccess As Long
Set olMail = Application.ActiveExplorer().Selection(1).itm.Subject
Set Reg1 = New RegExp
With Reg1
.Pattern = "(https?[:]//([0-9a-z=\?:/\.&-^!#$%;_])*)"
.Global = True
.IgnoreCase = True
End With
If Reg1.Test(olMail.Body) Then
Set M1 = Reg1.Execute(olMail.Body)
For Each M In M1
strURL = M.SubMatches(0)
Debug.Print strURL
If InStr(strURL, "unsubscribe") Then GoTo NextURL
If Right(strURL, 1) = ">" Then strURL = Left(strURL, Len(strURL) - 1)
lSuccess = ShellExecute(0, "Open", strURL)
DoEvents
NextURL:
Next
End If
Set Reg1 = Nothing
End Sub
This script does exactly what I want it to do...except...
I'd like it to add the Subject Line from the email as part of the file name.
I saw a possibility somewhere ["newName=itm.subject"] but whatever works is great.
What shall I add and where shall I add it?
Thank you so much.
Bob
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
Sub OpenLinksMessage()
Dim olMail As Outlook.MailItem
Dim Reg1 As RegExp
Dim M1 As MatchCollection
Dim M As Match
Dim strURL As String
Dim lSuccess As Long
Set olMail = Application.ActiveExplorer().Selection(1).itm.Subject
Set Reg1 = New RegExp
With Reg1
.Pattern = "(https?[:]//([0-9a-z=\?:/\.&-^!#$%;_])*)"
.Global = True
.IgnoreCase = True
End With
If Reg1.Test(olMail.Body) Then
Set M1 = Reg1.Execute(olMail.Body)
For Each M In M1
strURL = M.SubMatches(0)
Debug.Print strURL
If InStr(strURL, "unsubscribe") Then GoTo NextURL
If Right(strURL, 1) = ">" Then strURL = Left(strURL, Len(strURL) - 1)
lSuccess = ShellExecute(0, "Open", strURL)
DoEvents
NextURL:
Next
End If
Set Reg1 = Nothing
End Sub