Searching Outlook Folder - vba

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

Related

Set mails read if they were read in another folder

I'm trying to make an outlook macro, which will 'update' the mails. I have an Inbox folder and an another one. (2 mail accunts)
There is a rule, which is copying the mail from another folder to my inbox.
My goal is to set the mail as read in another folder, if it was read in the Inbox folder.
Sub precitane()
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.Folder
Dim myDestFolder As Outlook.Folder
Dim mydeffolder As Outlook.Folder
Dim items As Object
Dim defitems As Object
Set myNameSpace = Application.GetNamespace("MAPI")
Set myDestFolder = myNameSpace.Folders("") 'mymail
Set mydeffolder = myNameSpace.GetDefaultFolder(olFolderInbox)
For Each items In myDestFolder.items
For Each defitems In mydeffolder.items
If TypeOf items Is Outlook.MailItem & TypeOf defitems Is Outlook.MailItem Then
Dim oMail As Outlook.MailItem: Set oMail = items
Dim defMail As Outlook.MailItem: Set defMail = defitems
If oMail.SenderEmailAddress = "" & defMail.SenderEmailAddress = "" & defMail.Body = oMail.Body & defMail.UnRead = False Then
oMail.UnRead = True
oMail.Save
End If
End If
Next
Next
On Error GoTo 0
End Sub
"" contains my mail...
It looks like you tried with code from other than VBA.
I broke the If statement into separate parts as it is easier to follow and to debug.
Option Explicit
Sub precitane()
Dim myDestFolder As Folder
Dim mydeffolder As Folder
Dim item As Object
Dim defItem As Object
Set myDestFolder = Session.Folders("mailAddress2").Folders("Inbox").Folders("Test")
Set mydeffolder = Session.GetDefaultFolder(olFolderInbox).Folders("Test3")
For Each item In myDestFolder.items
If TypeOf item Is MailItem Then
For Each defItem In mydeffolder.items
If TypeOf defItem Is MailItem Then
If item.senderEmailAddress = defItem.senderEmailAddress Then
If item.Body = defItem.Body Then
If item.UnRead = False Then
defItem.UnRead = False
'If necessary
'item.Save
Exit For
End If
End If
End If
End If
Set defItem = Nothing
Next
End If
Set item = Nothing
Next
Debug.Print "Done."
End Sub

Folder path to enterprise vault using VBA for email migration

I have a long list of folders and to many rules for outlook to handle using the standard rules manager. I wrote code that would classify and move items to folders but recently I was migrated to an Enterprise Vault. I am trying to find the folder path to update my code. I tried something like
Outlook.Application.GetNamespace("MAPI").Folders("Vault - DOE, JOHN").Folders("My Migrated PSTs").Folders("PR2018")
but honestly I have no idea what the correct path should be. Everything I find online deals with pulling selected items out of the vault and not moving items into it. Below is an excerpt of the existing code. This is on Office 365/Outlook 2016.
Sub Sort_Test(Item)
Dim Msg As Object
Dim Appt As Object
Dim Meet As Object
Dim olApp As Object
Dim objNS As Object
Dim targetFolder As Object
On Error GoTo ErrorHandler
Set Msg = Item
Set PST = Outlook.Application.GetNamespace("MAPI").Folders("PR2018")
checksub = Msg.Subject
checksend = Msg.Sender
checksendname = Msg.SenderName
checksendemail = Msg.SenderEmailAddress
checkbod = Msg.Body
checkto = Msg.To
checkbcc = Msg.BCC
checkcc = Msg.CC
checkcreation = Msg.CreationTime
checksize = Msg.Size
'Classes Folder
If checksub Like "*Files*Lindsey*" Or checksub Like "*Course Login*" _
Or checksend Like "*Award*eBooks*" Then
Set targetFolder = PST.Folders("Education").Folders("Classes")
Msg.Move targetFolder
GoTo ProgramExit
End If
If targetFolder Is Nothing Then
GoTo ProgramExit
' Else
' Msg.Move targetFolder
End If
' Set olApp = Nothing
' Set objNS = Nothing
Set targetFolder = Nothing
Set checksub = Nothing
Set checksend = Nothing
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Try this code:
Sub MoveToFolder()
Dim olApp As New Outlook.Application
Dim olNameSpace As Outlook.NameSpace
Dim olArcFolder As Outlook.MAPIFolder
Dim olCompFolder As Outlook.MAPIFolder
Dim mailboxNameString As String
Dim myInspectors As Outlook.MailItem
Dim myCopiedInspectors As Outlook.MailItem
Dim myItem As Outlook.MailItem
Dim M As Integer
Dim iCount As Integer
Set olNameSpace = olApp.GetNamespace("MAPI")
Set olArcFolder = olNameSpace.Folders("Emails Stored on Computer").Folders("Archived")
Set olCompFolder = olNameSpace.Folders("Emails Stored on Computer").Folders("Computer")
For M = 1 To olArcFolder.items.Count
Set myItem = olArcFolder.items(M)
myItem.Display
Set myInspectors = Outlook.Application.ActiveInspector.CurrentItem
Set myCopiedInspectors = myInspectors.copy
myCopiedInspectors.Move olCompFolder
myInspectors.Close olDiscard
Next M
Here is a link for you reference:
Do for all open emails and move to a folder

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

