Solved

Save, Remove, and Comment incoming email attachments

Posted on 2009-03-31
11
632 Views
Last Modified: 2013-11-29
Hello,

I am trying to implement some code I found another site that has a concept I like. The title of the article is: Automatically Save, Remove, and Comment incoming email attachments
The url is: http://www.vbaexpress.com/kb/getarticle.php?kb_id=953
It is not working for me in Outlook 2003, and I am wondering if anyone here can identify any outdated syntax it contains. I can elaborate further on error messages below as needed.
0
Comment
Question by:expunjulator
  • 5
  • 5
11 Comments
 
LVL 76

Accepted Solution

by:
David Lee earned 250 total points
ID: 24032881
Hi, expunjulator.

That's a lot of code to look through.  How about this routine which does the same thing in a lot less code?
Sub SaveAndLinkAttachment(Item As Outlook.MailItem)

   Dim olkAttachment As Outlook.Attachment, _

        objFSO As Object, _

        strRootFolderPath As String, _

        strMyPath As String, _

        strFilename As String, _

        intCount As Integer
 

    'Change the path on the following line to the folder you want the attachments save in

    strRootFolderPath = "C:\eeTesting\"

    Set objFSO = CreateObject("Scripting.FileSystemObject")

    If Item.Attachments.Count > 0 Then

        If Item.BodyFormat = olFormatHTML Then

            Item.HTMLBody = Item.HTMLBody & "<br><br><b>Saved Attachments</b><br>"

        Else

            Item.Body = Item.Body & vbCrLf & vbCrLf & "Saved Attachments" & vbCrLf

        End If

        For Each olkAttachment In Item.Attachments

            strFilename = olkAttachment.FILENAME

            intCount = 0

            Do While True

                strMyPath = strRootFolderPath & strFilename

                If objFSO.FileExists(strMyPath) Then

                    intCount = intCount + 1

                    strFilename = "Copy (" & intCount & ") of " & olkAttachment.FILENAME

                Else

                    Exit Do

                End If

            Loop

            olkAttachment.SaveAsFile strRootFolderPath & strFilename

            If Item.BodyFormat = olFormatHTML Then

                Item.HTMLBody = Item.HTMLBody & "<a href=""file://" & strMyPath & """>" & olkAttachment.FILENAME & "</a><br>"

            Else

                Item.Body = Item.Body & strMyPath & vbCrLf

            End If

        Next

    End If

    Set objFSO = Nothing

    Set olkAttachment = Nothing

End Sub

Open in new window

0
 

Author Comment

by:expunjulator
ID: 24033079
True! :)
...
I like it! Very clean and clear.

 Would I insert that as a module, and call it from "This Outlook Session"?
In other words, how can I best implement it on incoming mail?
0
 
LVL 76

Expert Comment

by:David Lee
ID: 24033443
Copy the code and paste it into any module.  Personally, I added a module I called Rules for code that works from rules.  Helps me find a subroutine quickly if I know it runs from a rule.  It doesn't have to be in ThisOutlookSession, although you can put it there if you want to.  Once you've added the code create a rule that fires for the messages you want this to work against.  If you want it to work for all messages, then leave the rule's condition blank.  Set the rule's action to "run a script" and choose this script as the one to run.  You should be in business.
0
 

Author Comment

by:expunjulator
ID: 24041667
Thank you, this is great.
I'm not sure why, but the code is not updating the email body, although it will display the modified  Item.Body in a msgbox.
Would it be necessary to delete the attachments from the body before updating? (I would like to delete them).
I would also like to get rid of the security prompts (see attached image).






MOO.jpg
0
 

Author Comment

by:expunjulator
ID: 24043425
I added Item.Save after line 34 and now it writes the body text back to the message file.
I also did a backwards counting loop and used Item.Attachments.Item(i).Delete to remove the attachments.
Still wishing to remove the security prompts, if possible.
0
Do You Know the 4 Main Threat Actor Types?

Do you know the main threat actor types? Most attackers fall into one of four categories, each with their own favored tactics, techniques, and procedures.

 
LVL 76

Expert Comment

by:David Lee
ID: 24044564
Arrggghhhh.  Sorry about that.  Glad you got it fixed.

The security prompt is built into Outlook and cannot be turned off.  There are ways around it though.

1.  Sign the code.  Here's a link to instructions on doing that: http://www.howto-outlook.com/howto/selfcert.htm
2.  Use ClickYes (http://www.contextmagic.com/express-clickyes/), a small utility that'll click the Yes button for you.  It creates a security hole though, since a virus could start sending messages and ClickYes would click the Yes button for it too.  
3.  Use Redemption (http://www.dimastr.com), a COM library that enables code to safely bypass Outlook security.

0
 

Author Comment

by:expunjulator
ID: 24049568
Thank you again!  I used item number one from your last comment - I signed the code.
I guess because it takes an argument, my module doesn't show up in the list of Macros, but you can just click on Tools, Digital Certificate in the VBA editor, as I'm sure you know.
It was breaking on embedded attachments, so I added a step to check for them. Also added error checking and a few comments.
Am attaching the code below.
Sub SaveAndLinkAttachment(Item As Outlook.MailItem)

   Dim olkAttachment As Outlook.Attachment, _

        objFSO As Object, _

        strRootFolderPath As String, _

        strMyPath As String, _

        strFilename As String, _

        intCount As Integer, _

        i As Integer, _

        AttachCount As Integer

        

    

    On Error GoTo SaveAndLinkAttachment_err

    

    'Change the path on the following line to the folder you want the attachments save in

    strRootFolderPath = "C:\attachments\"

    Set objFSO = CreateObject("Scripting.FileSystemObject")

    If Item.Attachments.Count > 0 Then

    

        AttachCount = Item.Attachments.Count

               

        'You can turn on the message box below if you want notification

        'MsgBox ("you've got " & AttachCount & " attachments")

        If Item.BodyFormat = olFormatHTML Then

            'MsgBox ("html")

            Item.HTMLBody = Item.HTMLBody & "<br><br><b>Attachments have been removed and saved to the following location and name(s)</b><br>"

        Else

            'MsgBox ("plain text")

            Item.Body = Item.Body & vbCrLf & vbCrLf & "Attachments have been removed and saved to the following location and name(s)" & vbCrLf

        End If

        

        For Each olkAttachment In Item.Attachments

            

            'check attachment type and skip if "embedded" (type 6) - these cannot be deleted

            If olkAttachment.Type <> 6 Then

                

                

                strFilename = olkAttachment.FileName

                

                'check if file already exists with that name, and if so, give new name

                intCount = 0

                Do While True

                    strMyPath = strRootFolderPath & strFilename

                    If objFSO.fileExists(strMyPath) Then

                        intCount = intCount + 1

                        strFilename = "Copy (" & intCount & ") of " & olkAttachment.FileName

                    Else

                        Exit Do

                    End If

                Loop

                

                'save attachment

                olkAttachment.SaveAsFile strRootFolderPath & strFilename
 

                

                ' update message body with file name and path

                If Item.BodyFormat = olFormatHTML Then

                    Item.HTMLBody = Item.HTMLBody & "<a href=""file://" & strMyPath & """>" & olkAttachment.FileName & "</a><br>"

                Else

                    Item.Body = Item.Body & strMyPath & vbCrLf

                    'if you don't save here, it won't write the body back to the file

                    Item.Save

                  

                End If

                

            End If
 

        Next

        

            'Count backwards and delete the attachments

            For i = AttachCount To 1 Step -1

                ' Delete the attachment.

                Item.Attachments.Item(i).Delete

            Next i

       

        

    End If

    ' Must save here too, or objects are not deleted

     Item.Save

     

