Outlook Record Of Conversation (Select meeting in calendar and run)

This allows you to select a meeting in Outlook, run the macro and create a pre-formatted Record Of Conversation (ROC:[SUBJECT]) message with keys for identifying Projects,

Then you can start filling in content as the meeting progresses for a quick start and a consistent format. The HTML sections in the back hard code in the header information for the body text to start.

Attribute VB_Name = "Outlook_ROC" Option Explicit Private Const PR_SENT_REPRESENTING_ENTRYID As String = "http://schemas.microsoft.com/mapi/proptag/0x00410102" ''stripped character index tables '''''''''''''''''''0'''''''''1'''''''''2'''''''''3' '''''''''''''''''''0123456789x123456789x123456789x1 Const b32_5_bit = "()+.ABCDEFGHIJKLMNOPQRSTUVWXYZ_" '' basic text only naming '''''''''''''''''''0'''''''''1'''''''''2'''''''''3'''''''''4'''''''''5'''''''''6''' '''''''''''''''''''0123456789x123456789x123456789x123456789x123456789x123456789x123 Const b64_6_bit = ".0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz" ''Text and numbers naming '''''''''''''''''''0'''---''''''1'''''''''2'''''''''3'''''''''4'''''''''5'''''''''6'''''''''7'''''''''8'''''''''9'''''''''0'''''''''1'''''''''2 '''''''''''''''''''0123---456789x123456789x123456789x123456789x123456789x123456789x123456789x123459789x123456789x12345978 Const b128_7_bit = " !""""#$%&'()*+,-./0123456789:;<=>?@ABCEDFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcedfghijklmnopqrstufwxyz{|}~" ''Full printable characters for naming ''And more space....  

 

