I have the following code that does an instant search in Outlook, but I am unsure of how now to loop through these results to do further checks.
Any pointers would be gratefully received!
Sub SearchByAddress()
Dim myOlApp As New Outlook.Application
Dim ns As Outlook.NameSpace
Dim strFilter As String
Dim oMail As Outlook.MailItem
Set ns = myOlApp.GetNamespace("MAPI")
strFilter = "joebloggs#hotmail.com"
Set myOlApp.ActiveExplorer.CurrentFolder = ns.GetDefaultFolder(olFolderInbox)
txtSearch = "from:(" & Chr(34) & strFilter & Chr(34) & ") AND " & Chr(34) & "Check" & Chr(34)
myOlApp.ActiveExplorer.Search txtSearch, olSearchScopeAllFolders
Set myOlApp = Nothing
End Sub
Use Application.AdvancedSearch instead - it returns an instance of the Search object.
Related
Below code saves all items in an outlook folder to my desktop as PDFs. One flaw, The heading of the last email in the string is cut off. So when i send out vottingOptions, the PDF comes up blank for the response. Any ideas? Thank you.
Dim outApp As Object, objOutlook As Object, objFolder As Object, myItems As Object, myItem As Object
Dim psName As String, pdfName As String
Set outApp = CreateObject("Outlook.Application")
Set objOutlook = outApp.GetNamespace("MAPI")
Set objFolder = objOutlook.GetDefaultFolder(olFolderInbox).Folders("PDF Conversion")
Set myItems = objFolder.Items
FolderPath = "C:\Users\E086365\Desktop\Suz Macros\PDF Emails\"
Dim objDoc As Object, objInspector As Object
For Each myItem In myItems
FileName = Replace(myItem.SenderName, ":", "") & " - " & Replace(myItem.Subject, ":", "") & " - " & Replace(Replace(myItem.ReceivedTime, ":", ""), "/", "-")
Set objInspector = myItem.GetInspector
Set objDoc = objInspector.WordEditor
objDoc.ExportAsFixedFormat FolderPath & FileName & ".pdf", 17
Set objInspector = Nothing
Set objDoc = Nothing
Next myItem
End Sub```
First of all, there is no need to create a new Outlook Application instance if the code is run in Outlook. Instead, use the built-in Application property:
Set objOutlook = Application.GetNamespace("MAPI")
In the code, I also recommend checking the file path string after all replacing operations run against values:
objDoc.ExportAsFixedFormat FolderPath & FileName & ".pdf", 17
At work we are using Outlook 2016 and we have a shared folder. I am trying to count those emails in a subfolder of this shared folder which have a specified text in their body. I got one solution, but that is too slow (there is thousands of emails in one month).
My first solution, which works:
Sub SearchBody()
Dim myItems As Outlook.Items
Dim ShareInbox As Outlook.MAPIFolder
Dim myNamespace As Outlook.NameSpace
Dim myRecipient As Outlook.Recipient
Dim SubFolder As Object
Dim i As Integer
Dim myRestrictItems As Outlook.Items
Dim myItem As Object
Dim z As Integer
Dim dateStart As Date
i = 0
dateStart = DateTime.now
Set myNamespace = Application.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("email#email.com")
Set ShareInbox = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderInbox)
Set SubFolder = ShareInbox.Parent.Folders("SomeSubFolder")
Set myItems = SubFolder.Items
Set myRestrictItems = myItems.Restrict("[SentOn]>='2/1/2018' AND [SentOn]<'3/1/2018'")
For z = myRestrictItems.Count To 1 Step -1
If InStr(1, myRestrictItems(z).Body, "SomeStringToSearch") > 0 Then
i = i + 1
End If
Next
MsgBox i & vbNewLine & Format(DateTime.now - dateStart, "hh:mm:ss")
End Sub
So it works, but too slow (7-10 minutes).
My next code is:
Sub SearchBody2()
Dim table As Outlook.table
Dim filter As String
Dim myNamespace As Outlook.NameSpace
Dim myRecipient As Outlook.Recipient
Dim ShareInbox As Outlook.MAPIFolder
Dim SubFolder As Object
Dim row As Outlook.row
Dim myRestrictItems As Outlook.Items
Dim myItems As Outlook.Items
filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:textdescription" & Chr(34) & " like '%SomeStringToSearch%'"
Set myNamespace = Application.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("email#email.com")
Set ShareInbox = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderInbox)
Set SubFolder = ShareInbox.Parent.Folders("SomeSubFolder")
Set table = SubFolder.GetTable(filter, Outlook.OlTableContents.olUserItems)
MsgBox table.GetRowCount
End Sub
(I know that in this code there is no filter for date like in the first)
This works too, until it reaches 250 hits: it stops then.
Is there any solution to avoid the stop of the search? I am not admin of this shared folder, so I have no rights for settings.
Folder tree:
Your SubFolder Should be Set SubFolder = ShareInbox.folders("SomeSubFolder")
To add Date to your filter then example would be
filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " >= '02/01/2018' And " & _
Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " < '02/28/2018' And " & _
Chr(34) & "urn:schemas:httpmail:textdescription" & _
Chr(34) & "Like '%SomeStringToSearch%'"
If your having trouble working with shared folder then you can use CurrentFolder Property which represents the current folder displayed in the explorer
Below example has loop just for testing- deleted if not need it
Option Explicit
Public Sub Example()
Dim TargetFolder As Outlook.MAPIFolder
Dim Items As Outlook.Items
Dim i As Long
If TargetFolder Is Nothing Then Set TargetFolder = ActiveExplorer.CurrentFolder
Debug.Print TargetFolder.Name
Dim Filter As String
Filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " >= '02/01/2018' AND " & _
Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " < '02/28/2018' AND " & _
Chr(34) & "urn:schemas:httpmail:textdescription" & _
Chr(34) & "Like '%SomeStringToSearch%'"
Set Items = TargetFolder.Items.Restrict(Filter)
MsgBox (Items.Count & " Items in " & TargetFolder.Name)
Debug.Print Items.Count & " Items in " & TargetFolder.Name
For i = Items.Count To 1 Step -1
DoEvents
Debug.Print Items(i).Subject 'Immediate Window
Next
End Sub
I want to download all attachments from emails which are both unread and received from the specific sender in MS Outlook.
I found a code, which downloads all attachments from all unread emails.
Downloading Attachments from Unread Emails of MS Outlook and tried to adapt it.
However, filter is not working properly. It shows that there are no such e-mails.
Filter = "[Unread] = True And [SenderEmailAddress] = 'yrybchuk#gmail.com'"
Below is the entire code:
Option Explicit
Public Sub Example()
Dim oOlAp As Object
Dim olNs As Outlook.Namespace
Dim Inbox As Outlook.MAPIFolder
Dim Items As Outlook.Items
Dim Item As Outlook.MailItem
Dim Atmt As Attachment
Dim Filter As String
Dim FilePath As String
Dim AtmtName As String
Dim i As Long
'// Set Inbox Reference
Set oOlAp = GetObject(, "Outlook.application")
Set olNs = oOlAp.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
FilePath = "C:\Users\irybchuk\Documents\"
Filter = "[Unread] = True And [SenderEmailAddress] = 'yrybchuk#gmail.com'"
Set Items = Inbox.Items.Restrict(Filter)
'// Loop through backwards
For i = Items.Count To 1 Step -1
Set Item = Items.Item(i)
DoEvents
If Item.Class = olMail Then
Debug.Print Item.Subject ' Immediate Window
For Each Atmt In Item.Attachments
AtmtName = FilePath & Atmt.FileName
Atmt.SaveAsFile AtmtName
Next
End If
Next
Set Inbox = Nothing
Set Items = Nothing
Set Item = Nothing
Set Atmt = Nothing
Set olNs = Nothing
End Sub
I believe that here: How to filter items sendername from Items_ItemAdd Events? could be described possible solution how to change filter line. However, I couldn't do it.
Your filter seems to work for me but here is different one SQL DASL syntax you can use
Filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:fromname" & _
Chr(34) & " Like '%yrybchuk#gmail.com%' AND " & _
Chr(34) & "urn:schemas:httpmail:read" & _
Chr(34) & "=0"
Or better yet one with the attachment Restricted Filter to improve your loop
Filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:fromname" & _
Chr(34) & " Like '%yrybchuk#gmail.com%' AND " & _
Chr(34) & "urn:schemas:httpmail:hasattachment" & _
Chr(34) & "=1 AND " & _
Chr(34) & "urn:schemas:httpmail:read" & _
Chr(34) & "=0"
remember to update %yrybchuk#gmail.com%
FYI
If code is being run from Outlook then you don't need
oOlAp = GetObject(, "Outlook.application")
I am working on a code which attachment will be download to folder location in context to subject by using a subject filter.
After a long search on the internet, my code is working but the problem here is that I want to put the keyword in the subject filter so that it will download the attachment as the subject keep changing every day
e.g. Sub: training_24357 on one day and training_24359 on the next day.
Also, I want to run my code after every 5 minutes automatically, any help will be much appreciated,
below is my code.
Sub Attachment()
Dim OutOpened As Boolean
Dim App As Outlook.Application
Dim Ns As Outlook.NameSpace
Dim Folder As Outlook.MAPIFolder
Dim Attach As Outlook.Attachment
Dim Item As Object
Dim MailItem As Outlook.MailItem
Dim subject As String
Dim saveFolder As String
Dim dateFormat As String
saveFolder = "D:\Outlook\POS Visit Report"
If Right(saveFolder, 1) <> "\" Then saveFolder = saveFolder & "\"
subject = """*POS Visit*"""
OutOpened = False
On Error Resume Next
Set App = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set App = New Outlook.Application
OutOpened = True
End If
On Error GoTo 0
If App Is Nothing Then
MsgBox "Cannot Start Outlook Mail", vbExclamation
Exit Sub
End If
Set Ns = App.GetNamespace("MAPI")
Set Folder = Ns.GetDefaultFolder(olFolderInbox)
If Not olFolder Is Nothing Then
For Each Item In olFolder.Items
If Item.Class = Outlook.ObjectClass.olMail Then
Set MailItem = Item
If MailItem.subject = subject Then
Debug.Print MailItem.subject
For Each Attach In MailItem.Attachments
dateFormat = Format(Now(), "yyyy-mm-dd H-mm")
Attach.SaveAsFile saveFolder & "(" & dateFormat & ")" & " " & Attach
Next
End If
End If
Next
End If
If OutOpened Then App.Quit
Set App = Nothing
End Sub
To Search for Items with Attachment and by Subject line you can use Items.Restrict Method to filter Items collection containing all the match from the filter
Filter Example: [Attachment & Subject Like '%training%']
Filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & _
Chr(34) & " Like '%training%' AND " & _
Chr(34) & "urn:schemas:httpmail:hasattachment" & _
Chr(34) & "=1"
VBA Example https://stackoverflow.com/a/42547062/4539709 Or https://stackoverflow.com/a/42777485/4539709
Now if your running the code from Outlook then you do not need to GetObject, or Set App = New Outlook.Application Just simply Set Ns = Application.GetNamespace("MAPI")
To run your code when Items are added to you Inbox - Try working with Application.Startup Event (Outlook) And Items_ItemAdd Event (Outlook)
Items.ItemAdd Event Occurs when one or more Items are added to the specified collection. This event does not run when a large number of items are added to the folder at once.
Code Example:
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Items = Inbox.Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
'// call sub here
End If
End Sub
I am running the following script on the event that I receive an email from a specific address with a specific subject. The goal is to tag an email with a hyperlink that will be useful for the recipient of said email to have in the original message's body.
Option Explicit
Sub Megatron(MyMail As MailItem)
Dim objOL As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim strID As String
Dim strLink As String
Dim strNewText As String
Dim strLinkText As String
'On Error Resume Next
Set objOL = Application
strID = MyMail.EntryID
Set MyMail = Application.Session.GetItemFromID(strID)
If Not MyMail Is Nothing Then
Set objNS = objOL.Session
MyMail.BodyFormat = olFormatHTML
If MyMail.BodyFormat = olFormatHTML Then
MsgBox ("set to html")
End If
strLink = "http://www.example.com"
strLinkText = "Click on this Example!"
strNewText = "<p><a href=" & Chr(34) & strLink & _
Chr(34) & ">" & strLinkText & "</a></p>"
MyMail.HTMLBody = Replace(MyMail.HTMLBody, "</body>", _
strNewText, 1, 1, vbTextCompare)
MyMail.Save
MsgBox ("Hyperlink appended!")
Else
MsgBox ("Failure!")
End If
End Sub
While I get the message box telling me that the proper event occurred it appears that no actual changes are made (or are not being saved properly?).
This is the first work I have done with any kind of programming. I've gone through some tutorials for VB specifically, but I am very new to this. Any help/guidance is much appreciated!
This is a classic case of needing to use Option Explicit to require explicit variable declarations. Use this, since you are learning VBA. Also avoid the habit of using On Error Resume Next as this ignores all error handling.
You might not realize this but you are referring to your mail item in the following ways:
MyMail
objItem
objMsg
objMail
Note that the following two commands
objMsg.HTMLBody
objMail.Save
are performed on non-existent objects.
Remove the above three extra references:
Sub Megatron(MyMail As MailItem)
Dim objOL As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim objItem As Object
Dim strID As String
Dim strLink As String
Dim strNewText As String
Dim strLinkText As String
strLink = "http://www.example.com"
strLinkText = "Click on this Example!"
strNewText = "<p><a href=" & Chr(34) & strLink & _
Chr(34) & ">" & strLinkText & "</a></p>"
MyMail.HTMLBody = Replace(MyMail.HTMLBody, "</body>", _
strNewText, 1, 1, vbTextCompare)
MyMail.Save
end Sub
You also don't need the cleanup either.