• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 948
  • Last Modified:

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

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
awesomejohn19
Asked:
awesomejohn19
  • 2
1 Solution
 
Chris BottomleyCommented:
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
 
JohnBPriceCommented:
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
 
awesomejohn19Author Commented:
I guess this is as close as we get
0
 
Chris BottomleyCommented:
>>> 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
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now