|
Sub ListAllItemsInInbox()
Dim OLF As Outlook.MAPIFolder, CurrUser As String
Dim EmailItemCount As Integer, i As Integer, EmailCount As Integer
Application.ScreenUpdating = False
Workbooks.Add
Cells(1, 1).Formula = "Subject"
Cells(1, 2).Formula = "Recieved"
Cells(1, 3).Formula = "Attachments"
Cells(1, 4).Formula = "Read"
Cells(1, 5).Formula = "Importance"
Cells(1, 6).Formula = "Size"
With Range("A1:F1").Font
.Color = RGB(255, 153, 0)
.Name = "Comic Sans MS"
.Bold = True
.Size = 12
End With
Application.Calculation = xlCalculationManual
Set OLF = GetObject("", "Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
EmailItemCount = OLF.Items.Count
i = 0: EmailCount = 0
While i < EmailItemCount
i = i + 1
If i Mod 50 = 0 Then Application.StatusBar = "Creating email message record at " & Format(i / EmailItemCount, "0%") & "..."
With OLF.Items(i)
EmailCount = EmailCount + 1
Cells(EmailCount + 1, 1).Formula = .Subject
Cells(EmailCount + 1, 2).Formula = Format(.ReceivedTime, "dd-mmm-yyyy")
Cells(EmailCount + 1, 3).Formula = .Attachments.Count
Cells(EmailCount + 1, 4).Formula = Not .UnRead
Cells(EmailCount + 1, 5).Formula = .Importance
Cells(EmailCount + 1, 6).Formula = .Size
End With
Wend
Application.Calculation = xlCalculationAutomatic
Set OLF = Nothing
Columns("A:F").AutoFit
Range("A2").Select
ActiveWindow.FreezePanes = True
ActiveWorkbook.Saved = True
Application.StatusBar = False
End Sub |
|