Hello! I have this code for Outlook macro to creating hyperlinks to different Outlook objects. So, is it possible to make something like this for MS Project? I want to create hyperlinks to tasks and other Project objekts


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 to copy hyperlink to clipboard 
    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