Insert hyperlink in email

[shg]

I frequently send emails (from Outlook) like this:

Kenny, Tim,

[Some document name] is on the share.

I copy the path on the share, select the words "on the share" in the email, right-click, select Hyperlink, and paste from the clipboard into the Address textbox. A macro would be handy.

Outlook uses Word as an editor, and this does what I want in Word:

Sub OnTheShare()
  ' Adds a hyperlink with the text "on the share" at the
  ' insertion point to the path on the clipboard
 
  ' Shortcut Ctrl+Shift+O
 
  Dim oDO           As Object
  Dim sAddr         As String

  Set oDO = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")

  oDO.GetFromClipboard
  On Error Resume Next
  sAddr = oDO.GetText
  On Error GoTo 0

  If Len(sAddr) Then
    ActiveDocument.Hyperlinks.Add _
        Anchor:=Selection.Range, _
        Address:=sAddr, _
        SubAddress:="", _
        ScreenTip:="", _
        TextToDisplay:="on the share"
  Else
    MsgBox Prompt:="Nothing on clipboard!", _
           Title:="OnTheShare"
  End If
End Sub

I'd be grateful if some kind soul would show me how to code it for Outlook.

Now cross-posted at ExcelForum

 

[GWteB]

The code below does not use the clipboard but a file dialog to retrieve the filename of the file to be linked.
Note the separate functions. See whether you can use it.

Sub shg()

    Dim FullFileName  As String, LinkToFile    As String
    Dim OutApp As Object, OutMail As Object

    FullFileName = PickFileName(Environ("userprofile") & "\documents")
    If Len(FullFileName) Then

        FullFileName = Replace(FullFileName, " ", "%20")
        LinkToFile = "<a href=file:///" & FullFileName & ">on the share</a>"

        If InStr(1, Application.Name, "Outlook", vbTextCompare) > 0 Then
            Set OutMail = Application.CreateItem(0)
        Else
            Set OutApp = CreateObject("Outlook.Application")
            Set OutMail = OutApp.CreateItem(0)
        End If
        With OutMail
            .Display
            Signature = .HTMLbody
            .To = "Email@Ccompany.com "
            .CC = ""
            .BCC = ""
            .Subject = ""
            .HTMLbody = "Hi there, find a new document on the share:<br><br>"
            .HTMLbody = .HTMLbody & LinkToFile & "<br><br>" & Signature
        End With
    Else
        MsgBox "Cancel was pressed.", vbExclamation, "OnTheShare"
    End If
End Sub

Public Function PickFileName(ByVal argFromFolder As String) As String

    Dim fd As FileDialog, XL As Object
    If InStr(1, Application.Name, "Excel", vbTextCompare) > 0 Then
        Set fd = Application.FileDialog(msoFileDialogFilePicker)
    Else
        Set XL = CreateObject("Excel.Application")
        Set fd = XL.Application.FileDialog(msoFileDialogFilePicker)
    End If
    With fd
        .Title = "Select document to hyperlink"
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "Excel Workbooks", "*.xls?"
        .Filters.Add "Word Documents", "*.doc?"
        .Filters.Add "All Files", "*.*"
        .InitialFileName = BuildProperFolderPath(argFromFolder)
        If .Show Then
            PickFileName = .SelectedItems(1)
        Else
            ' cancel was pressed
        End If
    End With
    If Not XL Is Nothing Then XL.Quit
End Function

Public Function BuildProperFolderPath(ByVal argPath As String) As String
    Do While Right(argPath, 1) = "\": argPath = Left(argPath, Len(argPath) - 1): Loop
    BuildProperFolderPath = argPath & "\"
End Function

 

[shg]

Thank you for that, @GWteB. Rory posted a more literal translation at the cross-post, and I'm going to pursue that for the moment. I'll revisit your suggestion if I can't get that to work.

Thank you again.

 

[GWteB]

Glad to help and thanks for letting me know