Solved

Attach file on send in Outlook

Posted on 2013-01-15
10
652 Views
Last Modified: 2013-01-25
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.
0
Comment
Question by:djhardisty
  • 4
  • 4
10 Comments
 
LVL 76

Expert Comment

by:David Lee
ID: 38803875
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.
0
 

Author Comment

by:djhardisty
ID: 38804489
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
0
 
LVL 76

Expert Comment

by:David Lee
ID: 38805876
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

0
 

Author Comment

by:djhardisty
ID: 38813869
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
0
IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

 
LVL 76

Accepted Solution

by:
David Lee earned 500 total points
ID: 38814189
I'm guessing the error must be the result of more than one message going to the same person with each message having an attachment of the same name.  I suppose a DO WHILE ... LOOP is okay, but I think I'd use an IF ... END IF instead.  Something like this

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
                            If objDic.Count > 0 Then
                                objDic.Remove olkRcp.Name
                            End If
                        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

0
 

Author Comment

by:djhardisty
ID: 38814249
Thanks BlueDevilFan

I'm happy to accept this solution and post another for the 2003 version.

Best Regards
David
0
 
LVL 76

Expert Comment

by:David Lee
ID: 38814260
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)
0
 

Author Comment

by:djhardisty
ID: 38820794
Hi David,

Decided there was enough work there for two questions.  Will accept this solution and new question is here http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Q_28009450.html

Thanks for your help.
David
0

Featured Post

IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

Outlook Free & Paid Tools
This article explains in simple steps how to renew expiring Exchange Server Internal Transport Certificate.
To add imagery to an HTML email signature, you have two options available to you. You can either add a logo/image by embedding it directly into the signature or hosting it externally and linking to it. The vast majority of email clients display l…
Polish reports in Access so they look terrific. Take yourself to another level. Equations, Back Color, Alternate Back Color. Write easy VBA Code. Tighten space to use less pages. Launch report from a menu, considering criteria only when it is filled…

760 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

24 Experts available now in Live!

Get 1:1 Help Now