Export Outlook message to Excel, outlook macro

[taylor23]

I'm looking to create a simple outlook macro that would dump emails in a specific folder into an excel worksheet. The folder can be called "test" for reference purposes and the excel spreadsheet can be anything.

Outlook will always remain open and the spreadsheet would not be located on a server. This is all local.

Information I would like coming over is the date and the body (possibly the subject).

I've tried this a few different times and have yet to get a working version. I'm using Office 2007.

Any help would be greatly appreciated (appreciated = paypal???):help You all are great and very kind for helping out. It is greatly appreciated.

[JP2112]

It sounds like you already wrote some code. Can you post it? Maybe someone here can make a tweak and get it working.

HTH

[taylor23]

I've used a combination of codes i've find around the web but none of them seem to be updated for 07 and nothing specific to what i'm looking for. one of the codes i've tried is listed below. I had tweaked it a bit but i currently do not have that code with me. code was found at techrepublics blog.




Sub ExportToExcel() On Error GoTo ErrHandler Dim appExcel As Excel.Application Dim wkb As Excel.WorkbookDim wks As Excel.WorksheetDim rng As Excel.RangeDim strSheet As StringDim strPath As StringDim intRowCounter As IntegerDim intColumnCounter As IntegerDim msg As Outlook.MailItemDim nms As Outlook.NameSpaceDim fld As Outlook.MAPIFolderDim itm As Object strSheet = "OutlookItems.xls" strPath = "C:Examples\"strSheet = strPath & strSheetDebug.Print strSheet 'Select export folderSet nms = Application.GetNamespace("MAPI")Set fld = nms.PickFolder 'Handle potential errors with Select Folder dialog box.If fld Is Nothing ThenMsgBox "There are no mail messages to export", vbOKOnly, _"Error"Exit SubElseIf fld.DefaultItemType <> olMailItem ThenMsgBox "There are no mail messages to export", vbOKOnly, _"Error"Exit SubElseIf fld.Items.Count = 0 ThenMsgBox "There are no mail messages to export", vbOKOnly, _"Error"Exit SubEnd If 'Open and activate Excel workbook.Set appExcel = CreateObject("Excel.Application")appExcel.Workbooks.Open (strSheet)Set wkb = appExcel.ActiveWorkbookSet wks = wkb.Sheets(1)wks.ActivateappExcel.Application.Visible = True 'Copy field items in mail folder.For Each itm In fld.ItemsintColumnCounter = 1Set msg = itmintRowCounter = intRowCounter + 1Set rng = wks.Cells(intRowCounter, intColumnCounter)rng.Value = msg.TointColumnCounter = intColumnCounter + 1Set rng = wks.Cells(intRowCounter, intColumnCounter)rng.Value = msg.SenderEmailAddressintColumnCounter = intColumnCounter + 1Set rng = wks.Cells(intRowCounter, intColumnCounter)rng.Value = msg.SubjectintColumnCounter = intColumnCounter + 1Set rng = wks.Cells(intRowCounter, intColumnCounter)rng.Value = msg.SentOnintColumnCounter = intColumnCounter + 1Set rng = wks.Cells(intRowCounter, intColumnCounter)rng.Value = msg.ReceivedTimeNext itm Set appExcel = Nothing Set wkb = NothingSet wks = NothingSet rng = NothingSet msg = NothingSet nms = NothingSet fld = NothingSet itm = Nothing Exit SubErrHandler: If Err.Number = 1004 ThenMsgBox strSheet & " doesn't exist", vbOKOnly, _"Error"ElseMsgBox Err.Number & "; Description: ", vbOKOnly, _"Error"End IfSet appExcel = NothingSet wkb = NothingSet wks = NothingSet rng = NothingSet msg = NothingSet nms = NothingSet fld = NothingSet itm = NothingEnd Sub

I'm looking a simplier code just for date, body into rows. Data would be updated daily or more into the excel spreadsheet and would fill in the next empty row...Any ideas would be great. Thanks.

[Benzadeus]

Inside Excel, put code:

Dim r As Long

Sub GerarLista()

Dim appOutlook As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olFolder As Outlook.Folder

On Error Resume Next
Set appOutlook = GetObject(, "Outlook.Application")
If appOutlook Is Nothing Then 'ou seja, se não há instância, deve-se criar uma.
Set appOutlook = CreateObject("Outlook.Application")
End If
On Error GoTo 0

Set olNS = appOutlook.GetNamespace("MAPI")
'Troque a constante abaixo se desejar que se faça varredura em outra pasta.
Set olFolder = olNS.GetDefaultFolder(olFolderInbox)

'Limpa Planilha
Cells.Delete
r = 0
DescePasta olFolder

Set olFolder = Nothing
Set olNS = Nothing

End Sub

Sub DescePasta(olFolder As Outlook.Folder)

Dim olSubFolder As Outlook.Folder
'Agora será necessário declarar um objeto do tipo arquivo
'para realizar um loop de leitura de arquivos numa pasta
Dim olItem As MailItem

r = r + 1
Cells(r, "A") = olFolder.FolderPath
For Each olItem In olFolder.Items
r = r + 1
'Você pode visualizar uma série de propriedades de um objeto MailItem. Exemplos:
Cells(r, "A") = olItem.Subject 'Assunto do e-mail
Cells(r, "B") = olItem.SenderEmailAddress 'E-mail do remetente
Cells(r, "C") = olItem.To 'E-mail do destinatário
Cells(r, "D") = olItem.ReceivedTime 'Data/Hora de recebimento
Cells(r, "E") = olItem.Attachments.Count 'Número de anexos
Cells(r, "F") = olItem.Size 'Tamanho da mensagem em bytes
Next olItem

For Each olSubFolder In olFolder.Folders
DescePasta olSubFolder
Next olSubFolder

End Sub

[taylor23]

Thanks so much!
however I am getting user defined error here
Sub DescePasta(olFolder As Outlook.Folder)

It might be the spanish throwing me off :P, where would I input the specific folder I want to pull the data from?

Thanks again, I really appreciate all the help. Happy Holidays.

[JP2112]

This is the same generic code you posted in another thread. How does this code help the OP?

The OP wanted date, subject and body from emails in a specific folder. Yours loops through every sub-folder of the Inbox, and prints different information.

Also I should mention (since you didn't) that it requires an early bound reference to Outlook's object library.



Inside Excel, put code:

[Benzadeus]

@JP,
I shouldn't have entered on forum that day, serious. These things won't happen again, you'll see I'm a good programmer/user =D

@taylor23,
The code below should work. Just change paste the code on Excel and change the folder's name.

Sub GenerateList()

Dim appOutlook As Object
Dim olNS As Object
Dim olFolder As Object
Dim olItem As Object
Dim r As Long

'Get/create Outlook Application
On Error Resume Next
Set appOutlook = GetObject(, "Outlook.Application")
If appOutlook Is Nothing Then
Set appOutlook = CreateObject("Outlook.Application")
End If
On Error GoTo 0

Set olNS = appOutlook.GetNamespace("MAPI")

'Change value if you want another folder:
Set olFolder = olNS.Folders("Arquivo de Dados do Outlook").Folders("Caixa de Entrada")
'I don't know how 'Arquivos de Dados do Outlook' is in English. Just put the root folder's name.
'The 'Caixa de Entrada' is a subfolder.
'You can also use NUMBERS instead of "STRINGS", like (...)Folders(4)(...)

'Clear
Cells.Delete

r = 1
'Build headings:
Range("A1:C1") = Array("Subject", "Sent On", "Body")

For Each olItem In olFolder.Items
If TypeName(olItem) = "MailItem" Then
r = r + 1
Cells(r, "A") = olItem.Subject
Cells(r, "B") = olItem.SentOn
Cells(r, "C") = olItem.Body 'Can be a complex string
End If
Next olItem
Columns.AutoFit

End Sub

[taylor23]

This works great! Thank you so much! I greatly appreciate the time you put into this.

I had two additional questions:
1) Would there be a way to drop a new email below instead of above? for instance emails are received in said order "1 - 12/12 12pm ,2 - 12/12 1pm, 3 - 12/12 2pm" so they should up in outlook in folder view at 1 being the lowest, 2 in the middle and 3 on top, and consequently showing up in excel as 3, 2, 1. I guess the question is, how do i reverse the order when they are brought into excel?
(FROM)
3 - 12/12 2pm
2 - 12/12 1pm
1 - 12/12 12pm
(TO)
1 - 12/12 12pm
2 - 12/12 1pm
3 - 12/12 2pm

2) is there anyway to limit the text being imported? I'm looking for a max of 20 or 30 characters. No big deal it it cannot be.

@Benzadeus - thank you so much! :)

[taylor23]

Do not worry about number 2 if it is a big deal, number 1 would be fantastic if you knew how I could do that. Thanks again so much!

[Benzadeus]

Sub GenerateList()

Dim appOutlook As Object
Dim olNS As Object
Dim olFolder As Object
Dim olItem As Object
Dim r As Long

'Get/create Outlook Application
On Error Resume Next
Set appOutlook = GetObject(, "Outlook.Application")
If appOutlook Is Nothing Then
Set appOutlook = CreateObject("Outlook.Application")
End If
On Error GoTo 0

Set olNS = appOutlook.GetNamespace("MAPI")

'Change value if you want another folder:
Set olFolder = olNS.Folders("Arquivo de Dados do Outlook").Folders("Caixa de Entrada")
'I don't know how 'Arquivos de Dados do Outlook' is in English. Just put the root folder's name.
'The 'Caixa de Entrada' is a subfolder.
'You can also use NUMBERS instead of "STRINGS", like (...)Folders(4)(...)

'Clear
Cells.Delete

r = 1
'Build headings:
Range("A1:D1") = Array(vbNullString, "Subject", "Sent On", "Body")

