Saving attachments from Outlook

[dhighto]

Hey guys,

I have a code I'm using to save attachments, and it works, but I need the code to only save attachments from new/unread emails. Can you recommender what I need to change? Thanks!


Option Explicit

'***********************************************************************
'* Code based on sample code from Martin Green and adapted to my needs *
'***********************************************************************
Public Sub ShowMessage(Item As Outlook.MailItem)
End Sub
Sub GetAttachments()

On Error Resume Next
'create the folder if it doesnt exists:
Dim fso, ttxtfile, txtfile, WheretosaveFolder
Dim objFolders As Object
Set objFolders = CreateObject("WScript.Shell").SpecialFolders

'MsgBox objFolders("mydocuments")
ttxtfile = objFolders("mydocuments")

Set fso = CreateObject("Scripting.FileSystemObject")
Set txtfile = fso.CreateFolder(ttxtfile & "\OUTLOOK ATTACHMENTS")
Set fso = Nothing

WheretosaveFolder = ttxtfile & "\OUTLOOK ATTACHMENTS"

On Error GoTo GetAttachments_err
' Declare variables
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FILENAME As String
Dim i As Integer
Dim receivedtime As Date

Set ns = GetNamespace("MAPI")
'Set Inbox = ns.GetDefaultFolder(olFolderInbox)
' added the option to select whic folder to export
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("DAILY")

'to handle if the use cancalled folder selection
If SubFolder Is Nothing Then
MsgBox "You need to select a folder in order to save the attachments", vbCritical, _
"Export - Not Found"
Exit Sub
End If
''''

i = 0
' Check Inbox for messages and exit of none found
If SubFolder.Items.Count = 0 Then
MsgBox "There are no attachments in the selected folder", vbInformation, _
"Export - Not Found"
Exit Sub
End If
' Check each message for attachments
For Each Item In SubFolder.Items
' Save any attachments found
For Each Atmt In Item.Attachments
' This path must exist! Change folder name as necessary.
' FileName = "C:\Email Attachments\" & Atmt.FileName
'if want to add a filter:
'If Right(Atmt.FileName, 3) = "xls" Then

FILENAME = WheretosaveFolder & "\" & Format(Item.receivedtime, "m-d-yy hh mm") & Atmt.FILENAME
Atmt.SaveAsFile FILENAME
i = i + 1
Next Atmt
Next Item
' Show summary message
If i > 0 Then
MsgBox "There were " & i & " attached files." _
& vbCrLf & "These have been saved to the Outlook Attachments folder in My Documents." _
& vbCrLf & vbCrLf & "Good job!", vbInformation, "Export Complete"
Else
MsgBox "There were no attachments found in any mails.", vbInformation, "Export - Not Found"
End If
' 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

[skatonni]

With this format Sub ShowMessage(Item As Outlook.MailItem) the code is supposed to process the one Item passed to it. But since you made it work well enough then try processing unread items.


' Check each message for attachments
For Each Item In SubFolder.Items

If Item.Unread = True then

' Save any attachments found
For Each Atmt In Item.Attachments
' This path must exist! Change folder name as necessary.
' FileName = "C:\Email Attachments\" & Atmt.FileName
'if want to add a filter:
'If Right(Atmt.FileName, 3) = "xls" Then

FILENAME = WheretosaveFolder & "\" & Format(Item.receivedtime, "m-d-yy hh mm") & Atmt.FILENAME
Atmt.SaveAsFile FILENAME
i = i + 1
Next Atmt

Item.Unread = False
Item.Save ' I can never recall when a save is needed
End If

Next Item

[dhighto]

This works great! Thanks!

I added Public Sub ShowMessage(Item As Outlook.MailItem) so that the script would show up in my rules. I new to vba so this might be the wrong way.