Option Explicit
Sub Test()
Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    ForwardWithSubject olMsg
lbl_Exit:
    Exit Sub
End Sub

Sub ForwardWithSubject(olItem As Outlook.MailItem)
Dim olOutMail As Outlook.MailItem
Const strAddr As String = "someone@somewhere.com"
Const strSubject As String = " Additional subject text"
    Set olOutMail = olItem.Forward
    With olOutMail
        .Subject = .Subject & strSubject
        .To = strAddr
        .Display  'Change to .Send after testing
    End With
lbl_Exit:
    Set olOutMail = Nothing
    Exit Sub
End Sub