Search Outlook email from Excel

[haribsha]

Team

I found below code from this forum and it is working for me, but each email with same subject opens one by one (and outlook gets stuck as somany emails are there).

If any body can make a change to below code to list all emails with given text in outlook search box only - intead of opending all emails one by one - and I could select latest email from the list



Sub TestMailTool() ' Is working in Office 2000-2007
Dim OutApp As Object
Dim OutNameSpace As Object
Dim OutFolder As Object
Dim OutItms As Object
Dim OutMail As Object
Dim i As Integer
Dim mail
Dim replyall As Object
'Dim strbody As String
'Dim MyTasks As Object
'Dim sir() As String
'Dim myitems As Outlook.Items
'Dim myitem As Object
Set OutApp = CreateObject("Outlook.Application")
'Set OutMail = OutApp.CreateItem(0)
Set OutNameSpace = OutApp.GetNamespace("MAPI")
Set OutFolder = OutNameSpace.GetDefaultFolder(6)
Set OutItms = OutFolder.Items
i = 1
'Set MyTasks = OutFolder.Items
'Set myitems = myInbox.Items
For Each OutMail In OutFolder.Items
If InStr(OutMail.Subject, "City Pharmacy LLC") <> 0 Then
OutMail.Display
OutMail.replyall
Body = "test reply" & vbCrLf & BR
i = i + 1
End If
Next OutMail
End Sub

[gmayor]

It appears from your code listing that you are trying to create from Excel a 'replytoall' message from the most recent message in Outlook's Inbox that has the string "City Pharmacy LLC" in the subject. In that case you want the following. Copy the indicated function from http://www.rondebruin.nl/win/s1/outlook/openclose.htm to the same module to ensure that Outlook is opened correctly, or the editing of the message body text may not work correctly.


Option Explicit

Sub TestMailTool()
'Graham Mayor - https://www.gmayor.com - Last updated - 21 Jan 2022

'Use the function from http://www.rondebruin.nl/win/s1/outlook/openclose.htm
'to open Outlook, or it will not work correctly

Dim olApp As Object
Dim olNS As Object
Dim olFolder As Object
Dim olItms As Object
Dim olMail As Object
Dim olItem As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object
Dim i As Integer

Set olApp = OutlookApp() 'see note above
Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.GetDefaultFolder(6)
Set olItms = olFolder.Items
olItms.Sort "[Received]", True
For i = 1 To olItms.Count
Set olMail = olItms(i)
If InStr(olMail.Subject, "City Pharmacy LLC") > 0 Then
Set olItem = olMail.replyall
With olItem
.display
.BodyFormat = 2 'html
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor 'access the message body for editing
Set oRng = wdDoc.Range
oRng.Collapse 1 'set a range to the start of the message
oRng.Text = "This is the message body text test reply." & vbCr & vbCr & _
"The default signature will be retained"
End With
Exit For
End If
Next i
lbl_Exit:
Set olApp = Nothing
Set olNS = Nothing
Set olFolder = Nothing
Set olItms = Nothing
Set olMail = Nothing
Set olItem = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
Exit Sub
End Sub

[haribsha]

Dear gmayor

Thank you for your reply,,

Actually I didnt mean to reply all ( It was accidentaly included in code while copiying - sorry) , I want to just open list of all emails with subject "City Pharmacy LLC" in out look itself and I can select relevent message from that I will reply.

[gmayor]

You don't need a macro for that, just set a view with a filter for City Pharmacy LLC in the subject.

If you save that view as (say) City Pharmacy, you can toggle the view for that folder - here with the view 'Compact'

Sub CityPharmacy()
Dim objViews As Views
Dim objView As View
Set objViews = Application.ActiveExplorer.CurrentFolder.Views
If Application.ActiveExplorer.CurrentFolder.CurrentView = "Compact" Then
Set objView = objViews.Item("City Pharmacy")
Else
Set objView = objViews.Item("Compact")
End If
objView.Apply
End Sub
Better still create a rule to direct all messages from City Pharmacy into a new City Pharmacy sub folder of Inbox.