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
Related
I am trying to move sent mail from my regular Sent Items standard folder to two separate folders in Outlook (365). On the left in my Folder Pane I have my email 'main#domain.com', 'Online Archive - main#domain.com' (an Online Archive for more storage similar to a PST I guess) and then a shared mailbox 'secondary#domain.com'.
One of the backup folders is in my Online Archive and the other backup folder is a shared mailbox. Here's the VBA code I have so far. Ideally I would like it to run each time an email is sent/appears in the Sent Items so I think I could use WithEvents somehow but I am okay to run the macro on an as needed basis.
When I run the code none of the mail moves so I think the issue is something with how I am selecting the filtered mail items to move.
Sub MoveItems()
Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim mySource As Outlook.MAPIFolder
Dim myDestFolder As Outlook.MAPIFolder
Dim myItems As Outlook.Items
Dim myItem As Object
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set mySource = myNameSpace.GetDefaultFolder(olFolderSentMail)
Set myItems = mySource.Items
Set myDestFolder = Outlook.Session.Folders("Online Archive - main#domain.com").Folders("Backup")
Set myItem = myItems.Find("[SenderEmailAddress] = 'main#domain.com'")
While TypeName(myItem) <> "Nothing"
myItem.Move myDestFolder
Set myItem = myItems.FindNext
Wend
Set myItem = myItems.Find("[SenderEmailAddress] = 'secondary#domain.com'")
Set myDestFolder = Outlook.Session.Folders("secondary#domain.com").Folders("SecondaryBackup")
While TypeName(myItem) <> "Nothing"
myItem.Move myDestFolder
Set myItem = myItems.FindNext
Wend
End Sub
Sub MoveItems()
Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim mySource, myDestFolder As Outlook.MAPIFolder
Dim myItems As Outlook.Items
Dim myItem As Object
Dim strFilter As String
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set mySource = myNameSpace.GetDefaultFolder(olFolderSentMail)
Set myItems = mySource.Items
strFilter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:fromname" & Chr(34) & " like '%Main Display Name%'"
Set myDestFolder = Outlook.Session.Folders("Online Archive - main#domain.com").Folders("Backup")
Set myItem = myItems.Find(strFilter)
While TypeName(myItem) <> "Nothing"
myItem.Move myDestFolder
Set myItem = myItems.FindNext
Wend
strFilter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:fromname" & Chr(34) & " like '%Shared Box Display Name%'"
Set myDestFolder = Outlook.Session.Folders("Shared Box Display Name").Folders("Backup")
Set myItem = myItems.Find(strFilter)
While TypeName(myItem) <> "Nothing"
myItem.Move myDestFolder
Set myItem = myItems.FindNext
Wend
End Sub
You may change to senderName if senderEmailAddress is not in SMTP format.
Sub MoveItems_senderName()
Dim mySource As Folder
Dim myDestFolder As Folder
Dim myItems As Items
Dim myItem As Object
Set mySource = Session.GetDefaultFolder(olFolderSentMail)
'mySource.Display
Set myItems = mySource.Items
Set myDestFolder = Session.Folders("Online Archive - main#domain.com").Folders("Backup")
Debug.Print "senderName: " & senderName
Set myItem = myItems.Find("[SenderName] = 'text from immediate pane'")
While TypeName(myItem) <> "Nothing"
myItem.Move myDestFolder
Set myItem = myItems.FindNext
Wend
End Sub
Having problems moving Outlook specific mail item to subfolder. I have spent time with an Outlook MVP on Access Vba Code To Move Outlook Mail Item To Different Folder Fails - Sometimes to figure this out.
Just determined that Windows 10 Access and Outlook 2019 show the same behavior. so it must be in the code??
Maybe need an experienced Access person to take a look.
I have verified that:
Dim Mailobject As Outlook.MailItem
Dim myDestFolder As Outlook.MAPIFolder
immediately before the MOVE code, I have verified that Mailobject is still defined and is what I want by printing mailobject.subject and mailobject.sender.
I have verified myDestFolder by printing mydestfolder.name and mydestfolder.folderpath
Note that the code does work occasionally but certainly not very often.
I have listed below my code without the processing I do on each message and hiding an email address:
Public Sub ReadInbox()
Dim a As Boolean
'''http://www.blueclaw-db.com/read_email_access_outlook.htm
Dim TempRst As DAO.Recordset
Dim TempRst2 As DAO.Recordset
Dim TempRst3 As DAO.Recordset
Dim TempRst4 As DAO.Recordset
Dim rst As DAO.Recordset
Dim mynamespace As Outlook.NameSpace
Dim myOlApp As Outlook.Application
On Error Resume Next
Set myOlApp = GetObject(, "outlook.Application")
If Err.Number <> 0 Then
Set myOlApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
Set mynamespace = myOlApp.GetNamespace("MAPI")
Dim Inbox As Outlook.MAPIFolder
Dim InboxItems As Outlook.Items
Dim Mailobject As Outlook.MailItem
Dim db As DAO.Database
Dim selstr As String
Dim myDestFolder As Outlook.MAPIFolder
Dim myInbox As Outlook.folder
Dim myInbox2 As Outlook.MAPIFolder
Dim myitems As Outlook.Items
Dim strFilter As String
' let the user choose which account to use
Set myaccounts = myOlApp.GetNamespace("MAPI").Stores
For i = 1 To myaccounts.Count
If myaccounts.Item(i).DisplayName = "volunteerform#?????.org" Then
Set Items = GetFolderPath("volunteerform#?????.org\inbox").Items
Set myInbox2 = mynamespace.Folders("volunteerform#?????.org")
Exit For
End If
Next
If myInbox2 Is Nothing Then
'If Items Is Nothing Then
MsgBox ("mailbox not found")
Exit Sub ' avoid error if no account is chosen
End If
'
'''''Set InboxItems = myInbox2.Items
Set InboxItems = Items
'
For Each Mailobject In InboxItems
If Mailobject.Subject <> "test" Then GoTo NextMessage
MsgBox ("found one message")
'**** do my processing here *****
On Error GoTo 0
'Set myDestFolder = GetFolderPath("volunteerform#????.org\inbox\Volunteeremailsprocessed")
Set myDestFolder = myInbox2.Folders("Inbox")
Set myDestFolder = myDestFolder.Folders("Volunteeremailsprocessed")
'Set myDestFolder = myInbox2.Folders("Volunteeremailsprocessed")
Stop
Mailobject.Move myDestFolder
NextMessage:
' Next email message
Next Mailobject
'''Set OlApp = Nothing
Set myInbox2 = Nothing
Set InboxItems = Nothing
Set Mailobject = Nothing
Exit Sub
error_Handling:
Stop
Dim errornumber As String
Dim errordescr As String
errornumber = Err.Number
errordescr = Err.Description
MsgBox (errornumber + " " + errordesc)
Exit Sub
End Sub
Note that I have tried this in windows 10 with Access 2019 and Outlook 2019 with the same results/same problem.
OK this is code that works. It obviously has a backwards processing of messages in the inbox to avoid problems with inability to MOVE more than one matching message. However my original code code not MOVE ANY matching messages.
The code I used as a base for this solution is from a web site listed at the beginning of my code as a comment. I am thankful for that code.
Public Sub ReadInbox()
'' http://www.vbaexpress.com/forum/showthread.php?58433-VBA-Outlook-Move-mail-shared-Folder-to-shared-subfolder
Dim a As Boolean
'''******Open Outlook if not already open
On Error Resume Next
Set myOlApp = GetObject(, "outlook.Application")
If Err.Number <> 0 Then
Set myOlApp = CreateObject("Outlook.Application")
End If
On Error GoTo error_Handling
'''http://www.blueclaw-db.com/read_email_access_outlook.htm
'''On Error GoTo error_Handling
Dim TempRst As DAO.Recordset
Dim TempRst2 As DAO.Recordset
Dim TempRst3 As DAO.Recordset
Dim TempRst4 As DAO.Recordset
Dim rst As DAO.Recordset
Dim mynamespace As Outlook.namespace
Dim OlApp As Outlook.Application
Dim Inbox As Outlook.MAPIFolder
Dim InboxItems As Outlook.items
Dim Mailobject As Object
Dim db As DAO.Database
Dim dealer As Integer
Dim MessageBody As String
Dim selstr As String
Dim myDestFolder As Outlook.folder
Dim myInbox As Outlook.folder
Dim alreadyindb As Boolean
Dim n As Integer
'****
Set mynamespace = myOlApp.getnamespace("MAPI")
Dim NS As namespace
Dim Destinationfolder As folder
Dim myitems As Outlook.items
Dim myInbox2 As folder
Set NS = myOlApp.getnamespace("MAPI")
Set myInbox = NS.Folders("volunteerform#?????.org").Folders("Inbox")
Set myitems = myInbox.items
Set myInbox2 = NS.Folders("volunteerform#?????.org").Folders("inbox")
If myInbox2 Is Nothing Then
Exit Sub ' avoid error if no account is chosen
End If
Set myitems = myInbox2.items
'
''''For Each Mailobject In myitems
For n = myitems.Count To 1 Step -1
'''MsgBox ("process mailobject")
If myitems(n).Subject <> "ANV Volunteer Form Submission for Import" Then GoTo NextMessage
'************* all my processing here ********************
NextMessage:
' Next email message
Next n
'''Set OlApp = Nothing
Set myInbox2 = Nothing
Set InboxItems = Nothing
Set Mailobject = Nothing
Exit Sub
error_Handling:
Dim errornumber As String
Dim errordescr As String
errornumber = Err.Number
errordescr = Err.Description
a = WriteHistory("Process Form Retrieve_ProcessEmails", "Error = " & errornumber & " Mysection = " & MySection & " errordescription = " & errordescr & " MySection=" & MySection)
Exit Sub
End Sub
I copy an email from a shared mailbox to a local folder in my Outlook.
I am trying to forward the email from my local email account.
When I do this, it is sent from the shared mailbox account.
I set the account on the email as the confirmed correct account.
mailItem.Move myDestFolder
Set mailItem2 = mailItem.Forward
mailItem2.SendUsingAccount = oAccount (where oAccount is OutApp.Session.Accounts.Item (1))
mailItem2.Send
set mailItem2.SendUsingAccount = oAccount results in error
Property is Read-Only
Wondering if I don't have permissions to set this?
Option Explicit
Private rcvMail As Outlook.MailItem
Private fwMail As Outlook.MailItem
Private Const STR_MOVED_FOLDER As String = "Moved Emails"
Sub MoveAndForward()
Dim myNamespace As Outlook.NameSpace
Dim myInbox As Outlook.Folder
Dim myDestFolder As Outlook.Folder
Dim rcvFolder As Outlook.Folder
Dim oAccount As Outlook.Account
Dim myItems As Outlook.Items
Dim myItem As Object
Dim OutApp1 As Object
Dim mailBoxFolderName As String
Dim iEmailAccount As Integer
Dim iRecipientCount As Integer
Dim i As Integer
Set OutApp1 = CreateObject("Outlook.Application")
Set oAccount = OutApp1.Session.Accounts.Item(1)
Set myNamespace = Application.GetNamespace("MAPI")
Set myInbox = myNamespace.GetDefaultFolder(olFolderInbox)
Set myItems = myInbox.Items
CheckOrCreateFolder
Set myDestFolder = myInbox.Folders(STR_MOVED_FOLDER)
Set rcvMail = ReturnCurrentItem()
If rcvMail.Class <> olMail Then
MsgBox "This cannot be saved to file." & vbCrLf & _
"Only Mail Items are supported.", vbExclamation, "Error"
Exit Sub
End If
Set rcvFolder = rcvMail.Parent
mailBoxFolderName = rcvFolder.Name
rcvMail.Move myDestFolder
Set fwMail = rcvMail.Forward
Set fwMail.SendUsingAccount = oAccount
iRecipientCount = fwMail.Recipients.Count
If iRecipientCount > 0 Then
For i = iRecipientCount To 1 Step -1
fwMail.Recipients.Remove (i)
Next i
End If
fwMail.Recipients.Add "*****#***.com"
fwMail.Recipients.ResolveAll
fwMail.Body = myNamespace.CurrentUser & " Took this email from the Mailbox" & _
vbCrLf & rcvMail.Body
fwMail.Send
rcvMail.Close (olDiscard)
Set rcvMail = Nothing
Set fwMail = Nothing
Set myNamespace = Nothing
Set myInbox = Nothing
Set myItems = Nothing
Set myDestFolder = Nothing
End
End Sub
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
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!