Count Mailbox file size

[dicepackage]

I would like to write a program to count the size of several mailboxes in outlook as well as counting the size of the subfolders. I would like to use either Access or Excel to achieve this. I can get the program so it will calculate Inbox, Sent Items, Drafts, Trash but if I create a folder called Test it will not work.

How do I make it so it can see this folder Test? I would also like to see other shared mailboxes and be able to calculate the size on those as well.

Here is an example of the code I am currently using:

Option Explicit

Enum eFol
olFolDeletedItems = 3
olFolDrafts = 16
olFolInbox = 6
olFolSentMail = 5
End Enum

Sub exa_folsize()
Dim OL As Object '<--- Outlook.Application
Dim olNameSpace As Object '<--- NameSpace
Dim oDefFol As Object '<--- MAPIFolder
Dim olSubFol As Object '<--- MAPIFolder
Dim x As Long
Dim y As Long
Dim vntDef As Variant
Dim aryInfo As Variant
Dim aryOutput As Variant
With Range("A1:D1")
.Value = Array("Folder", "Size(kb)", "Subfolder(s)", "Size(kb)")
.Font.Bold = True
End With
'// To match above labels, as we initially do not know how many folders/subfolders //
'// we may find - we'll start an array with 4 rows and unk columns; then transpose //
'// later. //
ReDim aryInfo(1 To 4, 0 To 0)

'// I believe Outlook is single instance, so CreateObject should be okay. //
Set OL = CreateObject("Outlook.Application")
Set olNameSpace = OL.GetNamespace("MAPI")

Dim objTest As Outlook.MAPIFolder
For Each vntDef In Array(olFolDeletedItems, olFolSentMail, olFolDrafts, olFolInbox)
Set oDefFol = olNameSpace.GetDefaultFolder(vntDef)
If oDefFol.Items.Count > 0 Then
ReDim Preserve aryInfo(1 To 4, 1 To UBound(aryInfo, 2) + 1)
aryInfo(1, UBound(aryInfo, 2)) = oDefFol.Name
aryInfo(2, UBound(aryInfo, 2)) = AddSize(oDefFol)
End If
If oDefFol.Folders.Count > 0 Then
For Each olSubFol In oDefFol.Folders
ReDim Preserve aryInfo(1 To 4, 1 To UBound(aryInfo, 2) + 1)
aryInfo(3, UBound(aryInfo, 2)) = olSubFol.Name
aryInfo(4, UBound(aryInfo, 2)) = AddSize(olSubFol)
Next
End If
Next
ReDim aryOutput(1 To UBound(aryInfo, 2), 1 To 4)

For x = 1 To UBound(aryInfo, 2)
For y = 1 To 4
aryOutput(x, y) = aryInfo(y, x)
Next
Next

Range("A2").Resize(UBound(aryInfo, 2), 4).Value = aryOutput
Range("A1:D1").EntireColumn.AutoFit
End Sub

Function AddSize(Fol As Object) As Long 'Fol As MAPIFolder
Dim oMailItem As Object
Dim lSize As Long

lSize = 0
For Each oMailItem In Fol.Items
lSize = lSize + oMailItem.Size
Next
'// Return in KB //
AddSize = lSize \ 1024
End Function

[dicepackage]

I am also working on a different code set. If I can get either one working I will be happy. I would just like to change this example from Inbox to a folder I created called Test.


Dim objOutlook As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder, objUnknown As Object
Dim lngBytes As Long, intX As Integer

Set objOutlook = New Outlook.Application
Set objNS = objOutlook.GetNamespace("MAPI")
Set objFolder = objNS.GetDefaultFolder(olFolderInbox)

For intX = 1 To objFolder.Items.Count
lngBytes = lngBytes + objFolder.Items.item(intX).Size
Next

MsgBox "Folder size is " & lngBytes / 1024 & "kilo-bytes."

[dicepackage]

With a little more persistence and some more sample code I found online I was able to get this working. I'm posting the solution here in case anyone stumbles on this problem and needs a solution. Sorry for the lack of comments.


Function GetSubFolderSize(objFolder As MAPIFolder) As Long
Dim lFolderSize As Long
Dim objSubFolder As MAPIFolder

For Each objItem In objFolder.Items
lFolderSize = lFolderSize + objItem.Size
Next

For Each objSubFolder In objFolder.Folders
lFolderSize = lFolderSize + GetSubFolderSize(objSubFolder)
Next

GetSubFolderSize = lFolderSize
Set objFolder = Nothing
Set objItem = Nothing
End Function

Private Sub CommandButton1_Click()
Dim FolderSize As Long
Dim objSubFolder As MAPIFolder
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)

Set objOutlookToday = objNS.Folders("Mailbox - Shared Mailbox Name").Folders("Test")
'Will look for the folder Test in Mailbox - Shared Mailbox Name

