MS Outlook change subject line of all drafts - vba

I need to change the subject line of 1000s of emails in my drafts.
Here is the code I'm using but it's not changing the subject line. Could someone please let me know what I'm missing.
Sub Drafts_Send()
Dim objDrafts As Outlook.Items
Dim objDraft As Object
Dim strPrompt As String
Dim nResponse As Integer
Dim i As Long
Set objDrafts = Outlook.Application.Session.GetDefaultFolder(olFolderDrafts).Items
For i = objDrafts.Count To 1 Step -1
If objDrafts.Item(i).Subject = "Please Thank You" Then
objDrafts.Item(i).Subject = "Please & Thank You"
objDrafts.Item(i).Save
End If
Next i
Set objDrafts = Nothing
End Sub

My guess is that the default Drafts folder is not the folder containing the drafts you wish to update.
Run this macro:
Sub DsplStoreContainingfDefaultDrafts()
Dim NS As Outlook.NameSpace
Dim DefaultInboxFldr As MAPIFolder
Set NS = CreateObject("Outlook.Application").GetNamespace("MAPI")
Set DefaultInboxFldr = NS.GetDefaultFolder(olFolderDrafts)
Debug.Print "Default Drafts folder in """ & DefaultInboxFldr.Parent.Name & """"
End Sub
On my system it outputs:
Default Drafts folder in "Outlook Data File"
“Outlook Data File” is the default store that came with the installation but it is only used for information not associated with an email account. Outlook has created a separate store for each of my email accounts with names like JohnSmith#AcmeIsp.com and JohnSmith#gmail.com. Each of those stores has its own Drafts folder and drafts are in the Drafts folder of the account from which I will send the email.
Go to the folder containing the drafts you wish to update. Is it within the store identified by my macro? If not continue reading.
The complication is that on my system, Drafts is a top level folder in the store for my regular ISP account but a second level folder in folder for my gmail account.
You will need to replace:
Set objDrafts = Outlook.Application.Session.GetDefaultFolder(olFolderDrafts).Items
Outlook.Application. is redundant since you are running this within Outlook.
If you store is like my regular ISP account, you will need something like:
Set objDrafts = Session.Folders("JohnSmith#AcmeIsp.com").Folders("Drafts").Items
If you store is like my gmail account, you will need something like:
Set objDrafts = Session.Folders("JohnSmith#gmail.com").Folders("[Gmail]").Folders("Drafts").Items

There are some tricks you can try.
.DoEvents, .GetInspector and as a last resort .Display.
Sub Drafts_Send()
Dim objDrafts As Items
Dim objDraft As Object
Dim i As Long
Set objDrafts = Session.GetDefaultFolder(olFolderDrafts).Items
For i = objDrafts.Count To 1 Step -1
If objDrafts.Item(i).Class = olMail Then
Set objDraft = objDrafts.Item(i)
With objDraft
If .Subject = "Please Thank You" Then
' this has some .Display behaviour, without displaying
.GetInspector
'.Display ' as a last resort
objDrafts.Item(i).Subject = "Please & Thank You"
DoEvents
' if in Draft folder reading pane should be off
.Save
End If
End With
Set objDraft = Nothing
End If
Next
Set objDrafts = Nothing
End Sub

Related

List all Email in folder using Outlook MAPI

I'd like to list all of my emails in a specific folder by using Outlook MAPI. I have tried the following code,
but it only shows 400 out of the 20,000 emails in the folder. I would greatly appreciate it if anyone could please show me how to list all of the emails.
Sub EmailListinFolder()
Dim mn As Long
Dim Message As String
Dim item As Object
Dim NS As Object
Dim Folder As Object
'Get the MAPI Name Space
Set NS = CreateObject("Outlook.Application").GetNamespace("MAPI")
'Allow the user to select a folder in Outlook
Set Folder = NS.PickFolder
For Each item In Folder.Items
If item.Class = olMail Then
Message = item.Subject & "|" & item.CreationTime
If Len(Message) Then
mn = mn + 1
End If
End If
Next item
MsgBox (mn)
End Sub
Is that an online profile? Most likely you end up opening too many items (for each loop keeps all items referenced until the loop exits). Use Table object instead - see example at https://msdn.microsoft.com/VBA/Outlook-VBA/articles/folder-gettable-method-outlook.

Outlook Count Emails mark as Important

Can someone point out what I am missing here. Every time I run this it says that an object is required.
I apologize I feel like this is a very easy fix but I have been wrecking my brain for a while.
Basically what I am trying to accomplish is count how many emails are mark as high importance.
Again I feel like this is such a simple error but I am still learning this.
Sub CheckForImportance()
Dim myNs As Outlook.NameSpace
Dim infldr As Outlook.Folder
Dim impMail As Outlook.MailItem
Dim ttlcount As Integer
Set myNs = Application.GetNamespace("MAPI")
Set infldr = myNs.GetDefaultFolder(olFolderInbox)
Set impMail = infldr.Items
Set ttlcount = 0
If impMail.Importance = olImportanceHigh Then ttlImp = ttlImp + 1
MsgBox ("count:" & ttlImp)
End Sub
Outlook stores mail items, calendar items, tasks and so on in files it calls Stores. Sometimes people say mail items and so on are stored in PST files which is usually true. However, all PST files are stores but not all stores are PST files.
I remember when the default was for messages sent to any of your email addresses to be loaded to the same store. In that situation, Set infldr = myNs.GetDefaultFolder(olFolderInbox)was useful since the default Inbox was in that one store.
With Outlook 2016, and perhaps some other recent versions, the default is to have a separate store for each email address. Each of these stores is named for the email address, for example: “JohnDoe#hotmail.com” or “DoeJ#gmail.com”.
Copy this macro to an Outlook module and run it:
Sub DsplUsernameOfDefaultStore()
Dim NS As Outlook.NameSpace
Dim DefaultInboxFldr As MAPIFolder
Set NS = CreateObject("Outlook.Application").GetNamespace("MAPI")
Set DefaultInboxFldr = NS.GetDefaultFolder(olFolderInbox)
Debug.Print DefaultInboxFldr.Parent.Name
End Sub
On my system, this macro outputs “Outlook Data File”. This was the default store that came with Outlook but none of my emails are loaded to it.
You will need something like:
Set infldr = Session.Folders("Xxxx").Folders("Inbox")
where Xxxx is the name of the store containing the Inbox you wish to interrogate.
Below I have three alternative macros that count the number of high importance emails in an Inbox. Points of particular note:
Version 1 uses a For Each loop as I suggested in my comment. Version 2 uses a For IndexVariable loop. To my knowledge, neither type of For has an advantage over the other. I use whichever seems more convenient for the task at hand. Version 3 uses a filter. I have not found a use for the Outlook filter often enough to have become expert in its use so I normally use a For loop. olImportanceHigh is a constant with a value of 2. It appears you cannot use a constant within a Restrict string which is why it says [Importance] = 2.
I find Debug.Print much more convenient than MsgBox during development.
Come back with questions about my code as necessary.
Option Explicit
Sub CountHighImportanceEmails1()
Dim FldrInbox As Folder
Dim MailItemCrnt As MailItem
Dim NumEmailsHighImport As Long
Set FldrInbox = Session.Folders("Xxxx").Folders("Inbox")
NumEmailsHighImport = 0
For Each MailItemCrnt In FldrInbox.Items
If MailItemCrnt.Importance = olImportanceHigh Then
NumEmailsHighImport = NumEmailsHighImport + 1
End If
Next
Debug.Print "Number of high importance emails=" & NumEmailsHighImport
End Sub
Sub CountHighImportanceEmails2()
Dim FldrInbox As Folder
Dim InxMi As Long
Dim NumEmailsHighImport As Long
Set FldrInbox = Session.Folders("Xxxx").Folders("Inbox")
NumEmailsHighImport = 0
With FldrInbox
For InxMi = 1 To .Items.Count
If .Items(InxMi).Importance = olImportanceHigh Then
NumEmailsHighImport = NumEmailsHighImport + 1
End If
Next
End With
Debug.Print "Number of high importance emails=" & NumEmailsHighImport
End Sub
Sub CountHighImportanceEmails3()
Dim FldrInbox As Folder
Dim MailItemsHighImport As Items
Set FldrInbox = Session.Folders("Xxxx").Folders("Inbox")
Set MailItemsHighImport = FldrInbox.Items.Restrict("[Importance] = 2")
Debug.Print "Number of high importance emails=" & MailItemsHighImport.Count
End Sub
Example would be
Option Explicit
Public Sub Example()
Dim Inbox As Outlook.folder
Set Inbox = Application.Session.GetDefaultFolder( _
olFolderInbox)
Dim Filter As String
Filter = "[Importance] = 2"
Dim Items As Outlook.Items
Set Items = Inbox.Items.Restrict(Filter)
Debug.Print Items.Count
MsgBox Items.Count & " High importance Items are in " & Inbox.Name
End Sub

How to .SaveAs non-unique sent email to Windows folder

I have VBA code whose main functions are:
Load a form
Allow a user to choose a stock email response
Open a word document with the full response text
Create a reply using the text
Search the email and create a collection of strings containing corporate file numbers
Add the file numbers to an Excel list
Send the response
Now I want to save one copy of the sent item in a Windows folder, for each file number. I’ve been trying to wait until the item is sent and moved to Sent Items. The problem is that after calling the send method, the mailitem doesn’t send or move to Sent Items until after the code finishes so I end up in an infinite loop.
All the options I found involve using a class module and WithEvents. That would work if I wanted to copy every sent item to the folder. I can’t think of any criteria that would differentiate the emails created by this macro from normal emails. I could go into the Excel list of files, but that would bog everybody’s machine down on every send.
Is there a way to just have the email send find out when it has been sent and moved to sent items? My code to send, wait for it to go to sent items, and to save the emails is below. Note I have two global variables: cReply (Outlook.MailItem – the reply) and fNums (Collection – the file numbers).
I'm coding in Outlook 2016, but hope to move the module to Outlook 2010 at work.
Sub Send()
Dim badChar As String
badChar = "\/:*?™""® <>|.&##_+`©~;-+=^$!,'" & Chr(34)
Dim x As Integer
Dim fName As String
Dim inSentItems As Boolean
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olFldr As Outlook.MAPIFolder
Dim cSent As Outlook.MailItem
Dim sentMoment As Date
fName = cReply.Subject
For x = 1 To Len(badChar)
fName = Replace(fName, Mid(badChar, x, 1), "-")
Next x
Set olApp = GetObject(, "Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")
Set olFldr = olNS.GetDefaultFolder(olFolderSentMail)
inSentItems = True
x = olFldr.Items.Count
sentMoment = Now
cReply.Send
Do While olFldr.Items.Count <> x + 1
If Now - sentMoment > TimeValue("0:00:10") Then
inSentItems = False
Exit Do
End If
DoEvents
Loop
If inSentItems Then
Set cSent = olFldr.Items(olFldr.Items.Count)
For x = 1 To fNums.Count
cSent.SaveAs sentFldrPth & fNums.Item(x) & " - " & fName & ".msg", olMSG
Next x
'cSent.Delete
End If
Set olApp = Nothing
Set olNS = Nothing
Set olFldr = Nothing
End Sub
You could use SaveSentMessageFolder to save to another folder.
https://msdn.microsoft.com/en-us/library/office/ff868473.aspx
Monitor this other folder with ItemAdd code. You could move the mail to the Sent Items folder once done.

How to Create Task in Shared Task List?

I'm trying to convert an email to task and place that task inside a shared task folder. My co-worker shared the folder and has given me owner access to the folder as well.
We have utilized the script on slipstick to accomplish this. This code does work for my co-worker, but does not work for me.
When I dig into the list of folders I see my personal task list as a folder and not the shared folder. (Via the code below)
Is there any way that I can add a task to a shared task folder?
Public strFolders As String
Public Sub GetFolderNames()
Dim olApp As Outlook.Application
Dim olSession As Outlook.NameSpace
Dim olStartFolder As Outlook.MAPIFolder
Dim lCountOfFound As Long
lCountOfFound = 0
Set olApp = New Outlook.Application
Set olSession = olApp.GetNamespace("MAPI")
' Allow the user to pick the folder in which to start the search.
Set olStartFolder = olSession.PickFolder
' Check to make sure user didn't cancel PickFolder dialog.
If Not (olStartFolder Is Nothing) Then
' Start the search process.
ProcessFolder olStartFolder
End If
' Create a new mail message with the folder list inserted
Set ListFolders = Application.CreateItem(olMailItem)
ListFolders.Body = strFolders
ListFolders.Display
' clear the string so you can run it on another folder
strFolders = ""
End Sub
Sub ProcessFolder(CurrentFolder As Outlook.MAPIFolder)
Dim i As Long
Dim olNewFolder As Outlook.MAPIFolder
Dim olTempFolder As Outlook.MAPIFolder
Dim olTempFolderPath As String
' Loop through the items in the current folder.
For i = CurrentFolder.Folders.Count To 1 Step -1
Set olTempFolder = CurrentFolder.Folders(i)
olTempFolderPath = olTempFolder.FolderPath
' Get the count of items in the folder
olCount = olTempFolder.Items.Count
'prints the folder path and name in the VB Editor's Immediate window
Debug.Print olTempFolderPath & " " & olCount
' prints the folder name only
' Debug.Print olTempFolder
' create a string with the folder names.
' use olTempFolder if you want foldernames only
strFolders = strFolders & vbCrLf & olTempFolderPath & " " & olCount
lCountOfFound = lCountOfFound + 1
Next
' Loop through and search each subfolder of the current folder.
For Each olNewFolder In CurrentFolder.Folders
'Don't need to process the Deleted Items folder
If olNewFolder.Name <> "Deleted Items" Then
ProcessFolder olNewFolder
End If
Next
End Sub
In addition the Task folder, you will need permission to your co-worker's Mailbox. (Not Inbox nor other folders.)
If you add the mailbox to your profile, see the accepted answer here.
If you do not add the mailbox to your profile, see the answer describing GetSharedDefaultFolder. Redemption is not required.

For Each loop: Some items get skipped when looping through Outlook mailbox to delete items

I wanted to develop VBA code that:
Loops through all email items in mailbox
If there are any type of other items say "Calendar Invitation" skips that item.
Finds out the emails with attachments
If attached file has ".xml" extension and a specific title in it, saves it to a directory, if not it keeps searching
Puts all email includes .xml attachments to "Deleted Items" folder after doing step 4 and deletes all emails in that folder by looping.
Code works perfect EXCEPT;
For example
There are 8 email received with ".xml" file attached to each one of them in your mailbox.
run the code
you will see only 4 of the 8 items are processed successfully, other 4 remain in their positions.
If you run the code again, now there would be 2 items processed successfully and other 2 remain in your mailbox.
Problem: After running the code, it is supposed to process all files and deletes them all not the half of them in each run. I want it to process all items at a single run.
BTW, this code runs every time I open the Outlook.
Private Sub Application_Startup()
'Initializing Application_Startup forces the macros to be accessible from other offic apps
'Process XML emails
Dim InboxMsg As Object
Dim DeletedItems As Outlook.Folder
Dim MsgAttachment As Outlook.Attachment
Dim ns As Outlook.NameSpace
Dim Inbox As Outlook.Folder
Dim fPathTemp As String
Dim fPathXML_SEM As String
Dim fPathEmail_SEM As String
Dim i As Long
Dim xmlDoc As New MSXML2.DOMDocument60
Dim xmlTitle As MSXML2.IXMLDOMNode
Dim xmlSupNum As MSXML2.IXMLDOMNode
'Specify the folder where the attachments will be saved
fPathTemp = "some directory, doesn't matter"
fPathXML_SEM = "some directory, doesn't matter"
fPathEmail_SEM = "some directory, doesn't matter"
'Setup Outlook
Set ns = GetNamespace("MAPI")
Set Inbox = ns.Folders.Item("mailbox-name").Folders("Inbox")
Set DeletedItems = ns.Folders.Item("mailbox-name").Folders("Deleted Items")
'Loop through all Items in Inbox, find the xml attachements and process if they are the matching reponses
'On Error Resume Next
For Each InboxMsg In Inbox.Items
If InboxMsg.Class = olMail Then 'if it is a mail item
'Check for xml attachement
For Each MsgAttachment In InboxMsg.Attachments
If Right(MsgAttachment.DisplayName, 3) = "xml" Then
'Load XML and test for the title of the file
MsgAttachment.SaveAsFile fPathTemp & MsgAttachment.FileName
xmlDoc.Load fPathTemp & MsgAttachment.FileName
Set xmlTitle = xmlDoc.SelectSingleNode("//title")
Select Case xmlTitle.Text
Case "specific title"
'Get supplier number
Set xmlSupNum = xmlDoc.SelectSingleNode("//supplierNum")
'Save the XML to the correct folder
MsgAttachment.SaveAsFile fPathXML_SEM & xmlSupNum.Text & "_" & Format(Date, "yyyy-mm-dd") & ".xml"
'Save the email to the correct folder
InboxMsg.SaveAs fPathEmail_SEM & xmlSupNum.Text & "_" & Format(Date, "yyyy-mm-dd") & ".msg"
'Delete the message
InboxMsg.Move DeletedItems
Case Else
End Select
'Delete the temp file
On Error Resume Next
Kill fPathTemp & MsgAttachment.FileName
On Error GoTo 0
'Unload xmldoc
Set xmlDoc = Nothing
Set xmlTitle = Nothing
Set xmlSupNum = Nothing
End If
Next
End If
Next
'Loop through deleted items and delete
For Each InboxMsg In DeletedItems.Items
InboxMsg.Delete
Next
'Clean-up
Set InboxMsg = Nothing
Set DeletedItems = Nothing
Set MsgAttachment = Nothing
Set ns = Nothing
Set Inbox = Nothing
i = 0
End Sub
Likely cause: When you do this InboxMsg.Move, all of the messages in your inbox after the one that was moved are bumped up by one position in the list. So you end up skipping some of them. This is a major annoyance with VBA's For Each construct (and it doesn't seem to be consistent either).
Likely solution: Replace
For Each InboxMsg In Inbox.Items
with
For i = Inbox.Items.Count To 1 Step -1 'Iterates from the end backwards
Set InboxMsg = Inbox.Items(i)
This way you iterate backward from the end of the list. When you move a message to deleted items, then it doesn't matter when the following items in the list are bumped up by one, because you've already processed them anyway.
It's often not a good idea to modify the contents of a (sub)set of items while looping over them. You could modify your code so that it first identifies all of the items that need to be processed, and adds them to a Collection. Then process all the items in that collection.
Basically you shouldn't be removing items from the Inbox while you're looping through its contents. First collect all the items you want to process (in your Inbox loop), then when you're done looping, process that collection of items.
Here's some pseudo-code which demonstrates this:
Private Sub Application_Startup()
Dim collItems As New Collection
'Start by identifying messages of interest and add them to a collection
For Each InboxMsg In Inbox.Items
If InboxMsg.Class = olMail Then 'if it is a mail item
For Each MsgAttachment In InboxMsg.Attachments
If Right(MsgAttachment.DisplayName, 3) = "xml" Then
collItems.Add InboxMsg
Exit For
End If
Next
End If
Next
'now deal with the identified messages
For Each InboxMsg In collItems
ProcessMessage InboxMsg
Next InboxMsg
'Loop through deleted items and delete
For Each InboxMsg In DeletedItems.Items
InboxMsg.Delete
Next
End Sub
Sub ProcessMessage(InboxMsg As Object)
'deal with attachment(s) and delete message
End Sub