Solved

VBA code to check Outlook folders and save attachments to file folders on the drive

Posted on 2010-08-30
6
932 Views
Last Modified: 2012-05-10
I need a vba code, which goes and checks outlook folders (not all the folders but the folders that are specified by the user- some kind of interface might be needed like forms), if there are new files in the folder, and then checks if any of them has an attachment, and then saves it to folder on the drive (same name as the outlook folder - and if there is no folder that is named the same name as the outlook folder it creates one).
0
Comment
Question by:awesomejohn19
  • 2
6 Comments
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33584056
awesomejohn19,

What you ask sounds plausible so to try and scope it can I ask:

1. Select an outlook folder
2. Check for a dos path of the same name (as the outlook folder)... presumably you have a root folder in mind for them.
3. Checks for any attachments in the mails in the outlook folder.
4. Saves them to the dos folder.
5. Deletes the orig attachment - or not?

Chris
0
 
LVL 16

Accepted Solution

by:
JohnBPrice earned 500 total points
ID: 33585770
Here is some code that does a similar thing.  It looks for an outlook folder, scans the emails for old ones, and moves them to a different folder.  This is VB6, but nearly the same as VBA.

Outlook must be running for this to work.

The form has the from and to folder names, the date to check.  The QuitEarly checkbox allows quitting if your folder is sorted by date (once you exceed the date, no point in checking anymore)

Note that you can access the attachments from the msg object, though this code doesn't.

You can access the drive info (to create directory), using the FileSystemObject, not used here.

Option Explicit
Dim gAbort As Boolean
    Dim o As New Outlook.Application
    Dim n As Outlook.NameSpace
    Dim FromFolder As Outlook.MAPIFolder
    Dim ToFolder As Outlook.MAPIFolder
    Dim msg As Outlook.MailItem
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Sub cmdAbort_Click()
    gAbort = True
    cmdAbort.Caption = "ABORTING!!"
    cmdAbort.Refresh
    Me.Refresh
    DoEvents
End Sub

Sub FindFolders()
    lblStatus.Caption = "Finding FROM folder..."
    Me.Refresh
    DoEvents
    Set n = o.GetNamespace("MAPI")
    Set FromFolder = FindFolder(n.Folders, txtFrom.Text)
    If FromFolder Is Nothing Then
        MsgBox "can't find folder " & txtFrom.Text
        Exit Sub
    Else
        lblFromItems.Caption = FromFolder.Items.Count & " items."
    End If
    lblStatus.Caption = "Finding TO folder..."
    Me.Refresh
    DoEvents
    Set ToFolder = FindFolder(n.Folders, txtTo.Text)
    If ToFolder Is Nothing Then
        MsgBox "can't find folder " & txtTo.Text
        Exit Sub
    Else
        lblToItems.Caption = ToFolder.Items.Count & " items."
    End If
    lblStatus.Caption = ""
    Me.Refresh
    DoEvents
    
End Sub

Private Sub cmdCheck_Click()
    Screen.MousePointer = vbHourglass
    FindFolders
    Screen.MousePointer = vbDefault
    If Not FromFolder Is Nothing And Not ToFolder Is Nothing Then
        
        MsgBox "Folders found"
    End If
    
End Sub

Private Sub cmdMove_Click()
    Screen.MousePointer = vbArrowHourglass

    FindFolders
    Dim i As Long
    i = 0
    'For Each msg In FromFolder.Items
        'i = i + 1
    For i = FromFolder.Items.Count To 1 Step -1
        If gAbort Then GoTo QuitNow
        Set msg = FromFolder.Items(i)
        lblStatus.Caption = "Looking for messages: " & i
        Me.Refresh
        DoEvents
        If msg.ReceivedTime < CDate(txtDate.Text & " 11:59:59 PM") Then
            msg.Move ToFolder
            lblFromItems.Caption = FromFolder.Items.Count & " items."
            lblToItems.Caption = ToFolder.Items.Count & " items."
            Me.Refresh
            DoEvents
        Else
            If chkQuit.Value = vbChecked Then
                Exit For
            End If
        End If
        If chkPlayNice.Value = vbChecked Then
            Sleep 100
            DoEvents
        End If
        
        DoEvents
    Next
QuitNow:
    MsgBox "Done"
    Screen.MousePointer = vbDefault
End Sub

Private Sub Form_Load()
    lblStatus.Caption = ""
    Me.Refresh
    DoEvents

End Sub

Function FindFolder(TopFolder As Outlook.Folders, TargetPath As String) As Outlook.MAPIFolder
    Dim TempFolder As Outlook.MAPIFolder
    Dim TempFolder2 As Outlook.MAPIFolder
    For Each TempFolder In TopFolder
        If TempFolder.FolderPath = TargetPath Then
            Set FindFolder = TempFolder
            Exit Function
        Else 'walk through this folder too
            Set TempFolder2 = FindFolder(TempFolder.Folders, TargetPath)
            If Not TempFolder2 Is Nothing Then
                Set FindFolder = TempFolder2
                Exit Function
            End If
        End If
    Next
    
End Function

Open in new window

0
 

Author Closing Comment

by:awesomejohn19
ID: 33715839
I guess this is as close as we get
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33715879
>>> I guess this is as close as we get

It is if you don't respond to requests for clarification ;o) or ask for improvements on something as supplied.

Chris
0

Featured Post

Efficient way to get backups off site to Azure

This user guide provides instructions on how to deploy and configure both a StoneFly Scale Out NAS Enterprise Cloud Drive virtual machine and Veeam Cloud Connect in the Microsoft Azure Cloud.

Question has a verified solution.

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

Suggested Solutions

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…
In this step by step procedure, you will come to know the details of creating an Outlook meeting in 2007, 2010, 2013 & 2016.
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…
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…

770 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