Outlook VBA to create a meeting reminder to send to all Recipients who have not declined 1 hour prior to the meeting

Attribute VB_Name = "Meeting_Reminders" 'Option Explicit Private Const PR_SENT_REPRESENTING_ENTRYID As String = "http://schemas.microsoft.com/mapi/proptag/0x00410102" Public Sub Outlook_MTG_REMINDER() Dim myOlExp As Outlook.Explorer Dim myOlSel As Outlook.Selection Dim oMail As Outlook.MailItem Dim oAppt As Outlook.AppointmentItem Dim oPA As Outlook.PropertyAccessor Dim strSenderID As String Dim mRecipients As Recipients ''Recipients of meeting Dim mRecipient As Recipient ''Recipient in list Dim BoolSendRemind As Boolean ''proceed to send reminder or not Dim mBody As String Dim mDateUTC As Date Dim mDateZONE As Date Dim mDateZONEstr As String Dim objMail As MailItem Dim preHTML As String Dim postHTML As String Dim Re As New REGEXP Dim GeneratePrefixTextTxt As String Dim x As Integer Dim I As Integer GeneratePrefixTextTxt = "Senders of selected items:" ''<< Set myOlExp = Application.ActiveExplorer Set myOlSel = myOlExp.Selection For x = 1 To myOlSel.Count If myOlSel.Item(x).Class = OlObjectClass.olAppointment Then ' For appointment item, use the Organizer property. Set oAppt = myOlSel.Item(x) ''get sender adn all users ''remove meeting rooms Set mRecipients = oAppt.Recipients Set objMail = oAppt.Actions.Item("Reply to All").Execute ''Create mail objMail.Display For I = objMail.Recipients.Count To 1 Step -1 objMail.Recipients.Remove (I) Next I objMail.To = "" objMail.CC = "" objMail.BCC = "" ''GENERATE MESSAGE if not generated by replayall If objMail Is Nothing Then If MsgBox("Reply all failed to create message, Continue?", vbCritical + vbYesNo) <> vbYes Then objMail.Display Exit Sub Else Set objMail = Application.CreateItem(olMailItem) End If End If ''''''''''''''REMOVE AUTO SIG''''''''''''''''' RemoveSignature objMail '''''Get recipients and sort out those who have responded to attend or tentative For Each mRecipient In mRecipients BoolSendRemind = False ''reset check If Not mRecipient.name Like "*Room" And _ Not IsRoom(mRecipient) Then Select Case mRecipient.MeetingResponseStatus ''https://docs.microsoft.com/en-us/office/vba/api/outlook.olresponsestatus Case olResponseAccepted '' Meeting accepted BoolSendRemind = True Case olResponseTentative '' Meeting tentatively accepted BoolSendRemind = True Case olResponseNone '' The appointment is a simple appointment and does not require a response. BoolSendRemind = True Case olResponseNotResponded '' Recipient has not responded. BoolSendRemind = True Case olResponseOrganized '' The AppointmentItem is on the Organizer's calendar or the recipient is the Organizer of the meeting. BoolSendRemind = True Case olResponseDeclined '' Meeting Declined BoolSendRemind = False End Select If BoolSendRemind = True Then objMail.Recipients.Add mRecipient End If

Next mRecipient 'Set mSender = oAppt ''https://social.msdn.microsoft.com/Forums/sqlserver/en-US/e2fb4e2d-9e27-452e-a50a-7e5c0dac1af5/cant-get-vba-code-to-use-replyall-on-existing-meetings?forum=outlookdev ''Set objMail = oAppt.Actions.Item("Reply to All").Execute objMail.BodyFormat = olFormatHTML mBody = objMail.HTMLBody ''replayall and get message''' mDateUTC = oAppt.StartUTC mDateZONE = oAppt.StartInStartTimeZone mDateZONEstr = oAppt.StartTimeZone Else MsgBox "Meeting items from the calendar must be selected", vbCritical, "Error: exiting" Exit Sub End If ''Strip out TO: and other junk in body reply<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< With Re ''REGEXP .Pattern = "(.*)[-]{1,}Original Appointment[-]{1,}(.*)(Subject:.*)" .MultiLine = False .IgnoreCase = True If .Test(mBody) = True Then Set rep = .Execute(mBody).Item(0).SubMatches ''hard-coded matches based on regex and typical HTML pre = rep.Item(0) Post = rep.Item(2) '''''''''''''<< mBody = pre + Post End If End With ''RE REGEXP ''BREAK OUT HTML BODY TO STRIP OR MODIFY BODY OF MESSAGE With Re ''REGEXP remove header junk - retreat to essentials: .Pattern = "([\s\S]*)()([\s\S]*)()([\s\S]*)" .MultiLine = False .IgnoreCase = True If .Test(mBody) = True Then Set rep = .Execute(mBody).Item(0).SubMatches ''hard-coded matches based on regex and typical HTML preHTML = rep.Item(0) & rep.Item(1) postHTML = rep.Item(2) & rep.Item(3) & rep.Item(4) Else ''no html formatting EXISTS - JUST IN CASE... preHTML = "" postHTML = mBody & "

" End If End With ''RE REGEXP With objMail .BodyFormat = olFormatHTML strHead = "Reminder:" objMail.HTMLBody = preHTML & strHead & postHTML Do While Left(.Subject, 4) Like "RE: " .Subject = Right(.Subject, Len(.Subject) - 4) Loop '''REMINDERS<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '.FlagStatus = olFlagMarked .FlagIcon = olGreenFlagIcon .FlagRequest = "Meeting:" & oAppt.Subject '.FlagDueBy = oAppt.Start - 0.25 / 24 ''Local User Flag .ReminderTime = oAppt.Start - 10 / 60 / 24 ''10 minutes before .ReminderOverrideDefault = True .ReminderSet = True .Save Set objOutlookRecip = mRecipients ''Add with items add for multiple listings split on ; or , For Each objOutlookRecip In .Recipients objOutlookRecip.Resolve Next End With If objMail.Recipients.Count > 0 Then objMail.Send Else MsgBox "No recipients resolved to vaild addresses, Deleting messsage.", vbCritical objMail.Delete End If Next x End Sub Function IsRoom(objRecipient) As Boolean ''https://docs.microsoft.com/en-us/office/vba/api/outlook.recipient.type IsRoom = objRecipient.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x39050003") = 1073741831 End Function Sub RemoveSignature(objMail As MailItem) ''https://www.slipstick.com/developer/code-samples/remove-email-signature-message-vba/ ''Dim Item As Outlook.MailItem 'Set Item = Application.ActiveInspector.CurrentItem Dim objDoc As Word.Document Dim oBookmark As Word.Bookmark On Error Resume Next Set objDoc = objMail.GetInspector.WordEditor Set oBookmark = objDoc.Bookmarks("_MailAutoSig") If Not oBookmark Is Nothing Then oBookmark.Select objDoc.Windows(1).Selection.Delete End If 'Set Item = Nothing End Sub Sub VarCheck(ByVal strVar As String) Dim MyFile Open "C:\temp\OLvar.preHTML.txt" For Output As #1: Write #1, strVar: Close #1 End Sub