Adding Subject to this Link-Saving VBA

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
 
Outlook version
Outlook 2013 64 bit
Email Account
Exchange Server
Correction.
Set olMail = Application.ActiveExplorer().Selection(1).itm.Subject
should be
Set olMail = Application.ActiveExplorer().Selection(1).
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
Correction.
Set olMail = Application.ActiveExplorer().Selection(1).itm.Subject
should be
Set olMail = Application.ActiveExplorer().Selection(1).
without the last period...

Dang, was posted before I was ready. This macro opens a url, it doesn't save the message.

To add the subject, you would use olmail.subject - but need to run it though an illegal character function to remove characters not supported in file names. There are a couple of different ways of doing it - the sample at the link below uses a function to replace the illegal characts with a character of your choice- in this example, a dash.

sName = oMail.Subject
ReplaceCharsForFileName sName, "-"


Private Sub ReplaceCharsForFileName(sName As String, _
sChr As String _
)
sName = Replace(sName, "'", sChr)
sName = Replace(sName, "*", sChr)
sName = Replace(sName, "/", sChr)
sName = Replace(sName, "\", sChr)
sName = Replace(sName, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "<", sChr)
sName = Replace(sName, ">", sChr)
sName = Replace(sName, "|", sChr)
End Sub
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
Are you saving attachments or files that are downloaded from links in the email? Its more difficult to change the filename when its downloaded. I think you'll need to change it after the file is saved. I'll see if i can find any code.
 
Outlook version
Outlook 2013 64 bit
Email Account
Exchange Server
Are you saving attachments or files that are downloaded from links in the email? Its more difficult to change the filename when its downloaded. I think you'll need to change it after the file is saved. I'll see if i can find any code.
Saving the files that are downloaded.
 
Top