Create hyperlink to MS Project tasks

[GfiFer]

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