Here is a macro I wrote (more like assembled
to get all the email
attachments from all emails in the "matthew" folder.
Feel free to modify and use it as you like.
Matthew
Sub FindAttachment()
Dim arrFolders() As String
arrFolders() = Split(strFolderPath, "\")
' Declare variables
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set Matthew = GetFolder("Personal Folders/Matthew")
Set Catalog = Matthew.Folders("Catalog")
I = 0
' Check Inbox for messages and exit of none found
If Catalog.Items.Count = 0 Then
MsgBox "There are no messages in the Current Folder.",
vbInformation, _
"Nothing Found"
Exit Sub
End If
For Each Item In Catalog.Items
Call SaveAttachment(Item)
Next Item
End Sub
Sub SaveAttachment(Item As Outlook.MailItem)
'On Error GoTo GetAttachments_err
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Atmt As Attachment
Dim FileName As String
Dim Folder As String
Dim fName As String
Dim I As Integer
Set ns = GetNamespace("MAPI")
Set Matthew = GetFolder("Personal Folders/Matthew")
Set Catalog = Matthew.Folders("Catalog")
Set CatalogOld = Matthew.Folders("Catalog Old")
I = 0
For Each Atmt In Item.Attachments
fName = Format(Item.CreationTime, "yyyy mm dd") & Right(Atmt.FileName,
4)
' This path must exist!
FileName = "C:\Documents and Settings\Email User\My Documents\Sales
Leads\" & fName
Atmt.SaveAsFile FileName
I = I + 1
Next Atmt
Open "C:\Documents and Settings\Email User\My Documents\Sales
Leads\ToPrint.txt" For Append As #1
Write #1, Folder; fName
Close #1
Item.UnRead = False
Item.Move CatalogOld
' Clear memory
GetAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
' Handle errors
GetAttachments_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume GetAttachments_exit
End Sub
Public Function GetFolder(strFolderPath As String) As MAPIFolder
' folder path needs to be something like
' "Public Folders\All Public Folders\Company\Sales"
Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim colFolders As Outlook.Folders
Dim objFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim I As Long
On Error Resume Next
strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objFolder = objNS.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For I = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(I))
If objFolder Is Nothing Then
Exit For
End If
Next
End If
Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Function
