Solved

download all attachment from mailbox

Posted on 2013-12-11
5
356 Views
Last Modified: 2014-01-08
hello all,

i need a script that could scan all of my mailbox \ outlook and download all attachment to specific folder,

Asaf
0
Comment
Question by:Robert-Prodigy
  • 4
5 Comments
 
LVL 28

Assisted Solution

by:omgang
omgang earned 500 total points
ID: 39712201
@Robert-Prodigy
I recently was involved in a deployment of MS Dynamics CRM.  One of the requirements was to copy email messages and their attachments from Exchange/Outlook into Dynamics CRM templates for bulk upload.  I developed routines in Outlook VBA to automate this task and I believe they'll do what you're asking.  Below is the entire code module; not all of it will be necessary for your purpose.  I've removed a bunch of the coding and commented other.  I believe what I have below should work for you.

Select the appropriate folder you wish to begin processing with, e.g. Inbox, and then run the ExportMessageDataForCRM sub procedure.  You won't actually need the two references indicated as you won't be writing to FileSystem object nor automating Excel.

I suggest you first copy 100 or so messages to an Outlook PST file and test on that before running on your primary Exchange mailbox or PST file.  My notes about the issue with Date/Time stamp being rewritten had to do with copying/moving messages and not the saving of attachments.  Still, I'd hate for the routine mess something up so better safe than sorry.

Let me know if you have questions.
OM Gang



Option Explicit

'OM Gang - 2013
'
'requires reference to Microsoft Scripting Runtime library
'requires reference to Microsoft Excel Object library
'
'Purpose:  populate template files with email message data for upload/import into
'   Microsoft Dynamics CRM solution.
'
' !!!   Note on Sub Procedure MoveMsgItem   !!!
'       I've noticed the MailItem.Move method rewriting the Received date/time stamp for the item to the current
'       date/time.  Research on the web indicates this may be related to Outlook not being able to actually move
'       the item so it creates a copy and deletes the original; the copy is created with a current date/time stamp.
'       I've only seen this issue when processing folders in an Exchange mailbox but not when processing folders
'       in an Outlook PST file.  Recommend moving all messages into a PST file for processing to protect against
'       destruction of Received date/time for origninal messages. -- OM Gang
       

Public olNS As Outlook.NameSpace
Public olSubFlds As Folders
Public olSFld As Folder
Public olItem As Object

Public fso As New FileSystemObject
Public fsFile As TextStream
Public objXL As New Excel.Application
Public objXMLTemp As Excel.Workbook
Public intRowNum As Integer, intCounter As Integer, intFileNum As Integer


'///////   change the values of these constants for your environment    ////////////

'       destination directory for completed template files and attachments
Public Const TEMPLATE_DESTINATION_PATH As String = "c:\test2\CRMMsgs\"
Public Const ATTACHMENT_FLDR_NAME As String = "Attachments"


Sub ExportMessageDataForCRM()
'entry point - launch process from here
On Error GoTo Err_Handler

    Dim olExplor As Explorer
    Dim olFld As Folder
   
    Set olNS = Application.GetNamespace("MAPI")
    Set olExplor = Application.ActiveExplorer
   
        'get currently selected folder object (currently selected in Outlook gui) and assign
    Set olFld = olExplor.CurrentFolder
   
        'initialize unique ID counter for email messages
    intCounter = UNIQUEID_SEED
        'initialize file number counter for multiple email template files
    intFileNum = 0
   
        'call sub to create initial output template file
    'Call CopyTemplateFile("email")
   
        'call sub to recursively enumerate folder structure
    Call RecurseFolder(olFld)
   
        'close text file if it exists
    If Not (fsFile Is Nothing) Then fsFile.Close
   
        'close and save Excel file
    'objXMLTemp.Close (True)
        'exit the Excel application
    'objXL.Quit

Exit_ExportMessageDataForCRM:
        'destroy object variables
    Set olItem = Nothing
    Set olSFld = Nothing
    Set olSubFlds = Nothing
    Set objXMLTemp = Nothing
    Set objXL = Nothing
    Set fsFile = Nothing
    Set olFld = Nothing
    Set olExplor = Nothing
    Set fso = Nothing
    Set olNS = Nothing
    Exit Sub

Err_Handler:
    MsgBox Err.Number & " (" & Err.Description & ") in procedure ExportMessageDataForCRM"
    Resume Exit_ExportMessageDataForCRM

End Sub


Sub RecurseFolder(olFld As Folder)
'recursively enumerates folder structure and processes message object in each folder
'Outlook folder object to begin with is passed in as argument
On Error GoTo Err_RecurseFolder
   
        'assign Outlook mail item type constant
    Const MAILITEM As String = "MailItem"
   
        'enumerate items in the current folder
    For Each olItem In olFld.Items
            'we only want to process mail item objects (as opposed to calendar apts, etc.) so we'll test before proceeding
        If TypeName(olItem) = MAILITEM Then
                'we don't want to process messages sent from employee mailboxes so we'll check the sender adress value
            'If InStr(olItem.SenderEmailAddress, STEMP_ADDR_MATCH) Then
                    'call sub to move message object to special folder
            '    Call MoveMsgItem(olItem, olFld)
            '    GoTo NextRecord
            'End If
               
                'this counter is used to assign a unique ID for the message.  we'll increment it before moving on
            intCounter = intCounter + 1
           
                'check message item to see if it has attachments
            If olItem.Attachments.Count > 0 Then
                    'call routine to process attachments
                Call SaveMsgAttachments(olItem, intCounter)
            End If
               
                'this counter is used to specify the row number in the template we're processing.  we'll increment it
                'since we're done processing the current message
            intRowNum = intRowNum + 1

        End If
