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