Hello I'm Trying to extract email from outlook 2010 in an excel file.
Below is the code which I got for it:
Sub GetMailInfo()
Dim results() As String
results = ExportEmails(True)
Range(Cells(1, 1), Cells(UBound(results), UBound(results, 2))).Value = results
MsgBox "Completed"
End Sub
Function ExportEmails(Optional headerRow As Boolean = False) As String()
Dim objOutlook As Object
Dim objNamespace As Object
Dim strFolderName As Object
Dim objMailbox As Object
Dim objFolder As Object
Dim mailFolderItems As Object
Dim folderItem As Object
Dim msg As Object
Dim tempString() As String
Dim i As Long
Dim numRows As Long
Dim startRow As Long
Dim jAttach As Long
Dim debugMsg As Integer
Sheets("Outlook Results").Select
Sheets("Outlook Results").Cells.ClearContents
Range("A1").Select
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set strFolderName = objNamespace.PickFolder
Set mailFolderItems = strFolderName.Items
If headerRow Then
startRow = 1
Else
startRow = 0
End If
numRows = mailFolderItems.Count
ReDim tempString(1 To (numRows + startRow), 1 To 100)
For i = 1 To numRows
Set folderItem = mailFolderItems.Item(i)
If IsMail(folderItem) Then
Set msg = folderItem
End If
With msg
tempString(i + startRow, 1) = .SenderName
tempString(i + startRow, 2) = .SentOn
tempString(i + startRow, 3) = .ReceivedTime
tempString(i + startRow, 4) = .Subject
tempString(i + startRow, 5) = Left$(.Body, 900) ' throws error without limit
tempString(i + startRow, 6) = .To
tempString(i + startRow, 7) = .cc
tempString(i + startRow, 8) = .SenderEmailAddress
tempString(i + startRow, 9) = .SenderEmailType
End With
If msg.Attachments.Count > 0 Then
For jAttach = 1 To msg.Attachments.Count
tempString(i + startRow, 39 + jAttach) = msg.Attachments.Item(jAttach).DisplayName
Next jAttach
End If
Next i
If headerRow Then
tempString(1, 1) = "Sender Name"
tempString(1, 2) = "Sent On"
tempString(1, 3) = "Received Time"
tempString(1, 4) = "Subject"
tempString(1, 5) = "Body"
tempString(1, 6) = "Sent To"
tempString(1, 7) = "CC"
tempString(1, 8) = "Sender Email Address"
tempString(1, 9) = "Sender Email Type"
End If
ExportEmails = tempString
Range("A2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select
'Selection.AutoFilter
End Function
Function IsMail(itm As Object) As Boolean
IsMail = (TypeName(itm) = "MailItem")
End Function
However, in the above code when i run it, it gives a "Run-time error '91': Object variable or With block variable not set", when the code tries to execute this "tempString(i + startRow, 1) = .SenderName" command.
Not sure what exactly needs to be done to fix this.
Thought of asking all the experts here
Any help is appreciated.
Thanks is advance.
Below is the code which I got for it:
Sub GetMailInfo()
Dim results() As String
results = ExportEmails(True)
Range(Cells(1, 1), Cells(UBound(results), UBound(results, 2))).Value = results
MsgBox "Completed"
End Sub
Function ExportEmails(Optional headerRow As Boolean = False) As String()
Dim objOutlook As Object
Dim objNamespace As Object
Dim strFolderName As Object
Dim objMailbox As Object
Dim objFolder As Object
Dim mailFolderItems As Object
Dim folderItem As Object
Dim msg As Object
Dim tempString() As String
Dim i As Long
Dim numRows As Long
Dim startRow As Long
Dim jAttach As Long
Dim debugMsg As Integer
Sheets("Outlook Results").Select
Sheets("Outlook Results").Cells.ClearContents
Range("A1").Select
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set strFolderName = objNamespace.PickFolder
Set mailFolderItems = strFolderName.Items
If headerRow Then
startRow = 1
Else
startRow = 0
End If
numRows = mailFolderItems.Count
ReDim tempString(1 To (numRows + startRow), 1 To 100)
For i = 1 To numRows
Set folderItem = mailFolderItems.Item(i)
If IsMail(folderItem) Then
Set msg = folderItem
End If
With msg
tempString(i + startRow, 1) = .SenderName
tempString(i + startRow, 2) = .SentOn
tempString(i + startRow, 3) = .ReceivedTime
tempString(i + startRow, 4) = .Subject
tempString(i + startRow, 5) = Left$(.Body, 900) ' throws error without limit
tempString(i + startRow, 6) = .To
tempString(i + startRow, 7) = .cc
tempString(i + startRow, 8) = .SenderEmailAddress
tempString(i + startRow, 9) = .SenderEmailType
End With
If msg.Attachments.Count > 0 Then
For jAttach = 1 To msg.Attachments.Count
tempString(i + startRow, 39 + jAttach) = msg.Attachments.Item(jAttach).DisplayName
Next jAttach
End If
Next i
If headerRow Then
tempString(1, 1) = "Sender Name"
tempString(1, 2) = "Sent On"
tempString(1, 3) = "Received Time"
tempString(1, 4) = "Subject"
tempString(1, 5) = "Body"
tempString(1, 6) = "Sent To"
tempString(1, 7) = "CC"
tempString(1, 8) = "Sender Email Address"
tempString(1, 9) = "Sender Email Type"
End If
ExportEmails = tempString
Range("A2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select
'Selection.AutoFilter
End Function
Function IsMail(itm As Object) As Boolean
IsMail = (TypeName(itm) = "MailItem")
End Function
However, in the above code when i run it, it gives a "Run-time error '91': Object variable or With block variable not set", when the code tries to execute this "tempString(i + startRow, 1) = .SenderName" command.
Not sure what exactly needs to be done to fix this.
Thought of asking all the experts here
Any help is appreciated.
Thanks is advance.