VBATools

Sprawdzenie wielkości folderów realizuje się z poziomu prawego kliku na folderze i uruchomienie „Właściwości folderu/Rozmiar folderu”.

Rys. 1. Rozmiar folderu z podfolderami.

Ale czy ciekawi was ile posiadacie obiektów typu email, a ile z nich to wiadomości z załącznikami? Ile zajmują miejsca w waszych folderach? Na to pytanie odpowie wam poniżej umieszczony kod VBA.

Rys. 2. Ekran informujący o ilości załączników w Outlooku.

Powyższy ekran pokazuje ilość obiektów w folderach, wiadomości, wiadomości z załącznikami oraz ilość sumaryczną załączników i ich wielkość. Aby przygotować się utworzenia obiektów należy w developerze VBA utworzyć formę a w niej osadzić obiekt ListView z pakietu MSCOMCTL.OCX

Kod przewiduje uruchomienie ekranu z poziomu folderu nadrzecznego jak i podfolderu. Oczekiwanie na wynik jest uzależniony od ilości danych w Outlooku i miejsca uruchomienia.

W module osadzamy procedurę wywołującą formę, którą to można dodać pod przyciskiem w menu Outlooka. Operację tą tłumaczy artykuł:  Uruchamianie makr przyciskiem na pasku narzędzi

Sub Show_sum_of_attach()
 UserForm1.Show
End Sub

W formie dodajemy poniższy kod:

Option Explicit
'MVP OShon from VBATools.pl
Dim oFolder As MAPIFolder, oMail As MailItem, x&, y&
Dim Attach_Count&, msgItems&, msgItemsWithAttach&, AttachSize&
Dim sFolder As MAPIFolder
Dim itmX As ListItem

Private Sub UserForm_Initialize()
Dim clmX As ColumnHeader
With Me
 .Caption = "Machine by OShon from VBATools.pl"
 .Width = 402
 .Height = 177
End With
With ListView1
 Set clmX = .ColumnHeaders.Add(, , "Folders", .Width / 4.5)
 Set clmX = .ColumnHeaders.Add(, , "Objects", .Width / 8.1)
 Set clmX = .ColumnHeaders.Add(, , "Messages", .Width / 8.1)
 Set clmX = .ColumnHeaders.Add(, , "Mess.with Attachments", .Width / 6)
 Set clmX = .ColumnHeaders.Add(, , "Attach. Count", .Width / 6)
 Set clmX = .ColumnHeaders.Add(, , "Sum Size", .Width / 6.5)
 .FullRowSelect = True
 .GridLines = True
 .View = lvwReport
 .Top = 2
 .Left = 2
 .Width = 384
 .Height = 144
End With
Set clmX = Nothing
Call AttachCount
End Sub

Private Sub AttachCount()
Dim OnlyOnes As Boolean: OnlyOnes = False
Set sFolder = Application.ActiveExplorer.CurrentFolder
If sFolder.Folders.Count = 0 Then
 Set oFolder = Application.ActiveExplorer.CurrentFolder
 OnlyOnes = True
 GoTo StartCelected
End If
For Each oFolder In sFolder.Folders
StartCelected:
 msgItems = 0: Attach_Count = 0: msgItemsWithAttach = 0: AttachSize = 0

 For x = 1 To oFolder.Items.Count
 If oFolder.Items(x).Class = 43 Then
 Set oMail = oFolder.Items(x)
 DoEvents
 If oMail.Attachments.Count > 0 Then
 msgItemsWithAttach = msgItemsWithAttach + 1
 Attach_Count = Attach_Count + oMail.Attachments.Count
 For y = 1 To oMail.Attachments.Count
 AttachSize = AttachSize + oMail.Attachments.item(y).Size
 Next y
 End If
 msgItems = msgItems + 1
 End If
 Next x

 Set itmX = ListView1.ListItems.Add(, , oFolder.Name)
 itmX.SubItems(1) = oFolder.Items.Count
 itmX.SubItems(2) = msgItems
 itmX.SubItems(3) = msgItemsWithAttach
 itmX.SubItems(4) = Attach_Count
 itmX.SubItems(5) = Format(AttachSize  1024, "##,##0") & " KB"
 Set itmX = Nothing

If OnlyOnes = True Then
'Only code AttachCount, without Listview control
'MsgBox "In current folder " & Chr(34) & oFolder.Name & Chr(34) & " found " & oFolder.Items.Count & " object." & vbCr & _
 "Among these objects are " & msgItems & " messages." & vbCr & _
 "In among them, found " & msgItemsWithAttach & " messages with attachments." & vbCr & _
 "The sum is equal to " & Attach_Count & " attachments who weigh " & Format(AttachSize  1024, "##,##0") & " KB", _
 vbInformation, "Machine by OShon from VBATools.pl"
 GoTo TheEnd
End If
Next oFolder
TheEnd:
Set sFolder = Nothing
Set oFolder = Nothing
Set oMail = Nothing
End Sub

Osadzenie procedury znajdziecie w artykule: Instalacja i uruchamianie makr, przetłumaczenie nazw kolumn oraz komunikatów pozostawiam wam.

Artykuł dotyczy: Microsoft Outlook 2000/2003/XP/2007.

(c) Shon Oskar – www.VBATools.pl