Attach file on send in Outlook 2003

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.
djhardistyAsked:
Who is Participating?
 
David LeeConnect With a Mentor Commented:
David,

Try adding

Item.Save

Open in new window


immediately after line #10.
0
 
David LeeCommented:
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
 
djhardistyAuthor Commented:
HI David

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

Regards
David
0
Cloud Class® Course: CompTIA Healthcare IT Tech

This course will help prep you to earn the CompTIA Healthcare IT Technician certification showing that you have the knowledge and skills needed to succeed in installing, managing, and troubleshooting IT systems in medical and clinical settings.

 
David LeeCommented:
No worries, David.
0
 
djhardistyAuthor Commented:
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
 
djhardistyAuthor Commented:
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
 
David LeeCommented:
You're welcome, David.  Glad I could help out.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.