'How to handle non-email when importing Outlook email data into Excel with VBA?
I'm trying to import all mails received and sent the past year.
For the received mails works, but the code stops when importing the sent mails. Specifically for the OutlookMail.To property. It stops when it gets to an accepted invitation for a meeting that I have sent.
Is there a way to bypass all the accepted invitations that I have sent and only get the emails?
Sub GetFromOutlook()
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder1 As MAPIFolder
Dim Folder2 As MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer
Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder1 = OutlookNamespace.GetDefaultFolder(olFolderInbox)
Set Folder2 = OutlookNamespace.GetDefaultFolder(olFolderSentMail)
i = 1
For Each OutlookMail In Folder1.Items
If OutlookMail.ReceivedTime >= Range("H5").Value And OutlookMail.ReceivedTime <= Range("I5").Value Then
Range("C4").Offset(i, 0).Value = OutlookMail.Subject
Range("A4").Offset(i, 0).Value = OutlookMail.ReceivedTime
Range("B4").Offset(i, 0).Value = OutlookMail.SenderName
i = i + 1
End If
j = 1
Next OutlookMail
For Each OutlookMail In Folder2.Items
If OutlookMail.ReceivedTime >= Range("H5").Value And OutlookMail.ReceivedTime <= Range("I5").Value Then
Range("f4").Offset(j, 0).Value = OutlookMail.Subject
Range("d4").Offset(j, 0).Value = OutlookMail.ReceivedTime
Range("E4").Offset(j, 0).Value = OutlookMail.To
j = j + 1
End If
Next OutlookMail
Set Folder1 = Nothing
Set Folder2 = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
End Sub
Solution 1:[1]
Something like this (refactoring a bit)
Sub GetFromOutlook()
Dim olApp As Outlook.Application
Dim olNS As Namespace, ws As Worksheet
Set olApp = New Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set ws = ActiveSheet
ListFolder olNS.GetDefaultFolder(olFolderInbox), ws.Range("C4")
ListFolder olNS.GetDefaultFolder(olFolderSentMail), ws.Range("F4")
End Sub
'List info for all mail items in `fldr`, starting at `rng`
Sub ListFolder(fldr As MAPIFolder, rng As Range)
Dim itm As Variant, i As Long
For Each itm In fldr.Items
If TypeOf itm Is MailItem Then 'is this a mail item?
'faster to write whole row in one shot
rng.Cells(1).Offset(i).Resize(1, 3).Value = _
Array(itm.Subject, itm.ReceivedTime, itm.to)
i = i + 1 'increment row
End If 'is a mail object
Next itm
End Sub
Sources
This article follows the attribution requirements of Stack Overflow and is licensed under CC BY-SA 3.0.
Source: Stack Overflow
| Solution | Source |
|---|---|
| Solution 1 | Tim Williams |
