export folder and subfolder size to excel

[OTWarrior]

I have been asked to find out the reason for an outlook account having such a large filesize, and was wanting to do a macro to export each subfolder name with it's size into excel, to see which is the largest, then use that for suitable archiving.

I have searched and have yet to find anything suitable. Anyone attempted this before?

[GTO]

Hi OTWarrior,

I've barely touched Outlook, so no doubt a crude attempt, but maybe enough to get the thread started?

In a Standard Module:

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")


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


Hope that helps,

Mark

[JP2112]

Outlook version?

In Outlook 2003, right-click on the mailbox name, go to "Properties for Mailbox ..." and click the "Folder Size" button.

[OTWarrior]

Outlook version?

In Outlook 2003, right-click on the mailbox name, go to "Properties for Mailbox ..." and click the "Folder Size" button.

I'm sorry, I forgot this website was called "Interface express" and not "VBA Express". My mistake....

[JP2112]

Your goal is to find out the reason why a particular Outlook account has a large file size. I've suggested one method for arriving at that goal. You're free to use or ignore it. What I don't understand is why you've polluted your goal by requiring that it be solved with VBA.

Asking a question on a help forum and then criticizing the answer when it isn't the one you wanted is only going to limit the amount of future help you receive.

[OTWarrior]

Your goal is to find out the reason why a particular Outlook account has a large file size. I've suggested one method for arriving at that goal. You're free to use or ignore it. What I don't understand is why you've polluted your goal by requiring that it be solved with VBA.

Asking a question on a help forum and then criticizing the answer when it isn't the one you wanted is only going to limit the amount of future help you receive.

first of all there are about 200 sub folders in this email account, so right clicking and using properties, then manually recording the number into excel will take ages.

As for me criticizing your answer, yes I will when it is not helpful at all, and makes it appear like you are just trying to add to your post count. This is a forum for code discussion. My question was has anyone done anything like this before, not what is the easiest way to find out one individual folder size at a time.

Consequently, posting arrogant and obvious answers to someone's thread will make people ignore your suggestions in future. I know I will.

PS: Often programmers like to know if something can be done, just out of curiosity, as well as for practical use. Yes, spending a day finding the solution to a programming problem, when the actual task could be done in a couple of hours may appear to be a waste of time, until someone asks for similar data. Then said tool can save time.

[Med1234]

The code below is perfect and what I am looking for however after several attempt I am not able to add a outlook brower tool to select the inbox I would like to scan - any one can help?



Hi OTWarrior,

I've barely touched Outlook, so no doubt a crude attempt, but maybe enough to get the thread started?

In a Standard Module:

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")


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


Hope that helps,

Mark

[SamT]

This is a 12 yo thread. Please start a new thread. You can link back to this thread.

this thread is now Closed.