Friday, April 25, 2014

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 '''''''''''''''''''''''''''''''''''''''''''

No comments:

Post a Comment

Your feedback is always appreciated. I will try to reply to your queries as soon as time allows.Please don't spam,spam comments will be deleted upon reviews.