NextRecord:
    Next

        'set a reference to the subfolders collection of the current folder so we can enumerate the subfolders
    Set olSubFlds = olFld.Folders
    For Each olSFld In olSubFlds
            'we don't want to process subfolers with the specified name as these subfolders are being created by
            'us to hold messages originating from employee mailboxes
        'If olSFld.Name <> STEMP_FLDR_NAME Then
                'call this same routine so we can recursively enumerate the folder structure
            Call RecurseFolder(olSFld)
        'End If
    Next
   
Exit_RecurseFolder:
    Exit Sub

Err_RecurseFolder:
    Debug.Print olFld.FolderPath & "; " & olItem.Subject
    MsgBox Err.Number & " (" & Err.Description & ") in procedure RecurseFolder"
    Resume Exit_RecurseFolder

End Sub


Public Sub SaveMsgAttachments(olItem As Outlook.MAILITEM, varID As Variant)
'process attachments for mail item passed as argument
'UniqueID for the email message record in the email template is passed as second argument
On Error GoTo Err_SaveMsgAttachments

    Dim olAttachment As Outlook.Attachment
    Dim StrDocName As String, strFileName As String, strPath As String
   
        'check to see if a notes template file has already been instantiated
    'If fsFile Is Nothing Then
            'call sub to copy a blank notes template from the source directory and instantiate it
            'so we can populate it
    '    Call CopyTemplateFile("notes")
    'End If
   
        'specify path to folder where attachments are to be saved
    strPath = TEMPLATE_DESTINATION_PATH & ATTACHMENT_FLDR_NAME & "\"
   
        'check to see if destination directory exists
    If Not (fso.FolderExists(strPath)) Then
            'create the directory if it doesn't already exist
        fso.CreateFolder (strPath)
    End If
   
        'enumerate the attachments for the mail item
    For Each olAttachment In olItem.Attachments
        strFileName = olAttachment.FileName                 'original file name for attachment
        StrDocName = varID & "_" & olAttachment.FileName    'save-as file name for  attachment; UniqueID for email msg prepended to original file name
            'we need to trap error when file can't be saved to the file system
            'not sure what is causing this but the mail item doesn't actually appear to have an attachment
        On Error Resume Next
        olAttachment.SaveAsFile (strPath & StrDocName)      'save the attachment to the specified folder
        If Err.Number = -2147467259 Then GoTo Ignore_Attach 'trap error and jump to next attachment
       
        On Error GoTo Err_SaveMsgAttachments
            'write record to notes template file
        'fsFile.WriteLine "Attachment For:  " & Chr(34) & olItem.Subject & Chr(34) & "," & "," & varID & "," & strFileName & "," & StrDocName
Ignore_Attach:
    Next

Exit_SaveMsgAttachments:
        'destroy object variable
    Set olAttachment = Nothing
    Exit Sub

Err_SaveMsgAttachments:
    Debug.Print olItem.SenderEmailAddress & " -- " & olItem.Subject & " ;; " & varID
    MsgBox Err.Number & " (" & Err.Description & ") in procedure SaveMsgAttachments"
    Resume Exit_SaveMsgAttachments

End Sub
0
 
LVL 28

Expert Comment

by:omgang
ID: 39712207
Looks like I removed a Constant declaration that you'll actually need.  Add this back in near the other Constant declarations

'       initial seed value for UniqueID for email records; this value will be incremented by 1 prior to first assignment
Public Const UNIQUEID_SEED As Long = 100

OM Gang
0
 
LVL 28

Accepted Solution

by:
omgang earned 500 total points
ID: 39712293
I've cleaned it up and tested on my Exchange mailbox.  This does what you ask; it enumerates the email messages in your Outlook (beginning at the folder you have selected) and saves the attachments for each in the folder specified.
OM Gang

Option Explicit

Public olNS As Outlook.NameSpace
Public olSubFlds As Folders
Public olSFld As Folder
Public olItem As Object

Public intCounter As Integer


'///////   change the values of these constants for your environment    ////////////

'       destination directory for completed template files and attachments
Public Const TEMPLATE_DESTINATION_PATH As String = "c:\test2\CRMMsgs\"
Public Const ATTACHMENT_FLDR_NAME As String = "Attachments"


'       initial seed value for UniqueID for email records; this value will be incremented by 1 prior to first assignment
Public Const UNIQUEID_SEED As Long = 100


