I'm trying to create a macro that finds an email by the subject line, which is stored in a variable, and then move said email to another folder. What I have done so far is the following:
Dim myOlApp As New Outlook.Application
Dim objNamespace As Outlook.Namespace
Dim objFolder As Outlook.MAPIFolder
Dim strFilter As String
Set objNamespace = myOlApp.GetNamespace("MAPI")
Set MySentItems = objNamespace.GetDefaultFolder(olFolderSentMail)
Set SentItems = MySentItems.Items
Set EARInbox = objNamespace.Folders("EAR Inbox")
.
.
.
Subject = Email.Subject
Set Mail = SentItems.Find("[Subject] = " & Subject)
Mail.Move EARInbox.Folders("Sent Items")
I've realised that the above works if I write the exact subject line when trying to find, but when using a variable, it always gives me is "Cannot Parse "(" " , or something like that.
Many thanks in advance!
Your variable needs quotes since it represents text so try:
Set Mail = SentItems.Find("[Subject] = """ & Subject & """")
Related
I've had an Outlook 2016 VBA macro running for a year to check emails arriving in my inbox. Today, following installation of Windows 10 updates, I get a type mismatch error when this macro runs. The error line is the Set olNs = Application.GetNamespace("MAPI") line below:
Private Sub Application_Startup()
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim olRecip As Recipient
Dim dt As String
Dim strFile_Path As String
dt = Format(CStr(Now), "yyyy_mmm_dd_hh_mm")
strFile_Path = "d:\temp\parking.log"
Open strFile_Path For Append As #1
Write #1, dt & " " & "Application_Startup() triggered"
Close #1
Set olNs = Application.GetNamespace("MAPI")
Set olRecip = olNs.CreateRecipient("me#gmail.com")
Set Inbox = olNs.Folders("me#gmail.com").Folders("Inbox")
Set Items = Inbox.Items
End Sub
Any idea how I can fix this?
First of all, you need to make sure the COM references are set correctly.
You may try to run the code without setting a local variable:
Private Sub Application_Startup()
MsgBox "Welcome, " & Application.GetNamespace("MAPI").CurrentUser
Application.ActiveExplorer.WindowState = olMaximized
End Sub
I just ran into this issue (COM add-ins were fine) and as stated, removing the explicit declaration seems to fix the issue (you can also Dim the Namespace as an Object instead of Outlook.Namespace).
As a quick reference for anyone else I used the following code to bypass the issue:
With Application.GetNamespace("MAPI")
Dim Inbox As Outlook.MAPIFolder: Set Inbox = .GetDefaultFolder(olFolderInbox)
Dim Junk As Outlook.MAPIFolder: Set Junk = .GetDefaultFolder(olFolderJunk)
End With
I am having trouble getting my Outlook VBA code to recognize the subfolder in my Shared Tasks.
What I'm trying to do is create a macro that will automatically create a task in the department Shared Task folder. Tried Googling a variety of solutions to no avail. The code goes as follows:
Dim objApp As Outlook.Application
Dim defaultTasksFolder As Outlook.MAPIFolder
Dim subFolder As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace
Dim objMail As MailItem
Dim objItm As TaskItem
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objMail = Outlook.Application.ActiveExplorer.Selection.Item(1)
Dim objOwner As Outlook.Recipient
Set objOwner = objNS.CreateRecipient("name#email.com")
objOwner.Resolve
If objOwner.Resolved Then
Set defaultTasksFolder = objNS.GetSharedDefaultFolder(objOwner, olFolderTasks)
subFolder = defaultTasksFolder.Folders("TestFolder") **ERROR OCCURS HERE - OBJECT COULD NOT BE FOUND**
Set objItm = subFolder.Items.Add(olTaskItem)
With objItm
.Subject = "Name- " & objMail.Subject
.StartDate = objMail.ReceivedTime
.Body = objMail.Body
End With
objItm.Save
MsgBox ("Task Created for e-mail: " & vbCrLf & objMail.Subject)
End If
End Sub
It errors out on subFolder = defaultTasksFolder.Folders("TestFolder"), saying that the object could not be found. I double and tripled checked the folder name.
Any ideas what might be causing this error? Thank you!!
First of all, add the Logon method before accessing MAPI, it will log to the profile if Outlook has just been started. If it is already running it will not affect anything. Then try to add both mailboxes as delegate stores (see the Advanced tab of the Exchange account properties dialog). You should see both mailboxes.
Finally, I'd try to iterate over all folders before to make sure the folder exists. Also, I'd recommend checking the recipient's name.
Keep in mind that Outlook might cache only the default folders, but not their suborders.
Can you see and access the subfolder in Outlook?
In VBA scripting ,I am trying to write a Sub Function which has the following signature
Sub(taskName As String , myGroup As String, myFile As String ,myPer As String, RelatedTasks() As String )
Dim olApp As Outlook.Application
Dim m As Outlook.MailItem
Set olApp = New Outlook.Application
Set m = olApp.CreateItem(olMailItem)
With m
.display
.To = "somewhere#someplace.com"
.Subject = "Test Events"
.HTMLBody/.body = ...
End Sub
Email Body is as follows:
Hello All,
Please find the following information.
TASK: taskName
RELATED TASK:RelatedTasks()
FILE : myFile
PERSON : myPer
In the Sub function , the pattern to the left of colon is always constant.And the right side will change based on the inputs to the function.
For that I am reading the Template.htm which contains the required signature.
Template.htm contains:
Hello All,
Please find the following information.
TASK: {{mytask}}
RELATED TASK:{{myRelatedTasks}}
FILE : {{myFile}}
PERSON : {{myPerson}}
In VBA code,I am replacing all the fields.
The issue that I am facing is {{mytask}} and {{related tasks}} also should have a HTML reference. I have succeeded in adding the link to mytask .Clicking on the mytask in the mail will jump to the respective weblink.
<a href = "www.something.com&id ={{taskID}}>
{{mytask}}.....<a href = "www.xxx.com&id={{}}>{{myRelatedTasks}}
but having trouble in adding the same to Related tasks since it is an array.
My VBA code :
Option Explicit
Sub CreateNewMail()
Dim olApp As Outlook.Application
Dim m As Outlook.MailItem
Dim sigPath As String, sigText As String
Dim fso As Scripting.FileSystemObject
Dim ts As Scripting.TextStream
Dim t As String
Dim r(5) As Variant
t = "233444:dshfjhdjfdhjfhjdhfjdhfjd"
r(0) = "122343:dsjdhfjhfjdh"
r(1) = "323243:jfjfghfjhjddj"
r(2) = "834783:gffghjkjkgjkj"
Set olApp = New Outlook.Application
Set m = olApp.CreateItem(olMailItem)
sigPath = "C:\Users\Pavan-Kumar\Desktop\vbs\TestEvents.htm"
Set fso = New Scripting.FileSystemObject
Set ts = fso.OpenTextFile(sigPath)
sigText = ts.ReadAll
ts.Close
Set fso = Nothing
sigText = Replace(sigText, "{{mytask}}", t)
sigText = Replace(sigText, "{{myRelatedTasks}}", Join(r, "<br>"))
With m
.display
.To = "somewhere#someplace.com"
.Subject = "Test Events"
.HTMLBody = sigText
End With
End Sub
And also when I am joining the related tasks , I want them to come one below another with indentation. I tried it with giving "\t" as the delimiter with no success.
My current O/P in outlook mail:
Here is what I did to solve the same issue:
Write an email with exactly the format you want
In the email, use something unique for the fields, like {{recipient name}}
Save the email as HTML. This is now your template for the email body. You might keep several different templates for different situations.
In VBA, open the appropriate template file and read the whole thing into a string.
Using the VBA command Replace, fill in your fields. For example strHTMLTemplate = Replace(strHTMLTemplate, "{{recipient name}}", "Jane Doe")
Assign the final string to .htmlBody
For the RelatedTasks, it looks like you just want them to be on a single row. In that case, just make a "field" in your template, {{RelatedTasks}} and then do a replace like so strHTMLTemplate = Replace(strHTMLTemplate, "{{RelatedTasks}}", Join(RelatedTasks, ", ")).
If you want to get fancy, you can write functions that converts arrays of strings into html lists or tables
I'm writing a script that creates and updates an outlook note. Everything works fine except for one issue.
It creates and updates the note on my personal mailbox and I need it to create and maintain the note on a department mailbox that we all have access to(I have two accounts set up in my Outlook).
It is behaving this way despite the script being triggered by a rule on the department mailbox and being given mail items for the department mailbox. How do I tell VBS/Outlook which notes folder/account I want to use? I cannot find anything anywhere that outlines how to select which account the note will be created under.
I am using Outlook 2016.
Set olkFolder = Session.GetDefaultFolder(olFolderNotes)
Set olkNote = olkFolder.Items.Find("[Subject] = 'Sequential Number'")
If TypeName(olkNote) = "Nothing" Then
Set olkNote = Application.CreateItem(olNoteItem)
olkNote.Body = "Sequential Number" & vbCrLf & "NextValue=" & STARTING_VALUE + 1
GetNextNumber = STARTING_VALUE
Else
arrLines = Split(olkNote.Body, vbCrLf)
For Each varLine In arrLines
If Left(varLine, 10) = "NextValue=" Then
GetNextNumber = CInt(Mid(varLine, 11))
olkNote.Body = "Sequential Number" & vbCrLf & "NextValue=" & GetNextNumber + 1
End If
Next
End If
Instead of using Application.CreateItem, either open the folder from another mailbox using Application.Session.CreateRecipient / Application.Session.GetSharedDefaultFolder and call MAPIFolder.Items.Add or (if the mailbox is already available in Outlook) drill down to that folder starting from Application.Session.Folders and (again) call MAPIFolder.Items.Add.
Replace
Set olkFolder = Session.GetDefaultFolder(olFolderNotes)
...
Set olkNote = Application.CreateItem(olNoteItem)
with
set recip = Session.CreateRecipient("SomeOtherUser#YourDomain.demo")
Set olkFolder = Session.GetSharedDefaultFolder(recip, olFolderNotes)
...
Set olkNote = olkFolder.Items.Add
You can either move the note you created or add directly to the folder in the other account.
From the link, the code to Add:
Sub AddContact()
Dim myNamespace As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim myItem As Outlook.ContactItem
Dim myOtherItem As Outlook.ContactItem
Set myNamespace = Application.GetNamespace("MAPI")
Set myFolder = myNamespace.GetDefaultFolder(olFolderContacts)
Set myOtherItem = myFolder.Items("Dan Wilson")
Set myItem = myFolder.Items.Add
myItem.CompanyName = myOtherItem.CompanyName
myItem.BusinessAddress = myOtherItem.BusinessAddress
myItem.BusinessTelephoneNumber = myOtherItem.BusinessTelephoneNumber
myItem.Display
End Sub
If you have the mailbox in your navigation pane, "navigate down the tree". https://stackoverflow.com/a/6116820/1571407
ns.Folders("Personal Folders").Folders("Inbox")
In your code:
Set olkFolder = ns.Folders("name of other mailbox").Folders("Notes")
Whether the folder is in your navigation pane or not you may use CreateRecipient as described in the other answer.
I am trying to extract email addresses of all emails in my Outlook inbox. I found this code on the Internet.
Sub GetALLEmailAddresses()
Dim objFolder As MAPIFolder
Dim strEmail As String
Dim strEmails As String
''' Requires reference to Microsoft Scripting Runtime
Dim dic As New Dictionary
Dim objItem As Object
''Set objFolder = Application.ActiveExplorer.Selection
Set objFolder = Application.GetNamespace("Mapi").PickFolder
For Each objItem In objFolder.Items
If objItem.Class = olMail Then
strEmail = objItem.SenderEmailAddress
If Not dic.Exists(strEmail) Then
strEmails = strEmails + strEmail + vbCrLf
dic.Add strEmail, ""
End If
I am using outlook 2007. When I run this code from the Outlook Visual Basic Editor with F5 I get an error on the following line.
Dim dic As New Dictionary
"user defined type not defined"
I have provided updated code below
to dump the Inbox email addresses to a CSV file "c:\emails.csv" (the current code provides no "outlook" for the collected addresses
the code above works on a selected folder rather than Inbox as per your request
[Update: For clarity this is your old code that uses "early binding", setting this reference is unnecessary for my updated code below which uses "late binding"]
Part A: Your existing code (early binding)
In terms of the error you received:
The code sample aboves uses early binding, this comment "Requires reference to Microsoft Scripting Runtime" indciates that you need to set the reference
Goto the Tools menu
Select 'References'
check "Microdoft Scripting Runtime"
Part B: My new code (late binding - setting the reference is unnecessary)
Working Code
Sub GetALLEmailAddresses()
Dim objFolder As MAPIFolder
Dim strEmail As String
Dim strEmails As String
Dim objDic As Object
Dim objItem As Object
Dim objFSO As Object
Dim objTF As Object
Set objDic = CreateObject("scripting.dictionary")
Set objFSO = CreateObject("scripting.filesystemobject")
Set objTF = objFSO.createtextfile("C:\emails.csv", 2)
Set objFolder = Application.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox)
For Each objItem In objFolder.Items
If objItem.Class = olMail Then
strEmail = objItem.SenderEmailAddress
If Not objDic.Exists(strEmail) Then
objTF.writeline strEmail
objDic.Add strEmail, ""
End If
End If
Next
objTF.Close
End Sub
export the file to C:\Users\Tony\Documents\sent file.CSV
Then use ruby
email_array = []
r = Regexp.new(/\b[a-zA-Z0-9._%+-]+#[a-zA-Z0-9.-]+\.[a-zA-Z]{2,4}\b/)
CSV.open('C:\Users\Tony\Documents\sent file.CSV', 'r') do |row|
email_array << row.to_s.scan(r)
end
puts email_array.flatten.uniq.inspect
Here's an updated version for those using Exchange. It converts Exchange format addresses to normal email addresses (with the # symbol).
' requires reference to Microsoft Scripting Runtime
Option Explicit
Sub Write_Out_Email_Addresses()
' dictionary for storing email addresses
Dim email_list As New Scripting.Dictionary
' file for output
Dim fso As New Scripting.FileSystemObject
Dim out_file As Scripting.TextStream
Set out_file = fso.CreateTextFile("C:\emails.csv", True)
' open the inbox
Dim ns As Outlook.NameSpace
Set ns = Application.GetNamespace("MAPI")
Dim inbox As MAPIFolder
Set inbox = ns.GetDefaultFolder(olFolderInbox)
' loop through all items (some of which are not emails)
Dim outlook_item As Object
For Each outlook_item In inbox.Items
' only look at emails
If outlook_item.Class = olMail Then
' extract the email address
Dim email_address As String
email_address = GetSmtpAddress(outlook_item, ns)
' add new email addresses to the dictionary and write out
If Not email_list.Exists(email_address) Then
out_file.WriteLine email_address
email_list.Add email_address, ""
End If
End If
Next
out_file.Close
End Sub
' get email address form a Mailoutlook_item
' this entails converting exchange format addresses
' (like " /O=ROOT/OU=ADMIN GROUP/CN=RECIPIENTS/CN=FIRST.LAST")
' to proper email addresses
Function GetSmtpAddress(outlook_item As Outlook.MailItem, ns As Outlook.NameSpace) As String
Dim success As Boolean
success = False
' errors can happen if a user has subsequently been removed from Exchange
On Error GoTo err_handler
Dim email_address As String
email_address = outlook_item.SenderEmailAddress
' if it's an Exchange format address
If UCase(outlook_item.SenderEmailType) = "EX" Then
' create a recipient
Dim recip As Outlook.Recipient
Set recip = ns.CreateRecipient(outlook_item.SenderEmailAddress)
' extract the email address
Dim user As Outlook.ExchangeUser
Set user = recip.AddressEntry.GetExchangeUser()
email_address = user.PrimarySmtpAddress
email_address = user.Name + " <" + user.PrimarySmtpAddress + ">"
success = True
End If
err_handler:
GetSmtpAddress = email_address
End Function
Kudos to http://forums.codeguru.com/showthread.php?441008-Extract-sender-s-email-address-from-an-Exchange-email and Brettdj
In outlook, export a folder to a csv file, then open in Excel. A simple MID function should be able to extract the email address if it's not been placed in a "from" column already.