VBA CODE TO EXTRACT EMAIL FROM MS OUTLOOK 2010

R

Reetesh

Board Regular
Joined
Sep 6, 2020
Messages
50
Office Version
  1. 2016
  2. 2010
Platform
  1. Windows
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.
 

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
Sort by date Sort by votes
In taking a quick look, try it like this...

VBA Code: 
    For i = 1 To numRows
    
        Set folderItem = mailFolderItems.Item(i)
        
        If IsMail(folderItem) Then
            Set msg = folderItem
            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
                If .Attachments.Count > 0 Then
                    For jAttach = 1 To .Attachments.Count
                        tempString(i + startRow, 39 + jAttach) = .Attachments.Item(jAttach).DisplayName
                    Next jAttach
                End If
            End With
        End If
        
    Next i

Hope this helps!
 
Upvote 0
Hello Domenic.. thanks for your response.
I made changes to the code as you mentioned above, however it gives "Compile error: End If without block if" now.
 
Upvote 0
The code I posted shouldn't give you that error. It's probably somewhere in the rest of your code. Can you post the exact amended code that you now have?
 
Upvote 0
Here is the code


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
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
If .Attachments.Count > 0 Then
For jAttach = 1 To .Attachments.Count
tempString(i + startRow, 39 + jAttach) = .Attachments.Item(jAttach).DisplayName
Next jAttach
End If
End With
End If

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
 
Upvote 0
You're missing Next i just before If headerRow Then.

By the way, in the future, please post your code between code tags to make it easier to read the code. You'll find the Code button (</>) at the top of the message window.
 
Upvote 0
Thanks for letting me know about the code tags. was not aware about that.

I made the correction to the code and tried again, however its still giving me the same "compile error" message Domenic.

Below is the complete code again which i used:


VBA Code: 
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
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
If .Attachments.Count > 0 Then
For jAttach = 1 To .Attachments.Count
tempString(i + startRow, 39 + jAttach) = .Attachments.Item(jAttach).DisplayName
Next jAttach
End If
End With
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
 
Upvote 0
Which error message does it display, and which line gets highlighted in yellow?
 
Upvote 0
Domenic said:
Which error message does it display, and which line gets highlighted in yellow?
Click to expand...
It gives the error message as "Compile error: End if without block If".

"Function ExportEmails(Optional headerRow As Boolean = False) As String()" gets highlighted in yellow and "End if", the one which is after "End with" gets highlighted in blue.
 
Upvote 0
The code that you posted in Post #7 looks fine. In fact, I copied and pasted the code into a regular module, and then Tool bar >> Debug >> Compile VBA Project. It compiled successfully.

By the way, I don't see "End", only "End If". Are we talking about the same code?
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Question Question
Extract email from specific sender from outlook
Replies
0
Views
632
exceluser9
E
E
  • Question Question
Amend VBA code to extract details from outlook - Urgent help required
Replies
1
Views
1K
Peter_SSs
Peter_SSs
R
  • Solved
Is there a way for this VBA code to Ignore the spaces & give the results at the top of the page?
2
Replies
10
Views
649
Alex Blakenburg
A
C
  • Question Question
Opening Outlook to send and email
Replies
1
Views
463
Trebor76
T
I
  • Question Question
Unable to run VBA code
Replies
6
Views
165
RoryA
RoryA

Forum statistics

Threads
1,224,824
Messages
6,181,186
Members
453,020
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top