Solved

Attach file on send in Outlook 2003

Posted on 2013-01-25
7
471 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
  • 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
Top 6 Sources for Identifying Threat Actor TTPs

Understanding your enemy is essential. These six sources will help you identify the most popular threat actor tactics, techniques, and procedures (TTPs).

 

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

What Is Threat Intelligence?

Threat intelligence is often discussed, but rarely understood. Starting with a precise definition, along with clear business goals, is essential.

Join & Write a Comment

Set OWA language and time zone in Exchange for individuals, all users or per database.
Resolve Outlook connectivity issues after moving mailbox to new Exchange 2016 server
This video walks the viewer through the process of creating envelopes and labels, with multiple names and addresses. Navigate to the “Start Mail Merge” button in the Mailings tab: Follow the step-by-step process until asked to find the address doc…
Access reports are powerful and flexible. Learn how to create a query and then a grouped report using the wizard. Modify the report design after the wizard is done to make it look better. There will be another video to explain how to put the final p…

744 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

13 Experts available now in Live!

Get 1:1 Help Now