VBA Search in Outlook - vba

I have this code to search in my folder.
I do have a e-mail with the "sketch" subject, but VBA is not finding it (it goes to the ELSE clause)
Can anybody tell what is wrong ?
Set olApp = GetObject(, "Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(olFolderInbox)
Set olItms = olFldr.Items
Set Mail = olItms.Find("[Subject] = ""*sketch*""") 'Tracking
If Not (Mail Is Nothing) Then
'use mail item here
Else
NoResults.Show
End If

Here is a way to do the search using Items Restrict.
This runs fast and you do not need to loop through the items to find the items that match the search criteria.
Sub Search_Inbox()
Dim myOlApp As New Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim filteredItems As Outlook.Items
Dim itm As Object
Dim Found As Boolean
Dim strFilter As String
Set objNamespace = myOlApp.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)
strFilter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%sketch%'"
Set filteredItems = objFolder.Items.Restrict(strFilter)
If filteredItems.Count = 0 Then
Debug.Print "No emails found"
Found = False
Else
Found = True
' this loop is optional, it displays the list of emails by subject.
For Each itm In filteredItems
Debug.Print itm.Subject
Next
End If
'If the subject isn't found:
If Not Found Then
'NoResults.Show
Else
Debug.Print "Found " & filteredItems.Count & " items."
End If
'myOlApp.Quit
Set myOlApp = Nothing
End Sub

The reason your .Find isn't working is because Items.Find doesn't support the use of wildcards. Items.Find also doesn't support searching partial strings. So to actually find the email, you'd need to remove the wildcards and include the entire string in your search criteria.
So here are your options:
If you know the full subject line you're looking for, modify your code like so:
Set Mail = olItms.Find("[Subject] = ""This Sketch Email""")
If you don't (or won't) know the full subject, you can loop through your inbox folder and search for a partial subject line like so:
Untested
Sub Search_Inbox()
Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.MAPIFolder
Dim myitems As Outlook.Items
Dim myitem As Object
Dim Found As Boolean
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myitems = myInbox.Items
Found = False
For Each myitem In myitems
If myitem.Class = olMail Then
If InStr(1, myitem.Subject, "sketch") > 0 Then
Debug.Print "Found"
Found = True
End If
End If
Next myitem
'If the subject isn't found:
If Not Found Then
NoResults.Show
End If
myOlApp.Quit
Set myOlApp = Nothing
End Sub
Hope that helps!

Related

How to setup VBscript to run in a specific folder in Outlook [duplicate]

