Solved

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

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

PeopleSoft Has Never Been Easier

PeopleSoft Adoption Made Smooth & Simple!

On-The-Job Training Is made Intuitive & Easy With WalkMe's On-Screen Guidance Tool.  Claim Your Free WalkMe Account Now

Question has a verified solution.

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

This article describes how to import an Outlook PST file to Office 365 using a third party product to avoid Microsoft's Azure command line tool, saving you time.
Unified and professional email signatures help maintain a consistent company brand image to the outside world. This article shows how to create an email signature in Exchange Server 2010 using a transport rule and how to overcome native limitations …
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…
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: …

728 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