I have created a tool wherein the excel will extract the emails from this particular mailbox
Sub GetFromOutlook()
Dim OutlookApp as Outlook.Application
Dim OutlookNameSpace As Namespace
Dim Folder as MAPIfolder
Dim OutlookMail As Variant
Dim objowner As Variant
Dim i as Integer
Set OutlookApp = New Outlook.Application
Set OutlookNameSpace = OutlookApp. GetNamespace("MAPI")
Set objowner = OutlookNameSpace.CreateRecipient("[email protected]")
Objowner.Resolve
If objowner.Resolved then
Set Folder = OutlookNameSpace.GetSharedDefaultFolder(objowner, olFolderInbox)
End if
Dim strDateFilter As String:
StrDateFilter = "[ReceivedTime] >= '" & Format(Range("Date").Value, "dddd h:nn AMPM") & "'"
Dim Items As Object: Set Items = Folder.Items.Restrict(strDateFilter)
i = 1
For each OutlookMail in Items
Range("eMail_subject").offset(i,0).Value = OutlookMail.Subject
Range("eMail_date").offset(i,0).Value = OutlookMail.ReceivedTime
Range("eMail_Sender").offset(i,0).Value = OutlookMail.SenderName
Range("eMail_text").offset(i,0).Value = OutlookMail.Body
i = i i
Set Folder = Nothing
Set OutlookNameSpace = Nothing
Set OutlookApp = Nothing
End Sub
The problem that I am encountering now
I was advised that we are now needing to extract emails from 4 more shared mailboxes other than [email protected]
We need to also extract the emails from
And I don't know how I would do it. I tried insert the following codes
Dim Folder2 as MAPIfolder
Dim Folder3 as MAPIfolder
Dim Folder4 as MAPIfolder
Dim Folder5 as MAPIfolder
Dim objownwr2 as Variant
Dim objownwr3 as Variant
Dim objownwr4 as Variant
Dim objownwr5 as Variant
Set objowner2 = OutlookNameSpace.CreateRecipient("[email protected]")
Objowner2.Resolve '(and so on for all the other shared mailbox)
If objowner2.Resolved then
Set Folder = OutlookNameSpace.GetSharedDefaultFolder(objowner2, olFolderInbox)
End if
And so on but the code is not working. It only gets the emails from [email protected]
I am not that good in coding, mostly I just do research via Google, youtube and reading forums from here but I can't seem to locate the correct codes here. Please be kind and help me.
Thanks in advance
CodePudding user response：
This might be not the most elegant solution, but it shold worK.
sub start()
GetFromOutlook("[email protected]")
GetFromOutlook("[email protected]")
GetFromOutlook("[email protected]")
GetFromOutlook("[email protected]")
GetFromOutlook("[email protected]")
end sub
Sub GetFromOutlook(mailadress)
Dim OutlookApp as Outlook.Application
Dim OutlookNameSpace As Namespace
Dim Folder as MAPIfolder
Dim OutlookMail As Variant
Dim objowner As Variant
Dim i as Integer
Set OutlookApp = New Outlook.Application
Set OutlookNameSpace = OutlookApp. GetNamespace("MAPI")
Set objowner = OutlookNameSpace.CreateRecipient(mailadress)
Objowner.Resolve
If objowner.Resolved then
Set Folder = OutlookNameSpace.GetSharedDefaultFolder(objowner, olFolderInbox)
End if
Dim strDateFilter As String:
StrDateFilter = "[ReceivedTime] >= '" & Format(Range("Date").Value, "dddd h:nn AMPM") & "'"
Dim Items As Object: Set Items = Folder.Items.Restrict(strDateFilter)
i = 1
For each OutlookMail in Items
Range("eMail_subject").offset(i,0).Value = OutlookMail.Subject
Range("eMail_date").offset(i,0).Value = OutlookMail.ReceivedTime
Range("eMail_Sender").offset(i,0).Value = OutlookMail.SenderName
Range("eMail_text").offset(i,0).Value = OutlookMail.Body
i = i i
Next
Set Folder = Nothing
Set OutlookNameSpace = Nothing
Set OutlookApp = Nothing
End Sub
CodePudding user response：
First of all, the code doesn't contain the end of the foreach loop:
For each OutlookMail in Items
Range("eMail_subject").offset(i,0).Value = OutlookMail.Subject
Range("eMail_date").offset(i,0).Value = OutlookMail.ReceivedTime
Range("eMail_Sender").offset(i,0).Value = OutlookMail.SenderName
Range("eMail_text").offset(i,0).Value = OutlookMail.Body
i = i i
You need to add the Next statement to iterate over all items in the collection:
For each OutlookMail in Items
Range("eMail_subject").offset(i,0).Value = OutlookMail.Subject
Range("eMail_date").offset(i,0).Value = OutlookMail.ReceivedTime
Range("eMail_Sender").offset(i,0).Value = OutlookMail.SenderName
Range("eMail_text").offset(i,0).Value = OutlookMail.Body
i = i i
Next
To cover multiple shared mailboxes you need to call the method for each of them. Just need to introduce a string parameter for the recipient name and use it in the code instead of the hardcoded one.
But don't create a new Outlook Application instance each time you call the methods. Instead, create an instance once and then re-use it every time you call the method. The code may look like that:
Dim OutlookApp as Outlook.Application: Set OutlookApp = New Outlook.Application
Dim recpientName as String = "[email protected]"
Sub GetFromOutlook(name as string)
Dim OutlookNameSpace As Namespace
Dim Folder as MAPIfolder
Dim OutlookMail As Variant
Dim objowner As Variant
Dim i as Integer
Set OutlookNameSpace = OutlookApp. GetNamespace("MAPI")
Set objowner = OutlookNameSpace.CreateRecipient(name)
Objowner.Resolve
If objowner.Resolved then
Set Folder = OutlookNameSpace.GetSharedDefaultFolder(objowner, olFolderInbox)
End if
Dim strDateFilter As String:
StrDateFilter = "[ReceivedTime] >= '" & Format(Range("Date").Value, "dddd h:nn AMPM") & "'"
Dim Items As Object: Set Items = Folder.Items.Restrict(strDateFilter)
i = 1
For each OutlookMail in Items
Range("eMail_subject").offset(i,0).Value = OutlookMail.Subject
Range("eMail_date").offset(i,0).Value = OutlookMail.ReceivedTime
Range("eMail_Sender").offset(i,0).Value = OutlookMail.SenderName
Range("eMail_text").offset(i,0).Value = OutlookMail.Body
i = i i
Next
Set Folder = Nothing
Set OutlookNameSpace = Nothing
Set OutlookApp = Nothing
End Sub