I need your help guys if you can. I am new to VBA so I am still learning and my code is probably not powerful but I would like to bring it to life. It works, but in a different way than I expected. I am sharing with you my excel VBA code to receive emails from Outlook. When I start Excel and Outlook and run the vba code I get an error on this line =>
Set Folder = Outlook.Session.Folders(MailboxName).Folders(Pst_Folder_Name).Folders(subFolderName)
but when I close and re-open outlook it works and gets all the information into the table up to 30 days back and then I get the message "object doesn't support this property method" code438.. in this line =>
Sheets(1).Cells(iRow, 1) = Folder.Items.Item(iRow).ReceivedTime
FYI.. I have a default email address set up in outlook which is mine and a shared email address that other ppl also use and there is a sub file in the shared email address. so I'm trying to get the email from the shared email address and subfolder only.
Here is the code:
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