Copy hyperlink to buffer

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:

Code:

---

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:

Code:

---

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

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

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

Code:

---

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

---

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

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

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
[SPOILER]

Code:

---

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

---

[/SPOILER]

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.

Code:

---

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

---

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?

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.

Code:

---

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

---