Reply All with Email History and Copy Original Attachments

[agent_maxine]

Dear Mr. Excel,

I have the following codes that attempt to do the following, once an email is selected in MS Outlook:

1. Include all the recipients in the selected email
2. Copy the original attachments that came in the selected email
3. Reply with a designated text, along with default signature and email history

#1~2 work well, until it gets to #3 --> Run-Time Error 287: Application-Defined or Object-Defined Error

.HTMLBody = "Hello" & vbNewLine & .HTMLBody

The curious thing is, this code works just fine on a different computer.

Sub ReplyAll_Attachments()

MsgBox "Please make sure that you have selected the email to Reply All."

Dim outlookApp As Outlook.Application, outlookMail As Outlook.MailItem, outlookReply As Outlook.MailItem
Dim outlookItem As Object, Signature As String, strBody As String
    Set outlookApp = New Outlook.Application
    Set outlookMail = outlookApp.CreateItem(0)
    Set outlookItem = GetCurrentItem()

'On Error Resume Next
'On Error GoTo 0

'Get Default Email Signature
Signature = Environ("appdata") & "\Microsoft\Signatures\"

If Dir(Signature, vbDirectory) <> vbNullString Then
        Signature = Signature & Dir$(Signature & "*.htm")
    Else:
        Signature = ""
End If

Signature = CreateObject("Scripting.FileSystemObject").GetFile(Signature).OpenAsTextStream(1, -2).readall

'Create Email
'outlookMail.HTMLBody = Signature

If Not outlookItem Is Nothing Then
    Set outlookReply = outlookItem.ReplyAll
    With outlookReply
    .Subject = "Replying to " & outlookItem.Subject
    .HTMLBody = "Hello" & vbNewLine & .HTMLBody
    CopyAttachments outlookItem, outlookReply 'Copy Attachments from the Selected Email to Reply
    .Display
    outlookItem.UnRead = False
End With
End If

Set outlookReply = Nothing
Set outlookItem = Nothing

End Sub


Function GetCurrentItem() As Object

Dim objApp As Outlook.Application
Set objApp = Outlook.Application

'On Error Resume Next

Select Case TypeName(objApp.ActiveWindow)
    Case "Explorer"
        Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
    Case "Inspector"
        Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
End Select

    Set objApp = Nothing

End Function

Sub CopyAttachments(objSourceItem, objTargetItem)

Set fso = CreateObject("Scripting.FileSystemObject")
Set fldTemp = fso.GetSpecialFolder(2) 'Temporary Folder

    strPath = fldTemp.Path & "\"

For Each objAtt In objSourceItem.Attachments
    strFile = strPath & objAtt.FileName
    objAtt.SaveAsFile strFile
    objTargetItem.Attachments.Add strFile, , , objAtt.DisplayName
    fso.DeleteFile strFile
Next

Set fldTemp = Nothing
Set fso = Nothing

End Sub