djhardisty
asked on
Attach file on send in Outlook
I need a macro to attach a file when the user clicks on send. There are criteria involved: 1. Do not attach the file if the recipient is internal, ie. on the domain and 2. Do not attach the file if the recipient has already been sent an email already that day/week etc.
I have found the following:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Const strFile = "C:\MyAdvert.pdf"
If Item.Class = olMail Then
'if file doesn't exist then do nothing
If Not Dir(strFile, vbDirectory) = vbNullString Then
Item.Attachments.Add strFile
Item.Save
End If
End If
End Sub
This only checks that the pdf file exists but I also need to check the recipient to see if an email has already been sent to that recipient(s) on that day, and if so, send the email without the attachment. Also if the user is internal to the Exchange (2007) system then never attach the pdf file.
If there are several users and all are internal then don't attach. If only one is external then attach the file. Outlook versions 2003/2007 are being used.
I have found the following:
Private Sub Application_ItemSend(ByVal
Const strFile = "C:\MyAdvert.pdf"
If Item.Class = olMail Then
'if file doesn't exist then do nothing
If Not Dir(strFile, vbDirectory) = vbNullString Then
Item.Attachments.Add strFile
Item.Save
End If
End If
End Sub
This only checks that the pdf file exists but I also need to check the recipient to see if an email has already been sent to that recipient(s) on that day, and if so, send the email without the attachment. Also if the user is internal to the Exchange (2007) system then never attach the pdf file.
If there are several users and all are internal then don't attach. If only one is external then attach the file. Outlook versions 2003/2007 are being used.
ASKER
Hi BlueDevilFan
Thank you for the response. It's a big ask but please could you provide both solutions. I need to get this working in a mixed Outlook environment but plan to get rid of Outlook 2003 later this year and replace with 2012/2013. I am assuming the solution for 2007 will also work for 2010/2013.
Best Regards
David
Thank you for the response. It's a big ask but please could you provide both solutions. I need to get this working in a mixed Outlook environment but plan to get rid of Outlook 2003 later this year and replace with 2012/2013. I am assuming the solution for 2007 will also work for 2010/2013.
Best Regards
David
David,
Here's the solution for Outlook 2007. This code will add the attachment only if the message has at least one external addressee, at least one external addressee has not already received a message with this attachment today. If there are no external addressees or if all the external addressees have already received a message with the attachment today, then the code will not add the attachment.
I gave this a very brief test in my environment and it appears to work properly. Please test it in your environment to make sure it works the way you want it to before putting it into production.
I have to reinstall Outlook Redemption on my computer and then I'll put together a version for Outlook 2003.
Here's the solution for Outlook 2007. This code will add the attachment only if the message has at least one external addressee, at least one external addressee has not already received a message with this attachment today. If there are no external addressees or if all the external addressees have already received a message with the attachment today, then the code will not add the attachment.
I gave this a very brief test in my environment and it appears to work properly. Please test it in your environment to make sure it works the way you want it to before putting it into production.
I have to reinstall Outlook Redemption on my computer and then I'll put together a version for Outlook 2003.
'On the next line edit the path to the attachment. The path must end with a \
Const ATTACHMENT_PATH = "c:\Users\David\Documents\TestArea\"
'On the next line edit the name of the attachment
Const ATTACHMENT_NAME = "MyAdvert.pdf"
'On the next line edit the local domain name
Const LOCAL_EMAIL_DOMAIN = "@company.com"
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim strExternalAddressees As String
If Item.Class = olMail Then
strExternalAddressees = ExternalAddressee(Item)
If strExternalAddressees <> "" Then
If NoMessageToday(strExternalAddressees) Then
'if file doesn't exist then do nothing
If Not Dir(ATTACHMENT_PATH & ATTACHMENT_NAME, vbDirectory) = vbNullString Then
Item.Attachments.Add ATTACHMENT_PATH & ATTACHMENT_NAME
Item.Save
End If
End If
End If
End If
Cancel = True
End Sub
Private Function ExternalAddressee(olkMsg As Outlook.MailItem) As String
Dim olkRcp As Outlook.RECIPIENT, _
strSMTP As String, _
intPos As Integer
For Each olkRcp In olkMsg.Recipients
If olkRcp.AddressEntry.AddressEntryUserType = olExchangeUserAddressEntry Then
strSMTP = olkRcp.AddressEntry.GetExchangeUser.PrimarySmtpAddress
Else
strSMTP = olkRcp.AddressEntry.Address
End If
intPos = InStr(1, LCase(strSMTP), LCase(LOCAL_EMAIL_DOMAIN))
If intPos = 0 Then
ExternalAddressee = ExternalAddressee & olkRcp.Name & "|"
End If
Next
If Len(ExternalAddressee) > 0 Then ExternalAddressee = Left(ExternalAddressee, Len(ExternalAddressee) - 1)
Set olkRcp = Nothing
End Function
Private Function NoMessageToday(strAddressees As String) As Boolean
Dim olkItms As Outlook.Items, _
olkItm As Outlook.MailItem, _
olkRcp As Outlook.RECIPIENT, _
olkAtt As Outlook.Attachment, _
arrAddr As Variant, _
varAddr As Variant, _
objDic As Object, _
strQry As String
Set objDic = CreateObject("Scripting.Dictionary")
arrAddr = Split(strAddressees, "|")
For Each varAddr In arrAddr
objDic.Add varAddr, varAddr
Next
strQry = "[SentOn] >= '" & Format(Date & " 12:00 am", "ddddd h:nn AMPM") & "' AND [SentOn] <= '" & Format(Date & " 23:59 pm", "ddddd h:nn AMPM") & "'"
Set olkItms = Session.GetDefaultFolder(olFolderSentMail).Items.Restrict(strQry)
For Each olkItm In olkItms
If olkItm.Class = olMail Then
For Each olkRcp In olkItm.Recipients
If objDic.Exists(olkRcp.Name) Then
For Each olkAtt In olkItm.Attachments
If olkAtt.FileName = ATTACHMENT_NAME Then
objDic.Remove olkRcp.Name
End If
Next
End If
Next
End If
Next
If objDic.Count > 0 Then NoMessageToday = True
Set olkItms = Nothing
Set olkItm = Nothing
Set olkRcp = Nothing
Set olkAtt = Nothing
Set objDic = Nothing
End Function
ASKER
Hi BlueDevilFan
Thanks for the code. I did some testing yesterday and working well. I did make one change as it errored when the dictionary items were 0, so I put a Do..While...Loop around the code in the NoMessageToday function. Is that ok?
'On the next line edit the path to the attachment. The path must end with a \
Const ATTACHMENT_PATH = "c:\"
'On the next line edit the name of the attachment
Const ATTACHMENT_NAME = "MyAdvert.pdf"
'On the next line edit the local domain name
Const LOCAL_EMAIL_DOMAIN = "@domain"
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim strExternalAddressees As String
If Item.Class = olMail Then
strExternalAddressees = ExternalAddressee(Item)
If strExternalAddressees <> "" Then
If NoMessageToday(strExternal Addressees ) Then
'if file doesn't exist then do nothing
If Not Dir(ATTACHMENT_PATH & ATTACHMENT_NAME, vbDirectory) = vbNullString Then
Item.Attachments.Add ATTACHMENT_PATH & ATTACHMENT_NAME
Item.Save
End If
End If
End If
End If
'remove the following line - only for dev environment - puts email in draft folder
Cancel = True
End Sub
Private Function ExternalAddressee(olkMsg As Outlook.MailItem) As String
Dim olkRcp As Outlook.Recipient, _
strSMTP As String, _
intPos As Integer
For Each olkRcp In olkMsg.Recipients
If olkRcp.AddressEntry.Addres sEntryUser Type = olExchangeUserAddressEntry Then
strSMTP = olkRcp.AddressEntry.GetExc hangeUser. PrimarySmt pAddress
Else
strSMTP = olkRcp.AddressEntry.Addres s
End If
intPos = InStr(1, LCase(strSMTP), LCase(LOCAL_EMAIL_DOMAIN))
If intPos = 0 Then
ExternalAddressee = ExternalAddressee & olkRcp.Name & "|"
End If
Next
If Len(ExternalAddressee) > 0 Then ExternalAddressee = Left(ExternalAddressee, Len(ExternalAddressee) - 1)
Set olkRcp = Nothing
End Function
Private Function NoMessageToday(strAddresse es As String) As Boolean
Dim olkItms As Outlook.Items, _
olkItm As Outlook.MailItem, _
olkRcp As Outlook.Recipient, _
olkAtt As Outlook.Attachment, _
arrAddr As Variant, _
varAddr As Variant, _
objDic As Object, _
strQry As String
Set objDic = CreateObject("Scripting.Di ctionary")
arrAddr = Split(strAddressees, "|")
For Each varAddr In arrAddr
objDic.Add varAddr, varAddr
Next
strQry = "[SentOn] >= '" & Format(Date & " 12:00 am", "ddddd h:nn AMPM") & "' AND [SentOn] <= '" & Format(Date & " 23:59 pm", "ddddd h:nn AMPM") & "'"
Set olkItms = Session.GetDefaultFolder(o lFolderSen tMail).Ite ms.Restric t(strQry)
For Each olkItm In olkItms
If olkItm.Class = olMail Then
For Each olkRcp In olkItm.Recipients
If objDic.Exists(olkRcp.Name) Then
For Each olkAtt In olkItm.Attachments
Do While objDic.Count > 0
If olkAtt.FileName = ATTACHMENT_NAME Then
objDic.Remove olkRcp.Name
End If
Loop
Next
End If
Next
End If
Next
If objDic.Count > 0 Then NoMessageToday = True
Set olkItms = Nothing
Set olkItm = Nothing
Set olkRcp = Nothing
Set olkAtt = Nothing
Set objDic = Nothing
End Function
Thanks for the code. I did some testing yesterday and working well. I did make one change as it errored when the dictionary items were 0, so I put a Do..While...Loop around the code in the NoMessageToday function. Is that ok?
'On the next line edit the path to the attachment. The path must end with a \
Const ATTACHMENT_PATH = "c:\"
'On the next line edit the name of the attachment
Const ATTACHMENT_NAME = "MyAdvert.pdf"
'On the next line edit the local domain name
Const LOCAL_EMAIL_DOMAIN = "@domain"
Private Sub Application_ItemSend(ByVal
Dim strExternalAddressees As String
If Item.Class = olMail Then
strExternalAddressees = ExternalAddressee(Item)
If strExternalAddressees <> "" Then
If NoMessageToday(strExternal
'if file doesn't exist then do nothing
If Not Dir(ATTACHMENT_PATH & ATTACHMENT_NAME, vbDirectory) = vbNullString Then
Item.Attachments.Add ATTACHMENT_PATH & ATTACHMENT_NAME
Item.Save
End If
End If
End If
End If
'remove the following line - only for dev environment - puts email in draft folder
Cancel = True
End Sub
Private Function ExternalAddressee(olkMsg As Outlook.MailItem) As String
Dim olkRcp As Outlook.Recipient, _
strSMTP As String, _
intPos As Integer
For Each olkRcp In olkMsg.Recipients
If olkRcp.AddressEntry.Addres
strSMTP = olkRcp.AddressEntry.GetExc
Else
strSMTP = olkRcp.AddressEntry.Addres
End If
intPos = InStr(1, LCase(strSMTP), LCase(LOCAL_EMAIL_DOMAIN))
If intPos = 0 Then
ExternalAddressee = ExternalAddressee & olkRcp.Name & "|"
End If
Next
If Len(ExternalAddressee) > 0 Then ExternalAddressee = Left(ExternalAddressee, Len(ExternalAddressee) - 1)
Set olkRcp = Nothing
End Function
Private Function NoMessageToday(strAddresse
Dim olkItms As Outlook.Items, _
olkItm As Outlook.MailItem, _
olkRcp As Outlook.Recipient, _
olkAtt As Outlook.Attachment, _
arrAddr As Variant, _
varAddr As Variant, _
objDic As Object, _
strQry As String
Set objDic = CreateObject("Scripting.Di
arrAddr = Split(strAddressees, "|")
For Each varAddr In arrAddr
objDic.Add varAddr, varAddr
Next
strQry = "[SentOn] >= '" & Format(Date & " 12:00 am", "ddddd h:nn AMPM") & "' AND [SentOn] <= '" & Format(Date & " 23:59 pm", "ddddd h:nn AMPM") & "'"
Set olkItms = Session.GetDefaultFolder(o
For Each olkItm In olkItms
If olkItm.Class = olMail Then
For Each olkRcp In olkItm.Recipients
If objDic.Exists(olkRcp.Name)
For Each olkAtt In olkItm.Attachments
Do While objDic.Count > 0
If olkAtt.FileName = ATTACHMENT_NAME Then
objDic.Remove olkRcp.Name
End If
Loop
Next
End If
Next
End If
Next
If objDic.Count > 0 Then NoMessageToday = True
Set olkItms = Nothing
Set olkItm = Nothing
Set olkRcp = Nothing
Set olkAtt = Nothing
Set objDic = Nothing
End Function
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Thanks BlueDevilFan
I'm happy to accept this solution and post another for the 2003 version.
Best Regards
David
I'm happy to accept this solution and post another for the 2003 version.
Best Regards
David
David,
I'll leave that up to you. I'm okay with keeping the two together, I just haven't had time to load Redemption and put that solution together yet. If you do create a separate question, then please send me a link to it.
Cheers!
David (I'm a David too)
I'll leave that up to you. I'm okay with keeping the two together, I just haven't had time to load Redemption and put that solution together yet. If you do create a separate question, then please send me a link to it.
Cheers!
David (I'm a David too)
ASKER
Hi David,
Decided there was enough work there for two questions. Will accept this solution and new question is here https://www.experts-exchange.com/questions/28009450/Attach-file-on-send-in-Outlook-2003.html
Thanks for your help.
David
Decided there was enough work there for two questions. Will accept this solution and new question is here https://www.experts-exchange.com/questions/28009450/Attach-file-on-send-in-Outlook-2003.html
Thanks for your help.
David
I can help you with a solution for Outlook 2007. Outlook 2003 doesn't have a built-in means of determining if an addressee is inside the organization. The only solution I know of for that version is to use a third-party utility called Outlook Redemption. If you don't mind using a third-party tool, then I can help with that too.