Solved

Attach file on send in Outlook 2003

Posted on 2013-01-25
7
490 Views
Last Modified: 2013-02-06
I need a macro to attach a file when the user clicks on send.  There are criteria involved: I 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 is version 2003.
0
Comment
Question by:djhardisty
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 4
  • 3
7 Comments
 
LVL 76

Expert Comment

by:David Lee
ID: 38839052
Hi, djhardisty.

Here's the code for doing this.  The code is exactly the same as what I used in the original question with the exception of the function ExternalAddressee.  In this version I've used Outlook Redemption, a third-party library created by Dmitry Streblechenko.  In order to use this solution you will have to acquire and install a copy of Redemption on each computer you plan to use the solution on.  The reason for using Redemption is that Outlook 2003 does not have a built-in means of determining a recipient's SMTP address.  

'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 redSes As Object, _
        redMsg As Object, _
        redRcp As Object, _
        strSMTP As String, _
        intPos As Integer
    Set redSession = CreateObject("Redemption.RDOSession")
    redSession.MAPIOBJECT = Application.Session.MAPIOBJECT
    Set redMsg = redSession.GetMessageFromID(olkMsg.EntryID)
    For Each redRcp In redMsg.Recipients
        strSMTP = redRcp.AddressEntry.SmtpAddress
        intPos = InStr(1, LCase(strSMTP), LCase(LOCAL_EMAIL_DOMAIN))
        If intPos = 0 Then
            ExternalAddressee = ExternalAddressee & redRcp.Name & "|"
        End If
    Next
    If Len(ExternalAddressee) > 0 Then ExternalAddressee = Left(ExternalAddressee, Len(ExternalAddressee) - 1)
    Set redSes = Nothing
    Set redMsg = Nothing
    Set redRcp = 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
                            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: 38850167
HI David

Thanks for the code.  I've been away for a few days but will test this today.

Regards
David
0
 
LVL 76

Expert Comment

by:David Lee
ID: 38850954
No worries, David.
0
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 

Author Comment

by:djhardisty
ID: 38855036
Hi David

Getting a MAPI error on this line in function ExternalAddressee:    

Set redMsg = redSes.GetMessageFromID(olkMsg.EntryID) when olkMsg.EntryID is "".

It seems to take a couple of minutes until olkMsg.EntryID has a value which I think ties in with the message appearing in the Drafts folder.

Best Regards
David
0
 
LVL 76

Accepted Solution

by:
David Lee earned 500 total points
ID: 38855287
David,

Try adding

Item.Save

Open in new window


immediately after line #10.
0
 

Author Comment

by:djhardisty
ID: 38859498
Hi David

Thank you that worked.  Should have spotted that myself as I do remember reading that redemption needed the item to be saved.  I have slightly modified the code to use the email address rather than the name due to single quotes being used around the recipients name in olkRcp and objDic.Exist never matching.  I also changed the Date to check for the last 7 days.

The final solution is below.

Thanks for all your help.

Regards
David

'On the next line edit the path to the attachment.  The path must end with a \
Const ATTACHMENT_PATH = "c:\MyFolder"
'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 = "@mycompany.com"
 
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim strExternalAddressees As String
    If Item.Class = olMail Then
        Item.Save
        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 redSes As Object, _
        redMsg As Object, _
        redRcp As Object, _
        strSMTP As String, _
        intPos As Integer
    Set redSes = CreateObject("Redemption.RDOSession")
    redSes.Logon
    redSes.MAPIOBJECT = Application.Session.MAPIOBJECT
    Set redMsg = redSes.GetMessageFromID(olkMsg.EntryID)
    For Each redRcp In redMsg.Recipients
        strSMTP = redRcp.AddressEntry.SMTPAddress
        intPos = InStr(1, LCase(strSMTP), LCase(LOCAL_EMAIL_DOMAIN))
        If intPos = 0 Then
            ExternalAddressee = ExternalAddressee & redRcp.Address & "|"
        End If
    Next
    If Len(ExternalAddressee) > 0 Then ExternalAddressee = Left(ExternalAddressee, Len(ExternalAddressee) - 1)
    Set redSes = Nothing
    Set redMsg = Nothing
    Set redRcp = 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 - 7) & " 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.Address) Then
                    For Each olkAtt In olkItm.Attachments
                        If olkAtt.FileName = ATTACHMENT_NAME Then
                            If objDic.Count > 0 Then
                                objDic.Remove olkRcp.Address
                            End If
                        End If
                    Next
                End If
            Next
        End If
    Next
    If objDic.Count > 0 Then
        NoMessageToday = True
    Else
        NoMessageToday = False
    End If
   
    Set olkItms = Nothing
    Set olkItm = Nothing
    Set olkRcp = Nothing
    Set olkAtt = Nothing
    Set objDic = Nothing
End Function
0
 
LVL 76

Expert Comment

by:David Lee
ID: 38859780
You're welcome, David.  Glad I could help out.
0

Featured Post

Free Tool: Path Explorer

An intuitive utility to help find the CSS path to UI elements on a webpage. These paths are used frequently in a variety of front-end development and QA automation tasks.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

In this step by step procedure, you will come to know the details of creating an Outlook meeting in 2007, 2010, 2013 & 2016.
How to get Spreadsheet Compare 2016 working with the 64 bit version of Office 2016
The view will learn how to download and install SIMTOOLS and FORMLIST into Excel, how to use SIMTOOLS to generate a Monte Carlo simulation of 30 sales calls, and how to calculate the conditional probability based on the results of the Monte Carlo …
The viewer will learn how to use a discrete random variable to simulate the return on an investment over a period of years, create a Monte Carlo simulation using the discrete random variable, and create a graph to represent the possible returns over…

739 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