Consulting

Results 1 to 17 of 17

Thread: Export Outlook message to Excel, outlook macro

  1. #1

    Export Outlook message to Excel, outlook macro

    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???) You all are great and very kind for helping out. It is greatly appreciated.

  2. #2
    VBAX Expert JP2112's Avatar
    Joined
    Oct 2008
    Location
    Astoria, NY
    Posts
    590
    Location
    It sounds like you already wrote some code. Can you post it? Maybe someone here can make a tweak and get it working.

    HTH
    Regards,
    JP

    Read the FAQ
    Getting free help on the web
    My website
    Please use [vba][/vba] tags when posting code

  3. #3
    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.



    [vba]
    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[/vba]

    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.

  4. #4
    VBAX Tutor Benzadeus's Avatar
    Joined
    Dec 2008
    Location
    Belo Horizonte, Brazil
    Posts
    271
    Location
    Inside Excel, put code:

    [VBA]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[/VBA]
    ---
    Felipe Costa Gualberto
    Microsoft Excel MVP
    http://www.ambienteoffice.com.br

  5. #5
    Thanks so much!
    however I am getting user defined error here
    [vba]Sub DescePasta(olFolder As Outlook.Folder)[/vba]

    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.

  6. #6
    VBAX Expert JP2112's Avatar
    Joined
    Oct 2008
    Location
    Astoria, NY
    Posts
    590
    Location
    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.


    Quote Originally Posted by Benzadeus
    Inside Excel, put code:
    Regards,
    JP

    Read the FAQ
    Getting free help on the web
    My website
    Please use [vba][/vba] tags when posting code

  7. #7
    VBAX Tutor Benzadeus's Avatar
    Joined
    Dec 2008
    Location
    Belo Horizonte, Brazil
    Posts
    271
    Location
    @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.

    [VBA]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
    [/VBA]
    ---
    Felipe Costa Gualberto
    Microsoft Excel MVP
    http://www.ambienteoffice.com.br

  8. #8
    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!
    Last edited by taylor23; 12-13-2010 at 01:21 PM.

  9. #9
    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!

  10. #10
    VBAX Tutor Benzadeus's Avatar
    Joined
    Dec 2008
    Location
    Belo Horizonte, Brazil
    Posts
    271
    Location
    [VBA]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("A11") = 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[/VBA]
    ---
    Felipe Costa Gualberto
    Microsoft Excel MVP
    http://www.ambienteoffice.com.br

  11. #11

    Smile

    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? [vba]Array(vbNullString, "Subject", "Sent On", "Body")
    [/vba]
    Thanks again for your help! Happy Holidays!

  12. #12
    VBAX Tutor Benzadeus's Avatar
    Joined
    Dec 2008
    Location
    Belo Horizonte, Brazil
    Posts
    271
    Location
    That's strange... it works well for me.
    Anyway, just a workaround to add at the ending of your code:
    [VBA] End With
    Columns(1).Delete
    Rows(ActiveSheet.UsedRange.Rows.Count).Delete
    Columns.AutoFit
    [/VBA]
    ---
    Felipe Costa Gualberto
    Microsoft Excel MVP
    http://www.ambienteoffice.com.br

  13. #13
    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!?

  14. #14
    VBAX Master
    Joined
    Jul 2006
    Location
    Belgium
    Posts
    1,286
    Location
    [VBA]If InStr(1, olItem.Body, "word") > 0 Then
    'found it so here we put something to do
    End If[/VBA]Charlize

  15. #15
    VBAX Regular
    Joined
    Mar 2012
    Posts
    6
    Location

    Question Can I find out the Received By Email Address?

    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?

  16. #16
    VBAX Regular
    Joined
    Mar 2012
    Posts
    6
    Location
    OK, robinhudda12, how do I do it?
    If I knew, I would not have posted!

  17. #17

    Exclamation Outlook Express Script Help Needed

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

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

    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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •