Open .msg from Network Drive Folder Then Download Hyperlinks

Question

My objective is to open all Outlook .msg files that are saved in a shared drive folder. Once each email is opened, open the hyperlinks contained in the body of the email and save the file that opens from the link. I would ideally skip links which would be different from the rest.

This is the code I use to open .msg files and save attachments. I figure I could reuse part of this to open the hyperlinks.

Sub SaveAttachments()

    Dim msg As Outlook.MailItem
    Dim att As Outlook.Attachment
    Dim strFilePath As String
    Dim strAttPath As String
    Dim colFiles As New Collection, f
    Dim posr As String

    'path for msgs
    strFilePath = "R:\AP\FY18\"

    GetFiles strFilePath, "*.msg", True, colFiles

    'path for saving attachments
    strAttPath = "R:\AP\Testing Extracts\"

    For Each f In colFiles
        Set msg = Application.CreateItemFromTemplate(f)
        If msg.Attachments.Count > 0 Then
            For Each att In msg.Attachments
                posr = InStrRev(att.filename, ".")
                ext = Right(att.filename, Len(att.filename) - posr)
                posl = InStr(att.filename, ".")
                fname = Left(att.filename, posr - 1)
                att.SaveAsFile strAttPath & "\" & fname & "_" & Format(msg.ReceivedTime, "ddmmyyyy_hhmm") & "." & ext
'               att.SaveAsFile strAttPath & att.FileName
            Next
        End If
    Next

End Sub

Sub GetFiles(StartFolder As String, Pattern As String, _
             DoSubfolders As Boolean, ByRef colFiles As Collection)

    Dim f As String, sf As String, subF As New Collection, s

    If Right(StartFolder, 1) <> "\" Then StartFolder = StartFolder & "\"

    f = Dir(StartFolder & Pattern)
    Do While Len(f) > 0
        colFiles.Add StartFolder & f
        f = Dir()
    Loop

    sf = Dir(StartFolder, vbDirectory)
    Do While Len(sf) > 0
        If sf <> "." And sf <> ".." Then
            If (GetAttr(StartFolder & sf) And vbDirectory) <> 0 Then
                    subF.Add StartFolder & sf
            End If
        End If
        sf = Dir()
    Loop

    For Each s In subF
        GetFiles CStr(s), Pattern, True, colFiles
    Next s

End Sub

I've seen the following.

UrlDownloadToFile in Access 2010 - Sub or Function not Defined

outlook script that automatically opens links in emails

The second of those links lead me to HTMLBody. I managed to create a new email, not open the links in a saved email.

A few things to note:

1. The emails are saved to the folder by someone other than myself.
2. I do not have access to the outlook inbox that the emails are being sent to. So I cannot pull it directly from the email in outlook.
3. There are approximately 100 hyperlinks in the body of each .msg saved.

I've never worked with hyperlinks in VBA before.

Answer 1

Firstly, do not use Application.CreateItemFromTemplate. Use Application.Session.OpenSharedItem.

Once you have MailItem object (you are already accessing the Attachments collection in your script above), read GetInspector property (returns Inspector object), then use Inspector.WordEditor to access Word.Document object. It exposes Hyperlinks property.