VBATools

Przeliczenie wiadomości z załącznikami

by on Oct.10, 2010, under Outlook, Porady

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

Count_Folders

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.

Count_Attach_at_Folders

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

Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.

:, , , ,

Leave a Reply

Recently Active Members

Profile picture of vbatools
Profile picture of Karol Stilger
Profile picture of marcinmachalowski
Profile picture of Joanna Subik
Profile picture of Anorak
Profile picture of programistaaccess
Profile picture of piotrpawlik
Profile picture of Emil Wasilewski
Profile picture of kicekpicek
Profile picture of coldfusion
Profile picture of Gosia Borzęcka
Profile picture of lukaszch
Profile picture of itadministracja
Profile picture of farbenia
Profile picture of Łukasz Kałużny
Profile picture of kabzinski
Profile picture of rtynski
Profile picture of leszekbetlinski
Profile picture of Iv
Profile picture of Justyna Spychała