Consulting

Results 1 to 6 of 6

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

  1. #1

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

    Hello all! 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.

  2. #2
    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.

    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    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.


    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?

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

    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  5. #5

    Thumbs up

    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!


    Sub Hyperlink_Download()
    Call Forward
    Call gmayor
    End Sub
    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
    gmayor()
    I couldn't post your code because my account is too new? Something about too many URLs.

  6. #6
    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.

    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •