Link to home
Start Free TrialLog in
Avatar of djhardisty
djhardistyFlag for United Kingdom of Great Britain and Northern Ireland

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.
Avatar of David Lee
David Lee
Flag of United States of America image

Hi, djhardisty.

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.
Avatar of djhardisty

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
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.

'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

Open in new window

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(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
'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.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
                        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
Avatar of David Lee
David Lee
Flag of United States of America image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Thanks BlueDevilFan

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)
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