Public Sub Meeting_MAIL_ROC()

    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 mAppItm As AppointmentItem

    '''Dim mySender                       ''&lt&lt Broken

    Dim rep As SubMatches

    Dim mRecipient As Recipient

    'Dim objOutlookRecip As Recipient

    Dim boolKeepRecip As Boolean

    Dim ostr As String

   

    Dim objRecipients As Recipients

    Dim objRecip As Recipient

   

    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 boolHomeOnly As Boolean

    Dim strHOme As String ''home domain

   

    Dim GeneratePrefixTextTxt As String

    Dim x As Integer

    Dim J As Integer

   

    GeneratePrefixTextTxt = "Senders of selected items:"  ''&lt&lt&ltNeed to add code to look for messaged open in the foreground....!

    Set myOlExp = Application.ActiveExplorer

    Set myOlSel = myOlExp.Selection

    For x = 1 To myOlSel.Count

      If myOlSel.Item(x).Class = OlObjectClass.olMail Then

         ' For mail item, use the SenderName property.

         Set oMail = myOlSel.Item(x)

         Set objRecipients = oMail.Recipients

         Set mAppItm = oMail.sender

         oMail.BodyFormat = olFormatHTML

         mBody = oMail.HTMLBody

         mDateUTC = oMail.Sent

         ''mDateZONE = oMail.zo

         ''mDateZONEstr = oAppt.StartTimeZone

      ElseIf 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 mAppItm = 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

        

         'For Each mRecipient In objMail.Recipients

         '   objRecipients.Add (mRecipient)

         '   mRecipient.Delete

         'Next mRecipient ''&lt&ltREMOVE RECIPIENTS

         Set objRecipients = objMail.Recipients

         objMail.BodyFormat = olFormatHTML

        

         mBody = objMail.HTMLBody

         ''replayall and get message'''

         mDateUTC = oAppt.StartUTC

         mDateZONE = oAppt.StartInStartTimeZone

         mDateZONEstr = oAppt.StartTimeZone

         '''GeneratePrefixTextTxt = GeneratePrefixTextTxt & oAppt.Organizer & ";"

      ''Else

         ' For other items, use the property accessor to get sender ID,

         ' then get the address entry to display the sender name.

         'Set oPA = myOlSel.Item(x).PropertyAccessor

         'strSenderID = oPA.GetProperty(PR_SENT_REPRESENTING_ENTRYID)

         'Set mySender = Application.Session.GetAddressEntryFromID(strSenderID)

         '''GeneratePrefixTextTxt = GeneratePrefixTextTxt & mySender.Name & ";"

      End If

     

      ''&gt&gt&gt&gt&gt&gt&gt&gt&gt&gt&gt&gt&gt&gt&gtCLEANUP msg&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt

      With Re ''REGEXP

         .Pattern = "([\s\S]*)(&ltBODY[\s\S]{0,}?&gt)([\s\S]*)(&lt/BODY&gt)([\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 = "&lt!DOCTYPE HTML PUBLIC """"-//W3C//DTD HTML 3.2//EN""""&gt&ltHTML&gt&ltHEAD&gt&ltMETA NAME=""""Generator"""" CONTENT=""""MS Exchange Server version 16.0.11328.20390""""&gt&ltTITLE&gt&lt/TITLE&gt&lt/HEAD&gt"

             postHTML = mBody & "&lt/BODY&gt&lt/HTML&gt"

         End If

      End With ''RE REGEXP

       

      ''''''''''''''''''''''''''''''''''''''''''''''''''''

      ''Isolate current domain only for replies?

      strHOme = LCase(Split(getMyEmalAddress, "@")(1))

      ''Home domain report only?

      boolHomeOnly = (MsgBox("Strip non @" & strHOme & " Domain recipients from message?", vbYesNo, "Isolate domain addresses") = vbYes) ''home only

      ''For Each mRecipient In objRecipients

      For J = objRecipients.Count To 1 Step -1

         boolKeepRecip = True         ''reset check

        

         Set mRecipient = Nothing

         Set mRecipient = objRecipients(J)

       

         ostr = "": ostr = LCase(Split(GetSMTP(mRecipient), "@")(1))

        

         If IsRoom(mRecipient) Then ''remove rooms

            boolKeepRecip = False

         ElseIf StripLocalrecipientList(mRecipient) Then

            boolKeepRecip = False

         ElseIf boolHomeOnly And ostr &lt&gt strHOme Then ''force drop non-domain

            boolKeepRecip = False ''objRecipients.Remove (J)

         Else ''if passes 1st 2 then see if they responded

            Select Case mRecipient.MeetingResponseStatus

               ''https://docs.microsoft.com/en-us/office/vba/api/outlook.olresponsestatus

               Case olResponseAccepted      '' Meeting accepted

                  boolKeepRecip = True

               Case olResponseTentative     '' Meeting tentatively accepted

                  boolKeepRecip = True

               Case olResponseNone          '' The appointment is a simple appointment and does not require a response.

                  boolKeepRecip = True

               Case olResponseNotResponded  '' Recipient has not responded.

                  boolKeepRecip = True

               Case olResponseOrganized     '' The AppointmentItem is on the Organizer's calendar or the recipient is the Organizer of the meeting.

                  boolKeepRecip = True

               Case olResponseDeclined      '' Meeting Declined

                  boolKeepRecip = False

            End Select

         End If

        

         If boolKeepRecip = False Then objMail.Recipients.Remove (J)

         

      Next J ''mRecipient

    ''GENERATE MESSAGE if not generated by replayall

    If objMail Is Nothing Then Set objMail = Application.CreateItem(olMailItem)

    With objMail

        .BodyFormat = olFormatHTML

        objMail.HTMLBody = preHTML & StrHead & postHTML

       

        'Set objOutlookRecip = objRecipients    ''Add with items add for multiple listings split on ; or ,

        'objOutlookRecip.Type = olTo

        '.Subject = Format(Date + Time(), "YYYY-MM-DD-hh.mmap") & " Report summary as attached file"  ''&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt

        '.Body = "Please See Attached"

        '.Attachments.Add fn

       'For J = .Recipients.Count To 1 Step -1

       '    Set mRecipient = .Recipients(J)

       '    mRecipient.Resolve

       '    ostr = ""

       '    If InStr(1, GetSMTP(mRecipient), "@", vbTextCompare) &gt 0 Then

       '        ostr = LCase(Split(GetSMTP(mRecipient), "@")(1))

       '    End If

       '

       '    If boolHomeOnly Then

       '        If ostr &lt&gt strHOme Then .Recipients.Remove (J)

       '     End If

       'Next

       ''.DeferredDeliveryTime = (Weekday(Date, 6) - 1) + Date + 22 / 24 ''set delivery at 10pm friday end of week in case changes come up

        Do While Left(.Subject, 4) Like "RE: "

             .Subject = Right(.Subject, Len(.Subject) - 4)

        Loop

       

        .Subject = "ROC:" & .Subject & "-" & Format(mDateZONE, "YYYY-MM-DD")

        .Save

        .Display

        Exit Sub ''''''''''''''''''&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&ltEXIT BREAK&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt

    End With

   

    Set objMail = Nothing

   

    Next x

    'Debug.Print GeneratePrefixTextTxt

End Sub

Function StripLocalrecipientList(objRecipient As Recipient) As Boolean

    'Jim Kunst &ltJKunst@ktgy.com&gt

    Dim x()

    x = Array("JKunst@ktgy.com")

    Dim i

    For i = 0 To UBound(x)

        If LCase(Trim(objRecipient.Address)) = LCase(Trim(x(i))) Then

            StripLocalrecipientList = True

            Exit Function

        End If

    Next i

End Function

Function GetSMTP(objRecip As Recipient) As String

''https://stackoverflow.com/questions/31081960/vba-excel-how-to-find-an-email-address-from-an-exchange-user-in-outlook

Dim olNS As NameSpace

Dim olAddrEntry As AddressEntry

Dim olCont As ContactItem

Dim olExchUser As ExchangeUser

   

    Set olNS = Outlook.GetNamespace("MAPI")

    'Set olRecip = olNS.CreateRecipient("Dmitry Streblechenko")

    objRecip.Resolve

    Set olAddrEntry = objRecip.AddressEntry

    On Error Resume Next

    Set olCont = olAddrEntry.GetContact

    If olCont Is Nothing Then

      Set olExchUser = olAddrEntry.GetExchangeUser

        If olExchUser Is Nothing Then

          GetSMTP = olAddrEntry.Address

          ''NOTIHNG TO DO

        Else

          'olExchUser is ExchangeUser object

          GetSMTP = olExchUser.PrimarySmtpAddress

          If GetSMTP = "" Then

            GetSMTP = olAddrEntry.name

            If GetSMTP &gt "" Then GetSMTP = GetSMTP & "@unresolved.com"

          End If

        End If

    Else

      'this is a contact

      'olCont is ContactItem object

      MsgBox olCont.FullName

    End If

   

    If GetSMTP = "" Then

        GetSMTP = "UNRESOLVED@UNRESOLVED.COM"          '''&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lt&lttEMPORARY HACK FOR UNRESOLVED EMAIL ADDRESSES IN THE SYSTEM

            MsgBox "FOR USER: " & vbCr & vbCr & objRecip.AddressEntry, vbInformation + vbCritical, "Unable to resolve email address." & vbCr & vbCr & "Proceeding..."

        ''GetSMTP = objRecip.Address

    End If

   

    On Error GoTo 0

