?
Solved

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

Posted on 2010-08-30
6
Medium Priority
?
940 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
[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
  • 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 2000 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

Office 365 Training for Admins - 7 Day Trial

Learn how to provision tenants, synchronize on-premise Active Directory, implement Single Sign-On, customize Office deployment, and protect your organization with eDiscovery and DLP policies.  Only from Platform Scholar.

Question has a verified solution.

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

This article describes how to use a set of graphical playing cards to create a Draw Poker game in Excel or VB6.
New style of hardware planning for Microsoft Exchange server.
Polish reports in Access so they look terrific. Take yourself to another level. Equations, Back Color, Alternate Back Color. Write easy VBA Code. Tighten space to use less pages. Launch report from a menu, considering criteria only when it is filled…
The Email Laundry PDF encryption service allows companies to send confidential encrypted  emails to anybody. The PDF document can also contain attachments that are embedded in the encrypted PDF. The password is randomly generated by The Email Laundr…
Suggested Courses

743 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