Public Sub Outlook_ReplyAll(Subj As String, SendType As String, Optional Msg As String, Optional fwdto As String, Optional ccto As String, Optional bcto As String, Optional attachfile As String, Optional dtsent As Date, Optional sentfromshared As Boolean, Optional ImportanceLevel As Integer = 1)
'Reply to All from current message
'http://www.vbaexpress.com/forum/showthread.php?56727-How-To-Reply-To-Most-Recent-E-mail-for-a-Specific-Subject
'20180920
'------------------------
'Needs to be fixed so that replies to all, currently seems to only be able to
'display the existing message then have to manually click the reply to all
'button in outlook
'20180920
'Fixed by reviewing link and saw in post #2 that needed to use the SET statement
'rather than simply using .replyall
'added functionality to create message based on Reply, ReplyAll and Forward
'20181008
'------------------------
'Added optional message
'20181009
'Added "To" so can create a new message
'Added optional AttachFile so can attach
'a file, currently only single file, can
'modify later if need to handle multiple
'attachments
'20181101
'Added optional to send on behalf of the
'shared mailbox
'20190104
'Added optional Importance Level, with Late binding
'use the value.
'Name Value Description
'olImportanceHigh 2 Item is marked as high importance.
'olImportanceLow 0 Item is marked as low importance.
'olImportanceNormal 1 Item is marked as medium importance. (DEFAULT)
'https://docs.microsoft.com/en-us/office/vba/api/outlook.olimportance
'20190107
'Put in a loop to allow multiple attachments
'20200917
'Added Read Receipt Requested to Letters Ready for Signature
'https://social.msdn.microsoft.com/Forums/office/en-US/248e71f7-8ba3-485f-8735-80c55c2f001f/capture-ms-outlook-email-delivery-received-and-read-received-with-vba?forum=accessdev
'20211006
'Added optional bcc
'20230309
Dim olApp As Object 'Late
Dim Inbox As Object
Dim InboxItems As Object
Dim InboxAttachment As Object
Dim Mailobject As Object
Dim InboxReply As Object
Dim SubjectFilter As String
Dim stBody As String
Dim SigString As String
Dim Signature As String
Dim flds As Variant
Dim i As Integer
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application") 'Outlook Running
If Err.Number <> 0 Then
Err.Clear
Set olApp = CreateObject("Outlook.Application") 'Outlook Not Running
End If
'Doc Control Inbox
Set Inbox = olApp.GetNamespace("Mapi").Folders("Inbox")
Set InboxItems = Inbox.Items
'Set InboxAttachment = Mailobject.Attachment
SubjectFilter = (Subj) ' THIS IS WHERE YOU PLACE THE EMAIL SUBJECT FOR THE CODE TO FIND
If Len(Msg) > 0 Then
'stBody = "The RFIs requested below are now closed, if any were missed, please let me know. " & _
"<br><br>Thanks,<br>"
stBody = Msg
End If
If SendType = "To" Then 'Original message
Set Mailobject = olApp.createitem(0)
'Change only Mysig.htm to the name of your signature
SigString = Environ("appdata") & _
"\Microsoft\Signatures\SignatureFile.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
With Mailobject
.bodyformat = 3 'Late binding in lieu of olFormatRichText
.to = fwdto
.CC = ccto
.bcc = bcto
If sentfromshared = True Then
.SentonBehalfofName = "Shared@mail.com"
End If
'-----------------
'Commented out since seems to go to all recipients and not
'just the one person that needs it
'20211006
'If Subj = "Letters Ready for Signature" Then
' .ReadReceiptRequested = True
' .OriginatorDeliveryReportRequested = True
'End If
'-----------------
.importance = ImportanceLevel
.Subject = Subj
.htmlbody = stBody & "<br>" & Signature
'Attach file if included and it exists in the location specified
If Len(attachfile) > 0 Then
If Dir(attachfile) <> "" Then
DoEvents
'-------------------------------------------
'Put in loop to allow multiple attachments
'20200917
If InStr(attachfile, ",") > 0 Then
flds = Split(attachfile, ",")
For i = 1 To UBound(flds)
.attachments.Add (flds(i))
DoEvents
Next
Else
.attachments.Add (attachfile)
End If
'-------------------------------------------
DoEvents
Else
MsgBox attachfile & " not found.", vbOKOnly + vbInformation, "File Not Found"
End If
End If
'.Send
.Display 'Use for testing in lieu of .Send
End With
ElseIf Not Inbox Is Nothing Then
For Each Mailobject In InboxItems
'Debug.Print Mailobject.Subject & " " & SubjectFilter
If InStr(1, Mailobject.Subject, SubjectFilter) > 0 And InStr(1, Mailobject.senton, Nz(dtsent, "")) > 0 Then
'Set InboxReply = Mailobject.replyall 'per post number2 use set rather than in the with section
Select Case SendType
Case "Reply"
Set InboxReply = Mailobject.reply
Case "Reply All"
Set InboxReply = Mailobject.replyall
Case "Forward"
Set InboxReply = Mailobject.Forward
End Select
With InboxReply 'Mailobject
'.replyall 'per post number2 use set rather than in the with section
If Len(fwdto) > 0 Then
.to = fwdto
End If
.htmlbody = stBody & "<br>" & .htmlbody
.Display
End With
End If
Next
End If
Finished:
Set olApp = Nothing
Set Inbox = Nothing
Set InboxItems = Nothing
Set Mailobject = Nothing
End Sub
Function GetBoiler(ByVal sfile As String) As String
'Dick Kusleika
'http://www.rondebruin.nl/win/s1/outlook/signature.htm
'20160826
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sfile).OpenAsTextStream(1, -2)
GetBoiler = ts.ReadAll
ts.Close
End Function