End Function

Private Function getMyEmalAddress() As String

''https://stackoverflow.com/questions/26519325/how-to-get-the-email-address-of-the-current-logged-in-user

Dim olNS As Outlook.NameSpace

Dim olFol As Outlook.Folder

Set olNS = Outlook.GetNamespace("MAPI")

Set olFol = olNS.GetDefaultFolder(olFolderInbox)

getMyEmalAddress = olFol.Parent.name '~~&gt most cases contains the email address

'MsgBox olNS.Accounts.Item(1).DisplayName '~~&gt usually email address

'MsgBox olNS.Accounts.Item(1).SmtpAddress '~~&gt email address

'MsgBox olNS.Accounts.Item(1).UserName '~~&gt displays the user name

End Function

Function IsRoom(objRecipient As Recipient) As Boolean

''https://docs.microsoft.com/en-us/office/vba/api/outlook.recipient.type

   IsRoom = False

   On Error GoTo IsRoomErr

  

   IsRoom = objRecipient.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x39050003") = 1073741831 _

            Or InStr(1, "room", objRecipient.name) &gt 0

   

  

IsRoomErr:

End Function

Private Function StrHead() As String

''formatting for body of message in HTML format

StrHead = _

      "&ltdiv class=WordSection1&gt" & vbCr _

    & "&ltb&gtIf anything appears to be incorrect- please reply with different color inline comments for corrections.&lt/b&gt" & vbCr _

    & "&lt/p&gt" & vbCr _

    & "&ltp class=MsoNormal&gt&ltspan style='mso-fareast-font-family:""""Times New Roman""""'&gt" & vbCr _

    & "|&ltspan style='background:yellow;mso-highlight:yellow'&gtQuestion/Unanswered issue&lt/span&gt" & vbCr _

    & "|&ltspan style='background:lime;mso-highlight:lime'&gtKey Point/Answer&lt/span&gt" & vbCr _

    & "|&ltspan style='background:aqua;mso-highlight:aqua'&gtProject&lt/span&gt" & vbCr _

    & "|&ltb&gt&ltspan style='color:yellow;background:red;mso-highlight:red'&gtCritical Issue&lt/span&gt&lt/b&gt" & vbCr _

    & "|&ltspan style='background:silver;mso-highlight:silver'&gtAfter/Unaddressed&lt/span&gt" & vbCr _

    & "|&lto:p&gt&lt/o:p&gt&lt/span&gt&lt/p&gt"

    StrHead = StrHead _

    & "&ltb&gt&ltspan style='font-size:16.0pt'&gtSUMMARY--------------------&lto:p&gt&lt/o:p&gt&lt/span&gt&lt/b&gt&lt/p&gt" & vbCr _

    & "&ltp class=MsoNormal&gt&ltspan style='mso-fareast-font-family:""""Times New Roman""""'&gt&lto:p&gt &lt/o:p&gt&lt/span&gt&lt/p&gt" & vbCr _

    & "&ltp class=MsoNormal&gt&ltb&gt&ltspan style='font-size:16.0pt'&gt" & vbCr _

    & "&ltp class=MsoNormal&gt&ltb&gt&ltspan style='font-size:16.0pt'&gtROC-----------------------------&lto:p&gt&lt/o:p&gt&lt/span&gt&lt/b&gt&lt/p&gt" & vbCr

    StrHead = StrHead _

    & "&ltp class=MsoNormal&gt&lto:p&gt &lt/o:p&gt&lt/p&gt" & vbCr _

    & "&ltp class=MsoNormal&gt&lto:p&gt &lt/o:p&gt&lt/p&gt" & vbCr _

    & "&lt/div&gt" & vbCr _

    & "&lt/body&gt" & vbCr _

    & "&lt/html&gt"

