How to download a PDF that is in a hyperlink using VB in Outlook 2016

Question

I'm looking for some assistance with automating a task I do several times per day.I receive emails from a certain address which I automatically sort (using Rules) into a dedicated folder.

These emails have hyperlinks to different documents to download from the web; however the links are not written as a URL, rather there is a link saying "Open the document".

I click on this link, it opens the PDF, then I save this PDF file on my desktop before I upload it to a document library

I'm looking to automate this process. It's a fiddly task doing it manually because I receive so many emails, and downloading each one separately to a folder on my machine and then uploading them to my document library takes a long time.

I don't have much programming experience with VBA but I'm willing to learn.

Could anyone help me?

Answer 1

Start with enabling the Developer Tab in OutLook.

Then how to create a Macro in OutLook

Copy the code below into a new Module.

Finally, edit your rule to move the emails and add another step to run a script. Click in the rule your new Module should show up.

Done.

Sub SavePDFLinkAction(item As Outlook.MailItem)

    Dim subject As String
    Dim linkName As String

    '*******************************
    ' Intitial setup
    '*******************************
    subject = "Criteria" ' Subject of the email
    linkName = "Open the document" ' link name in the email body
    '*******************************

    Dim link As String

    link = ParseTextLinePair(item.body, "HYPERLINK")
    link = Replace(link, linkName, "")
    link = Replace(link, """", "")
    'Download the file - Intitial settings need to be set
    DownloadFile (link)

End Sub

Sub DownloadFile(myURL As String)

    Dim saveDirectoryPath As String

    '*******************************
    ' Intitial setup
    '*******************************
    saveDirectoryPath = "C:\temp\" 'where your files will be stored
    '*******************************

    Dim fileNameArray() As String
    Dim fileName As String
    Dim arrayLength As Integer
    Dim DateString As String
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")

    fileNameArray = Split(myURL, "/")
    arrayLength = UBound(fileNameArray)
    fileName = fileNameArray(arrayLength)

    'Add date to the file incase there are duplicates comment out these lines if you do not want the date added
    fileName = Replace(fileName, ".pdf", "_" & DateString & ".pdf")
    fileName = Replace(fileName, ".PDF", "_" & DateString & ".PDF")

    Dim WinHttpReq As Object
    Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
    WinHttpReq.Open "GET", myURL, False, "username", "password"
    WinHttpReq.Send

    myURL = WinHttpReq.responseBody
    If WinHttpReq.Status = 200 Then
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Open
        oStream.Type = 1
        oStream.Write WinHttpReq.responseBody
        oStream.SaveToFile saveDirectoryPath & fileName, 2 ' 1 = no overwrite, 2 = overwrite
        oStream.Close
    End If

End Sub

Function ParseTextLinePair(strSource As String, strLabel As String)
    Dim intLocLabel As Integer
    Dim intLocCRLF As Integer
    Dim intLenLabel As Integer
    Dim strText As String

    intLocLabel = InStr(strSource, strLabel)
    intLenLabel = Len(strLabel)
    If intLocLabel > 0 Then
        intLocCRLF = InStr(intLocLabel, strSource, vbCrLf)
        If intLocCRLF > 0 Then
            intLocLabel = intLocLabel + intLenLabel
            strText = Mid(strSource, _
                            intLocLabel, _
                            intLocCRLF - intLocLabel)
        Else
            intLocLabel = Mid(strSource, intLocLabel + intLenLabel)
        End If
    End If
    ParseTextLinePair = Trim(strText)
End Function