Outlook local links

CopyLocalLink.vba

Option Explicit

Sub CopyLocalLink()

    Dim activeWin As Object
    Dim targetItem As Object
    Dim targetMsg As MailItem
    Dim targetFolder As Folder
    Dim urlData As Object

    Set activeWin = Application.ActiveWindow
    ' Case 1: Calling this from the message window.
    If activeWin.Class = olInspector Then
        Set targetItem = activeWin.CurrentItem
        If targetItem.Class <> olMail Then
            MsgBox "The current item is not a message.", vbExclamation, "Create Appointment from Message"
            Exit Sub
        End If
        Set targetMsg = targetItem
    ' Case 2: Calling this from the folder window.
    ElseIf activeWin.Class = olExplorer Then
        ' Ensure current folder is a folder of messages.
        Set targetFolder = activeWin.CurrentFolder
        If targetFolder Is Nothing Then
            MsgBox "No folder is in view.", vbExclamation, "Create Appointment from Message"
            Exit Sub
        End If
        If targetFolder.DefaultItemType <> olMailItem Then
            MsgBox "The current folder is not a message folder.", vbExclamation, "Create Appointment from Message"
            Exit Sub
        End If
        Set targetFolder = Nothing
        ' Ensure the unique selection is a message.
        Set targetItem = activeWin.Selection
        If targetItem.Count = 0 Then
            MsgBox "No item is selected.", vbExclamation, "Create Appointment from Message"
            Exit Sub
        ElseIf targetItem.Count <> 1 Then
            MsgBox "Multiple items are selected.", vbExclamation, "Create Appointment from Message"
            Exit Sub
        End If
        Set targetItem = targetItem.Item(1)
        If targetItem.Class <> olMail Then
            MsgBox "The selected item is not a message.", vbExclamation, "Create Appointment from Message"
            Exit Sub
        End If
        Set targetMsg = targetItem
    ' Case 3: Mysterious.
    Else
        MsgBox "The active window is neither an inspector not an explorer.", vbExclamation, "Create Appointment from Message"
        Exit Sub
    End If

    ' Use class moniker for MSForms.DataObject to avoid adding reference.
    Set urlData = CreateObject("new:1C3B4210-F441-11CE-B9EA-00AA006B1A69")
    urlData.SetText "outlook:" & targetMsg.EntryID
    urlData.PutInClipboard

End Sub

PasteLocalLink.vba

Option Explicit

Sub PasteLocalLink()

    Dim targetCell As Object
    Dim targetObject As Range
    Dim urlData As Object
    Dim url As String

    Set targetCell = Application.Selection
    If Not (TypeOf targetCell Is Range) Then
        MsgBox "The selection is not a cell.", vbCritical
        Exit Sub
    End If
    If targetCell.Cells.Count <> 1 Then
        MsgBox "The selection msut be a single cell.", vbCritical
        Exit Sub
    End If
    Set targetObject = targetCell

    ' Use class moniker for MSForms.DataObject to avoid adding reference.
    Set urlData = CreateObject("new:1C3B4210-F441-11CE-B9EA-00AA006B1A69")
    urlData.GetFromClipboard
    url = urlData.GetText
    If Left(url, Len("outlook:")) <> "outlook:" Then
        MsgBox "Not an Outlook local link.", vbCritical
        Exit Sub
    End If

    targetObject.ClearContents
    targetObject.Hyperlinks.Add targetObject, url, , , "Link"

End Sub