Forward Message with Attachments (Public)

PHOTO EMBED

Fri Aug 06 2021 07:00:58 GMT+0000 (UTC)

Saved by @Darkleech #vba

Sub ReplyWithAttachments() 'Reply with message attachments and as forward. 

    Dim oReply As Outlook.MailItem 

    Dim oItem As Object 

      

    Set oItem = GetCurrentItem() 

    If Not oItem Is Nothing Then 

        Set oReply = oItem.Reply 

        CopyAttachments oItem, oReply 

        oReply.Display 

        oItem.UnRead = False 

    End If 

      

    Set oReply = Nothing 

    Set oItem = Nothing 

End Sub 

  

Sub ReplyAllWithAttachments() 'Reply All with message attachments and as forward. 

    Dim oReply As Outlook.MailItem 

    Dim oItem As Object 

      

    Set oItem = GetCurrentItem() 

    If Not oItem Is Nothing Then 

        Set oReply = oItem.ReplyAll 

        CopyAttachments oItem, oReply 

        oReply.Display 

        oItem.UnRead = False 

    End If 

      

    Set oReply = Nothing 

    Set oItem = Nothing 

End Sub 

Function GetCurrentItem() As Object 

    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) 

   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 
content_copyCOPY