Sub GetEmails()
'Add Tools->References->"Microsoft Outlook nn.n Object Library"
'nn.n varies as per our Outlook Installation
Const NUM_DAYS As Long = 18
Dim OutlookApp As Outlook.Application
Dim i As Long
Dim Folder As Outlook.MAPIFolder
Dim itm As Object
Dim iRow As Long, oRow As Long, ws As Worksheet, sBody As String
Dim mailboxName As String, inboxName As String, subfolderName As String, diff As Double
mailboxName = "SF"
inboxName = "Inbox"
subfolderName = "NP"
'for example
Set OutlookApp = New Outlook.Application
On Error Resume Next
Set Folder = OutlookApp.Session.Folders(mailboxName) _
.Folders(inboxName).Folders(subfolderName)
On Error GoTo 0
If Folder Is Nothing Then
MsgBox "Source folder Not found!", vbExclamation, _
"Problem With export"
Exit Sub
End If
Set ws = ThisWorkbook.Worksheets(1)
ws.Cells.ClearContents
'add headers
ws.Range("A1").Resize(1, 4).Value = Array("Sender", "Subject", "Date", "Body")
iRow = 2
Folder.Items.Sort "Received"
For Each itm In Folder.Items
If TypeOf itm Is Outlook.MailItem Then
'check it's a mail item (not appointment, etc)
diff = -999
'reset time difference
On Error Resume Next
'ignore error if Receivedtime not available
diff = Date - itm.ReceivedTime
'try to calculate interval
On Error GoTo 0
'stop ignoring errors
If diff <> -999 Then
'could read Receivedtime
If diff <= NUM_DAYS Then
sBody = Left(Trim(itm.Body), 150)
'first 150 chars of Body
sBody = Replace(sBody, vbCrLf, "; ")
'remove newlines
sBody = Replace(sBody, vbLf, "; ")
ws.Cells(iRow, 1).Resize(1, 4).Value = _
Array(itm.SenderName, itm.Subject, itm.ReceivedTime, sBody)
iRow = iRow + 1
End If
Else
Debug.Print 't read ReceivedTime" & vbLf & _
itm.SenderName & ":" & itm.Subject
End If
End If
Next itm
MsgBox "Outlook Mails Extracted To Excel"
End Sub.
VBA Code:
[CODE=vba]Sub GetEmails()
'Add Tools->References->"Microsoft Outlook nn.n Object Library"
'nn.n varies as per our Outlook Installation
Const NUM_DAYS As Long = 18
Dim OutlookApp As Outlook.Application
Dim i As Long
Dim Folder As Outlook.MAPIFolder
Dim itm As Object
Dim iRow As Long, oRow As Long, ws As Worksheet, sBody As String
Dim mailboxName As String, inboxName As String, subfolderName As String, diff As Double
mailboxName = "SF"
inboxName = "Inbox"
subfolderName = "NP"
'for example
Set OutlookApp = New Outlook.Application
On Error Resume Next
Set Folder = OutlookApp.Session.Folders(mailboxName) _
.Folders(inboxName).Folders(subfolderName)
On Error GoTo 0
If Folder Is Nothing Then
MsgBox "Source folder Not found!", vbExclamation, _
"Problem With export"
Exit Sub
End If
Set ws = ThisWorkbook.Worksheets(1)
ws.Cells.ClearContents
'add headers
ws.Range("A1").Resize(1, 4).Value = Array("Sender", "Subject", "Date", "Body")
iRow = 2
Folder.Items.Sort "Received"
For Each itm In Folder.Items
If TypeOf itm Is Outlook.MailItem Then
'check it's a mail item (not appointment, etc)
diff = -999
'reset time difference
On Error Resume Next
'ignore error if Receivedtime not available
diff = Date - itm.ReceivedTime
'try to calculate interval
On Error GoTo 0
'stop ignoring errors
If diff <> -999 Then
'could read Receivedtime
If diff <= NUM_DAYS Then
sBody = Left(Trim(itm.Body), 150)
'first 150 chars of Body
sBody = Replace(sBody, vbCrLf, "; ")
'remove newlines
sBody = Replace(sBody, vbLf, "; ")
ws.Cells(iRow, 1).Resize(1, 4).Value = _
Array(itm.SenderName, itm.Subject, itm.ReceivedTime, sBody)
iRow = iRow + 1
End If
Else
Debug.Print 't read ReceivedTime" & vbLf & _
itm.SenderName & ":" & itm.Subject
End If
End If
Next itm
MsgBox "Outlook Mails Extracted To Excel"
End Sub.
[/CODE]