Solved

Attach file on send in Outlook 2003

Posted on 2013-01-25
7
493 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
Creating Instructional Tutorials  

For Any Use & On Any Platform

Contextual Guidance at the moment of need helps your employees/users adopt software o& achieve even the most complex tasks instantly. Boost knowledge retention, software adoption & employee engagement with easy solution.

 

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

Efficient way to get backups off site to Azure

This user guide provides instructions on how to deploy and configure both a StoneFly Scale Out NAS Enterprise Cloud Drive virtual machine and Veeam Cloud Connect in the Microsoft Azure Cloud.

Question has a verified solution.

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

When you have clients or friends from around the world, it becomes a challenge to arrange a meeting or effectively manage your time. This is where Outlook's capability to show 2 time zones in one calendar comes in handy.
Mailbox Overload?
This tutorial gives a high-level tour of the interface of Marketo (a marketing automation tool to help businesses track and engage prospective customers and drive them to purchase). You will see the main areas including Marketing Activities, Design …
Learn how to create and modify your own paragraph styles in Microsoft Word. This can be helpful when wanting to make consistently referenced styles throughout a document or template.

729 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