Copy hyperlink to buffer

[GfiFer]

Hello!
I need to paste links to outlook emails in some documents. To get links to mails I wrote such macro, that copies the internal message ID and creates a right link(like Outlook:3HDF8EWJE8FJ) but I can't make macro that wil push this link like hyperlink to buffer

The correct macro that copy the normal link and the subject:


Sub CopyLink()
Dim objMail As Outlook.MailItem
Dim doClipboard As DataObject
Set doClipboard = New DataObject

If Application.ActiveExplorer.Selection.Count <> 1 Then
MsgBox ("Select 1 object")
Exit Sub
End If

Set objMail = Application.ActiveExplorer.Selection.Item(1)
doClipboard.SetText "[[outlook:" + objMail.EntryID + "][MESSAGE: " + objMail.Subject + " (" + objMail.SenderName + ")]]"
doClipboard.PutInClipboard
End Sub



I tried to push the hyperlink to the buffer this way, but it's not working:

Sub CopyLink()
Dim objMail As Outlook.MailItem
Dim doClipboard As DataObject
Set doClipboard = New DataObject

If Application.ActiveExplorer.Selection.Count <> 1 Then
MsgBox ("Select 1 object")
Exit Sub
End If
Set objMail = Application.ActiveExplorer.Selection.Item(1)
ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:= _
"outlook:" + objMail.EntryID, SubAddress:="", ScreenTip:="", TextToDisplay:=objMail.SenderName
Selection.Copy
End Sub


P.S. Sorry for my bad English

[gmayor]

Your English is fine and infinitely better than my Russian :)

You almost had it with your second example, but what you need is:

Option Explicit

Sub CopyLink()
Dim objMail As Outlook.MailItem
Dim olTemp As Outlook.MailItem
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oLink As Object
Dim oRng As Object

Set objMail = Application.ActiveExplorer.Selection.Item(1)
Set olTemp = CreateItem(olMailItem)
With olTemp
.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:" + objMail.EntryID, _
SubAddress:="", _
ScreenTip:="", _
TextToDisplay:=objMail.SenderName)
Set oRng = oLink.Range
oRng.Copy
olTemp.Close olDiscard
MsgBox "Link copied to clipboard"
End With
lbl_Exit:
Set objMail = Nothing
Set olTemp = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set oLink = Nothing
Set oRng = Nothing
Exit Sub
End Sub

[GfiFer]

Oh, thank you so much! It is absolutely what I needed!:clap2:
How can I thank you?

[gmayor]

Should you ever venture into my part of the world, Moskovskaya vodka goes down a treat ;)

[GfiFer]

Hello!) I need your help again. Is it possible to make something like this for MS Project? I want to create hyperlinks to tasks

P.S. I have improved code for Outlook to creating hyperlinks to other Outlook objects :thumb



Sub CopyLink()
Dim olTemp As Outlook.MailItem
Set olTemp = CreateItem(olMailItem)

Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oLink As Object
Dim oRng As Object

Dim linkName
Dim linkID

Dim doClipboard As DataObject
Set doClipboard = New DataObject

'One and ONLY one message muse be selected
If Application.ActiveExplorer.Selection.Count <> 1 Then
MsgBox ("One and ONLY one message muse be selected")
Exit Sub
End If

Dim SelectedItem
SelectedItem = TypeName(Application.ActiveExplorer.Selection.Item(1))

If SelectedItem = "MailItem" Then
Dim objMail As Outlook.MailItem
Set objMail = Application.ActiveExplorer.Selection.Item(1)
linkName = objMail.Subject
linkID = objMail.EntryID
Else
If SelectedItem = "TaskItem" Then
Dim objTask As Outlook.TaskItem
Set objTask = Application.ActiveExplorer.Selection.Item(1)
linkName = objTask.Subject
linkID = objTask.EntryID
Else
If SelectedItem = "ContactItem" Then
Dim objContact As Outlook.ContactItem
Set objContact = Application.ActiveExplorer.Selection.Item(1)
linkName = objContact.FullName
linkID = objContact.EntryID
Else
If SelectedItem = "NoteItem" Then
Dim objNote As Outlook.NoteItem
Set objNote = Application.ActiveExplorer.Selection.Item(1)
linkName = objNote.Subject
linkID = objNote.EntryID
Else
If SelectedItem = "AppointmentItem" Then
Dim objAppoint As Outlook.AppointmentItem
Set objAppoint = Application.ActiveExplorer.Selection.Item(1)
linkName = objAppoint.Subject
linkID = objAppoint.EntryID
Else
MsgBox ("Invalid object selected")
Exit Sub
End If
End If
End If
End If
End If

'Create temp message
With olTemp
.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:=linkName)


'font correction
oLink.Range.Font.Name = "Adobe Fan Heiti Std B"
oLink.Range.Font.Size = 10
'oLink.Range.Font.Color = vbRed


Set oRng = oLink.Range
oRng.Copy
olTemp.Close olDiscard
End With

End Sub

[gmayor]

You don't need all those IF/Then loops or objects. I regret I cannot advise about Microsoft Project. I suggest asking a question in the appropriate forum.


Sub CopyLink()
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 SelectedItem As String
Dim linkName As String
Dim linkID As String

If Application.ActiveExplorer.Selection.Count <> 1 Then
MsgBox ("First selected item only will be processed")
End If

Set olItem = Application.ActiveExplorer.Selection.Item(1)
SelectedItem = TypeName(olItem)
Select Case SelectedItem
Case Is = "MailItem", "TaskItem", "NoteItem", "AppointmentItem"
linkName = olItem.Subject
linkID = olItem.EntryID
Case Is = "ContactItem"
linkName = olItem.FullName
linkID = olItem.EntryID
Case Else
MsgBox ("Invalid object selected")
GoTo lbl_Exit
End Select
'Create temp message
Set olTemp = CreateItem(olMailItem)
With olTemp
.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:=linkName)

'font correction
oLink.Range.Font.Name = "Adobe Fan Heiti Std B"
oLink.Range.Font.Size = 10
'oLink.Range.Font.Color = vbRed
oLink.Range.Copy
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

[GfiFer]

Oh, thanks!) I'm not good with programming.. I have asked this at MSDN forum, but no one knows about it. Could you suggest some MS Project forum?

[Hornblower40]

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