VBA Search in Outlook

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!

Outlook 2010 GAL with Excel VBA

I have the following code to get contacts out of Outlook from Excel:
Public Sub GetGAL()
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFldr As Outlook.Items
Dim olContact As Outlook.ContactItem
Set olApp = CreateObject("Outlook.Application.14")
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(olFolderContacts).Items
For Each olContact In olFldr
Debug.Print olContact.FullName
Next olContact
End
End Sub
It is failing on this line saying there is a type mismatch:
For Each olContact In olFldr
Does anyone know why this is?
Also, how do I access the GAL as opposed to just my own contacts?
Thanks for any help.
Edit: Here's my new code to access the addressEntry and ExchangeUser, however, not the country field yet:
Option Explicit
Public Sub GetGAL()
Application.ScreenUpdating = False
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olGAL As Outlook.addressEntries
Dim olAddressEntry As Outlook.addressEntry
Dim olUser As Outlook.ExchangeUser
Dim i As Long
'Dim sTemp As String
'Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(1)
Set olApp = CreateObject("Outlook.Application.14")
Set olNs = olApp.GetNamespace("MAPI")
Set olGAL = olNs.addressLists("Global Address List").addressEntries
'On Error Resume Next
For i = 1 To olGAL.Count
Set olAddressEntry = olGAL.Item(i)
If olAddressEntry.DisplayType = olRemoteUser Then
Set olUser = olAddressEntry.GetExchangeUser
'Debug.Print olUser.Name & ";" & olUser.StateOrProvince
'Debug.Print sTemp
'ws.Cells(i, 1) = olUser.Name
'ws.Cells(i, 2) = olUser.StateOrProvince
End If
Next i
End
Application.ScreenUpdating = True
End Sub
Give this a try. Although if you have tons and tons of entries in your GAL, it will take awhile to complete, and you may have to increase the 65000.
Sub tgr()
Dim appOL As Object
Dim oGAL As Object
Dim oContact As Object
Dim oUser As Object
Dim arrUsers(1 To 65000, 1 To 2) As String
Dim UserIndex As Long
Dim i As Long
Set appOL = CreateObject("Outlook.Application")
Set oGAL = appOL.GetNameSpace("MAPI").AddressLists("Global Address List").AddressEntries
For i = 1 To oGAL.Count
Set oContact = oGAL.Item(i)
If oContact.AddressEntryUserType = 0 Then
Set oUser = oContact.GetExchangeUser
If Len(oUser.lastname) > 0 Then
UserIndex = UserIndex + 1
arrUsers(UserIndex, 1) = oUser.Name
arrUsers(UserIndex, 2) = oUser.PrimarySMTPAddress
End If
End If
Next i
appOL.Quit
If UserIndex > 0 Then
Range("A2").Resize(UserIndex, UBound(arrUsers, 2)).Value = arrUsers
End If
Set appOL = Nothing
Set oGAL = Nothing
Set oContact = Nothing
Set oUser = Nothing
Erase arrUsers
End Sub
Your code assumes that you can only have ContactItem objects in the folder. It will break if you encounter an object of type DistListItem.
Declare the item variable as a generic Object, then check the Class property (exposed by all Outlook objects) or use TypeName function to figure out the exact item type.
EDIT: PR_BUSINESS_ADDRESS_COUNTRY DASL name is "http://schemas.microsoft.com/mapi/proptag/0x3A26001F"
For address entries you can see the DASS property names in OutlookSpy (I am its author). For example, you can click IMAPISession button, click QueryIdentity, select a property, look at the DASL edit box.