VBA code for Outlook - Reply Mail With Attachment

May times it happens that you want to Reply some mail with attachment but when you click reply, it removes the attachment from your mail, and you need to attach it manually. Following function will help you to reply mail with attachment.

'''''''''''''''''''''' Reply Module ''''''''''''''''''''''''''

Sub ReplyWithAttachments()  ' For Only single Reply

    Dim rpl As Outlook.MailItem

    Dim itm As Object

     

    Set itm = GetCurrentItem()

    If Not itm Is Nothing Then

        Set rpl = itm.Reply

        CopyAttachments itm, rpl

        rpl.Display

    End If

     

    Set rpl = Nothing

    Set itm = Nothing

End Sub

 

Sub ReplyALLWithAttachments()   ' For Reply ALL

    Dim rpl As Outlook.MailItem

    Dim itm As Object

     

    Set itm = GetCurrentItem()

    If Not itm Is Nothing Then

        Set rpl = itm.ReplyAll

        CopyAttachments itm, rpl

        rpl.Display

    End If

     

    Set rpl = Nothing

    Set itm = Nothing

End Sub

Sub ReplyOnly()  ' For Only Reply without Body message

    Dim rpl As Outlook.MailItem

    Dim itm As Object

    Set itm = GetCurrentItem()

    If Not itm Is Nothing Then

        Set rpl = itm.Reply

        rpl.subject = itm.subject

        rpl.Display

'        rpl.HTMLBody = rpl.HTMLBody

    SendKeys "^f"

    SendKeys "From:"

    SendKeys "{Enter}"

    SendKeys "{Esc}"

    SendKeys "{Home}"

    SendKeys "^+{End}"

    SendKeys "{Del}"

    SendKeys "^{Home}"

    

    End If

     

    Set rpl = Nothing

    Set itm = Nothing

End Sub

Function GetCurrentItem() As Object ' Will Create object for the current selected One mail

    Dim objApp As Outlook.Application

         

    Set objApp = 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)   ' Coping the Attachment if exist.

   Set fso = CreateObject("Scripting.FileSystemObject")

   Set fldTemp = fso.GetSpecialFolder(2) ' TemporaryFolder

   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

'''''''''''''''''''''' End of Reply Module '''''''''''''''''''''''''''''''''''''''''''