Outlook 2013 Script Assistance - Save Opened Link with Subject Added

Outlook version
Outlook 2013 64 bit
Email Account
Exchange Server
Good morning!

I believe that I now have the two "pieces" that I need to achieve my goal.
How do I modify CODE ONE so that it saves the linked object with the Subject Line included?
CODE TWO (below) is the code snippet I think I need for this.


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)

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)




End If

Set Reg1 = Nothing

End Sub

' get the subject from the header

strTemp = propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0070001E")

aItem.Subject = strTemp


    Set Reg1 = CreateObject("VBScript.RegExp")

    With Reg1

        .Pattern = "(Subject:\s(.*)\n(.*))"

        .Global = True

    End With


    If Reg1.Test(strHeader) Then


        Set M1 = Reg1.Execute(strHeader)

        For Each M In M1

        strTemp = M.SubMatches(1)


    End If


      aItem.Subject = strTemp

     iItemsUpdated = iItemsUpdated + 1


Next aItem

MsgBox iItemsUpdated & " of " & mail.Items.Count & " Messages Updated"

Set myolApp = Nothing