I am connected to my company's MS Exchange. From my own Outlook profile, I access a generic mailbox. All incoming messages will be tagged to a category and then moved to a folder (Mailbox - Generic > Resolved). How can I generate a total count of each category in this folder?
Mailbox - Javen
Inbox
Sent Items
...
Mailbox - Generic
Inbox
Sent Items
Resolved
...
Each category will be named to a name...
Example: Red = John, Yellow = Peter, Purple = Peggy
This should get you going. It filters the folder a specified category. You can edit it to do loop of the Outlook Categories collection to get the counts. Or you could change it to be a function that returns the count...passing the Category name as a parameter.
Private Sub CountbyCategory()
Dim fldr As Outlook.Folder = Nothing
Dim itms As Outlook.Items = Nothing
Dim filteredItms As Outlook.Items = Nothing
'Do this for each category...
Dim typeFilter As String = "[Category] = " & Chr(39) & "INSERT CATEGORY NAME HERE" & Chr(39)
'This assumes default inbox, you'll need to select you folder...maybe use PickFolder?
'fldr = Application.Session.PickFolder()
fldr = Application.Session.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderInbox)
itms = fldr.Items
filteredItms = itms.Restrict(typeFilter)
Dim iCount As Integer = filteredItms.Count
'Repeat for each category
End Sub
You can learn more about working with Outlook items here:
Working with Outlook mail items: how to create, delete, access & enumerate
Working with Outlook Accounts, Stores, Folders and Items
Related
In my company we have a number of different email addresses which go to "Shared Inbox" accounts that are managed by a few people.
We want to keep track of how many emails are in each Inbox.
A user might look after several different shared inboxes, and no one user has access to the same set of inboxes.
The VBA code I have loops through all of the logged-in user's shared inboxes and counts how many emails are in each inbox folder which isn't their own "personal" inbox and logs that data to a table using a separate procedure:
Sub WorkPosition()
Dim ThisUser As String
Dim Mailbox As Object
Dim MailBoxName As String
Dim oStore As Outlook.Store
Dim olFolder As Outlook.Folder
ThisUser = UCase(Environ("UserName"))
For x = Application.Session.Stores.Count To 1 Step -1
Set Mailbox = Nothing
On Error Resume Next
Set Mailbox = Application.Session.Stores(x)
On Error GoTo 0
If Mailbox Is Nothing Then GoTo SkipMailbox
MailBoxName = Mailbox
If InStr(UCase(Mailbox), ThisUser) = 0 Then
Set olFolder = Mailbox.GetDefaultFolder(olFolderInbox)
Set objItems = olFolder.Items
MailCount = objItems.Count
LogFolder MailBoxName, MailCount, ThisUser 'Run the "Logfolder" sub which logs the data
End If
SkipMailbox:
Next x
End Sub
This all works, except users don't name their shared inbox accounts very well. Several users have the same name for their shared inbox, but they're associated to different email addresses.
For example:
Charles might have info#mycompany.com as an Outlook store named "Customer Questions"
David might have queries#mycompany.com as an Outlook store also named "Customer Questions"
When Charles and David log their mail counts using my VBA code, they are both being logged with the MailBoxName as "Customer Questions".
I've come to the conclusion that I don't want to log the mailbox name. I want to log the email address instead, which they can't change and will be unique to that inbox.
I am able to do this if there is an email in the inbox, since I can just take the "to" address from the first mail item in the folder, but not if there are 0 emails in the folder.
How can I extract the incoming email address(es) which are associated to a user's Outlook store into a VBA string, so that I can pass it to my "LogFolder" procedure?
Outlook Object Model does not expose anything like that.
If using Redemption is an option (I am its author), it exposes RDOExchangeMailbox.Owner property (returns RDOAddressEntry object):
skPrimaryExchangeMailbox = 3
skDelegateExchangeMailbox = 4
set Session = CreateObject("Redemption.RDOSession")
Session.MAPIOBJECT = Application.Session.MAPIOBJECT
for each Store in Session.Stores
If (Store.StoreKind = skPrimaryExchangeMailbox) or (Store.StoreKind = skDelegateExchangeMailbox)Then
Debug.Print Store.Name & " : " & Store.Owner.SMTPAddress
End If
next
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
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.
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.
I wish to create a VBA program to remove items within the Deleted Items folder of my outlook. However, I only wish to remove such items from the certain users through matching a loose string.
For example, deleting all emails within the Deleted Items box from any user with address like "Plan_Group_", given I may receive emails from "Plan_Group_1", "Plan_Group_2","Plan_Group_3",...etc.
At present this is what I have for deletion, but it is for all items within the Deleted Items box:
Sub RemoveAutomaticItemsInDeletedItems()
Dim oDeletedItems As Outlook.Folder
Dim oItems As Outlook.Items
Dim i As Long
'Obtain a reference to deleted items folder
Set oDeletedItems = Application.Session.GetDefaultFolder(olFolderDeletedItems)
Set oItems = oDeletedItems.Items
For i = oItems.Count To 1 Step -1
oItems.Item(i).Delete
Next
End Sub
How can I extend this to only look for emails that loosely match a from address string?
Use an If statement to check the email address:
If TypeName(oItems.Item(i)) = "MailItem" And oItems(i).SenderEmailAddress Like "Plan_Group_*" Then
oItems.Item(i).Delete
End If
Or:
If TypeName(oItems.Item(i)) = "MailItem" And Left$(oItems(i).SenderEmailAddress, 11) = "Plan_Group_" Then
oItems.Item(i).Delete
End If
Just 2 ways of doing it