Sub ExportMessageDataForCRM()
'entry point - launch process from here
On Error GoTo Err_Handler

    Dim olExplor As Explorer
    Dim olFld As Folder
   
    Set olNS = Application.GetNamespace("MAPI")
    Set olExplor = Application.ActiveExplorer
   
        'get currently selected folder object (currently selected in Outlook gui) and assign
    Set olFld = olExplor.CurrentFolder
   
        'initialize unique ID counter for email messages
    intCounter = UNIQUEID_SEED
   
        'call sub to recursively enumerate folder structure
    Call RecurseFolder(olFld)

Exit_ExportMessageDataForCRM:
        'destroy object variables
    Set olItem = Nothing
    Set olSFld = Nothing
    Set olSubFlds = Nothing
    Set objXMLTemp = Nothing
    Set objXL = Nothing
    Set fsFile = Nothing
    Set olFld = Nothing
    Set olExplor = Nothing
    Set fso = Nothing
    Set olNS = Nothing
    Exit Sub

Err_Handler:
    MsgBox Err.Number & " (" & Err.Description & ") in procedure ExportMessageDataForCRM"
    Resume Exit_ExportMessageDataForCRM

End Sub


Sub RecurseFolder(olFld As Folder)
'recursively enumerates folder structure and processes message object in each folder
'Outlook folder object to begin with is passed in as argument
On Error GoTo Err_RecurseFolder
   
        'assign Outlook mail item type constant
    Const MAILITEM As String = "MailItem"
   
        'enumerate items in the current folder
    For Each olItem In olFld.Items
            'we only want to process mail item objects (as opposed to calendar apts, etc.) so we'll test before proceeding
        If TypeName(olItem) = MAILITEM Then
               
                'this counter is used to assign a unique ID for the message.  we'll increment it before moving on
            intCounter = intCounter + 1
           
                'check message item to see if it has attachments
            If olItem.Attachments.Count > 0 Then
                    'call routine to process attachments
                Call SaveMsgAttachments(olItem, intCounter)
            End If
           
        End If
NextRecord:
    Next
        'set a reference to the subfolders collection of the current folder so we can enumerate the subfolders
    Set olSubFlds = olFld.Folders
    For Each olSFld In olSubFlds
            'call this same routine so we can recursively enumerate the folder structure
        Call RecurseFolder(olSFld)

    Next
   
Exit_RecurseFolder:
    Exit Sub

Err_RecurseFolder:
    Debug.Print olFld.FolderPath & "; " & olItem.Subject
    MsgBox Err.Number & " (" & Err.Description & ") in procedure RecurseFolder"
    Resume Exit_RecurseFolder

End Sub


Public Sub SaveMsgAttachments(olItem As Outlook.MAILITEM, varID As Variant)
'process attachments for mail item passed as argument
'UniqueID for the email message record in the email template is passed as second argument
On Error GoTo Err_SaveMsgAttachments

    Dim olAttachment As Outlook.Attachment
    Dim StrDocName As String, strFileName As String, strPath As String
   
        'specify path to folder where attachments are to be saved
    strPath = TEMPLATE_DESTINATION_PATH & ATTACHMENT_FLDR_NAME & "\"
   
        'check to see if destination directory exists
    If Not (fso.FolderExists(strPath)) Then
            'create the directory if it doesn't already exist
        fso.CreateFolder (strPath)
    End If
   
        'enumerate the attachments for the mail item
    For Each olAttachment In olItem.Attachments
        strFileName = olAttachment.FileName                 'original file name for attachment
        StrDocName = varID & "_" & olAttachment.FileName    'save-as file name for  attachment; UniqueID for email msg prepended to original file name
            'we need to trap error when file can't be saved to the file system
            'not sure what is causing this but the mail item doesn't actually appear to have an attachment
        On Error Resume Next
        olAttachment.SaveAsFile (strPath & StrDocName)      'save the attachment to the specified folder
        If Err.Number = -2147467259 Then GoTo Ignore_Attach 'trap error and jump to next attachment
       
        On Error GoTo Err_SaveMsgAttachments

Ignore_Attach:
    Next

Exit_SaveMsgAttachments:
        'destroy object variable
    Set olAttachment = Nothing
    Exit Sub

Err_SaveMsgAttachments:
    Debug.Print olItem.SenderEmailAddress & " -- " & olItem.Subject & " ;; " & varID
    MsgBox Err.Number & " (" & Err.Description & ") in procedure SaveMsgAttachments"
    Resume Exit_SaveMsgAttachments

End Sub
0
 

Author Comment

by:Robert-Prodigy
ID: 39720301
tanks a lot
0
 
LVL 28

Expert Comment

by:omgang
ID: 39765264
@Robert-Prodigy, thanks for accepting my solution but I'm curious as to the B grade?
OM Gang
0

Featured Post

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

Suggested Solutions

Title # Comments Views Activity
SBS 20011 to Office 365 7 57
Voting in Outlook 2016 1 38
room finder - outlook 2016 2 22
outlook 2013 8 30
Use these top 10 tips to master the art of email signature design. Create an email signature design that will easily wow recipients, promote your brand and highlight your professionalism.
Follow this checklist to learn more about the 15 things you should never include in an email signature from personal quotes, animated gifs and out-of-date marketing content.
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 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: …

747 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

14 Experts available now in Live!

Get 1:1 Help Now