Select Outlook Folder With Excel VBA - vba

I'm trying to bypass having to select the folder I want and just tell Excel to go ahead and count the "Inbox"
Sub Get_Emails()
Dim OLF As Outlook.MAPIFolder
Dim EmailItemCount As Long
Set OLF = GetObject("", "Outlook.Application").GetNamespace("MAPI").PickFolder
EmailItemCount = OLF.Items.Count
Range("A1") = EmailItemCount
Set OLF = Nothing
Application.StatusBar = False
End Sub
Does anyone know how I can just get the count without having to select the folder? Excel VBA should just automatically go into the "Inbox" and give me my count.
Note: You have to go to Tools > References > and select "Microsoft Outlook 14.0 Object Library" in order for this macro to work.

Here is something that works:
Option Explicit
Sub LoopFoldersInInbox()
Dim ns As Outlook.Namespace
Dim myfolder As Outlook.Folder
Dim mysubfolder As Outlook.Folder
Set ns = GetObject("", "Outlook.Application").GetNamespace("MAPI")
Set myfolder = ns.GetDefaultFolder(olFolderInbox)
For Each mysubfolder In myfolder.Folders
Debug.Print mysubfolder.name
Debug.Print mysubfolder.Items.Count
Next mysubfolder
End Sub
With some credits here. It is with early binding. Thus, if you press the dot in ns or mysubfolder you will see the properties and the actions they have:
Here is the late binding, thus you do not need to refer to the Outlook Library explicitly and the code would work on more users:
Option Explicit
Sub LoopFoldersInInbox()
Dim ns As Object
Dim objFolder As Object
Dim objSubfolder As Object
Set ns = GetObject("", "Outlook.Application").GetNamespace("MAPI")
Set objFolder = ns.GetDefaultFolder(6) ' 6 is equal to olFolderInbox
For Each objSubfolder In objFolder.Folders
Debug.Print objSubfolder.name
Debug.Print objSubfolder.Items.Count
Next objSubfolder
End Sub
In this late binding, I have used 6 in stead of olFolderInbox.
Edit:
If you want the results in the cells, use this code:
Option Explicit
Sub LoopFoldersInInbox()
Dim ns As Object
Dim objFolder As Object
Dim objSubfolder As Object
Dim lngCounter As Long
Set ns = GetObject("", "Outlook.Application").GetNamespace("MAPI")
Set objFolder = ns.GetDefaultFolder(6) ' 6 is equal to olFolderInbox
For Each objSubfolder In objFolder.Folders
With ActiveSheet
lngCounter = lngCounter + 1
.Cells(lngCounter, 1) = objSubfolder.Name
.Cells(lngCounter, 2) = objSubfolder.Items.Count
End With
Debug.Print objSubfolder.Name
Debug.Print objSubfolder.Items.Count
Next objSubfolder
End Sub

The below is more of what I am looking for but Vityana's code works very well too. It all depends on what you need. I would like to specify a folder within the "Inbox" but am currently unable to. This only gets the count for the "Inbox" but there are folders nested under the "Inbox" folder that I am unable to specify. Anyone know how to do that?
Sub HowManyEmails()
Dim objOutlook As Object, objnSpace As Object, objFolder As Object
Dim EmailCount As Integer
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
On Error Resume Next
Set objFolder = objnSpace.Folders("Joe.L.Smo#company.com").Folders("Inbox")
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder."
Exit Sub
End If
EmailCount = objFolder.Items.Count
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
[B2].Value = EmailCount
End Sub

You can just "continue the specification".
You had:
Set objFolder = objnSpace.Folders("Joe.L.Smo#company.com").Folders("Inbox")
To get -for example- the content of the subfolder Temp under the Inbox, specify:
Set objFolder = objnSpace.Folders("Joe.L.Smo#company.com").Folders("Inbox").Folders("Temp")
Hope this helps

Related

if there is that folder pass else create it

