Here is the code pieced together from discussions in this forum. So thanks
to everyone for the help. Essentially the code should look 4 rules:
1) The subject field should be exactly "ASM Store Photos"
2) The first 4 characters in the attachment's filename should be the store
number, with leading zeros.
3) The attachment's filename MUST contain the date information in
"mm-dd-yyyy".
4) And the file extensions must be .jpg
If all the conditions are met, then it saves the attachments to different
subfolders and toggles the UnRead field to FALSE.
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim SubSubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim StoreNo As String
Dim y, z As Integer ' Counters.
'Dim tempChar As String ' Letter to evaluate.
Dim DateProper As Boolean ' TRUE/FALSE
Dim AtmtExtProper As Boolean ' TRUE/FALSE
Dim ItemSubProper As Boolean ' TRUE/FALSE
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("Store Photos")
Set SubSubFolder = SubFolder.Folders("Need to save images")
i = 0
' If there are emails, then do this.
For Each Item In SubSubFolder.Items
ItemSubProper = False
DateProper = False
AtmtExtProper = False
' Check for proper subject line heading.
ItemSubProper = False
For y = 1 To Len(Item.Subject)
If Mid$(Item.Subject, y, Len("ASM Store Photos")) = "ASM Store Photos"
Then
ItemSubProper = True
End If
Next y
For Each Atmt In Item.Attachments
' Check date format.
For y = 1 To Len(Atmt.FileName)
If IsDate(Mid$(Atmt.FileName, y, Len("mm-dd-yyyy"))) And
Len(Trim(Mid$(Atmt.FileName, y, Len("mm-dd-yyyy")))) = Len("mm-dd-yyyy") Then
DateProper = True
Exit For
Else
DateProper = False
End If
Next y
' Check file extension.
If Right(Atmt.FileName, 4) = ".jpg" Then
AtmtExtProper = True
End If
StoreNo = Mid$(Atmt.FileName, 1, 4)
FileName = "V:\Users\Store Photos\" & StoreNo & "\" & Atmt.FileName
If (Err.Number = 0) And (ItemSubProper = True) And (DateProper = True)
And (AtmtExtProper = True) Then
Atmt.SaveAsFile FileName
End If
i = i + 1
Next Atmt
If (Err.Number = 0) And (ItemSubProper = True) And (DateProper = True)
And (AtmtExtProper = True) Then
Item.UnRead = False ' Marks email as read when attachments are fully
copied.
End If
Next Item