Solved

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

Posted on 2010-08-30
6
927 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

What Security Threats Are You Missing?

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

Join & Write a Comment

We are happy to announce a brand new addition to our line of acclaimed email signature management products – CodeTwo Email Signatures for Office 365.
Are you using email marketing software? If not, you're missing out on effortless marketing and the reaching of desired conversion rates through email marketing software.
The viewer will learn how to use the =DISCRINV command to create a discrete random variable, use this command to model a set of probabilities and outcomes in a Monte Carlo simulation, and learn how to find the standard deviation of a set of probabil…
This Micro Tutorial will demonstrate the easy use of Gmail embedding images in your email so the recipient of your email can view them in context.

746 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

11 Experts available now in Live!

Get 1:1 Help Now