Graham
You are a VBA guru! An old post but it solved my need to put links to Outlook items on the clipboard as hyperlinks, instead of plain text. I've seen the idea of using a temporary mail/Word item and the Word formatting abilities before, but your example is the cleanest I've seen.
I've made some minor changes to your original code: Added lots of comments (I need the help when I come back to code later). Made it capable of handling an Inspector as well as an Explorer item. Added some information about the type of the item being linked to in the hyperlink text. Included "PostItem" in the Type Case.
Public Sub GUID_GetCurrent()
Dim olTemp As Outlook.MailItem
Dim olItem As Object
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oLink As Object
Dim oRng As Object
Dim ItemTypeName As String
Dim linkType As String
Dim linkName As String
Dim linkID As String
' Get an Item from the current Inspector or Explorer Selection
If TypeOf Application.ActiveWindow Is Outlook.Inspector Then
Set olItem = ActiveInspector.CurrentItem
If olItem Is Nothing Then
MsgBox "Inspector item not found", vbOKOnly + vbExclamation, "GUID_GetCurrent"
GoTo lbl_Exit
End If
ElseIf TypeOf Application.ActiveWindow Is Outlook.Explorer Then
If Application.ActiveExplorer.Selection.Count <> 1 Then
MsgBox "Must be only one Explorer item selected", vbOKOnly + vbExclamation, "GUID_GetCurrent"
GoTo lbl_Exit
End If
Set olItem = Application.ActiveExplorer.Selection.Item(1)
Else
MsgBox "There must be an open Inspector or an Explorer with one item selected", vbOKOnly + vbExclamation, "GUID_GetCurrent"
GoTo lbl_Exit
End If
' Get the value to use for the link name/type and the EntryID of the item
' based on the type of the item
ItemTypeName = TypeName(olItem)
Select Case ItemTypeName
Case Is = "MailItem", "TaskItem", "NoteItem", "AppointmentItem", "PostItem"
linkName = olItem.Subject
linkID = olItem.EntryID
linkType = Left(ItemTypeName, Len(ItemTypeName) - Len("Item"))
If linkType = "Post" Then linkType = "Card"
Case Is = "ContactItem"
linkName = olItem.FullName
linkID = olItem.EntryID
linkType = "Contact"
Case Else
MsgBox "Invalid item type selected : " + ItemTypeName, vbOKOnly + vbExclamation, "GUID_GetCurrent"
GoTo lbl_Exit
End Select
' Create a temporary MailItem
Set olTemp = CreateItem(olMailItem)
With olTemp
' Populate the body of the mail with the hyperlink
.BodyFormat = olFormatHTML
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
' .Display
oRng.Text = ""
Set oLink = wdDoc.Hyperlinks.Add(Anchor:=oRng, _
Address:="outlook:" + linkID, _
SubAddress:="", _
ScreenTip:="", _
TextToDisplay:="Outlook " + linkType + " : " + linkName)
' font correction (if desired)
oLink.Range.Font.Name = "Courier New"
oLink.Range.Font.Size = 10
' oLink.Range.Font.Color = vbRed
' Copy the body of the mail (the hyperlink) to the clipboard
oLink.Range.Copy
' Throw away the temp mail
olTemp.Close olDiscard
End With
lbl_Exit:
Set olTemp = Nothing
Set olInsp = Nothing
Set olItem = Nothing
Set oLink = Nothing
Set oRng = Nothing
Set wdDoc = Nothing
Exit Sub
End Sub