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 = "
Comments
Post a Comment