End Function

Sub ExportWithDateTime() ''export selecte items with prefixed date-time ''Microsoft Schema for extracting properties Const PR_SENT_REPRESENTING_ENTRYID As String = _ "http://schemas.microsoft.com/mapi/proptag/0x00410102" '' Dim myOlExp As Outlook.Explorer ''outlook browser explorer API Dim myOlSel As Outlook.Selection ''current selection Dim mySender As Outlook.AddressEntry ''Address Dim oMail As Outlook.MailItem ''Mail Dim oAppt As Outlook.AppointmentItem 'Appointment Dim oPA As Outlook.PropertyAccessor 'propoerty accessor for getting inforation from interface Dim strSenderID As String ''sender ID Dim MsgTxt As String ''gathereing message for end Dim FP As String ''file folder path to save from browse Dim X As Long ''generic counter Dim fn As String ''file name Dim strDT As String ''date time ''Dim FSO As FileSystemObject ''File system object for looking at files/folders, creteing folders, etc. ''Set FSO = CreateObject("Scripting.FileSystemObject") Set myOlExp = Application.ActiveExplorer Set myOlSel = myOlExp.Selection If myOlSel.Count = 0 Then MsgBox "Please select multiple messages to export.", vbInformation + vbOKOnly Exit Sub End If ''continue if selected FP = "D:\Users\Ron.Allen\Documents\KTGY(Personal)\_ROCs" '' BrowseForFolder.SelectFolder For X = 1 To myOlSel.Count If myOlSel.Item(X).Class = OlObjectClass.olMail Then ' For mail item, use the SenderName property. Set oMail = myOlSel.Item(X) strDT = "" strDT = Format(oMail.SentOn, "YYYY-MM-DDtHHmm") fn = "" fn = Left(strDT & Format(oMail.SentOn, "ap") & "-" & CleanNAME(oMail.Subject), 64) 'Stop '<<<<<<<<<<<<<<<<<<<<< <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< If VBA.FileSystem.Dir(FP & fn & ".*") > "" Then Select Case MsgBox(FP & fn, vbCritical + vbYesNoCancel, "File exists - overwrite?") Case vbYes MsgTxt = MsgTxt & " SAVED:" ''continue thorugh to write Case vbNo MsgTxt = MsgTxt & "EXISTED:" GoTo SkipSave Case vbCancel MsgBox "Cancelled", vbCritical Exit Sub End Select End If ''save as message intact ''oMail.SaveAs FP & fn & ".msg", olMSG ''Save as MSG file ''save as olDoc oMail.SaveAs FP & fn & ".doc", olDoc ''Save as DOC SkipSave: MsgTxt = MsgTxt & oMail.SenderName & ";" ElseIf myOlSel.Item(X).Class = OlObjectClass.olAppointment Then ' For appointment item, use the Organizer property. Set oAppt = myOlSel.Item(X) MsgTxt = MsgTxt & oAppt.Organizer & ";" Else ' For other items, use the property accessor to get sender ID, ' then get the address entry to display the sender name. 'Set oPA = myOlSel.Item(X).PropertyAccessor 'strSenderID = oPA.GetProperty(PR_SENT_REPRESENTING_ENTRYID) 'Set mySender = Application.Session.GetAddressEntryFromID(strSenderID) 'MsgTxt = MsgTxt & mySender.name & ";" End If Next X ''MsgBox MsgTxt MsgBox "Done exporting " & myOlSel.Count & " Messages." End Sub Function CleanNAME(strSource As String) As String Dim objRegex As REGEXP ''Regular exporession Dim strTemp As String ''temp string storage Set objRegex = CreateObject("VBScript.RegExp") ''initialize Regexp ''pares illegal characters and repeates to "-" objRegex.Pattern = "[^a-zA-Z0-9\-\+\.]{1,}" ''a-z upper or lower, numbers + - and . are aceptable objRegex.Global = True objRegex.IgnoreCase = True strTemp = objRegex.Replace(strSource, "-") ''replace illegal chars with "-" ''parse dots to underscoires objRegex.Pattern = "\." strTemp = objRegex.Replace(strTemp, "_") ''Parse combinations of -_ to - objRegex.Pattern = "[-_$]{1,}" strTemp = objRegex.Replace(strTemp, "-") ''remove trailing -_ objRegex.Pattern = "[-_]{1,}$" strTemp = objRegex.Replace(strTemp, "") CleanNAME = strTemp End Function Function CleanFN(strSource As String, Optional strPatt As String = "[^a-zA-Z0-9\-+]", Optional strRepl As String = "-") As String Dim objRegex As REGEXP ''Regular exporession Const strREP_FN_FEXT = "(.*)(\..*$)" ''file extension extractor for regexp Dim objMC As MatchCollection ''match collection from top regex Dim objSM As SubMatches ''Submatches in collection(s) Dim strFext As String ''string to store File Extension Set objRegex = CreateObject("VBScript.RegExp") ''initialize Regexp objRegex.Pattern = "(^.*[\/\\]){0,1}(.*)(\..*){0,1}$" objRegex.Global = True objRegex.IgnoreCase = True Set objMC = objRegex.Execute(strSource) Set objSM = objMC.Item(0).SubMatches strFext = objSM.Item(2) strSource = objSM.Item(1) Stop objRegex.Pattern = strPatt objRegex.Global = True objRegex.IgnoreCase = True CleanFN = objRegex.Replace(strSource, "-")
End Function


