Validating Outlook Email Attachment Name through VB Macro - vba

Im creating an outlook Macro to validate an Email attachment and recipient name before sending the mail.
The recipient name can be easily validated through the ItemSend Function on the Outlook session.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim Recipients As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim i
Dim prompt As String
Set Recipients = Item.Recipients
For i = Recipients.Count To 1 Step -1
Set recip = Recipients.Item(i)
If InStr(LCase(recip), "bad#address.com") Then
prompt$ = "You sending this to this to " & Item.To & ". Are you sure you want to send it?"
If MsgBox(prompt$, vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Check Address") = vbNo Then
Cancel = True
End If
End If
Next i
End Sub
While this helps with recipients, it does not allow to validate the attachment name before sending the mail. i.e Validate the Mail Draft. The code below helps to check for attachments present on the draft but does not help validate it.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
If InStr(1, Item.Body, "attach", vbTextCompare) > 0 Then
If Item.Attachments.Count = 0 Then
answer = MsgBox("There's no attachment, send anyway?", vbYesNo)
If answer = vbNo Then Cancel = True
End If
So i tried to add item.Attachment. Name \ item.attachment.FileName but this works only if i attribute it to a outlook MailItem instead of a normal object.
Is it possible to create code to validate the attachment name for certain criteria ( name should conform to certain naming constraints ). The code has already been created and works as a normal macro and not as a session Macro.
Function Segregate_Function(Attach_Name_Pass1 As String)
Dim FullName As String
Dim Recepients As String
Region_Ext = Right(Attach_Name_Pass1, 7)
region = Left(Region_Ext, 3)
'MsgBox region
If region = "ENG" Then
Recepients = "ABC#gmail.com;XYZ#gmail.com"
Call Send_Function(Attach_Name_Pass1, Recepients)
Else
MsgBox " Not an Acceptable Attachment. Mail Could not be Generated "
End If
End Function
I would like the above code to execute when clicking on send to validate an attachment name directly, instead of having a procedural Macro running.
Do advice.

Try testing within ItemSend.
Something like this:
Option Explicit
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim att As attachment
Dim Attach_Name_Pass1 As String
Dim Region_Ext As String
Dim Region As String
Cancel = False
If Item.Attachments.count = 0 Then
If MsgBox("There's no attachment, send anyway?", vbYesNo) = vbNo Then Cancel = True
Else
Debug.Print Item.To
If InStr(Item.To, "ABC#gmail.com") > 0 Or InStr(Item.To, "XYZ#gmail.com") > 0 Then
For Each att In Item.Attachments
Attach_Name_Pass1 = att.DisplayName
Region_Ext = Right(Attach_Name_Pass1, 7)
Region = Left(Region_Ext, 3)
'MsgBox region
Debug.Print Region
If Region <> "ENG" Then
Cancel = True
MsgBox " Not an Acceptable Attachment. Send cancelled."
Exit For
End If
Next
End If
End If
End Sub

Related

How to prompt when sending to an external email address?

I want a warning every time I try to send an email outside my company, where external email addresses are those that don't end in the mycompany.com domain.
This prompts every time I send an email, regardless of the recipient or recipients.
It should only prompt if at least one of the to/cc/bcc recipients has an email address with a different domain.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim xMailItem As Outlook.MailItem
Dim xRecipients As Outlook.Recipients
Dim i As Long
Dim xRecipientAddress As String
Dim xPrompt As String
Dim xYesNo As Integer
Dim xPos As Integer
On Error Resume Next
If Item.Class <> olMail Then Exit Sub
Set xMailItem = Item
Set xRecipients = xMailItem.Recipients
For i = xRecipients.Count To 1 Step -1
xRecipientAddress = xRecipients.Item(i).Address
xPos = InStrRev(LCase(xRecipientAddress), "#mycompany.com")
If xPos <= 0 Then Exit For
Cancel = False
Next
If InStrRev(LCase(xRecipientAddress), "#mycompany.com") > 0 Then Exit Sub
xPrompt = "Are you sure you want to send this email outside of The Company?"
xYesNo = MsgBox(xPrompt, vbYesNo + vbQuestion, "External Email Warning")
If xYesNo = vbNo Then Cancel = True
End Sub
The Recipient.Address may not return an SMTP email address in case of Exchange accounts. Microsoft Exchange Server can operate with email address types such as Exchange, SMTP, X.400, Microsoft Mail, etc. By default, the Address property of the Recipient class returns just an Exchange type address, for example this one:
/O=ORGANIZATION_NAME /OU=EXCHANGE_GROUP /CN=RECIPIENTS /CN=USER_NAME
To get other address types, we need to find the recipient in the Outlook address book by using the IAddrBook.ResolveName method, then reach the IMailUser interface with the IAddrBook.OpenEntry method and get the PR_EMS_AB_PROXY_ADDRESSES property. Read more about that in the HowTo: Convert Exchange-based email address into SMTP email address article.
Also you may consider using the AddressEntry property of the Recipient class return an object which represents a person, group, or public folder to which the messaging system can deliver messages. You can check out the AddressEntry.AddressEntryUserType property which returns a constant from the OlAddressEntryUserType enumeration representing the user type of the AddressEntry. In case of Exchange entry you need to use the following sequence of property and method calls:
Recipient.AddressEntry.GetExchangeUser().PrimarySmtpAddress
The ExchangeUser.PrimarySmtpAddress property returns a string representing the primary Simple Mail Transfer Protocol (SMTP) address for the ExchangeUser.
I think this logic is easier to follow. I believe InStr is sufficient.
Option Explicit
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim xMailItem As MailItem
Dim xRecipients As Recipients
Dim i As Long
Dim xRecipientAddress As String
Dim xPrompt As String
Dim xYesNo As VbMsgBoxResult
Dim xPos As Long
If Item.Class <> olMail Then Exit Sub
Set xMailItem = Item
Set xRecipients = xMailItem.Recipients
For i = xRecipients.count To 1 Step -1
xRecipientAddress = xRecipients.Item(i).Address
Debug.Print xRecipientAddress
' Use text from internal xRecipientAddress
xPos = InStr(LCase(xRecipientAddress), "#mycompany.com")
Debug.Print xPos
If xPos = 0 Then
xPrompt = "Are you sure you want to send this email outside of The Company?"
xYesNo = MsgBox(xPrompt, vbYesNo + vbQuestion, "External Email Warning")
If xYesNo = vbNo Then Cancel = True
Exit For
End If
Next
End Sub

How to get the date mentioned in the email into the VBA script in Outlook?

I have created a rule that executed when outlook receives an mail and it will create the appointment on outlook calendar. In that I need to get the date and time mentioned in the mail as the appointment date.
Sub NewMeetingRequestFromEmail(email As MailItem)
Dim app As New Outlook.Application
Dim meetingRequest As AppointmentItem
Set meetingRequest = app.CreateItem(olAppointmentItem)
meetingRequest.Categories = email.Categories
meetingRequest.Body = email.Body
meetingRequest.Subject = email.Subject
meetingRequest.Location = email.Subject
meetingRequest.Start = DateSerial(Year(Now), Month(Now), Day(Now) + 1) + #10:00:00 AM#
meetingRequest.Duration = 60
meetingRequest.ReminderMinutesBeforeStart = 45
meetingRequest.ReminderSet = True
Dim attachment As attachment
For Each attachment In email.Attachments
CopyAttachment attachment, meetingRequest.Attachments
Next attachment
Dim recipient As recipient
Set recipient = meetingRequest.Recipients.Add(email.SenderEmailAddress)
recipient.Resolve
For Each recipient In email.Recipients
RecipientToParticipant recipient, meetingRequest.Recipients
Next recipient
Dim inspector As inspector
Set inspector = meetingRequest.GetInspector
'inspector.CommandBars.FindControl
inspector.Display
meetingRequest.Save
End Sub
Private Sub RecipientToParticipant(recipient As recipient, participants As Recipients)
Dim participant As recipient
If LCase(recipient.Address) <> LCase(Session.CurrentUser.Address) Then
Set participant = participants.Add(recipient.Address)
Select Case recipient.Type
Case olBCC:
participant.Type = olOptional
Case olCC:
participant.Type = olOptional
Case olOriginator:
participant.Type = olRequired
Case olTo:
participant.Type = olRequired
End Select
participant.Resolve
End If
End Sub
Private Sub CopyAttachment(source As attachment, destination As Attachments)
On Error GoTo HandleError
Dim filename As String
filename = Environ("temp") & "\" & source.filename
source.SaveAsFile (filename)
destination.Add (filename)
Exit Sub
HandleError:
Debug.Print Err.Description
End Sub
The Outlook object model provides three main ways for working with item bodies:
Body.
HTMLBody.
The Word editor. The WordEditor property of the Inspector class returns an instance of the Word Document which represents the message body.
See Chapter 17: Working with Item Bodies for more information.

Outlook VBA -> Check the email extension of an address after it has been resolved

I was wondering if there is a way i can modify my Item.To in the below code block to test against the physical email address? Right now it is checking against the resolved name.
I.E. if i am testing for #here.com within John.Doe#here.com, and Outlook auto resolves the name, i'm left with a logic test of #here.com <> "John Doe". Simply does not work. Thanks for the assistance! Code follows:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'**************************************************************************************************************************
' Summary: Outlook BCC Insert util based by scan of to field for matching user
' USAGE: populate user options and insert in to the "ThisOutlookSession" code body in Outlook
'**************************************************************************************************************************
' History:
' 05/04/2015 Me Created
'**************************************************************************************************************************
Dim objRecip As Recipient
Dim strMsg As String
Dim res As Integer
Dim EmailToCheckAgainst As String
Dim BCCEmailToAdd As String
On Error Resume Next
' #### USER OPTIONS ####
EmailToCheckAgainst = "#here.com" 'email address you are checking against
BCCEmailToAdd = "BCCme#mycompany.com" 'email address you are adding as BCC
' #### END USER OPTIONS ####
If InStr(LCase(Item.To), LCase(EmailToCheckAgainst)) > 0 Then
Set objRecip = Nothing
Set objRecip = Item.Recipients.Add(BCCEmailToAdd)
objRecip.Type = olBCC
'Resolve it?
Cancel = False
If Not objRecip.Resolve Then
strMsg = "Could not resolve the Bcc recipient. " & _
"Do you want still to send the message?"
res = MsgBox(strMsg, vbYesNo + vbDefaultButton1, _
"Could Not Resolve Bcc Recipient")
If res = vbNo Then
Cancel = True
End If
End If
End If
On Error GoTo 0
End Sub
Do no use the To/CC/BCC properties. Loop through all recipients in the MailItem.Recipients collection and compare the Recipient.Address property (if it is resolved) or Recipient.Name if it is not.

How to delete autoforwarded email in SENT folder Outlook 2010 Exchange

Newbie poster with Outlook VBA. Intermediate Excel VBA coder.
I have a VBA routine that autoforwards all incoming email to a Gmail account. It is not all my code, (modified from a blog post) but it works. I need to keep a copy of all my email received in all my accounts so I can consolidate them into one main one. In the Outlook 2010 Exchange account, all the forwarded mail gets saved in the SENT folder as a copy.
Is it possible to delete the autoforwarded copy in the SENT folder, without deleting all SENT emails? I need to keep the emails I actually respond to.
I would not have a problem using conversation mode in the INBOX, to store the replied to emails. but as it now stands, everything is duplicated due to the bcc copy in the SENT folder when I toggle Conversation mode for the INBOX.
Thanks in advance for any assistance.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim objRecip As Recipient
Dim strMsg As String
Dim res As Integer
Dim strBcc As String
On Error Resume Next
' #### USER OPTIONS ####
' address for Bcc -- must be SMTP address or resolvable
' to a name in the address book
strBcc = "bcc.hwb#gmail.com"
Set objRecip = Item.Recipients.Add(strBcc)
objRecip.Type = olBCC
If Not objRecip.Resolve Then
strMsg = "Could not resolve the Bcc recipient. " & _
"Do you want still to send the message?"
res = MsgBox(strMsg, vbYesNo + vbDefaultButton1, _
"Could Not Resolve Bcc Recipient")
If res = vbNo Then
Cancel = True
End If
End If
Set objRecip = Nothing
End Sub
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim varEntryIDs
Dim objItem
Dim myItem As MailItem
Dim i As Integer
varEntryIDs = Split(EntryIDCollection, ",")
For i = 0 To UBound(varEntryIDs)
Set objItem = Application.Session.GetItemFromID(varEntryIDs(i))
'MsgBox (varEntryIDs(i))
Set myItem = objItem.Forward
myItem.Recipients.Add "bcc.hwb#gmail.com"
myItem.Send
'myItem.Delete
Set myItem = Nothing
Next
End Sub
See MailItem.DeleteAfterSubmit Property (Outlook)
myItem.DeleteAfterSubmit = True

Removing Signatures / attachments from outlook emails going to Mac users or SpiceWorks

So here's an interesting problem I stumbled upon on. I’m running into issues by sending emails out to SpiceWorks and Mac users.
When a user has a problem they will email Help Desk. We setup a personal Outlook email to handle Help Desk tickets. Once the ticket hits the outlook mailbox it will automatically be sent to our SpiceWorks site.
Now all of our emails have signatures and there are certain signatures with small png image logos (Youtube, LinkedIn, Facebook, and Twitter).
When the email hits SpiceWorks it uploads those png images as attachments. These attachments cause most of the problems because some email threads get very long before they even get submitted as an help desk ticket. They would end up with maybe 20+ attachments of the same four logo png's.
I coded to remove all attachments to that specific address but some users send actual attachments. I tried remove the specific attachments by name but if there are duplicates of same .png image they would just iterate. (img001 through img004 is now img005 through img009)
I found the current VBA script in the HelpDesk Outlook. I was told that Outlook has to be running all the time in order for it to work... sometimes.
I started writing my own script where it checks if the current email is going to HelpDesk email address then remove the attachemnts. No luck yet.
Current Code
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim msg As Outlook.MailItem
Dim recips As Outlook.Recipients
Dim str As String
Dim emailAddress As String
Dim prompt As String
Dim msgbody As String
msgbody = Item.Body
Set msg = Item 'Subject Message
Set recips = msg.Recipients
str = "HelpDesk"
For x = 1 To GetRecipientsCount(recips)
str1 = recips(x)
If str1 = str Then
'MsgBox str1, vbOKOnly, str1 'For Testing
prompt = "Are you sure you want to send to " & str1 & "?" 'For Testing
If MsgBox(prompt, vbYesNo + vbQuestion, "Sample") = vbNo Then 'For Testing
Cancel = True
End If
'if attachments are there
If Item.Attachments.Count > 0 Then
'for all attachments
For i = Item.Attachments.Count To 1 Step -1
'if the attachment's filename is similar to "image###.png", remove
If InStr(Item.Attachments(i).FileName, "image") > 0 And Right(Item.Attachments(i).FileName, 4) = ".png" Then
MsgBox ("Item Removed " + Item.Attachments(i))
Item.Attachments.Remove (i)
End If
Next
End If
End If
Next x
End Sub
Public Function GetRecipientsCount(Itm As Variant) As Long
' pass in a qualifying item, or a Recipients Collection
Dim obj As Object
Dim recips As Outlook.Recipients
Dim types() As String
types = Split("MailItem, AppointmentItem, JournalItem, MeetingItem, TaskItem", ",")
Select Case True
' these items have a Recipients collection
Case UBound(Filter(types, TypeName(Itm))) > -1
Set obj = Itm
Set recips = obj.Recipients
Case TypeName(Itm) = "Recipients"
Set recips = Itm
End Select
GetRecipientsCount = recips.Count
End Function
A few questions:
1.) Is there a way to set rules in outlook(Looked at numerous possibilities) or do something with the Exchange Server to stop this from happening?
2.) With Vba is there a way to remove or not allow a signature when the email is sent?
If anything, my ultimate goal is just to prevent those .png's being uploaded as images to Mac users and SpiceWorks.
I'm sure there is more to this but I will gladly answer any questions given to me.
Thank you for any help or directions!
If I understand you correctly, you're trying to remove .png files being sent to SpiceWorks. If so, use the macro below from the Outlook mailbox sending to SpiceWorks. On the ItemSend event, this will check the filename of all attachments and remove those with .png extensions. If this is not what you're trying to do, post back here. Thanks.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'if attachments are there
If Item.Attachments.count > 0 Then
'for all attachments
For i = Item.Attachments.count To 1 Step -1
'if the attachment's extension is .png, remove
If Right(Item.Attachments(i).FileName, 4) = ".png" Then
Item.Attachments.Remove (i)
End If
Next
End If
End Sub
----- updated to only remove attachments that look like "image###.png" -----
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'if attachments are there
If Item.Attachments.count > 0 Then
'for all attachments
For i = Item.Attachments.count To 1 Step -1
'if the attachment's filename is similar to "image###.png", remove
If InStr(Item.Attachments(i).FileName, "image") > 0 And Right(Item.Attachments(i).FileName, 4) = ".png" Then
Item.Attachments.Remove (i)
End If
Next
End If
End Sub
----- updated to only remove attachments that are <10kb and look like "image###.png"-----
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'if attachments are there
If Item.Attachments.count > 0 Then
'for all attachments
For i = Item.Attachments.count To 1 Step -1
'if attachment size is less than 10kb
If Item.Attachments(i).Size < 10000 Then
'if the attachment's filename is similar to "image###.png", remove
If InStr(Item.Attachments(i).FileName, "image") > 0 And Right(Item.Attachments(i).FileName, 4) = ".png" Then
Item.Attachments.Remove (i)
End If
End If
Next
End If
End Sub