Solved

Save, Remove, and Comment incoming email attachments

Posted on 2009-03-31
11
643 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
[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
  • 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
Salesforce Has Never Been Easier

Improve and reinforce salesforce training & adoption using WalkMe's digital adoption platform. Start saving on costly employee training by creating fast intuitive Walk-Thrus for Salesforce. Claim your Free Account Now

 

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

How our DevOps Teams Maximize Uptime

Our Dev teams are like yours. They’re continually cranking out code for new features/bugs fixes, testing, deploying, responding to production monitoring events and more. It’s complex. So, we thought you’d like to see what’s working for us. Read the use case whitepaper.

Question has a verified solution.

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

This article lists the top 5 free OST to PST Converter Tools. These tools save a lot of time for users when they want to convert OST to PST after their exchange server is no longer available or some other critical issue with exchange server or impor…
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…
CodeTwo Sync for iCloud (http://www.codetwo.com/sync-for-icloud?sts=6554) automatically synchronizes your Outlook 2016, 2013, 2010 or 2007 folders with iCloud folders available via iCloud Control Panel. This lets you automatically sync them with…

739 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