HOW-TO: Loop Folder, Save All Attchmts in Every Msg As

  • Thread starter Thread starter Guest
  • Start date Start date
G

Guest

I receive >500 emails every day with heavy pdf/ppt attachments from
inter-bank counterparties. I find Outlook Rules to be partly useful. I want
to loop through all emails in an Outlook folder, and Save All attachments for
each email on my disk. Would someone suggest how I might write the macro.

Folder = "MERRILL"
Do While ( Email exists in Outlook Folder named "MERRILL" )
Open Email
Save All Attachments into D:\Mails\MERRILL\
Loop 'Next email in "MERRILL"





TIA!

Regards,
BR
 
Hi Barath,

this could do your job:

1) LoopMailFolderByFolderPath: Replace the parameter in GetFolder
through the full path to your Folder "Merrill"!

2) SaveAttachments: Replace the path in sPath through an *existing" path
you want to!


'<DieseOutlookSitzung>
Public Sub LoopMailFolderByFolderPath()
On Error GoTo ERR_HANDLER
Dim oFld As Outlook.MAPIFolder
Dim obj As Object

Set oFld = GetFolder("persönliche ordner\posteingang")
If Not oFld Is Nothing Then
For Each obj In oFld.Items
If TypeOf obj Is Outlook.MailItem Then
SaveAttachments obj
End If
Next
End If
Exit Sub
ERR_HANDLER:
MsgBox Err.Description, vbExclamation
End Sub

Public Function GetFolder(strFolderPath As String) As Outlook.MAPIFolder
'
' Author: Sue Mosher
'
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 objNS = Application.Session
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
End Function

Public Sub SaveAttachments(ByRef olMail As Outlook.MailItem)
On Error Resume Next
Dim olAtt As Outlook.Attachment
Dim sPath As String
Dim sName As String

sPath = "c:\xyz\"
sPath = sPath & Format(olMail.ReceivedTime, "yyyymmdd_hhnnss_",
vbMonday, vbFirstJan1)

For Each olAtt In olMail.Attachments
sName = olAtt.FileName
ReplaceCharsForFileName sName, "_"
olAtt.SaveAsFile sPath & sName
Next
End Sub

Private Sub ReplaceCharsForFileName(ByRef sName As String, sChr As
String)
sName = Replace(sName, "/", sChr)
sName = Replace(sName, "\", sChr)
sName = Replace(sName, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "<", sChr)
sName = Replace(sName, ">", sChr)
sName = Replace(sName, "|", sChr)
End Sub
'</DieseOutlookSitzung>
 
Danke! It works like magic :-)



Michael Bauer said:
Hi Barath,

this could do your job:

1) LoopMailFolderByFolderPath: Replace the parameter in GetFolder
through the full path to your Folder "Merrill"!

2) SaveAttachments: Replace the path in sPath through an *existing" path
you want to!


'<DieseOutlookSitzung>
Public Sub LoopMailFolderByFolderPath()
On Error GoTo ERR_HANDLER
Dim oFld As Outlook.MAPIFolder
Dim obj As Object

Set oFld = GetFolder("persönliche ordner\posteingang")
If Not oFld Is Nothing Then
For Each obj In oFld.Items
If TypeOf obj Is Outlook.MailItem Then
SaveAttachments obj
End If
Next
End If
Exit Sub
ERR_HANDLER:
MsgBox Err.Description, vbExclamation
End Sub

Public Function GetFolder(strFolderPath As String) As Outlook.MAPIFolder
'
' Author: Sue Mosher
'
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 objNS = Application.Session
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
End Function

Public Sub SaveAttachments(ByRef olMail As Outlook.MailItem)
On Error Resume Next
Dim olAtt As Outlook.Attachment
Dim sPath As String
Dim sName As String

sPath = "c:\xyz\"
sPath = sPath & Format(olMail.ReceivedTime, "yyyymmdd_hhnnss_",
vbMonday, vbFirstJan1)

For Each olAtt In olMail.Attachments
sName = olAtt.FileName
ReplaceCharsForFileName sName, "_"
olAtt.SaveAsFile sPath & sName
Next
End Sub

Private Sub ReplaceCharsForFileName(ByRef sName As String, sChr As
String)
sName = Replace(sName, "/", sChr)
sName = Replace(sName, "\", sChr)
sName = Replace(sName, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "<", sChr)
sName = Replace(sName, ">", sChr)
sName = Replace(sName, "|", sChr)
End Sub
'</DieseOutlookSitzung>
Click to expand...
 
Hi,

With regards to the code below would it be possible to use this on a shared
mailbox?

Thanks

Nick
 
Back
Top