Outlook Email Current Date 1

[rss01]

I have some code that will save the excel attachments from messages in a certain folder to a folder on the network.

I need some help in modifying this code only to look at emails with Todays date. The email folder has the same message in it mutiply times. I get a new excel sheet everyday with the current MTD information and this is the only file I want saved.

Thanks in advance for any help or suggestions.

Public Sub SaveAttachmentsToFolder()

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 varResponse As VbMsgBoxResult
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("Test Folder")
i = 0

' Check subfolder for messages and exit of none found
If SubFolder.Items.Count = 0 Then
Exit Sub
End If

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


' Check filename of each attachment and save if it has "xls" extension
If Right(Atmt.FileName, 3) = "xls" Then
FileName = "C:\Email\" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
End If

Next Atmt
Next Item

' Clear memory
SaveAttachmentsToFolder_exit:
    Set Atmt = Nothing
    Set Item = Nothing
    Set ns = Nothing
    Exit Sub


End Sub

 

[PHV]

For Each Item In SubFolder.Items
If Int(Item.ReceivedTime) = Int(Date) Then
For Each Atmt In Item.attachments
...
Next Atmt
End If
Next Item

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ181-2886

 

[rss01]

Thank you, worked like a charm.