Download Hyperlink Files from Internal Server and save file name with preceding text

Hello all! :hi: My name is Michael and I'm seeking a method to help me facilitate the task of downloading files from Outlook hyperlinks to save time. I've searched this forum a few times viewing similar questions and I was unable to find one that matched my needs; or I didn't understand enough to re-purpose it. Thank you for taking a look!


My Problem
I receive many emails everyday linking to files located on an internal server which I need to download. Sometimes there are hundreds of files that I need to download and honestly, the way I've been doing it is to copy the hyperlink to clipboard, paste it into the windows search, drag it into a folder, and rename it. This can be an arduous process to say the least. I'm looking for a better way and I'm hoping a bit of VBA is the savior.

My Thoughts
Search through the body of an email looking for hyperlinks that match the below format (Name= Hyperlink)
Download all of the hyperlink files into a folder
Name the file by the it's "Name" (characters which precede the equal sign before the hyperlink)

The Files
All of the hyperlinks I want to download all contain the same beginning string "H:\LIB\DOCS\LIAB". It's not always in capital letters but the characters are the same.
File 1 Name Here= File://h:\lib\docs\LIAB\1234\2153265\MONKEY\2QR8323.DOC
Name of File 2= File://H:\LIB\DOCS\LIAB\5588\2054280\DINOSAUR\2YG3431.DOCX
Possible Name which breaks it 6/17/2018= File://h:\lib\docs\LIAB\9876\TURTLE\COSTSFIRM\4TP8398.PDF





Some additional information:

Reserved Characters in the "Name"
Some of the "Names" may have reserved characters. This will mostly be dates using backslashes but sometimes colons and other appear. Perhaps we can remove those characters entirely? I'm open to suggestions!

Preferred Save Location
%systemdrive%\users\%username%\Desktop\Outlook Hyperlinks
If this variable path doesn't work for this method, then a "C:\Folder" or something similar will be just as useful.

Dialog Box
I'm not sure if something like this would warrant a Dialog Box or not. I would think a dialog box notifying that "Downloads Complete" or similar would be comforting to see. No Dialog Box is perfectly acceptable too if this executes instantly and all I'm left with is waiting for the Windows file transfer to complete.

My Environment
Currently using Windows 7; upgrading to 10 soon. Outlook 2010. Please let me know if you need any specifics.

How can you have reserved characters in the filenames?

The following will copy accessible linked files to the folder on your desktop, with the original filenames. If the name already exists in the target folder it will be overwritten. If you want to retain existing files then see the filenameunique code example on my web site. The target folder is created if it doesn't exist. Select a message and Run the Test macro. Alternatively you could run the main macro as a script from a rule that identifies the messages in question as they arrive.

Code:

---

Option Explicit

Sub Test()
Dim olMsg As MailItem
    'On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    SaveLinkedFiles olMsg
lbl_Exit:
    Exit Sub
End Sub

Sub SaveLinkedFiles(olItem As Object)
'Graham Mayor - http://www.gmayor.com - Last updated - 18 Jun 2018
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oLink As Object
Dim strSource As String
Dim strFname As String
Dim fso As Object
    CreateFolders Environ("USERPROFILE") & "\Desktop\Outlook Hyperlinks"
    Set fso = CreateObject("Scripting.FileSystemObject")
    If TypeName(olItem) = "MailItem" Then
        With olItem
            Set olInsp = .GetInspector
            Set wdDoc = olInsp.WordEditor
            .Display
            For Each oLink In wdDoc.Hyperlinks
                strSource = oLink.Address
                If fso.FileExists(strSource) Then
                    strFname = Mid(strSource, InStrRev(strSource, Chr(92)))
                    FileCopy oLink.Address, Environ("USERPROFILE") & "\Desktop\Outlook Hyperlinks" & strFname
                End If
            Next oLink
        End With
    End If
    olItem.Close 0
lbl_Exit:
    Set olInsp = Nothing
    Set fso = Nothing
    Set wdDoc = Nothing
    Set oLink = Nothing
    Exit Sub
End Sub