' This 1st loop checks the root folder itself
For Each objItem In objOutlookToday.Items
FolderSize = FolderSize + objItem.Size
Next
' This next loop checks the subfolders. Omit this loop if you do not intend to check the subfolders
For Each objSubFolder In objOutlookToday.Folders
FolderSize = FolderSize + GetSubFolderSize(objSubFolder)
Next
MsgBox(FolderSize)
End Sub

[jumpjack]

Property "PR_MESSAGE_SIZE_EXTENDED" should do the trick:


Public Sub ShowQuotas()' Show Outlook Exhange user quotas
' ----------
' References:
' Accessing Exchange proerties: https://msdn.microsoft.com/EN-US/library/office/ff863046.aspx
' Outlook quotas: http://blogs.technet.com/b/outlooking/archive/2013/09/19/mailbox-quota-in-outlook-2010-general-information-and-troubleshooting-tips.aspx
' Properties for quotas: http://blogs.msdn.com/b/stephen_griffin/archive/2012/04/17/cached-mode-quotas.aspx
' Property format: https://msdn.microsoft.com/en-us/library/ee159391(v=exchg.80).aspx
' http://schemas.microsoft.com/mapi/proptag/0xQQQQRRRR
' QQQQ = id
' RRRR = type


Dim oStore As Store
Dim propertyAccessor As Outlook.propertyAccessor

For Each oStore In Outlook.Application.Session.Stores
' Set oStore = Outlook.Application.Session.Stores.item(1)
Debug.Print "Display name: " & oStore.DisplayName
Debug.Print "Type: " & oStore.ExchangeStoreType & " (";
If oStore.ExchangeStoreType = olAdditionalExchangeMailbox Then Debug.Print "olAdditionalExchangeMailbox)"
If oStore.ExchangeStoreType = olExchangeMailbox Then Debug.Print "olExchangeMailbox)"
If oStore.ExchangeStoreType = olExchangePublicFolder Then Debug.Print "olExchangePublicFolder)"
If oStore.ExchangeStoreType = olNotExchange Then Debug.Print "olNotExchange)"
If oStore.ExchangeStoreType = olPrimaryExchangeMailbox Then Debug.Print "olPrimaryExchangeMailbox)"
Debug.Print "Path: " & oStore.FilePath
Debug.Print "Cached (=online): " & oStore.IsCachedExchange


Set propertyAccessor = oStore.propertyAccessor
If oStore.ExchangeStoreType = olExchangePublicFolder Or oStore.ExchangeStoreType = olPrimaryExchangeMailbox Then
PR_QUOTA_WARNING = propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x341A0003") / 1024
PR_QUOTA_SEND = propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x341B0003") / 1024
PR_QUOTA_RECEIVE = propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x341C0003") / 1024
PR_MESSAGE_SIZE_EXTENDED = propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E080014") / 1024
PR_MESSAGE_SIZE_EXTENDED = PR_MESSAGE_SIZE_EXTENDED / 1024
Debug.Print "PR_QUOTA_WARNING: " & PR_QUOTA_WARNING & " MB"
Debug.Print "PR_QUOTA_SEND: " & PR_QUOTA_SEND & " MB"
Debug.Print "PR_QUOTA_RECEIVE: " & PR_QUOTA_RECEIVE & " MB"
Debug.Print "PR_MESSAGE_SIZE_EXTENDED (Inbox size): " & Round(PR_MESSAGE_SIZE_EXTENDED) & " MB (=" & Round(100 * PR_MESSAGE_SIZE_EXTENDED / PR_QUOTA_RECEIVE) & "%)"
Debug.Print "Free space: " & Round(PR_QUOTA_RECEIVE - PR_MESSAGE_SIZE_EXTENDED) & " MB"
Else
Debug.Print " Quota data not available for local storage"
End If
Debug.Print "------------"
Next
Set oStore = Nothing
End Sub

[jumpjack]

Short version:


Public Sub ShowQuotas() Dim oStore As Store
Dim propertyAccessor As Outlook.propertyAccessor

For Each oStore In Outlook.Application.Session.Stores
Set propertyAccessor = oStore.propertyAccessor
If oStore.ExchangeStoreType = olExchangePublicFolder Or oStore.ExchangeStoreType = olPrimaryExchangeMailbox Then
PR_MESSAGE_SIZE_EXTENDED = propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E080014") / 1024
PR_MESSAGE_SIZE_EXTENDED = PR_MESSAGE_SIZE_EXTENDED / 1024
Debug.Print "PR_MESSAGE_SIZE_EXTENDED (Inbox size): " & Round(PR_MESSAGE_SIZE_EXTENDED) & " MB (=" & Round(100 * PR_MESSAGE_SIZE_EXTENDED / PR_QUOTA_RECEIVE) & "%)"
End If
Debug.Print "------------"
Next
Set oStore = Nothing
End Sub