Sub CopyItem()
'Graham Mayor - https://www.gmayor.com - Last updated - 05 Apr 2021 
Dim olApptCopy As Outlook.AppointmentItem
Dim objItem As Object
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object

    On Error Resume Next
    Select Case Outlook.Application.ActiveWindow.Class
        Case olInspector
            Set objItem = ActiveInspector.currentItem
        Case olExplorer
            Set objItem = Application.ActiveExplorer.Selection.Item(1)
    End Select
    Set olApptCopy = Outlook.CreateItem(olAppointmentItem)

    'Copy the desired details to a new appointment item
    If objItem.Class = olAppointment Then

        With olApptCopy
            .Subject = objItem.Subject
            .Location = objItem.Location
            .Body = objItem.Body
            .Categories = objItem.Categories
            .AllDayEvent = objItem.AllDayEvent
            Set olInsp = .GetInspector
            Set wdDoc = olInsp.WordEditor
            Set oRng = wdDoc.Range
            'set font for the body text
            oRng.Font.Name = "Times New Roman"
            oRng.Font.Size = "14"
            .Display
        End With
    End If
    Set olApptCopy = Nothing
    Set objItem = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing
End Sub