SaveAndLinkAttachment_Exit:

    Set objFSO = Nothing

    Set olkAttachment = Nothing

    Exit Sub

    

SaveAndLinkAttachment_err:

    MsgBox "An unexpected error has occurred." _

      & vbCrLf & "Please note and report the following information." _

      & vbCrLf & "Macro Name: GetAttachments" _

      & vbCrLf & "Error Number: " & Err.number _

      & vbCrLf & "Error Description: " & Err.Description _

      , vbCritical, "Error!"

   Resume SaveAndLinkAttachment_Exit

    

    Set objFSO = Nothing

    Set olkAttachment = Nothing

    

End Sub

Open in new window

0
 
LVL 76

Expert Comment

by:David Lee
ID: 24049610
You're welcome.  

"I guess because it takes an argument, my module doesn't show up in the list of Macros"
Correct.
0
 

Author Closing Comment

by:expunjulator
ID: 31564976
Thanks, BlueDevilFan, you rock! :)
0
 
LVL 76

Expert Comment

by:David Lee
ID: 24049932
I appreciate that.  Glad I could help out.
0
 

Expert Comment

by:ger2111
ID: 36294191
Hi,
Can I modify this code so that only attachments sent in to a specified internal address are saved?
eg mails to automail@mycompany.com with attachments have the attachments automatically saved to c:\attachment_store
Thanks,
Ger
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

Granting full access permission allows users to access mailboxes present in their database. By giving full access permission one can open and read the content of any mailbox but cannot send emails from that mailbox.
Outlook Free & Paid Tools
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
This Experts Exchange video Micro Tutorial shows how to tell Microsoft Office that a word is NOT spelled correctly. Microsoft Office has a built-in, main dictionary that is shared by Office apps, including Excel, Outlook, PowerPoint, and Word. When …

760 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

19 Experts available now in Live!

Get 1:1 Help Now