Solved

Save, Remove, and Comment incoming email attachments

Posted on 2009-03-31
11
641 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
VMware Disaster Recovery and Data Protection

In this expert guide, you’ll learn about the components of a Modern Data Center. You will use cases for the value-added capabilities of Veeam®, including combining backup and replication for VMware disaster recovery and using replication for data center migration.

 

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

Free Tool: Subnet Calculator

The subnet calculator helps you design networks by taking an IP address and network mask and returning information such as network, broadcast address, and host range.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

Question has a verified solution.

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

MS Outlook is a world-class email client application that is mainly used for e-communication globally.  In this article, we will discuss the basic idea about MS Outlook, its advanced features, and types of MS Outlook File formats.
Large Outlook files lead to various unwanted errors and corruption issues. Furthermore, large outlook files can also make Outlook take longer to start-up, search, navigate, and shut-down. So, In this article, i will discuss a method to make your Out…
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 …
This video shows how to remove a single email address from the Outlook 2010 Auto Suggestion memory. NOTE: For Outlook 2016 and 2013 perform the exact same steps. Open a new email: Click the New email button in Outlook. Start typing the address: …

828 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