I would like to create a code if there is a folder in outlook than just pass and run the rest of the code else create the folder than just run the rest of the code
If objFolder Is Nothing Then
objFolder = objNS.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderInbox)
objFolder = objFolder.Folders.Add("test", Outlook.OlDefaultFolders.olFolderInbox)
End If
https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/object-required-error-424
You're not using Set to assign objFolder
In VBA Set is required when assigning objects to a variable.
See: What does the keyword Set actually do in VBA?
As already mentioned, you need to use the keyword Set to assign an object to a variable. The following code will first check whether the folder already exists. If not, it creates one.
Dim objFolder As Outlook.Folder
Dim objTestFolder As Outlook.Folder
Set objFolder = objNS.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderInbox)
On Error Resume Next
Set objTestFolder = objFolder.Folders("test")
If objTestFolder Is Nothing Then
Set objTestFolder = objFolder.Folders.Add("test", Outlook.OlDefaultFolders.olFolderInbox)
End If
On Error GoTo 0
Typically you should use the following construction:
If obj Is Nothing Then
' need to initialize obj: '
Set obj = ...
Else
' obj already set / initialized. '
End If
So, use the following code instead:
Sub MoveItems()
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.Folder
Dim myDestFolder As Outlook.Folder
Dim myitems As Outlook.Items
Dim myitem As Object
Dim objApp As Outlook.Application
Dim objFolder As Outlook.Folder
Dim objTestFolder As Outlook.Folder
Set myNameSpace = Application.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderInbox)
On Error Resume Next
Set objTestFolder = myInbox.Folders("test")
If objTestFolder Is Nothing Then
Set myDestFolder = myInbox.Folders.Add("test", Outlook.OlDefaultFolders.olFolderInbox)
End If
On Error GoTo 0
Set oDeletedItems = Application.Session.GetDefaultFolder(olFolderDeletedItems)
Set myitems = oDeletedItems.Items
Debug.Print myitems.Count
For I = myitems.Count To 1 Step -1
myitems.Item(I).Move myDestFolder
Next
End Sub

Reference to non-default non-English inbox

I am trying set a reference to a non-default inbox in MS Outlook. I have found a code in SO,
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders("Procurement, Request")
Set objFolder = objFolder.Folders("Inbox")
which is OK when inbox is named "Inbox".
There is a possibility for inboxes to be named in non-English languages.
You may refer to the default inbox by
objNS.getdefaultfolder(6)
But what about non-defaults?
You should be able to get inboxes by Store index or name.
Option Explicit
Sub Inbox_by_Store()
Dim allStores As Stores
Dim storeInbox As Folder
Dim i As Long
Set allStores = Session.Stores
For i = 1 To allStores.count
Debug.Print i & " DisplayName - " & allStores(i).DisplayName
Set storeInbox = Nothing
On Error Resume Next
Set storeInbox = allStores(i).GetDefaultFolder(olFolderInbox)
On Error GoTo 0
If Not storeInbox Is Nothing Then
storeInbox.Display
End If
Next
ExitRoutine:
Set allStores = Nothing
Set storeInbox = Nothing
End Sub

Shared Mailbox Management

I need a macro that will move messages received into a shared mailbox to a subfolder of that mailbox, depending on the sender's email address, basically a normal outlook rule.
I've been looking at some articles on http://www.slipstick.com/ which has got me part way there but there isn't an exact solution for what I want to do and I'm not proficient enough with VBA in Outlook yet to work it out.
So far I've got this code on ThisOutlookSession to watch the mailbox:
Dim i As Long
Private WithEvents olInboxItems As Items
Private Sub Application_Startup()
Dim objNS As NameSpace
Set objNS = Application.Session
Set olInboxItems = GetFolderPath(">Digital Analytics\Inbox").Items
Set objNS = Nothing
End Sub
And this function in a module to obtain the path of the watched mailbox folder:
' Use the GetFolderPath function to find a folder in non-default mailboxes
Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
Dim oFolder As Outlook.Folder
Dim FoldersArray As Variant
Dim i As Integer
On Error GoTo GetFolderPath_Error
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
If Not oFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = oFolder.Folders
Set oFolder = SubFolders.Item(FoldersArray(i))
If oFolder Is Nothing Then
Set GetFolderPath = Nothing
End If
Next
End If
'Return the oFolder
Set GetFolderPath = oFolder
Exit Function
GetFolderPath_Error:
Set GetFolderPath = Nothing
Exit Function
End Function
This works, I used a case to move the item if it came from a specific email address:
Dim i As Long
Private WithEvents olInboxItems As Items
Private Sub Application_Startup()
Dim objNS As NameSpace
Set objNS = Application.Session
Set olInboxItems = GetFolderPath(">Digital Analytics\Inbox").Items
Set objNS = Nothing
For Each Item In olInboxItems
End Sub
Private Sub olInboxItems_ItemAdd(ByVal Item As Object)
Dim objDestFolder As Outlook.MAPIFolder
Dim destFolder As String
Dim sendersAddress As String
If Item.Class = olMail Then
sendersAddress = Item.SenderEmailAddress
Select Case sendersAddress
Case "no-reply#omniture.com"
destFolder = ">Digital Analytics\Inbox\Reports"
Case "no-reply#edigitalresearch.com"
destFolder = ">Digital Analytics\Inbox\Reports"
End Select
Set objDestFolder = GetFolderPath(destFolder)
Item.Move objDestFolder
End If
End Sub

Searching Outlook Folder

