Sub SetStatus()
Dim temparray() As Variant
Dim Myemailarray() As Variant
Dim mea As Integer
Dim es As Integer
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 MItem As 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 MatchFound As String
Dim countnoemail As Integer
Dim emaillist As Variant
Dim sender As Variant
Dim el As Integer
Dim j As Integer
Dim t 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!
emaillist = ""
el = 0
sender = ""
'****************************************************************
' This macro will look in the body of each email and extract
' the email addresses contained within them to cross reference
' them with the email addresses in excle and will set the status
' according to the subject email. March 4 2011
'****************************************************************
'MsgBox MySubFolder.Items.count ' Debugging Only
mea = 1
'MsgBox MItem.SenderEmailAddress 'email address from sender
For Each MItem In MySubFolder.Items ' Starts with first email recieved
'********** Just for Testing purpose *****************
If MItem.MessageClass = "IPM.Note" Then
MsgBox "it's an email"
MsgBox MItem.SenderEmailAddress
ElseIf InStr(MItem.MessageClass, "Report") Then
MsgBox "it's a read receipt"
MsgBox MItem.MessageClass
MsgBox MItem.SenderEmailAddress
End If
'MItemm.Reply
'************* End of testing **************************
MItem.unread = "True" 'set the email as unread
'MsgBox MItem.Body
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 InStr(MItem.Subject, 14) = "Returned mail:": Status = "Invalid Email"
Case Else: Status = "Other"
End Select
' Now I need to Find all of the email adresses within the email and not include duplicated ones, If any.
If InStr(MItem.Body, "@") Then ' If MItem.body contains an @ character
'Assign each word in the body of the email to Ewords
MItem.unread = "False"
Ewords = Split(MItem.Body) ' Split each word in MItem.body and assign it to the Ewords variable
For i = LBound(Ewords) To UBound(Ewords) ' sets the for i loop to the number of split in MItem
If InStr(Ewords(i), "@") Then 'Found the string that contains an email address
'clean the email address
Call EmailAddresCleanup(Ewords(i))
ReDim Preserve temparray(2, mea)
'look into my array to see if the email is already there?
If temparray(LBound(temparray), LBound(temparray)) <> "" Then 'compare emails
For j = LBound(temparray, 2) To UBound(temparray, 2)
If temparray(1, j) = emailclean Then temparray(2, j) = Status: t = "true" 'update its status only
Next j
End If
If t <> "true" Then ' No match was found so writing the new email and status
temparray(1, mea) = emailclean
temparray(2, mea) = Status
mea = mea + 1
Else
t = ""
End If
Else
' No emails were found in the string, look at next string
End If
Next i 'Next String in body of email
Else
'MsgBox "No email in the body, need to find the code to grab it from the 'from'"
' on workaround would be to reply to the email and then read the "to" field
' Grab the email address from the sender
On Error Resume Next
'MsgBox MItem.senderemailaddress
sender = MItem.SenderEmailAddress ' this is not working because the item is not an email it's a read reciept
Dim k As Integer
ReDim Preserve temparray(2, mea)
For k = LBound(temparray, 2) To UBound(temparray, 2)
If temparray(1, k) = sender Then temparray(2, k) = Status: t = "true" 'update its status only
Next k
If t <> "true" Then
temparray(1, mea) = sender
temparray(2, mea) = Status
MItem.unread = "False"
mea = mea + 1
Else
t = ""
End If
End If
'MItem.Move ProcessedFolder
Next MItem ' Goes to next email
Myemailarray = Application.Transpose(temparray)
'****************************************************************************
' Update excel with most recent status
'
'****************************************************************************
Dim x As Integer
x = 1
For x = LBound(Myemailarray, 1) To UBound(Myemailarray, 1)
For Each Cell In Columns("D").Cells.SpecialCells(xlCellTypeConstants) ' scroll thru the D column
'MsgBox Cells(Cell.row, "J").Value
If Myemailarray(x, 1) = Cells(Cell.row, "D").Value Then 'found the cell with the same email address
Cells(Cell.row, "J").Value = Myemailarray(x, 2) 'update status
Else
End If
Next ' Looking at the next cell
Next x
GoTo cleanup ' Cleans all of the variables
cleanup:
Set MItem = Nothing
Set Inbox = Nothing
Set NmSpace = Nothing
Set OutApp = Nothing
Set MySubFolder = Nothing
MsgBox "Done"
End Sub
