G
Graeme
Hello,
Within an excel worksheet I have created a named range called "Outlook
Folders". The entries
in this named range correspond to the names of the email subfolders within
my default outlook email pst file.
Modifying some VBA which I sourced off the Net I have been able to extract
various fields from my
default outlook email pst file where there is a match back to the subfolder
list contained within my named range.
This is great but I am having trouble trying to generalise the code so that
it also looks at non default pst files.
I have several old pst files which I would like to query with this VBA macro
but I can't seem to get it to work.
e.g I have a pst file called "OldEmail" which shows up when I open outlook.
Some preliminary net searching indicates that I need to somehow modify the
following code, perhaps subsituting "GetSharedDefaultFolder"
for "GetDefaultFolder".
Code extract to be modified:
If folder <> "" Then
Set OLF = GetObject("", _
"Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders(folder.Value)
End If
Can I have your thoughts please on how to generalise the code?
Thanks Graeme.
Full VBA :
Sub ListAllItemsInInbox()
Dim OLF As Outlook.MAPIFolder, CurrUser As String
Dim EmailItemCount As Integer, i As Integer, EmailCount As Integer
Dim folder As Variant
Dim vrow As Integer
Dim vdate As Variant
Dim acount As Integer
Sheets("Sheet1").Cells(1, 1).Formula = "Subject"
Sheets("Sheet1").Cells(1, 2).Formula = "Received"
Sheets("Sheet1").Cells(1, 3).Formula = "Attachments"
Sheets("Sheet1").Cells(1, 4).Formula = "Read"
Sheets("Sheet1").Cells(1, 5).Formula = "Folder Name"
Sheets("Sheet1").Cells(1, 6).Formula = "Attachment Name"
vrow = 0
For Each folder In Range("OutlookFolders")
If folder <> "" Then
Set OLF = GetObject("", _
"Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders(folder.Value)
End If
EmailItemCount = OLF.Items.Count
i = 0: EmailCount = 0
' read e-mail information
While i < EmailItemCount
i = i + 1
vrow = vrow + 1
With OLF.Items(i)
EmailCount = EmailCount + 1
Sheets("Sheet1").Cells(vrow + 1, 1).Formula = .Subject
On Error Resume Next
Sheets("Sheet1").Cells(vrow + 1, 2).Formula =
Format(.ReceivedTime, "dd.mm.yyyy hh:mm")
Sheets("Sheet1").Cells(vrow + 1, 3).Formula = .Attachments.Count
Sheets("Sheet1").Cells(vrow + 1, 4).Formula = Not .UnRead
Sheets("Sheet1").Cells(vrow + 1, 5).Value = folder.Value
For acount = 1 To .Attachments.Count
Sheets("Sheet1").Cells(vrow + 1, 5 + acount).Value =
..Attachments(acount).Filename
Next acount
End With
Wend
Next folder
End Sub
Within an excel worksheet I have created a named range called "Outlook
Folders". The entries
in this named range correspond to the names of the email subfolders within
my default outlook email pst file.
Modifying some VBA which I sourced off the Net I have been able to extract
various fields from my
default outlook email pst file where there is a match back to the subfolder
list contained within my named range.
This is great but I am having trouble trying to generalise the code so that
it also looks at non default pst files.
I have several old pst files which I would like to query with this VBA macro
but I can't seem to get it to work.
e.g I have a pst file called "OldEmail" which shows up when I open outlook.
Some preliminary net searching indicates that I need to somehow modify the
following code, perhaps subsituting "GetSharedDefaultFolder"
for "GetDefaultFolder".
Code extract to be modified:
If folder <> "" Then
Set OLF = GetObject("", _
"Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders(folder.Value)
End If
Can I have your thoughts please on how to generalise the code?
Thanks Graeme.
Full VBA :
Sub ListAllItemsInInbox()
Dim OLF As Outlook.MAPIFolder, CurrUser As String
Dim EmailItemCount As Integer, i As Integer, EmailCount As Integer
Dim folder As Variant
Dim vrow As Integer
Dim vdate As Variant
Dim acount As Integer
Sheets("Sheet1").Cells(1, 1).Formula = "Subject"
Sheets("Sheet1").Cells(1, 2).Formula = "Received"
Sheets("Sheet1").Cells(1, 3).Formula = "Attachments"
Sheets("Sheet1").Cells(1, 4).Formula = "Read"
Sheets("Sheet1").Cells(1, 5).Formula = "Folder Name"
Sheets("Sheet1").Cells(1, 6).Formula = "Attachment Name"
vrow = 0
For Each folder In Range("OutlookFolders")
If folder <> "" Then
Set OLF = GetObject("", _
"Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders(folder.Value)
End If
EmailItemCount = OLF.Items.Count
i = 0: EmailCount = 0
' read e-mail information
While i < EmailItemCount
i = i + 1
vrow = vrow + 1
With OLF.Items(i)
EmailCount = EmailCount + 1
Sheets("Sheet1").Cells(vrow + 1, 1).Formula = .Subject
On Error Resume Next
Sheets("Sheet1").Cells(vrow + 1, 2).Formula =
Format(.ReceivedTime, "dd.mm.yyyy hh:mm")
Sheets("Sheet1").Cells(vrow + 1, 3).Formula = .Attachments.Count
Sheets("Sheet1").Cells(vrow + 1, 4).Formula = Not .UnRead
Sheets("Sheet1").Cells(vrow + 1, 5).Value = folder.Value
For acount = 1 To .Attachments.Count
Sheets("Sheet1").Cells(vrow + 1, 5 + acount).Value =
..Attachments(acount).Filename
Next acount
End With
Wend
Next folder
End Sub