I want to search a specific Outlook folder using an activecell value.
I tried Excel VBA for searching in mails of Outlook and VBA Search in Outlook.
The closest I was able to get:
Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.MAPIFolder
Dim myitems As Outlook.Items
Dim myitem As Object
Dim Found As Boolean
Dim OutlookSearch as string
Outlooksearch = Cstr(Activecell.cells(1,4).Value)
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myitems = myInbox.Items
Found = False
For Each myitem In myitems
If myitem.Class = olMail Then
If InStr(1, myitem.Subject, "sketch") > 0 Then
Debug.Print "Found"
Found = True
End If
End If
Next myitem
'If the subject isn't found:
If Not Found Then
MsgBox "Cannot find"
End If
myOlApp.Quit
Set myOlApp = Nothing
I want to use the string in Activecell.cells(1, 4) as the subject for a search in a specific Outlook folder in the inbox.
I get is the MsgBox even if I've sent an email containing values that match with activecell.
You can specify the folder to search in, within the inbox, by using the .Folders property.
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("myFolder")
I've had a play around and come up with the code below. No need to set references to Outlook.
Sub Test1()
Dim oOutlook As Object 'Outlook.Application
Dim nNameSpace As Object 'Outlook.Namespace
Dim mFolderSelected As Object 'Outlook.MAPIFolder
Dim cFolder As Object
Dim oItem As Object
Dim oMyItem As Object
Dim sOutlookSearch As String
Dim aFolders() As String
Dim i As Long
'sOutlookSearch needs to be something like:
'"Mailbox - Darren Bartrup-Cook\Inbox"
sOutlookSearch = ThisWorkbook.Worksheets("Sheet1").Cells(1, 4)
sOutlookSearch = Replace(sOutlookSearch, "/", "\")
aFolders() = Split(sOutlookSearch, "\")
Set oOutlook = GetObject(, "Outlook.Application")
Set nNameSpace = oOutlook.GetNamespace("MAPI")
Set mFolderSelected = nNameSpace.Folders.Item(aFolders(0))
If Not mFolderSelected Is Nothing Then
For i = 1 To UBound(aFolders)
Set cFolder = mFolderSelected.Folders
Set mFolderSelected = Nothing
Set mFolderSelected = cFolder.Item(aFolders(i))
If mFolderSelected Is Nothing Then
Exit For
End If
Next i
End If
'Set mFolderSelected = nNameSpace.PickFolder 'Alternative to above code block - just pick the folder.
For Each oItem In mFolderSelected.items
If oItem.class = 43 Then '43 = olmail
If InStr(1, oItem.Subject, "sketch") > 0 Then
Debug.Print "Found: " & oItem.sendername
Exit For
End If
End If
Next oItem
End Sub
The code block for finding the correct folder was taken from here:
http://www.outlookcode.com/d/code/getfolder.htm

Accessing another maibox in outlook using vba

I have two mailboxes in my Outlook.
One that is mine and it automatically logs me in when I log in to my pc and another I have that is for mail bounces.
I really need to access the inbox of the mail's account but I just can't seem to do it.
And there is no way I can make the mailbox of the mail account to be my default mailbox
Here is the code I have so far:
Public Sub GetMails()
Dim ns As NameSpace
Dim myRecipient As Outlook.Recipient
Dim aFolder As Outlook.Folders
Set ns = GetNamespace("MAPI")
Set myRecipient = ns.CreateRecipient("mail#mail.pt")
myRecipient.Resolve
If myRecipient.Resolved Then
MsgBox ("Resolved")
Set aFolder = ns.GetSharedDefaultFolder(myRecipient, olFolderInbox)
Else
MsgBox ("Failed")
End If
End Sub
The problem I am getting is at the
Set aFolder = ns.GetSharedDefaultFolder(myRecipient, olFolderInbox)
I get the Resolved msgbox so I know that is working but after that I get an error:
Run-Time Error
which doesn't say much about the error itself.
Can anyone help me out here please?
Thanks
If the folder you wish to access is not an Exchange folder, you will need to find it, if it is an Exchange folder, try logging on to the namespace.
Log on to NameSpace
Set oNS = oApp.GetNamespace("MAPI")
oNS.Logon
Find Folder
As far as I recall, this code is from Sue Mosher.
Public Function GetFolder(strFolderPath As String) As Object 'MAPIFolder
' strFolderPath needs to be something like
' "Public Folders\All Public Folders\Company\Sales" or
' "Personal Folders\Inbox\My Folder" ''
Dim apOL As Object 'Outlook.Application '
Dim objNS As Object 'Outlook.NameSpace '
Dim colFolders As Object 'Outlook.Folders '
Dim objFolder As Object 'Outlook.MAPIFolder '
Dim arrFolders() As String
Dim I As Long
On Error GoTo TrapError
strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")
Set apOL = CreateObject("Outlook.Application")
Set objNS = apOL.GetNamespace("MAPI")
On Error Resume Next
Set objFolder = objNS.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For I = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(I))
If objFolder Is Nothing Then
Exit For
End If
Next
End If
Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Set apOL = Nothing
End Function