Consulting

Results 1 to 8 of 8

Thread: Copy hyperlink to buffer

  1. #1
    VBAX Regular
    Joined
    Sep 2016
    Posts
    6
    Location

    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:
    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

  2. #2
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    VBAX Regular
    Joined
    Sep 2016
    Posts
    6
    Location
    Oh, thank you so much! It is absolutely what I needed!
    How can I thank you?

  4. #4
    Should you ever venture into my part of the world, Moskovskaya vodka goes down a treat
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  5. #5
    VBAX Regular
    Joined
    Sep 2016
    Posts
    6
    Location
    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
    [SPOILER]
    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]

  6. #6
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  7. #7
    VBAX Regular
    Joined
    Sep 2016
    Posts
    6
    Location
    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?

  8. #8
    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

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •