none
Save currently marked emails subject line and receive time to excel sheet RRS feed

  • Question

  • Hi All,

    I have been searching the web all evening without useable results for this.

    What I would like to do is that I receive a number of emails trough out the day where I need to track the time to response the way I was thinking to do this was to extract the subject line (always unique) and the time I received the email.
    I found this VBA code here (http://techniclee.wordpress.com/2011/10/29/exporting-outlook-messages-to-excel/):

    Sub ExportMessagesToExcel()
        Dim olkMsg As Object, _
            excApp As Object, _
            excWkb As Object, _
            excWks As Object, _
            intRow As Integer, _
            intVersion As Integer, _
            strFilename As String
        strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", "Export Messages to Excel")
        If strFilename <> "" Then
            intVersion = GetOutlookVersion()
            Set excApp = CreateObject("Excel.Application")
            Set excWkb = excApp.Workbooks.Add()
            Set excWks = excWkb.ActiveSheet
            'Write Excel Column Headers
            With excWks
                .Cells(1, 1) = "Subject"
                .Cells(1, 2) = "Received"
                .Cells(1, 3) = "Sender"
            End With
            intRow = 2
            'Write messages to spreadsheet
            For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
                'Only export messages, not receipts or appointment requests, etc.
                If olkMsg.Class = olMail Then
                    'Add a row for each field in the message you want to export
                    excWks.Cells(intRow, 1) = olkMsg.Subject
                    excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
                    excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
                    intRow = intRow + 1
                End If
            Next
            Set olkMsg = Nothing
            excWkb.SaveAs strFilename
            excWkb.Close
        End If
        Set excWks = Nothing
        Set excWkb = Nothing
        Set excApp = Nothing
        MsgBox "Process complete.  A total of " & intRow - 2 & " messages were exported.", vbInformation + vbOKOnly, "Export messages to Excel"
    End Sub
     
    Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
        Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
        On Error Resume Next
        Select Case intOutlookVersion
            Case Is < 14
                If Item.SenderEmailType = "EX" Then
                    GetSMTPAddress = SMTP2007(Item)
                Else
                    GetSMTPAddress = Item.SenderEmailAddress
                End If
            Case Else
                Set olkSnd = Item.Sender
                If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                    Set olkEnt = olkSnd.GetExchangeUser
                    GetSMTPAddress = olkEnt.PrimarySmtpAddress
                Else
                    GetSMTPAddress = Item.SenderEmailAddress
                End If
        End Select
        On Error GoTo 0
        Set olkPrp = Nothing
        Set olkSnd = Nothing
        Set olkEnt = Nothing
    End Function
     
    Function GetOutlookVersion() As Integer
        Dim arrVer As Variant
        arrVer = Split(Outlook.Version, ".")
        GetOutlookVersion = arrVer(0)
    End Function
     
    Function SMTP2007(olkMsg As Outlook.MailItem) As String
        Dim olkPA As Outlook.PropertyAccessor
        On Error Resume Next
        Set olkPA = olkMsg.PropertyAccessor
        SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")
        On Error GoTo 0
        Set olkPA = Nothing
    End Function
    
    

    The problem with this script is that it takes all emails in the folder and not just the one or two that is marked.

    Also this script over writes the excel file if this exists I would like it to append to the file instead.

    Thanks in advance for any help.


    Thanks Jesper

    Tuesday, August 20, 2013 6:46 PM

Answers

  • Hi,

    What do you mean by "emails be marked"? Do you mean flag or categorize email?

    If I understood correctly, you can compare the properties, categories or FlagRequset of olkMsg object.

    The code below can append results to an exist Excel file:

    Sub ExportMessagesToExcel()
        Dim olkMsg As Object, _
            excApp As Object, _
            excWkb As Object, _
            excWks As Object, _
            intRow As Integer, _
            intVersion As Integer, _
            strFilename As String
        strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", "Export Messages to Excel")
        If strFilename <> "" Then
            intVersion = GetOutlookVersion()
            Set excApp = CreateObject("Excel.Application")
            If Dir(strFilename) <> "" Then
                 Set excWkb = excApp.Workbooks.Open(strFilename)
               
            Else
                Set excWkb = excApp.Workbooks.Add()
            End If
            Set excWks = excWkb.ActiveSheet
            'Write Excel Column Headers
           With excWks
                    .Cells(1, 1) = "Subject"
                    .Cells(1, 2) = "Received"
                    .Cells(1, 3) = "Sender"
            End With
            
            intRow = 2
            Do While excWks.Cells(intRow, 1).Value <> ""
                intRow = intRow + 1
            Loop
          
            'if(
            'Write messages to spreadsheet
            For Each olkMsg In Application.ActiveExplorer.currentFolder.Items
                'Only export messages, not receipts or appointment requests, etc.
                If olkMsg.Class = olMail Then
                    'Add a row for each field in the message you want to export
                    excWks.Cells(intRow, 1) = olkMsg.Subject
                    excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
                    excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
                    intRow = intRow + 1
                End If
            Next
            Set olkMsg = Nothing
            excWkb.SaveAs strFilename
            excWkb.Close
        End If
        Set excWks = Nothing
        Set excWkb = Nothing
        Set excApp = Nothing
        MsgBox "Process complete.  A total of " & intRow - 2 & " messages were exported.", vbInformation + vbOKOnly, "Export messages to Excel"
    End Sub

    You can get more information from link below:

    MailItem Properties (Outlook)



    <THE CONTENT IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, WHETHER EXPRESS OR IMPLIED>
    Thanks
    MSDN Community Support

    Please remember to "Mark as Answer" the responses that resolved your issue. It is a common way to recognize those who have helped you, and makes it easier for other visitors to find the resolution later.


    Wednesday, August 21, 2013 10:54 AM
    Moderator