'-------------------------------------------------------------------

Attribute VB_Name = "BrowseForFolder"

Option Explicit

' For Outlook 2010.

#If VBA7 Then

    ' The window handle of Outlook.

    Private lHwnd As LongPtr

    ' /* API declarations. */

    Private Declare PtrSafe Function FindWindow Lib "user32" _

            Alias "FindWindowA" (ByVal lpClassName As String, _

                                 ByVal lpWindowName As String) As LongPtr

' For the previous version of Outlook 2010.

#Else

    ' The window handle of Outlook.

    Private lHwnd As Long

    ' /* API declarations. */

    Private Declare PtrSafe Function FindWindow Lib "user32" _

            Alias "FindWindowA" (ByVal lpClassName As String, _

                                 ByVal lpWindowName As String) As Long

#End If

'

' Windows desktop -

' the virtual folder that is the root of the namespace.

Private Const CSIDL_DESKTOP = &H0

' Only return file system directories.

' If user selects folders that are not part of the file system,

' then OK button is grayed.

Private Const BIF_RETURNONLYFSDIRS = &H1

' Do not include network folders below

' the domain level in the dialog box's tree view control.

Private Const BIF_DONTGOBELOWDOMAIN = &H2

Public Function SelectFolder() As String

    Dim objFSO As Object

    Dim objShell As Object

    Dim objFolder As Object

    Dim strFolderPath As String

    Dim blnIsEnd As Boolean

    blnIsEnd = False

    Set objShell = CreateObject("Shell.Application")

    Set objFSO = CreateObject("Scripting.FileSystemObject")

    Set objFolder = objShell.BrowseForFolder( _

                lHwnd, "Please Select Folder to:", _

                BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN, CSIDL_DESKTOP)

    If objFolder Is Nothing Then

        SelectFolder = ""

        blnIsEnd = True

        GoTo PROC_EXIT

    Else

        SelectFolder = CGPath(objFolder.Self.Path)

    End If

PROC_EXIT:

    Set objFSO = Nothing

    If blnIsEnd Then End

End Function

Public Function CGPath(ByVal Path As String) As String

    If Right(Path, 1) &lt&gt "\" Then Path = Path & "\"

    CGPath = Path

End Function