Sub SetStatus()
Dim OutApp As Object ' ****'Outlook.Application
Dim NmSpace As Object ' ** 'Outlook.NameSpace
Dim Inbox As Object ' **** 'Outlook.MAPIFolder
Dim MItem As Object ' **** 'Outlook.MailItem
Dim MySubFolder As Object
Dim i As Long
Dim Response As String
Dim BodyArray() As Variant
Dim EmailAddress As String
Dim Ebody As Variant
Dim Ewords As Variant
Dim Status As String
Dim Cell As Range
Dim ProcessedFolder As Object
Dim MartchFound As String
Set OutApp = CreateObject("Outlook.Application")
Set NmSpace = OutApp.GetNamespace("MAPI")
Set Inbox = NmSpace.GetDefaultFolder(6) 'olFolderInbox
Set MySubFolder = Inbox.Folders("test") ' Note Case Sensitive!
Set ProcessedFolder = Inbox.Folders("processed") ' Note Case Sensitive!
'look in the body of the email for email address
For Each MItem In MySubFolder.Items
[COLOR="Green"] 'look at subject to set the satus
'' Status = "Other" ' This is the default if no condition have been meet or email cleaning failed
'' If Left(MItem.Subject, 13) = "Undeliverable" Then Status = "Undeliverable" ': MsgBox Status & vbLf & Cell.row & vbLf & EmailClean
'' If Left(MItem.Subject, 4) = "Read" Then Status = "Read" ': MsgBox Status & vbLf & Cell.row & vbLf & EmailClean
'' If Left(MItem.Subject, 8) = "Not Read" Then Status = "Deleted" ': MsgBox Status & vbLf & Cell.row & vbLf & EmailClean
'' If Left(MItem.Subject, 38) = "Delivery Status Notification (Failure)" Then Status = "failed" ': MsgBox Status & vbLf & Cell.row & vbLf & EmailClean
'' If Left(MItem.Subject, 36) = "Delivery Status Notification (Delay)" Then Status = "Delayed"
'' If Left(MItem.Subject, 3) = "RE:" Then Status = "Replied"
'' If Left(MItem.Subject, 3) = "Re:" Then Status = "Replied"
'' If Left(MItem.Subject, 3) = "re:" Then Status = "Replied"[/COLOR]
[COLOR="Red"] Select Case True
Case Left(MItem.Subject, 13) = "Undeliverable": Status = "Undeliverable"
Case Left(MItem.Subject, 4) = "Read": Status = "Read"
Case Left(MItem.Subject, 8) = "Not Read": Status = "Deleted"
Case InStr(MItem.Subject, "(Failure)"): Status = "failed"
Case InStr(MItem.Subject, "(Delay)"): Status = "Delayed"
Case UCase(Left(MItem.Subject, 3)) = "RE:": Status = "Replied"
Case Else: Status = "Other"
End Select[/COLOR]
' If Status = "Other" Then MsgBox "The email " & MItem.Subject & " ins't part of any conditions, thus we wont do anything with this email!" 'status didn't change thus no above condition where meet
If InStr(MItem.body, "@") Then ' If MItem.body contains an @ character
Ewords = Split(MItem.body) ' Split each word in MItem.body and assign it to the Ewords variable
MatchFound = ""
' MsgBox "Found email addresse in Boby of " & vbLf & MItem
For i = LBound(Ewords) To UBound(Ewords) ' sets the for i loop to the number of split in MItem
If InStr(Ewords(i), "@") Then 'Looking for the word that as the email address
[COLOR="Green"]'' CleanEmail = Ewords(i) 'passing this CleanEmail to EmailAdresCleanup sub
'' Call EmailAddresCleanup ' Cleanup email address as much as possible[/COLOR]
[COLOR="Red"] CleanEmail = EmailAddressCleanup(Ewords(i)) 'EmailAddressCleanup as a function[/COLOR]
'now that I have a clean email address look for it in column "D" There are duplicated email so will need to figure out how to work with that? set status based on email subject
[COLOR="Green"]' MsgBox EmailClean '[/COLOR]
[COLOR="Red"]MsgBox CleanEmail[/COLOR]
[COLOR="Green"]'' For Each Cell In Columns("D").Cells.SpecialCells(xlCellTypeConstants) ' scroll thru the D column
'' '****************what to do with duplicates?******************************
'' If EmailClean = Cell.Value Then 'found the cell with the same email address
'' 'write status to "J" of the same row
'' MatchFound = MatchFound + "yes"
'' Cells(Cell.Row, "J").Value = Status
''
'' 'this will duplicate the emails if there are duplicat email addresses.
'' If MatchFound = "yes" And Status <> "Other" Then
'' MItem.Move ProcessedFolder: MsgBox MItem & " was moved to " & ProcessedFolder ': MItem.Category = "Interview": MItem.Save
'' Else
'' MsgBox "The email " & MItem & " " & EmailClean & _
'' " was not moved" & vbLf & Status & vbLf & _
'' MatchFound & vbLf & EmailClean & " = " & _
'' Cells(Cell.Row, "D").Value & "in row " & Cell.Row
'' End If
''
'' Else
'' ' exit if and look at next cell it will flag all duplicates with the latest email states!!****************
'' End If
''
'' Next Cell[/COLOR]
[COLOR="Red"] Dim Found As Range, FirstFound As String
' The .Find method is faster at finding a cell match than looping through each cell
Set Found = Columns("D").Find(What:=EmailClean, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Found Is Nothing Then ' Test if a Match was found
FirstFound = Found.Address ' Remember first match address to stop the loop later
Do
Found.Offset(, 6).Value = Status ' Put Status in column J
If Status <> "Other" Then
MItem.Move ProcessedFolder: MsgBox MItem & " was moved to " & ProcessedFolder ': MItem.Category = "Interview": MItem.Save
Else
MsgBox "The email " & MItem & " " & EmailClean & _
" was not moved" & vbLf & Status & vbLf & _
"yes" & vbLf & EmailClean & " = " & _
Found.Value & " in row " & Found.Row
End If
Set Found = Columns("D").FindNext(After:=Found)
Loop Until Found.Address = FirstFound 'Loop until the first match is found again
End If[/COLOR]
Else
' didn't find an "@" in the current string will look at the next string
End If
Next i 'ok now i'm really going to the next string
Else
' no email address in this email body moving to the next one
MsgBox "No email address in this email " & MItem & vbLf & MItem.body
End If
Next MItem 'did all I had to do with this email, lets go to the next.
'' GoTo cleanup 'sub done let's clean up after ourselves
cleanup:
Set MItem = Nothing
Set Inbox = Nothing
Set NmSpace = Nothing
Set OutApp = Nothing
Set MySubFolder = Nothing
End Sub