Public Sub CreateFolders(strPath As String)
'A Graham Mayor/Greg Maxey AddIn Utility Macro
Dim oFSO As Object
Dim lng_PathSep As Long
Dim lng_PS As Long
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    lng_PathSep = InStr(3, strPath, "\")
    If lng_PathSep = 0 Then GoTo lbl_Exit
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Do
        lng_PS = lng_PathSep
        lng_PathSep = InStr(lng_PS + 1, strPath, "\")
        If lng_PathSep = 0 Then Exit Do
        If Len(Dir(Left(strPath, lng_PathSep), vbDirectory)) = 0 Then Exit Do
    Loop
    Do Until lng_PathSep = 0
        If Not oFSO.FolderExists(Left(strPath, lng_PathSep)) Then
            oFSO.CreateFolder Left(strPath, lng_PathSep)
        End If
        lng_PS = lng_PathSep
        lng_PathSep = InStr(lng_PS + 1, strPath, "\")
    Loop
lbl_Exit:
    Set oFSO = Nothing
    Exit Sub
End Sub

---

Thank you so much for your help, gmayor! This is a game changer for me. This perfectly saves the hyperlink file to the folder on my desktop. There is one alteration I'm researching regarding the strFname.

Quote:

---

How can you have reserved characters in the filenames?

---

I didn't explain this, sorry. These files are coming from a program we use. The files are technically saved with the 7 character alpha numeric string at the end of the hyperlink, the strSource in your macro. The files are linked within a database which allows us to assign them a "Reference Name" and other useful information about the files such as categories, dates, author, etc. It's those Reference Names that are eligible to contain the reserved characters.

File 1 Name Here= File://h:\lib\docs\LIAB\1234\2153265\MONKEY\2QR8323.DOC

This macro that you've created; thank you again btw, is currently saving the files with their "actual" file name: the 7 characters at the end of the hyperlink, "2QR8323". I would like to change that to the text at the beginning of the line and stopping before the equals sign: "File 1 Name Here".

I was looking at the code and I was wondering if the strFname String could be altered to refer to the "Reference Name" preceding the hyperlink rather than the "Actual" file name itself. I'm currently looking into how to begin the string at the beginning of the line containing the strSource hyperlink. Do you think that's possible?

Assuming that the 'lines' in the message are paragraphs and not a single paragraph separated by line breaks then you can use

Code:

---

Sub SaveLinkedFiles(olItem As Object)
'Graham Mayor - http://www.gmayor.com - Last updated - 18 Jun 2018
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oLink As Object
Dim oRng As Object
Dim strSource As String
Dim strFname As String
Dim fso As Object
Dim arrInvalid() As String
Dim lng_Index As Long
Dim strExt As String
    arrInvalid = Split("9|10|11|13|34|42|47|58|60|62|63|92|124", "|")

    CreateFolders Environ("USERPROFILE") & "\Desktop\Outlook Hyperlinks"
    Set fso = CreateObject("Scripting.FileSystemObject")
    If TypeName(olItem) = "MailItem" Then
        With olItem
            Set olInsp = .GetInspector
            Set wdDoc = olInsp.WordEditor
            .Display
            For Each oLink In wdDoc.Hyperlinks
                strSource = oLink.Address
                If fso.FileExists(strSource) Then
                    strExt = Mid(strSource, InStrRev(strSource, Chr(46)))
                    Set oRng = oLink.Range.Paragraphs(1).Range
                    strFname = oRng.Text
                    strFname = Split(strFname, "=")(0)
                    For lng_Index = 0 To UBound(arrInvalid)
                        strFname = Replace(strFname, Chr(arrInvalid(lng_Index)), Chr(95))
                    Next lng_Index
                    FileCopy oLink.Address, Environ("USERPROFILE") & "\Desktop\Outlook Hyperlinks\" & strFname & strExt
                End If
            Next oLink
        End With
    End If
    olItem.Close 0
lbl_Exit:
    Set olInsp = Nothing
    Set fso = Nothing
    Set wdDoc = Nothing
    Set oLink = Nothing
    Exit Sub
End Sub

---

If the 'lines' are separated by line breaks and not paragraph breaks then add the line below - however this will change the message in the inbox so only do it if necessary.

With olItem
.Body = Replace(.Body, Chr(11), Chr(13))
Set olInsp = .GetInspector

Thank you, gmayor! This is incredible. My response too a few days since I didn't look at this until yesterday and when I typed my response the first time, my laptop ran out of battery and when I turned it back on and went to submit the post (which was saved on screen) it must have timed out.

You were right about the 'lines'. They were line breaks and not paragraph breaks. Your substitution worked, enabling the files to be saved with the 'File Name' text. And you were also right about it changing the message.

File 1 Name Here= File://h:\lib\docs\LIAB\1234\2153265\MONKEY\2QR8323.DOC
changed into
File 1 Name Here= HYPERLINK"File://h:\lib\docs\LIAB\1234\2153265\MONKEY\2QR8323.DOC"File://h:\lib\docs\LIAB\1234\2153265\MONKEY\2QR8323.DOC

I was thinking about this and decided to tackle a solve on my own. My thought in researching a fix came from an idea about think about your fix. It's changing the body of the email I've selected. I thought, what if I open the email in a new body? My solution was to first Forward the email to bring it into a new window. Then, with it in a new window of which I don't care what happens to, run your code. The result works smoothly. It even closed the forwarded email I had opened.

Here is how I did it. Please let me know if this is an efficient fix. Well, you don't have to; I'm super satisfied with what I have. I'm marking this thread as solved. But, if you wanted to let me know if there is a better way then by all means!

Code:

---

Sub Hyperlink_Download()
Call Forward
Call gmayor
End Sub

---

Code:

---

Option Private ModuleSub Forward()
'Code copied from Sue Mosher of a PCReview.co.uk forum thread
Dim objMail As Outlook.MailItem
Set objItem = GetCurrentItem()
Set objMail = objItem.Forward
objMail.To = ""
objMail.Display
Set objItem = Nothing
Set objMail = Nothing
End Sub


Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = _
objApp.ActiveExplorer.Selection.item(1)
Case "Inspector"
Set GetCurrentItem = _
objApp.ActiveInspector.CurrentItem
Case Else
End Select
End Function

---

Code:

---

gmayor()

---

I couldn't post your code because my account is too new? Something about too many URLs. :yes

I am all for lateral thinking :), but I think you are overthinking the approach. To use a copy you just need a couple of extra lines in the main macro.

Code:

---

Sub SaveLinkedFiles(olItem As Object)
'Graham Mayor - http://www.gmayor.com - Last updated - 22 Jun 2018
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oLink As Object
Dim oRng As Object
Dim strSource As String
Dim strFname As String
Dim fso As Object
Dim arrInvalid() As String
Dim lng_Index As Long
Dim strExt As String
Dim olTemp As MailItem
    arrInvalid = Split("9|10|11|13|34|42|47|58|60|62|63|92|124", "|")
    CreateFolders Environ("USERPROFILE") & "\Desktop\Outlook Hyperlinks"
    Set fso = CreateObject("Scripting.FileSystemObject")
    If TypeName(olItem) = "MailItem" Then
        Set olTemp = CreateItem(0)
        With olTemp
            .Body = Replace(olItem.Body, Chr(11), Chr(13))
            Set olInsp = .GetInspector
            Set wdDoc = olInsp.WordEditor
            .Display
            For Each oLink In wdDoc.Hyperlinks
                strSource = oLink.Address
                If fso.FileExists(strSource) Then
                    strExt = Mid(strSource, InStrRev(strSource, Chr(46)))
                    Set oRng = oLink.Range.Paragraphs(1).Range
                    strFname = oRng.Text
                    strFname = Split(strFname, "=")(0)
                    For lng_Index = 0 To UBound(arrInvalid)
                        strFname = Replace(strFname, Chr(arrInvalid(lng_Index)), Chr(95))
                    Next lng_Index
                    FileCopy oLink.Address, Environ("USERPROFILE") & "\Desktop\Outlook Hyperlinks\" & strFname & strExt
                End If
            Next oLink
        End With
    End If
    olTemp.Close olDiscard
lbl_Exit:
    Set olTemp = Nothing
    Set olInsp = Nothing
    Set fso = Nothing
    Set wdDoc = Nothing
    Set oLink = Nothing
    Exit Sub
End Sub

---