I am sharing with you my Excel VBA code to receive email data from Outlook.
When I start Excel and Outlook and run the VBA code I get an error on
Set Folder = Outlook.Session.Folders(MailboxName).Folders(Pst_Folder_Name).Folders(subFolderName)
When I close and re-open Outlook I get all the information into the table up to 30 days back, then I get the message
code 438 object doesn't support this property or method
on
Sheets(1).Cells(iRow, 1) = Folder.Items.Item(iRow).ReceivedTime
I have a default Outlook email address and a shared email address. There is a subfolder in the shared email address.
I'm trying to get the email from the shared email address and subfolder only.
Sub GetEmailsInTo()
Dim ol As Outlook.Application
Dim ns As Outlook.Namespace
Dim Pst_Folder_Name As String
Dim MailboxName As String
Dim subFolderName As String
Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
'Mailbox or PST Main Folder Name (As how it is displayed in your Outlook Session)
MailboxName = "shareemails@info.com"
'Mailbox Folder or PST Folder Name (As how it is displayed in your Outlook Session)
Pst_Folder_Name = "Inbox"
'subfolder name
subFolderName = "important"
Set Folder = Outlook.Session.Folders(MailboxName).Folders(Pst_Folder_Name).Folders(subFolderName)
If Folder = "" Then
MsgBox "Invalid Data in Input"
GoTo end_lbl1:
End If
Range("A2", Range("A2").End(xlDown).End(xlToRight)).Clear
'Date
Columns("A:A").Select
Selection.NumberFormat = "[$-409]ddd dd/mm/yy;@"
Range("A2:A500").Select
Selection.ColumnWidth = 13
Range("A2:A500").HorizontalAlignment = xlLeft
Range("A2:A500").VerticalAlignment = xlCenter
Range("A1:E1").Select
With Selection
.VerticalAlignment = xlBottom
.WrapText = False
.RowHeight = 55
.HorizontalAlignment = xlCenter
End With
Range("B2:B500").Select
With Selection
.WrapText = True
.ColumnWidth = 16
.Rows.AutoFit
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
End With
Range("C2:C500").Select
With Selection
.WrapText = True
.ColumnWidth = 40
.Rows.AutoFit
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
End With
Range("D2:D500").Select
With Selection
.WrapText = True
.ColumnWidth = 170
.Rows.AutoFit
.VerticalAlignment = xlTop
.HorizontalAlignment = xlLeft
End With
Range("E2:E500").Select
With Selection
.WrapText = True
.ColumnWidth = 50
.Rows.AutoFit
.VerticalAlignment = xlTop
.HorizontalAlignment = xlLeft
End With
'Rad Through each Mail and export the details to Excel for Email Archival
Sheets(1).Activate
For iRow = 2 To Folder.Items.Count
Sheets(1).Cells(iRow, 2).Select
Sheets(1).Cells(iRow, 1) = Folder.Items.Item(iRow).ReceivedTime
Sheets(1).Cells(iRow, 2) = Folder.Items.Item(iRow).SenderName
Sheets(1).Cells(iRow, 3) = Folder.Items.Item(iRow).Subject
Sheets(1).Cells(iRow, 4) = Folder.Items.Item(iRow).To
Sheets(1).Cells(iRow, 5) = Folder.Items.Item(iRow).CC
Next iRow
MsgBox "Email import complete"
end_lbl1:
End Sub
Non-mailitems may not have a mailitem property. As well iRow is one more than the item index.
Option Explicit
Sub GetEmailsInToV2()
Dim ol As Outlook.Application
Dim ns As Outlook.Namespace
Dim mailboxFolder As Outlook.folder
Dim inboxFolder As Outlook.folder
Dim subFolder As Outlook.folder
Dim mailboxName As String
Dim inboxName As String
Dim subFolderName As String
Dim iRow As Long
Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
'Mailbox Name as displayed in your Outlook Session)
mailboxName = "shareemails@info.com"
inboxName = "Inbox"
'subfolder name
subFolderName = "important"
' No attempt to address unknown error referencing the subfolder
Set mailboxFolder = ns.Folders(mailboxName)
Set inboxFolder = mailboxFolder.Folders(inboxName)
Set subFolder = inboxFolder.Folders(subFolderName)
Range("A2", Range("A2").End(xlDown).End(xlToRight)).Clear
'Date
With Columns("A:A")
.NumberFormat = "[$-409]ddd dd/mm/yy;@"
.ColumnWidth = 13
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
End With
With Range("B:B")
.WrapText = True
.ColumnWidth = 16
.Rows.AutoFit
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
End With
With Range("C:C")
.WrapText = True
.ColumnWidth = 40
.Rows.AutoFit
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
End With
With Range("D:D")
.WrapText = True
.ColumnWidth = 170
.Rows.AutoFit
.VerticalAlignment = xlTop
.HorizontalAlignment = xlLeft
End With
With Range("E:E")
.WrapText = True
.ColumnWidth = 50
.Rows.AutoFit
.VerticalAlignment = xlTop
.HorizontalAlignment = xlLeft
End With
With Range("A1:E1")
.VerticalAlignment = xlBottom
.WrapText = False
.RowHeight = 55
.HorizontalAlignment = xlCenter
End With
'Read each mail and export the details to Excel for Email Archival
'Sheets(1).Activate
For iRow = 2 To subFolder.Items.Count + 1
With subFolder.Items.Item(iRow - 1)
' Non-mailitems may not have mailitem properties
If .Class = olMail Then
'Sheets(1).Cells(iRow, 2).Select
Sheets(1).Cells(iRow, 1) = .ReceivedTime
Sheets(1).Cells(iRow, 2) = .SenderName
Sheets(1).Cells(iRow, 3) = .Subject
Sheets(1).Cells(iRow, 4) = .To
Sheets(1).Cells(iRow, 5) = .CC
' Clear requires an entry in column E
If Sheets(1).Cells(iRow, 5) = "" Then
Sheets(1).Cells(iRow, 5) = "-"
End If
Else
Sheets(1).Cells(iRow, 1) = "-" ' Clear requires an entry in column A
Sheets(1).Cells(iRow, 3) = "Not a mailitem."
Sheets(1).Cells(iRow, 5) = "-" ' Clear requires an entry in column E
End If
End With
Next
MsgBox "Email import complete"
End Sub