excel vba to extract "to" & "ccopy" outlook "inbox"email to excel

[bnfkru4567]

Hi All the experts:

I need your help by using EXCEL VBA to extract "to" and "ccopy" email address into excel after the filter(excel vba) find the correct wording in email subject for now (in future email body) . All the email are in the "inbox"

After did some research and tried to learn from other codes, I still could not extract email address.

Could you please help me out and my existing codes are the following
Sub GetFromInbox()

Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim Myormail As Object
Dim mydestfolder As Outlook.Folder

Dim pa As Outlook.PropertyAccessor
Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"**


Dim i, ij As Integer
Dim tt As Date

Dim AA1, AA2, AA3 As String



Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")

Set Fldr = olNs.GetDefaultFolder(olFolderInbox)



AA1 = Session.GetDefaultFolder(olFolderInbox).Name
AA2 = Session.GetDefaultFolder(olFolderInbox).Parent.Name
AA3 = Session.GetDefaultFolder(olFolderInbox).Parent.Folders("testing")

'AA3 = Session.GetDefaultFolder(olFolderInbox).Parent.Folders("application").Folders("barclays")

' MsgBox ("(AA1=" & AA1 & " ) (BB1=" & BB1 & " ) (CC1=" & CC1)


Set mydestfolder = Session.GetDefaultFolder(olFolderInbox).Parent.Folders("testing")

'Set mydestfolder = Session.GetDefaultFolder(olFolderInbox).Parent.Folders("application").Folders("barclays")





MsgBox ("(AA1=" & AA1 & " ) (AA2=" & AA2 & " ) (AA3=" & AA3 & " ) (mydestfolder=" & mydestfolder & " )")

i = 5
ij = 0
x = Date

For Each Myormail In Fldr.Items

ij = ij + 1



Sheets("test").Range("a1").Select
Sheets("test").Range("I1").Clear
Sheets("test").Range("I2") = ij

If TypeName(Myormail) = "MailItem" Then

Sheets("test").Range("I1").Value = CDate(Format(Myormail.ReceivedTime, "dd/mm/yy"))

Else

End If


tt = Sheets("test").Range("I1")



If tt >= Range("H1") Then

'If InStr(Myormail.Subject, "catch") > 0 And tt >= Range("h1") Then
If InStr(Myormail.Subject, "ASA") > 0 Then

ActiveSheet.Range("h2") = "y"
ActiveSheet.Cells(i, 1).Value = Myormail.Subject
ActiveSheet.Cells(i, 2).Value = Myormail.ReceivedTime
ActiveSheet.Cells(i, 3).Value = Myormail.SenderName
ActiveSheet.Cells(i, 4).Value = Myormail.SenderEmailAddress
tt = CDate(Format(Myormail.ReceivedTime, "dd/mm/yy"))
ActiveSheet.Cells(i, 5).Value = CDate(Format(Myormail.ReceivedTime, "dd/mm/yy"))
' tt = ActiveSheet.Cells(i, 4).Value
ActiveSheet.Cells(i, 6).Value = (Format(Myormail.ReceivedTime, "hh:mm"))



Dim test123 As Outlook.Recipient
test123 = Email.recipentsaddress

test123 = Myormail.Name & pa.GetProperty(PR_SMTP_ADDRESS)

MsgBox ("test123=" & test123)
ActiveSheet.Cells(i, 7).Value = test123


Myormail.Move mydestfolder



i = i + 1
End If

Else
Sheets("test").Range("h2") = "N"

End If
Next Myormail

Set Fldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
'tt = ""

End Sub

 

[bnfkru4567]

Please help