How can I in an Outlook VBA macro iterate all email items in a specific Outlook folder (in this case the folder belongs not to my personal inbux but is a sub-folder to the inbox of a shared mailbox.
Something like this but I've never done an Outlook macro...
For each email item in mailboxX.inbox.mySubfolder.items
// do this
next item
I tried this but the inbox subfolder is not found...
Private Sub Application_Startup()
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders("myGroupMailbox")
Set objFolder = objFolder.Folders("Inbox\mySubFolder1\mySubFolder2")
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
For Each Item In objFolder.Items
If TypeName(Item) = "MailItem" Then
Set Msg = Item
If new_msg.Subject Like "*myString*" Then
strBody = myItem.Body
Dim filePath As String
filePath = "C:\myFolder\test.txt"
Open filePath For Output As #2
Write #2, strBody
Close #2
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
Next Item
End Sub
In my case the following worked:
Sub ListMailsInFolder()
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders.GetFirst ' folders of your current account
Set objFolder = objFolder.Folders("Foldername").Folders("Subfoldername")
For Each Item In objFolder.Items
If TypeName(Item) = "MailItem" Then
' ... do stuff here ...
Debug.Print Item.ConversationTopic
End If
Next
End Sub
Likewise, you can as well iterate through calender items:
Private Sub ListCalendarItems()
Set olApp = CreateObject("Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")
Set olRecItems = olNS.GetDefaultFolder(olFolderTasks)
strFilter = "[DueDate] > '1/15/2009'"
Set olFilterRecItems = olRecItems.Items.Restrict(strFilter)
For Each Item In olFilterRecItems
If TypeName(Item) = "TaskItem" Then
Debug.Print Item.ConversationTopic
End If
Next
End Sub
Note that this example is using filtering and also .GetDefaultFolder(olFolderTasks) to get the builtin folder for calendar items. If you want to access the inbox, for example, use olFolderInbox.
The format is:
Set objFolder = objFolder.Folders("Inbox").Folders("mySubFolder1").Folders("mySubFolder2")
As advised in a comment "move the next item line to before the ProgramExit label"
Sub TheSub()
Dim objNS As Outlook.NameSpace
Dim fldrImAfter As Outlook.Folder
Dim Message As Outlook.MailItem
'This gets a handle on your mailbox
Set objNS = GetNamespace("MAPI")
'Calls fldrGetFolder function to return desired folder object
Set fldrImAfter = fldrGetFolder("Folder Name Here", objNS.Folders)
For Each Message In fldrImAfter.Items
MsgBox Message.Subject
Next
End Sub
Recursive function to loop over all folders until the specified folder name is found....
Function fldrGetFolder( _
strFolderName As String _
, objParentFolderCollection As Outlook.Folders _
) As Outlook.Folder
Dim fldrSubFolder As Outlook.Folder
For Each fldrGetFolder In objParentFolderCollection
'MsgBox fldrGetFolder.Name
If fldrGetFolder.Name = strFolderName Then
Exit For
End If
If fldrGetFolder.Folders.Count > 0 Then
Set fldrSubFolder = fldrGetFolder(strFolderName,
fldrGetFolder.Folders)
If Not fldrSubFolder Is Nothing Then
Set fldrGetFolder = fldrSubFolder
Exit For
End If
End If
Next
End Function

Outlook scan through the Inbox for a specific string in the subject

I'm working on a project were I need a macro in outlook that will scan through the inbox for an e-mail with a "reference number" contained with-in the subject field. If no e-mail was detected, the system can then move on to the next reference from an excel spreadsheet.
If an e-mail was detected, it gets extracted as an "MSG" file and the actual e-mail moved into a subfolder. So far I have a code for extracting the e-mails as "MSG" files but I cant get it to identify the specific string (reference No) in the subject field. I got the below EXCEL Macro code so far from this site.
Sub Work_with_Outlook()
Set outlookApp = CreateObject("Outlook.Application")
Dim olNs As Outlook.NameSpace
Dim Fldr As Outlook.MAPIFolder
Dim olMail As Variant
Dim sir() As String
Set outlookApp = New Outlook.Application
Set olNs = outlookApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set myTasks = Fldr.Items
Set olMail = myTasks.Find("[Subject] = ""Macro""")
If Not (olMail Is Nothing) Then
olMail.Display
End If
End Sub
Try below code:
Sub SaveAttachments()
Dim myOlapp As Outlook.Application
Dim myNameSpace As Outlook.Namespace
Dim myFolder, destFolder As Outlook.MAPIFolder
Dim i, lr As Long
'last used row in excel
lr = Cells(Rows.Count, "A").End(xlUp).Row
Set myOlapp = GetObject(, "Outlook.application")
Set myNameSpace = myOlapp.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
Set destFolder = myFolder.Folders("provide subFolderName here")
Set mytask = myFolder.Items
'Download and move attachment if found
For i = 1 To lr
'The below line of code will not work if you are using wild card or partial string
Set ref = mytask.Find("[Subject] =" & Range("a" & i).Value)
If Not (ref Is Nothing) Then
ref.Attachments.Item(1).SaveAsFile "C:\" & Range("a" & i).Value & ".msg"
ref.Move destFolder
End If
Set ref = Nothing
'The workaround code goes as below
For Each myItem In mytask
If myItem.Class = olMail Then
If InStr(1, myItem.Subject, Range("a" & i).Value) > 0 Then
myItem.Attachments.Item(1).SaveAsFile "C:\" & Range("a" & i).Value & ".msg"
myItem.Move destFolder
End If
End If
Next myItem
Next i
Set myOlapp = Nothing
Set myNameSpace = Nothing
Set myFolder = Nothing
Set destFolder = Nothing
Set mytask = Nothing
End Sub
Note: Assuming reference number is in "A" Column

Having MS Access Search Outlook for e-mails

So I am trying to create a Macro that will search my e-mails based on a piece of information on an access form I know I am close but I cannot seem to figure out the final piece
Private Sub btnEMAIL_Click()
Dim strID As String, strMessages As String
Call Outlook_open 'CHECKS TO SEE IF OUT LOOK IS OPEN
Dim myOlApp As Object
Set myOlApp = CreateObject("Outlook.Application") 'Creates outlook object
strID = PayeeID.Value 'this is a value on the form
Dim myNameSpace As Outlook.Namespace
Dim myInbox As Outlook.MAPIFolder
Dim myitems As Outlook.Items
Dim myitem As Object
Dim blnfound As Boolean
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myInbox = myNameSpace.Folders("HQP Field Compensation").Folders("Inbox")
Set myitems = myInbox.Items
Set mySearch = AdvancedSearch(Scope:=myInbox,Filter:="urn:schemas:mailheader:subject= '" & strID & "'")
Set myResults = mySearch.Results
If myResults.Count > 0 Then
For intCounter = 1 To myResults.Count
myResults.Item(intCounter).Display 'Should display the relevant e-mail
Next intCounter
End If
End Sub
AdvancedSearch is asynchronous/ Since you are only searching through the Inbox, use Items.Restrict or Items.Find/FindNext
set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
set myItems = myInbox.Items
set myItem = myItems.Find("[Subject]='" & strID & "'")
while Not (myItem Is Nothing)
myItem.Display
set myItem = myItems.FindNext
wend

Searching Outlook Folder

I want to search a specific Outlook folder using an activecell value.
I tried Excel VBA for searching in mails of Outlook and VBA Search in Outlook.
The closest I was able to get:
Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.MAPIFolder
Dim myitems As Outlook.Items
Dim myitem As Object
Dim Found As Boolean
Dim OutlookSearch as string
Outlooksearch = Cstr(Activecell.cells(1,4).Value)
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myitems = myInbox.Items
Found = False
For Each myitem In myitems
If myitem.Class = olMail Then
If InStr(1, myitem.Subject, "sketch") > 0 Then
Debug.Print "Found"
Found = True
End If
End If
Next myitem
'If the subject isn't found:
If Not Found Then
MsgBox "Cannot find"
End If
myOlApp.Quit
Set myOlApp = Nothing
I want to use the string in Activecell.cells(1, 4) as the subject for a search in a specific Outlook folder in the inbox.
I get is the MsgBox even if I've sent an email containing values that match with activecell.
You can specify the folder to search in, within the inbox, by using the .Folders property.
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("myFolder")
I've had a play around and come up with the code below. No need to set references to Outlook.
Sub Test1()
Dim oOutlook As Object 'Outlook.Application
Dim nNameSpace As Object 'Outlook.Namespace
Dim mFolderSelected As Object 'Outlook.MAPIFolder
Dim cFolder As Object
Dim oItem As Object
Dim oMyItem As Object
Dim sOutlookSearch As String
Dim aFolders() As String
Dim i As Long
'sOutlookSearch needs to be something like:
'"Mailbox - Darren Bartrup-Cook\Inbox"
sOutlookSearch = ThisWorkbook.Worksheets("Sheet1").Cells(1, 4)
sOutlookSearch = Replace(sOutlookSearch, "/", "\")
aFolders() = Split(sOutlookSearch, "\")
Set oOutlook = GetObject(, "Outlook.Application")
Set nNameSpace = oOutlook.GetNamespace("MAPI")
Set mFolderSelected = nNameSpace.Folders.Item(aFolders(0))
If Not mFolderSelected Is Nothing Then
For i = 1 To UBound(aFolders)
Set cFolder = mFolderSelected.Folders
Set mFolderSelected = Nothing
Set mFolderSelected = cFolder.Item(aFolders(i))
If mFolderSelected Is Nothing Then
Exit For
End If
Next i
End If
'Set mFolderSelected = nNameSpace.PickFolder 'Alternative to above code block - just pick the folder.
For Each oItem In mFolderSelected.items
If oItem.class = 43 Then '43 = olmail
If InStr(1, oItem.Subject, "sketch") > 0 Then
Debug.Print "Found: " & oItem.sendername
Exit For
End If
End If
Next oItem
End Sub
The code block for finding the correct folder was taken from here:
http://www.outlookcode.com/d/code/getfolder.htm

Iterate all email items in a specific Outlook folder

How can I in an Outlook VBA macro iterate all email items in a specific Outlook folder (in this case the folder belongs not to my personal inbux but is a sub-folder to the inbox of a shared mailbox.
Something like this but I've never done an Outlook macro...
For each email item in mailboxX.inbox.mySubfolder.items
// do this
next item
I tried this but the inbox subfolder is not found...
Private Sub Application_Startup()
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders("myGroupMailbox")
Set objFolder = objFolder.Folders("Inbox\mySubFolder1\mySubFolder2")
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
For Each Item In objFolder.Items
If TypeName(Item) = "MailItem" Then
Set Msg = Item
If new_msg.Subject Like "*myString*" Then
strBody = myItem.Body
Dim filePath As String
filePath = "C:\myFolder\test.txt"
Open filePath For Output As #2
Write #2, strBody
Close #2
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
Next Item
End Sub
In my case the following worked:
Sub ListMailsInFolder()
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders.GetFirst ' folders of your current account
Set objFolder = objFolder.Folders("Foldername").Folders("Subfoldername")
For Each Item In objFolder.Items
If TypeName(Item) = "MailItem" Then
' ... do stuff here ...
Debug.Print Item.ConversationTopic
End If
Next
End Sub
Likewise, you can as well iterate through calender items:
Private Sub ListCalendarItems()
Set olApp = CreateObject("Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")
Set olRecItems = olNS.GetDefaultFolder(olFolderTasks)
strFilter = "[DueDate] > '1/15/2009'"
Set olFilterRecItems = olRecItems.Items.Restrict(strFilter)
For Each Item In olFilterRecItems
If TypeName(Item) = "TaskItem" Then
Debug.Print Item.ConversationTopic
End If
Next
End Sub
Note that this example is using filtering and also .GetDefaultFolder(olFolderTasks) to get the builtin folder for calendar items. If you want to access the inbox, for example, use olFolderInbox.
The format is:
Set objFolder = objFolder.Folders("Inbox").Folders("mySubFolder1").Folders("mySubFolder2")
As advised in a comment "move the next item line to before the ProgramExit label"
Sub TheSub()
Dim objNS As Outlook.NameSpace
Dim fldrImAfter As Outlook.Folder
Dim Message As Outlook.MailItem
'This gets a handle on your mailbox
Set objNS = GetNamespace("MAPI")
'Calls fldrGetFolder function to return desired folder object
Set fldrImAfter = fldrGetFolder("Folder Name Here", objNS.Folders)
For Each Message In fldrImAfter.Items
MsgBox Message.Subject
Next
End Sub
Recursive function to loop over all folders until the specified folder name is found....
Function fldrGetFolder( _
strFolderName As String _
, objParentFolderCollection As Outlook.Folders _
) As Outlook.Folder
Dim fldrSubFolder As Outlook.Folder
For Each fldrGetFolder In objParentFolderCollection
'MsgBox fldrGetFolder.Name
If fldrGetFolder.Name = strFolderName Then
Exit For
End If
If fldrGetFolder.Folders.Count > 0 Then
Set fldrSubFolder = fldrGetFolder(strFolderName,
fldrGetFolder.Folders)
If Not fldrSubFolder Is Nothing Then
Set fldrGetFolder = fldrSubFolder
Exit For
End If
End If
Next
End Function