What Visual Basic for Applications method will allow me to find a specific Outlook email so that I can access data from it like its message content - perhaps by searching by the subject of the email?
Items.Find Method is a alternative solution, you can use VBA string search function:
Sub sofWorkWithOutlook20082550()
Dim outlookApp
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim olMail As Variant
Dim myTasks
Dim sir() As String
'Set outlookApp = New Outlook.Application
Set outlookApp = CreateObject("Outlook.Application")
Set olNs = outlookApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set myTasks = Fldr.Items
'
'Set olMail = myTasks.Find("[Subject] = ""123456""")
'
For Each olMail In myTasks
'
If (InStr(1, olMail.Body, "My-Text-to-Search", vbTextCompare) > 0) Then
olMail.Display
Exit For
End If
Next
End Sub
PS: change "My-Text-to-Search" to some string you have in your email
Acess this site for more information: Items.Find Method
Related
I changed from Windows to MacOS.
I used VBA code to create a folder under the inbox based on email title and move the email to the folder.
I'm trying to do the same with AppleScript.
I would appreciate if someone can help me write the same logic in AppleScript (or suggest an alternative to somehow keep using the VBA code).
Public Function ReturnNonAlpha(ByVal sString As String) As String
Dim i As Integer
For i = 1 To Len(sString)
If Mid(sString, i, 1) Like "[0-9]" Then
ReturnNonAlpha = ReturnNonAlpha + Mid(sString, i, 1)
End If
Next i
End Function
Function CheckForFolder(strFolder As String) As Boolean
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder
Dim FolderToCheck As Outlook.MAPIFolder
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)
On Error Resume Next
Set FolderToCheck = olInbox.Folders(strFolder)
On Error GoTo 0
If Not FolderToCheck Is Nothing Then
CheckForFolder = True
End If
ExitProc:
Set FolderToCheck = Nothing
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function
Function CreateSubFolder(strFolder As String) As Outlook.MAPIFolder
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)
Set CreateSubFolder = olInbox.Folders.Add(strFolder)
ExitProc:
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function
Function SearchAndMove(lookFor As String)
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder
Dim FolderToCheck As Outlook.MAPIFolder
Dim myItem As Object
Dim MyFolder As Outlook.MAPIFolder
Dim lookIn As String
Dim newName As String
Dim location As Integer
Dim endLocation As Integer
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)
For Each myItem In olInbox.Items
lookIn = myItem.Subject
If InStr(lookIn, lookFor) Then
endLocation = InStr(lookIn, "SUP-")
newName = ReturnNonAlpha(lookIn)
newName = Mid(newName, 1, 5)
If CheckForFolder(newName) = False Then
Set MyFolder = CreateSubFolder(newName)
myItem.Move MyFolder
Else
Set MyFolder = olInbox.Folders(newName)
myItem.Move MyFolder
End If
End If
Next myItem
End Function
Sub myMacro(Item As Outlook.MailItem)
Dim str As String
str = "[JIRA]"
SearchAndMove (str)
End Sub
I was really determined to find a solution, so eventually with some help from https://hackernoon.com/automated-inbox-cleansing-with-outlook-2016-and-applescript-49cf4c4422fa
I was able to write a script which does what I need.
I thought I'll share it for future references since I don't see a lot of info about applescript around here.
This script basically creates a subfolder under inbox based on email subject and move the email there. I wrote it with my own problem to solve in mind, but you can do adjustments to your own problems.
tell application "Microsoft Outlook"
set myInbox to folder "Inbox" of default account
set theMessages to messages 1 through 20 of inbox
repeat with theMessage in theMessages
try
set theSubject to subject of theMessage
if theSubject contains "[JIRA]" then
set s to quoted form of theSubject
do shell script "sed s/[a-zA-Z\\']//g <<< " & s
set newFolderName to the result
set numlist to {}
repeat with i from 1 to count of words in newFolderName
set this_item to word i of newFolderName
try
set this_item to this_item as number
set the end of numlist to this_item
end try
end repeat
set newFolderName to first item of numlist as text
if mail folder newFolderName exists then
move theMessage to mail folder newFolderName of myInbox
else
make new mail folder at myInbox with properties {name:newFolderName}
move theMessage to mail folder newFolderName of myInbox
end if
end if
on error errorMsg
log "Error: " & errorMsg
end try
end repeat
end tell
I would like to save and share important items across user accounts running on an Exchange 2016 server. This is setup via Public Folders on the server.
How do I specify the appointment items created go to the folder in the root public folder that is designated for calendar items?
I created all the necessary public folder items on the Exchange 2016 server and have them appearing across multiple accounts that have been designated the required permissions.
I have the appointment item populated with some basic information and I would like it to go to said folder once the user populates any additional fields and clicks the save/send button.
The folder structure for the public folders:
All Public Folders
Company Name sub-folder (Public Folder Mailbox)
Mail
Contacts
Calendars
Public Sub CreateAppointment()
Dim objOL As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim objMsg As Outlook.MailItem 'Message Object
Dim objCalAppt As Outlook.AppointmentItem
Dim objPublicFolderRoot As Outlook.Folder
Dim objDKRRFolder As Outlook.Folder
Dim objApptFolder As Outlook.Folder
Set objNS = Application.GetNamespace("MAPI")
Set objCalAppt = Application.CreateItem(olAppointmentItem)
Set objMsg = Application.ActiveExplorer().Selection(1)
Set objPublicFolderRoot = objNS.GetDefaultFolder(olPublicFoldersAllPublicFolders)
Set objCompanyFolder = objPublicFolderRoot.Folders("Company_Shared")
Set objApptFolder = objCompanyFolder.Folders("Calendars")
With objCalAppt
.MeetingStatus = olNonMeeting 'Not an invitation
.Subject = objMsg.Subject
.Start = objMsg.SentOn
.Duration = 120
End With
objCalAppt.Display
End Sub
If I manually send/save the item, it does not appear in the folder, and it also doesn't appear in the user's calendar.
Instead of creating a "lonely" appointment item, try to create an additional item within the appropriate calendar instead:
Public Sub CreateAppointment()
Dim objOL As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim objMsg As Outlook.MailItem 'Message Object
Dim objCalAppt As Outlook.AppointmentItem
Dim objPublicFolderRoot As Outlook.Folder
Dim objCompanyFolder As Outlook.Folder
Dim objApptFolder As Outlook.Folder
Set objNS = Application.GetNamespace("MAPI")
Set objMsg = Application.ActiveExplorer().Selection(1)
Set objPublicFolderRoot = objNS.GetDefaultFolder(olPublicFoldersAllPublicFolders)
Set objCompanyFolder = objPublicFolderRoot.Folders("Company_Shared")
Set objApptFolder = objCompanyFolder.Folders("Calendars")
Set objCalAppt = objApptFolder.Items.Add(olAppointmentItem)
With objCalAppt
.MeetingStatus = olNonMeeting 'Not an invitation
.Subject = objMsg.Subject
.Start = objMsg.SentOn
.Duration = 120
End With
objCalAppt.Display
End Sub
As the code row Set objMsg = Application.ActiveExplorer().Selection(1) only works, if the user currently selected an email item, I suggest to verify that additionally:
Dim objSel As Outlook.Selection
Set objSel = Application.ActiveExplorer.Selection
If objSel.Count > 0 Then
If objSel(1).Class = olMail Then
Set objMsg = objSel(1)
Else
MsgBox "Works only on selected email."
End If
Else
MsgBox "Works only on selected email."
End If
I've tried countless ways of deleting items from a custom folder called "Spam Digests" older than 14 days. I have successfully done this when I nest this folder underneath the olDefaultFolder(Inbox) but when I have it outside of the default inbox, I cannot reference it as I receive object not found.
Here is what I have and I cannot seem to figure out why the object is not found when referencing "fldSpamDigest"
Dim outapp As Outlook.Application
Set outapp = CreateObject("outlook.application")
Dim olitem As Object
Dim fldSpamDigest As Outlook.MAPIFolder
Set fldSpamDigest = outapp.GetNamespace("MAPI").Folders("Spam Digests")
For Each olitem In fldSpamDigest.Items
If DateDiff("d", olitem.CreationTime, Now) > 14 Then olitem.Delete
Next
Set fldSpamDigest = Nothing
Set olitem = Nothing
Set outapp = Nothing
GetDefaultFolder(olFolderInbox) is a shortcut.
You can reference any folder the long way.
Sub reference_walk_the_path()
Dim outapp As Outlook.Application
Set outapp = CreateObject("outlook.application")
Dim olitem As Object
Dim fldSpamDigest As Outlook.MAPIFolder
' from the default inbox to the parent which is your mailbox
Set fldSpamDigest = outapp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Parent
' from the mailbox to a folder at the same level as the Inbox
Set fldSpamDigest = fldSpamDigest.folders("Spam Digests")
' or
' directly from the mailbox to a folder at the same level as the Inbox
'Set fldSpamDigest = outapp.GetNamespace("MAPI").folders("your email address").folders("Spam Digests")
For Each olitem In fldSpamDigest.Items
If dateDiff("d", olitem.CreationTime, Now) > 14 Then olitem.Delete
Next
Set fldSpamDigest = Nothing
Set olitem = Nothing
Set outapp = Nothing
End Sub
Dim outapp As Outlook.Application
Set outapp = CreateObject("outlook.application")
There is no need to create a new Outlook Application instance in the Outlook VBA, simply use the Application property
To reference a folder that is not under default Inbox - example would be
Option Explicit
Public Sub Example()
Dim olNs As Outlook.NameSpace
Set olNs = Application.Session
Dim Digest_Fldr As Outlook.MAPIFolder
Set Digest_Fldr = olNs.GetDefaultFolder(olFolderInbox) _
.Parent.Folders("fldSpamDigest")
Dim Items As Outlook.Items
Set Items = Digest_Fldr.Items
Dim i As Long
For i = Items.Count To 1 Step -1
DoEvents
Debug.Print Items(i).Subject
Next
End Sub
I have an email account "Fred.Smith#domain.co.uk" (domain being made up).
Outlook shows an archive named " Archive - Fred.Smith#domain.co.uk" where Outlook automatically moves emails after a certain period.
Current code:
Set olRecip = olNS.CreateRecipient("Archive - Fred.Smith#domain.co.uk")
olRecip.Resolve
Set olFolder = olNS.GetSharedDefaultFolder(olRecip, olFolderInbox)
This opens the main inbox. How do I select the archive folder?
"Archive" folder is usually at the root level - like inbox
in that case:
Sub ArchiveItems()
' Moves each of the selected items on the screen to an Archive folder.
Dim olApp As New Outlook.Application
Dim olExp As Outlook.Explorer
Dim olSel As Outlook.Selection
Dim olNameSpace As Outlook.NameSpace
Dim olArchive As Outlook.Folder
Dim intItem As Integer
Set olExp = olApp.ActiveExplorer
Set olSel = olExp.Selection
Set olNameSpace = olApp.GetNamespace("MAPI")
Set olArchive = olNameSpace.Folders("myMail#mail.com").Folders("Archive")
For intItem = 1 To olSel.Count
olSel.Item(intItem).Move olArchive
Next intItem
End Sub
to get Inbox you could use default access:
Dim olInbox As Outlook.Folder
Set olInbox = olNameSpace.GetDefaultFolder(olFolderInbox)
Note - This will get you the default Inbox folder, if you have a few accounts in outlook you should verify it's really the folder you want - or use the mail specific approach like in Archive folder above
For Debugging - if you want to check all available subfolders
For i = 1 To olInbox.Folders.Count
Debug.Print olInbox.Folders(i).Name
Next i
Should be
Dim ARCHIVE_FOLDER As Outlook.MAPIFolder
Set ARCHIVE_FOLDER = olNs.Folders("Archive - Fred.Smith#domain.co.uk")
Full Example
Option Explicit
Public Sub Example()
Dim olNs As Outlook.NameSpace
Dim ARCHIVE_FOLDER As Outlook.MAPIFolder
Dim Items As Outlook.Items
Dim i As Long
Set olNs = Application.Session
Dim ARCHIVE_FOLDER As Outlook.MAPIFolder
Set ARCHIVE_FOLDER = olNs.Folders("Archive - Fred.Smith#domain.co.uk") _
.Folders("Inbox")
Debug.Print ARCHIVE_FOLDER.Name
Debug.Print ARCHIVE_FOLDER.FolderPath
Debug.Print ARCHIVE_FOLDER.Store.DisplayName
ARCHIVE_FOLDER.Display
Set Items = ARCHIVE_FOLDER.Items
For i = Items.Count To 1 Step -1
DoEvents
Debug.Print Items(i).Subject
Next
End Sub
MAPIFolder Object
This code was derived from Excel VBA for searching in mails of Outlook.
I made adjustments to make it search a SharedMailbox which does work but the issue is that the mailbox is receiving hundreds of emails a day which makes searching time a bit longer for my liking (we have emails from early last year even). I would like to impose a 2nd search criteria, this time a date limit, like only search emails that are 2 to 3 days old.
Here is what I got:
Dim outlookapp
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim olMail As Variant
Dim myTasks
Dim projIDsearch As String
Dim myRecipient As Outlook.Recipient
Dim days2ago As Date
Set outlookapp = CreateObject("Outlook.Application")
Set olNs = outlookapp.GetNamespace("MAPI")
Set myRecipient = olNs.CreateRecipient("SharedMailboxName")
myRecipient.Resolve
'Set Fldr = olNs.GetDefaultFolder(olFolderInbox).Folders("x")
Set Fldr = olNs.GetSharedDefaultFolder(myRecipient, olFolderInbox)
Set myTasks = Fldr.Items
projIDsearch = ActiveCell.Cells(1, 4)
days2ago = DateTime.Now - 3
For Each olMail In myTasks
'If olMail.ReceivedTime > days2ago Then
If (InStr(1, olMail.Subject, projIDsearch, vbTextCompare) > 0) Then
olMail.Display
'Exit For
End If
Next
I've looked around and found the .ReceivedTime property, which sounds like the thing that I need but I'm having a struggle on how to incorporate it into the code.
Actually I don't even know how a Variant(olMail) is able to accept the .display method and .subject property.
These are the codes that I've added but they don't seem to work:
days2ago = DateTime.Now - 3
and
If olMail.ReceivedTime > days2ago Then
You can Restrict the number of items in the loop. https://msdn.microsoft.com/en-us/library/office/ff869597.aspx
Sub test()
Dim outlookapp As Object
Dim olNs As Outlook.Namespace
Dim myFldr As Outlook.Folder
Dim objMail As Object
Dim myTasks As Outlook.Items
Dim daysAgo As Long
Dim projIDsearch As String
Dim myRecipient As Outlook.Recipient
Set outlookapp = CreateObject("Outlook.Application")
Set olNs = outlookapp.GetNamespace("MAPI")
Set myRecipient = olNs.CreateRecipient("SharedMailboxName")
myRecipient.Resolve
Set myFldr = olNs.GetSharedDefaultFolder(myRecipient, olFolderInbox)
projIDsearch = ActiveCell.Cells(1, 4)
' Restrict search to daysAgo
daysAgo = 3
Set myTasks = myFldr.Items.Restrict("[ReceivedTime]>'" & Format(Date - daysAgo, "DDDDD HH:NN") & "'")
For Each objMail In myTasks
If (InStr(1, objMail.Subject, projIDsearch, vbTextCompare) > 0) Then
objMail.Display
End If
Next
End Sub