Want to win a PS4? Go Premium and enter to win our High-Tech Treats giveaway. Enter to Win

x
?
Solved

Attach file on send in Outlook 2003

Posted on 2013-01-25
7
Medium Priority
?
502 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
Learn Veeam advantages over legacy backup

Every day, more and more legacy backup customers switch to Veeam. Technologies designed for the client-server era cannot restore any IT service running in the hybrid cloud within seconds. Learn top Veeam advantages over legacy backup and get Veeam for the price of your renewal

 

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

Ask an Anonymous Question!

Don't feel intimidated by what you don't know. Ask your question anonymously. It's easy! Learn more and upgrade.

Question has a verified solution.

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

This article will help to fix the below errors for MS Exchange Server 2013 I. Certificate error "name on the security certificate is invalid or does not match the name of the site" II. Out of Office not working III. Make Internal URLs and Externa…
This article describes how to use a set of graphical playing cards to create a Draw Poker game in Excel or VB6.
Many of my clients call in with monstrous Gmail overloading issues with Outlook. A quick tip is to turn off the All Mail and Important folders from synching. Here is a quick video I made to show you how to turn off these and other folders in Gmail s…
This is my first video review of Microsoft Bookings, I will be doing a part two with a bit more information, but wanted to get this out to you folks.

610 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