The code found in this thread works fine for single email results: Excel VBA for searching in mails of Outlook, But it only returns the latest email.
Is it possible to adjust the code to display more than 1 result?
The code that I have from the thread is:
Option Explicit
Public Sub search_outlook()
Dim outlookapp
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim olMail As Variant
Dim myTasks
Dim projIDsearch As String
projIDsearch = ActiveCell.Cells(1, 4)
Set outlookapp = CreateObject("Outlook.Application")
'Set outlookapp = New Outlook.Application
Set olNs = outlookapp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox).Folders("ExemptionReview")
Set myTasks = Fldr.Items
For Each olMail In myTasks
If (InStr(1, olMail.Subject, projIDsearch, vbTextCompare) > 0) Then
olMail.Display
Exit For
End If
Next
End Sub
Remove the Exit For. This drops out of the loop when a match is found:
olMail.Display
Exit For '<Remove this
Related
The VBA code does not move all emails with a certain words in the Subject "has been updated" and "Item" from the inbox to the subfolder "Neu". Emails should be already read. After 5-6 iterations , all emails will be moved. But why doesn't it work immediately after the first time of code running? Maybe you have faced the same problem? Out of 46 emails, 26 of them are moved firstly, then 39, then 44 and then 46.
Thank you very much in advance!
Sub Emails_Outlook_Transport()
Dim olApp As Outlook.Application
Set olApp = New Outlook.Application
Dim olNS As Outlook.Namespace
Set olNS = olApp.GetNamespace("MAPI")
Dim olFldr As Outlook.MAPIFolder
Set olFldr = olNS.GetDefaultFolder(olFolderInbox)
Dim Items As Outlook.Items
Set Items = olFldr.Items
Dim newFldr As Outlook.MAPIFolder
Set newFldr = olFldr.Folders("Neu")
Dim msg As Object
Dim olMailItem As MailItem
Dim Found As Boolean
On Error Resume Next
For Each msg In Items
If TypeOf msg Is MailItem And msg.UnRead = False Then
Set olMailItem = msg
If InStr(olMailItem.Subject, "has been updated") > 0 And InStr(olMailItem.Subject, "Item") > 0 Then
olMailItem.Move newFldr
End If
End If
Next
End Sub
No error messages, just not a proper work of the code
Problem:
Apparently when the items are moved around, it messes with the item being referred in the loop in case of For Each loop
Solution:
Work a Loop after counting the Items and Backwards.So that each item is referred by an Index.
Try this:
Sub Emails_Outlook_Transport()
Dim olApp As Outlook.Application
Set olApp = New Outlook.Application
Dim olNS As Outlook.NameSpace
Set olNS = olApp.GetNamespace("MAPI")
Dim olFldr As Outlook.MAPIFolder
Set olFldr = olNS.GetDefaultFolder(olFolderInbox)
Dim Items As Outlook.Items
Set Items = olFldr.Items
Dim newFldr As Outlook.MAPIFolder
Set newFldr = olFldr.Folders("Neu")
Dim msg As Object
Dim olMailItem As MailItem
Dim Found As Boolean
Dim i As Integer
For i = Items.Count To 1 Step -1
If TypeOf Items(i) Is MailItem And Items(i).UnRead = False Then
Set olMailItem = Items(i)
If InStr(olMailItem.Subject, "has been updated") > 0 And InStr(olMailItem.Subject, "Item") > 0 Then
olMailItem.Move newFldr
End If
End If
Next
End Sub
We are in the middle of a new production line start-up and have a lot of info and emails to communicate. What we want is that all the info is gathered in a folder on the server and that people who need info could search in a textfield to find related subjects. So what I want is to search for a string in email body's but currently I only know how to do this in my own mail box but not how to do it in saved emails in a folder. The code that I have for now is this and is for a Excel macro:
Sub FindSubjectInEmails()
Dim outlookApp
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim olMail As Variant
Dim myTasks
Dim sir() As String
Set outlookApp = CreateObject("Outlook.Application")
Set olNs = outlookApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set myTasks = Fldr.Items
For Each olMail In myTasks
If (InStr(1, olMail.Body, "text_to_find", vbTextCompare) > 0) Then
olMail.Display
Exit For
End If
Next
End Sub
Is this what you are trying?
Option Explicit
Sub Sample()
Dim OutApp As Object, OutMsg As Object
Dim msgFolder As String, emlFile As String
Set OutApp = CreateObject("Outlook.Application")
'~~> Change this to the relevant folder
msgFolder = "C:\Users\routs\Desktop\Test\"
emlFile = Dir(msgFolder & "\*.msg")
'~~> Loop through the folder to work with the emails
Do While Len(emlFile) > 0
Set OutMsg = OutApp.Session.OpenSharedItem(msgFolder & emlFile)
If (InStr(1, OutMsg.Body, "text_to_find", vbTextCompare) > 0) Then
OutMsg.Display
Exit Do
End If
emlFile = Dir
Loop
Set OutMsg = Nothing
Set OutApp = Nothing
End Sub
I'm trying to get the .To email address from my sent box using Excel-VBA. However, To only returns the name not the email address. After some search found that the recipient should be what I'm looking for. Tried by following the msdn guide, but the code does not seem to work.
Sub test()
Dim objoutlook As Object
Dim objNamespace As Object
Dim olFolder As Object
Dim OutlookMail As outlook.MailItem
Set objoutlook = CreateObject("Outlook.Application")
Set objNamespace = objoutlook.GetNamespace("MAPI")
Set olFolder = objNamespace.GetDefaultFolder(olFolderSentMail)
Set OutlookMail = objoutlook.CreateItem(olMailItem)
Dim recips As outlook.Recipients
Dim recip As outlook.Recipient
Dim pa As outlook.PropertyAccessor
Const PR_SMTP_ADDRESS As String = _
"http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Set recips = OutlookMail.Recipients
For Each recip In recips 'Something is wrong here
Set pa = recip.PropertyAccessor
Debug.Print recip.Name & " SMTP=" & pa.GetProperty(PR_SMTP_ADDRESS)
Next
Set olFolder = Nothing
Set objNamespace = Nothing
Set objoutlook = Nothing
End Sub
I'm not really familiar with VBA, please guide along.
You can try this:
Private Sub GetRecipientSMTP(objAllRecip As Outlook.Recipients)
Dim objRecip As Outlook.Recipient
Dim objExUser As Outlook.ExchangeUser
Dim objExDisUser As Outlook.ExchangeDistributionList
For Each objRecip In objAllRecip
Select Case objRecip.AddressEntry.AddressEntryUserType
Case 0, 10
Set objExUser = objRecip.AddressEntry.GetExchangeUser
If Not objExUser Is Nothing Then _
Debug.Print objExUser.PrimarySmtpAddress '/* or copy somewhere */
Case 1
Set objExDisUser = objRecip.AddressEntry.GetExchangeDistributionList
If Not objExDisUser Is Nothing Then _
Debug.Print objExDisUser.PrimarySmtpAddress '/* or copy somewhere */
Case Else
'/* Do nothing, recipient not recognized */
End Select
Next
End Sub
You can run it in your sub like below using recips from your code (or see sample usage).
GetRecipientSMTP recips
Basically, this will check on the each Recipient on Recipients you supplied. Then will check if it is an ExchangeUser type or ExchangeDistributionList before returning the PrimartSMTPAddress. HTH.
Sample Usage:
Sub marine()
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFolder As Outlook.Folder
Dim olMail As Outlook.MailItem
Dim i As Integer
Set olApp = GetObject(, "Outlook.Application") '/* assuming OL is running */
Set olNs = olApp.GetNamespace("MAPI")
Set olFolder = olNs.GetDefaultFolder(olFolderInbox)
With olFolder
For i = .Items.Count To 1 Step -1
If TypeOf .Items(i) Is MailItem Then
Set olMail = .Items(i)
GetRecipientSMTP olMail.Recipients
End If
Exit For '/* I just want to process the first mail */
Next
End With
End Sub
Note: I used early binding and set reference to Outlook Object Library.
Quick Example
Option Explicit
Public Sub Example()
Dim OUTLOOK_APP As Outlook.Application
Dim olNs As Outlook.Namespace
Dim SENT_FLDR As MAPIFolder
Dim Items As Outlook.Items
Dim olRecip As Outlook.Recipient
Dim olRecipAddress As String
Dim i As Long
Set OUTLOOK_APP = New Outlook.Application
Set olNs = OUTLOOK_APP.GetNamespace("MAPI")
Set SENT_FLDR = olNs.GetDefaultFolder(olFolderSentMail)
Set Items = SENT_FLDR.Items
For i = Items.Count To 1 Step -1
DoEvents
If Items(i).Class = olMail Then
For Each olRecip In Items(i).Recipients
olRecipAddress = olRecip.Address
Debug.Print olRecipAddress
Next
End If
Next
End Sub
this is my way of getting Recipient email Address. I hope it would help you.
Sub CopyCurrentContact()
Dim objRcp As Outlook.Recipient
Dim objRcpS As Outlook.Recipients
Dim rcpStr As String
Set outLookObj = CreateObject("Outlook.Application")
Set InspectorObj = outLookObj.ActiveInspector
Set ItemObj = InspectorObj.CurrentItem
Set objRcpS = ItemObj.Recipients
For Each objRcp In objRcpS
rcpStr = objRcp.Address & "; " & rcpStr
Debug.Print rcpStr
Next objRcp
End Sub
I want to select the body of a specific email, copy it and paste it into Outlook.
I know that it would be easier to just press Ctrl + A and then Ctrl + C in the spreadsheet but this is part of a much larger process that involves automation of a report.
Sub GetFromInbox()
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFldr As Outlook.MAPIFolder
Dim olItms As Outlook.Items
Dim olMail As Variant
Dim i As Long
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace(”MAPI”)
Set olFldr = olNs.GetDefaultFolder(olFolderInbox)
Set olItms = olFldr.Items
olItms.Sort “Subject”
i = 1
For Each olMail In olItms
If InStr(olMail.Subject, “Criteria") > 0 Then
ThisWorkbook.Sheets("YourSheet").Cells(i, 1).Value = outMail.Body
i = i + 1
End If
Next olMail
Set olFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
I get a syntax error on:
If InStr(olMail.Subject, “Criteria") > 0 Then
I'd look at two things. First, is the sheet you want to paste the mail body to actually called "YourSheet" and secondly, you're referencing outMail.Body where outMail has never been dimensioned or set. Try this (assuming the sheet to paste to is called "Sheet1").
Sub GetFromInbox()
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFldr As Outlook.MAPIFolder
Dim olItms As Outlook.Items
Dim olMail As Variant
Dim i As Long
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(olFolderInbox)
Set olItms = olFldr.Items
olItms.Sort "Subject"
i = 1
For Each olMail In olItms
If InStr(1, olMail.Subject, "Criteria") > 0 Then
ThisWorkbook.Sheets("Sheet1").Cells(i, 1).Value = olMail.Body
i = i + 1
End If
Next olMail
Set olFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
I am using the following VBA code which checks for any emails with a specific subject heading.
The problem is it checks my default outlook inbox folder when I need it to check the inbox of my other email account.
Can someone please show me how I would do this?
Sub Macro1()
Set olApp = CreateObject("Outlook.Application")
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim myItem As Outlook.MailItem
Dim myAttachment As Outlook.Attachment
Dim I As Long
Dim olMail As Variant
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set myTasks = Fldr.Items
Set olMail = myTasks.Find("[Subject] = ""New Supplier Request: Ticket""")
If Not (olMail Is Nothing) Then
For Each myItem In myTasks
If myItem.Attachments.Count <> 0 Then
For Each myAttachment In myItem.Attachments
If InStr(myAttachment.DisplayName, ".txt") Then
I = I + 1
myAttachment.SaveAsFile "\\uksh000-file06\Purchasing\NS\Unactioned\" & myAttachment
End If
Next
End If
Next
For Each myItem In myTasks
myItem.Delete
Next
Call Macro2
Else
MsgBox "There Are No New Supplier Requests."
End If
End Sub
Instead of iterating through all folder items in Outlook:
For Each myItem In myTasks
If myItem.Attachments.Count <> 0 Then
For Each myAttachment In myItem.Attachments
I'd suggest using the Find/FindNext or Restrict methods of the Items class. Also you may consider using using the AdvancedSearch method of the Application class. Take a look at the following articles for the sample code which illustrates how to use them in the code:
How To: Use Restrict method to retrieve Outlook mail items from a folder
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
Advanced search in Outlook programmatically: C#, VB.NET
The reason is that you have declared variable myItem as Outlook.MailItem and you use it later to iterate through the collection of items in MAPI folder.
However, MAPI folder contains not only MailItems but also MeetingItems and every time the loop finds an object of MeetingItem type, it throws an Mismatch type error since it expects only objects of MailItem type.
You just need to change declaration of myItem variable to:
Dim myItem as Object
=============================================================
The code below should iterate through the filtered items only:
Sub Work_with_Outlook()
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim myItem As Object
Dim myAttachment As Outlook.Attachment
Dim olMail As Variant
Dim i As Long
Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set myTasks = Fldr.Items
Set olMail = myTasks.Find("[Subject] = ""test""")
While Not olMail Is Nothing
If olMail.Attachments.Count Then
For Each myAttachment In olMail.Attachments
i = i + 1
myAttachment.SaveAsFile "\\uksh000-file06\Purchasing\Supplier Attachments\test" & i & ".txt"
Next myAttachment
End If
Set olMail = myTasks.FindNext
Wend
MsgBox "Scan Complete."
End Sub