Warn if key terms are in email before sending "ROC:"
''In My Outlook Session
Function MyEmailAddress(Optional strUSer As String) As String
''https://stackoverflow.com/questions/26519325/how-to-get-the-email-address-of-the-current-logged-in-user
Dim OL As Object
Dim olAllUsers As Object
Dim oExchUser As Object
Dim oentry As Object
Dim myitem As Object
Set OL = Application
Set olAllUsers = OL.Session.AddressLists.Item("All Users").AddressEntries
If strUSer = "" Then strUSer = OL.Session.CurrentUser.name
Set oentry = olAllUsers.Item(strUSer)
Set oExchUser = oentry.GetExchangeUser()
MyEmailAddress = oExchUser.PrimarySmtpAddress
End Function
Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim objrecip As Recipient
Dim mydomain As String
Dim ExternalAddress As Boolean
If Outlook_ROC.ContainsROC(Item) Then
mydomain = Split(MyEmailAddress, "@")(1)
For Each objRecipient In Item.Recipients
''compare domain with my domain if none match external=true
If Not (Outlook_ROC.GetSMTP(objRecipient) Like "*" & mydomain) Then
ExternalAddress = True
Exit For
End If
Next objRecipient
''subscan to see if any email addresses are outside company
If ExternalAddress Then
If MsgBox("ROC: detected in message. " & vbCr & vbCr & " Click CANCEL to edit or OK to send.", vbOKCancel + vbInformation, "Warning:") = vbOK Then
Cancel = False
Else
Cancel = True
End If
End If
End If
End SubAttribute 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 = ".0123ABCDEFGHIJKLMNOPQRSTUVWXYZ_" '' basic upper case 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 ''<< 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 strSMTP As String
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:" ''<<<Need 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 ''<<REMOVE 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
''>>>>>>>>>>>>>>>CLEANUP msg<<<<<<<<<<<<<<<<<<<<<
With Re ''REGEXP
.Pattern = "([\s\S]*)(<BODY[\s\S]{0,}?>)([\s\S]*)(</BODY>)([\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 = "<!DOCTYPE HTML PUBLIC """"-//W3C//DTD HTML 3.2//EN""""><HTML><HEAD><META NAME=""""Generator"""" CONTENT=""""MS Exchange Server version 16.0.11328.20390""""><TITLE></TITLE></HEAD>"
postHTML = mBody & "</BODY></HTML>"
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)
'<<<<<<<<<<<<<<<<<<<<<<<<''''''''''''''''''''''''''''''''''''''''''''''''''''''if distribution list - break open
'If IsDistribution(MRecipient) Then
''add all members to the list and skip this entry
'End If
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<DEBUG
strSMTP = GetSMTP(MRecipient)
ostr = "": ostr = LCase(Split(strSMTP, "@")(1))
If IsDistribution(MRecipient) Then
''break out list to add to end of recipients
boolKeepRecip = False ''Skip distribution list
'skip rest of checks and proceed
Else
On Error GoTo Meeting_MAIL_ROC_SKIP: ''added skip when distribution list fails
ostr = "": ostr = LCase(Split(strSMTP, "@")(1))
If IsRoom(MRecipient) Then ''remove rooms
boolKeepRecip = False
ElseIf StripLocalrecipientList(MRecipient) Then
boolKeepRecip = False
ElseIf boolHomeOnly And ostr <> 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
End If
Meeting_MAIL_ROC_SKIP:
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" ''<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
'.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) > 0 Then
' ostr = LCase(Split(GetSMTP(mRecipient), "@")(1))
' End If
'
' If boolHomeOnly Then
' If ostr <> 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 ''''''''''''''''''<<<<<<<<<<<<<<<<<<<<<<<<<<<<EXIT BREAK<<<<<<<<<<<<<
End With
Set objMail = Nothing
Next X
'Debug.Print GeneratePrefixTextTxt
End Sub
Function IsDistribution(MRecipient As Recipient) As Boolean
'MsgBox "Not ready yet"
'Stop
End Function
Function StripLocalrecipientList(objRecipient As Recipient) As Boolean
'Jim Kunst <JKunst@ktgy.com>
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(ByVal 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 > "" Then GetSMTP = GetSMTP & "@unresolved.com"
End If
End If
Else
'this is a contact
'olCont is ContactItem object
GetSMTP = olAddrEntry.Address ''''<<2020-09-28 - added BBLas resolve
'MsgBox olCont.FullName
End If
If GetSMTP = "" Then
GetSMTP = "UNRESOLVED@UNRESOLVED.COM" '''<<<<<<<<<<<<<<<<<<<<<tEMPORARY 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 '~~> most cases contains the email address
'MsgBox olNS.Accounts.Item(1).DisplayName '~~> usually email address
'MsgBox olNS.Accounts.Item(1).SmtpAddress '~~> email address
'MsgBox olNS.Accounts.Item(1).UserName '~~> displays the user name
End Function
Private Function StrHead_old() As String
''formatting for body of message in HTML format
StrHead_old = _
"<p class=MsoNormal><span style='background:yellow;mso-highlight:yellow'>Question/Unanswered issue</span><o:p></o:p></p>" & vbCr _
& "<p class=MsoNormal><span style='background:lime;mso-highlight:lime'>Key Point/Answer</span><o:p></o:p></p>" & vbCr _
& "<p class=MsoNormal><span style='background:aqua;mso-highlight:aqua'>Project</span><o:p></o:p></p>" & vbCr _
& "<p class=MsoNormal><b style='mso-bidi-font-weight:normal'><span style='color:yellow;background:red;mso-highlight:red'>Critical Issue</span><span style='color:yellow'><o:p></o:p></span></b></p>" & vbCr _
& "<p class=MsoNormal><o:p> </o:p></p>" & vbCr _
& "<p class=MsoNormal><o:p> </o:p></p>" & vbCr _
& "<p class=MsoNormal><o:p> </o:p></p>" & vbCr _
& "<p class=MsoNormal>SUMMARY--------------------</p>" & vbCr _
& "<p class=MsoNormal><o:p> </o:p></p>" & vbCr _
& "<p class=MsoNormal><o:p> </o:p></p>" & vbCr _
& "<p class=MsoNormal><o:p> </o:p></p>" & vbCr _
& "<p class=MsoNormal>ROC-----------------------------<o:p></o:p></span></p>" & vbCr _
& "<p class=MsoNormal><o:p> </o:p></span></p>"
End Function
Private Function StrHead() As String
''formatting for body of message in HTML format
StrHead = _
"<div class=WordSection1>" & vbCr _
& "<b>If anything appears to be incorrect- please reply with different color inline comments for corrections.</b>" & vbCr _
& "</p>" & vbCr _
& "<p class=MsoNormal><span style='mso-fareast-font-family:""""Times New Roman""""'>" & vbCr _
& "|<span style='background:yellow;mso-highlight:yellow'>Question/Unanswered issue</span>" & vbCr _
& "|<span style='background:lime;mso-highlight:lime'>Key Point/Answer</span>" & vbCr _
& "|<span style='background:aqua;mso-highlight:aqua'>Project</span>" & vbCr _
& "|<b><span style='color:yellow;background:red;mso-highlight:red'>Critical Issue</span></b>" & vbCr _
& "|<span style='background:silver;mso-highlight:silver'>After/Unaddressed</span>" & vbCr _
& "|<o:p></o:p></span></p>"
StrHead = StrHead _
& "<b><span style='font-size:16.0pt'>SUMMARY--------------------<o:p></o:p></span></b></p>" & vbCr _
& "<p class=MsoNormal><span style='mso-fareast-font-family:""""Times New Roman""""'><o:p> </o:p></span></p>" & vbCr _
& "<p class=MsoNormal><b><span style='font-size:16.0pt'>" & vbCr _
& "<p class=MsoNormal><b><span style='font-size:16.0pt'>ROC-----------------------------<o:p></o:p></span></b></p>" & vbCr
StrHead = StrHead _
& "<p class=MsoNormal><o:p> </o:p></p>" & vbCr _
& "<p class=MsoNormal><o:p> </o:p></p>" & vbCr _
& "</div>" & vbCr _
& "</body>" & vbCr _
& "</html>"
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) > 0
IsRoomErr:
End Function
Private Function StrHead3() As String
''formatting for body of message in HTML format
StrHead3 = _
"<body lang=EN-US link=blue vlink=purple style='tab-interval:.5in'>" & vbCr _
& "<div class=WordSection1>" _
& "If anything appears to be incorrect- please reply with different color inline comments for corrections." & vbCr _
& "</p>" & vbCr _
& "<p class=MsoNormal><span style='mso-fareast-font-family:""""Times New Roman""""'>" & vbCr _
& "*<span style='background:yellow;mso-highlight:yellow'>Question/Unanswered issue</span>" & vbCr _
& "*<span style='background:lime;mso-highlight:lime'>Key Point/Answer</span>" & vbCr _
& "*<span style='background:aqua;mso-highlight:aqua'>Project</span>" & vbCr _
& "*<b><span style='color:yellow;background:red;mso-highlight:red'>Critical Issue</span></b>" & vbCr _
& "*<span style='background:silver;mso-highlight:silver'>After/Unaddressed</span>" & vbCr _
& "*<o:p></o:p></span></p>"
StrHead3 = StrHead3 _
& "<p class=MsoNormal><b><span style='font-size:16.0pt;mso-fareast-font-family:""""Times New Roman""""'>" & vbCr _
& "SUMMARY--------------------<o:p></o:p></span></b></p>" & vbCr _
& "<p class=MsoNormal><span style='mso-fareast-font-family:""""Times New Roman""""'><o:p> </o:p></span></p>" & vbCr _
& "<p class=MsoNormal><b><span style='font-size:16.0pt'>" & vbCr _
& "ROC-----------------------------<u1:p></u1:p></span></b><u2:p></u2:p>" & vbCr _
& "<span style='font-size:16.0pt'> <o:p></o:p></span></p> <p class=MsoNormal><span style='mso-fareast-font-family:""""Times New Roman""""'><o:p> </o:p></span></p>" & vbCr _
& "<p class=MsoNormal><span style='font-size:16.0pt'><o:p> </o:p></span></p>" & vbCr _
& "</div></body></html>"
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
Function ContainsROC(objMail As Outlook.MailItem) As Boolean
If InStr(1, objMail.HTMLBody, "Subject: ROC:", vbBinaryCompare) > 0 Or _
InStr(1, objMail.Body, "Subject: ROC:", vbBinaryCompare) > 0 _
Then
ContainsROC = True
End If
End Function
Comments
Post a Comment