For Each olItem In olFolder.Items
If TypeName(olItem) = "MailItem" Then
r = r + 1
Cells(r, "A") = r
Cells(r, "B") = olItem.Subject
Cells(r, "C") = olItem.SentOn
Cells(r, "D") = Left(olItem.Body, 20) 'Get only 20 letters of body text
End If
Next olItem
With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=Columns(1), Order:=xlDescending
.SetRange Cells
.Header = xlYes
.Apply
End With
Columns(1).Delete
Columns.AutoFit

End Sub

[taylor23]

again, this is working great. One minor issue. When I run the macro, it drops the headings below all of the imported data. What would I change to keep this at the top? Array(vbNullString, "Subject", "Sent On", "Body")

Thanks again for your help! :) Happy Holidays!

[Benzadeus]

That's strange... it works well for me.
Anyway, just a workaround to add at the ending of your code:
End With
Columns(1).Delete
Rows(ActiveSheet.UsedRange.Rows.Count).Delete
Columns.AutoFit

[taylor23]

here is an added twist... wondering if you could help out again @Benzadeus

If olItem.Body = "word" Then
Import into the excel spreadsheet

so essentially - if the email contains a word it will import into the spreadsheet. if it does not, it will not import. The code will still run through all the emails but will only import ones with the body containing a specific word...

any thoughts!?

[Charlize]

If InStr(1, olItem.Body, "word") > 0 Then
'found it so here we put something to do
End IfCharlize

[Rob M]

This was very helpful, together with the list of available properties at msdn.microsoft.com/en-us/library/ff861252.aspx.

However, is there a way to get the email address an email was sent to?

The property list gives ReceivedByName and ReceivedOnBehalfOfName, which both give the display name, not the email address.

The other options are ReceivedByEntryID and ReceivedOnBehalfOfEntryID, but can you get from there to the email address? Or is there another way of doing this?

[Rob M]

OK, robinhudda12, how do I do it?
If I knew, I would not have posted!

[charliekent6]

Can anyone help? I need this script to work on outlook express it works on entorage :doh: :banghead: :think:

*********************************************

property msgID : 0
property RefNr : 0
property senderName : "John Doe"
property senderAddress : "john@doe.com"

tell application "Microsoft Outlook"

if msgID ≠ 0 then
try
set msgTemplate to message id msgID
on error
beep
display dialog "! You must have either done a complex rebuild of Entourage recently or deleted your message template." & return & return & "Select your template and run the Message template script again to reset it." buttons {"OK"} default button "OK" with icon 2
set msgID to 0
return
end try
else
try
set sel to current messages
set msgTemplate to item 1 of sel
if (count of sel) ≠ 1 or class of msgTemplate ≠ outgoing message or «class dlvs» of msgTemplate ≠ «constant Edlvunst» then error number -128
set folderID to id of «class stor» of msgTemplate
set isLocal to my GetUrFolder(folderID)
if not isLocal then return
on error
beep
display dialog "! You must select just one unsent, saved draft message as your message template in a LOCAL folder [\"On My Computer\"]." & return & return & "Do so, and run the script again." buttons {"OK"} default button "OK" with icon 2 --
return
end try

display dialog "Do you want to save your template as UNSENT, allowing you to alter it but always showing as bolded in its folder, or as a SENT message, unbolded but unalterable?" buttons {" Cancel ", " Sent ", " Unsent "} default button 3 with icon 1
if button returned of result = " Cancel " then
return
else if button returned of result = " Sent " then
set «class dlvs» of msgTemplate to «constant Edlvsent»
end if

set msgID to id of msgTemplate

display dialog "All set up!" & return & return & "Do you want to write a new email message with your template right now?" buttons {"Not Now", "Open New Message"} default button 2 with icon 1

if button returned of result = "Not Now" then return

end if

set folderID to id of «class stor» of msgTemplate
set isLocal to my GetUrFolder(folderID)
if not isLocal then return
--if doesn't quit then all is OK

set RefNr to RefNr + 1
set newMsg to duplicate msgTemplate --message id msgID
tell newMsg
set subject to "WLN: " & (text -4 thru -1 of ("0000" & RefNr)) & " - "
set sender to {«class addr»:senderAddress, display name:senderName}
end tell
move newMsg to «class pDrF»
open newMsg

end tell




on GetUrFolder(someID)

local theParent, parentID, isTrue

tell application "Microsoft Outlook"
try
set theParent to parent of folder id someID
if class of theParent = folder then
set parentID to id of theParent
set isTrue to my GetUrFolder(parentID)
if not isTrue then return false
else if {class of theParent} is in {«class impA», «class HtmA»} then
beep
display dialog "! You must leave your message template in a LOCAL folder [\"On My Computer\"] for this script to work." & return & return & "Move or copy it to a local folder (Drafts folder or another), select it there, and run the script once to set it up again." buttons {" Cancel "} default button 1 with icon 0
set my msgID to 0
return false

end if -- parent must be Entourage, folder is top-level
on error -- parent must be Entourage, folder is top-level
return true
end try

end tell

return true

end GetUrFolder