none
Date Format on Outlook Date Extracts incorrect RRS feed

  • Question

  • Hi All

    I am using VBA to extract "dates and times" of the Last Verb Executed and am using the UTC function kindly provided by this forum.  However I am having an issues where some dates are coming across in the format dd/mm/yyyy hh:mm whereas others are coming across in the format mm/dd/yyyy hh:mm which is skewing my metrics.

    Can anyone advise what I may be doing wrong please.

    Look forward to hearing from anyone.

    Thanks in anticipation.

    Kind regards

    Tony


    TKHussar

    Monday, January 4, 2016 3:24 PM

Answers

  • >>>For example if I run the code on a particular email that I am having issues with the forwarded date is shown in the actual email as "6/11/2015 16:14".  However when I run the routine provided by Graham it is displaying in Excel as "11/6/2015 17:14".<<<

    According to your description, it's possible that  you are returning a string and vba will assume US format if possible-perhaps use:

    If IsDate(StrColM) Then
       xlSheet.Range("M" & NextRow) = CDate(StrColM)
    Else
       xlSheet.Range("M" & NextRow) = StrColM
    End If

    • Marked as answer by David_JunFeng Sunday, January 17, 2016 2:48 PM
    Wednesday, January 6, 2016 8:03 AM

All replies

  • Hello Tony,

    Try to check the LanguageSettings property of the Application class which returns a LanguageSettings object for the application that contains the language-specific attributes of Outlook.

    Monday, January 4, 2016 3:53 PM
  • Hi Eugene

    Many thanks for your swift response.  How would that explain the fact that some dates are coming across in the correct format (even though they may be an hour out in terms of times)?

    Look forward to hearing from you.

    Kind regards

    Tony


    TKHussar

    Monday, January 4, 2016 4:18 PM
  • What is your code? PT_SYSTIME properties are returned as DateTime values, they are not formatted in any way (since they are not strings) until you convert the data to strings.

    Dmitry Streblechenko (MVP)
    http://www.dimastr.com/redemption
    Redemption - what the Outlook
    Object Model should have been
    Version 5.5 is now available!

    Monday, January 4, 2016 5:07 PM
  • >>>However I am having an issues where some dates are coming across in the format dd/mm/yyyy hh:mm whereas others are coming across in the format mm/dd/yyyy hh:mm which is skewing my metrics.

    According to your description, for the sake of there aren't sample codes, I have tried to make a sample to reproduce this issue, unfortunately, I can't. So I suggest that you could use CDate Function to return an expression that has been converted to a Variant of subtype Date. You could refer to below code:

    Sub GetDate()
        Dim msg As Outlook.MailItem
    
        Set msg = Application.ActiveExplorer.Selection.item(1)
        strDate = GetLastVerb(msg)
        Debug.Print strDate
        Debug.Print CDate(strDate)
        
    End Sub
    Public Function GetLastVerb(olkMsg As Outlook.MailItem) As String
    Dim intVerb As Integer
    intVerb = GetProperty(olkMsg, "http://schemas.microsoft.com/mapi/proptag/0x10810003")
    Select Case intVerb
        Case 102
            Debug.Print ("Reply to Sender")
            GetLastVerb = GetLastVerbTime(olkMsg)
        Case 103
            Debug.Print ("Reply to All")
            GetLastVerb = GetLastVerbTime(olkMsg)
        Case 104
         Debug.Print ("Forward")
            GetLastVerb = olkMsg.ReceivedTime
        Case 108
         Debug.Print ("Reply to Forward")
            GetLastVerb = GetLastVerbTime(olkMsg)
        Case Else
         Debug.Print ("Unknown")
            GetLastVerb = "Not replied to"
    End Select
    End Function
    
    Public Function GetProperty(olkItm As Object, strPropName As String) As Date
    Dim olkPA As Outlook.propertyAccessor
    Set olkPA = olkItm.propertyAccessor
    GetProperty = olkPA.UTCToLocalTime(olkPA.GetProperty(strPropName))
    Set olkPA = Nothing
    End Function
    
    Public Function GetLastVerbTime(olkItm As Object) As Variant
    GetLastVerbTime = GetDateProperty(olkItm, "http://schemas.microsoft.com/mapi/proptag/0x10820040")
    End Function
    
    Public Function GetDateProperty(olkItm As Object, strPropName As String) As Date
    Dim olkPA As Outlook.propertyAccessor
    Set olkPA = olkItm.propertyAccessor
    GetDateProperty = olkPA.UTCToLocalTime(olkPA.GetProperty(strPropName))
    Set olkPA = Nothing
    End Function

    Otherwise could you provide more information about your issue, for example sample code, screenshot etc., that will help us reproduce and resolve your issue.
    Thanks for your understanding.


    Tuesday, January 5, 2016 3:09 AM
  • Hi

    Many thanks for your response.  A copy of my current code (kindly provided by Graham Mayor) is shown below.

    For example if I run the code on a particular email that I am having issues with the forwarded date is shown in the actual email as "6/11/2015 16:14".  However when I run the routine provided by Graham it is displaying in Excel as "11/6/2015 17:14".  This does not happen on every email and I have searched high and low for a pattern that may be causing this to happen but cant find one.

    Any help would be appreciated.

    Tony

    Option Explicit
     
    Sub Defra_EmailExport()
        Dim xlApp As Object
        Dim xlWB As Object
        Dim xlSheet As Object
        Dim rCount As Long
        Dim bXStarted As Boolean
        Dim cFolders As Collection
        Dim olFolder As Folder
        Dim subFolder As Folder
        Dim olNS As NameSpace
        Dim strPath As String
         
        strPath = "D:\Email Metrics\Master Email Metrics.xlsm"
         
        On Error Resume Next
        Set xlApp = GetObject(, "Excel.Application")
        If Err <> 0 Then
            Set xlApp = CreateObject("Excel.Application")
            bXStarted = True
        End If
        On Error GoTo 0
         
        CreateFolders "D:\Email Metrics\"
        If FileExists(strPath) Then
            Set xlWB = xlApp.Workbooks.Open(strPath)
            Set xlSheet = xlWB.Sheets("DefraRawData")
        Else
            Set xlWB = xlApp.Workbooks.Add
            xlWB.Sheets(1).Name = "DefraRawData"
            Set xlSheet = xlWB.Sheets("DefraRawData")
             'Add column Headers
            With xlSheet
                .Range("A" & 1) = "Sender Name"
                .Range("B" & 1) = "Creation Time"
                .Range("C" & 1) = "Sent To"
                .Range("D" & 1) = "Recipients"
                .Range("E" & 1) = "Received By Name"
                .Range("F" & 1) = "Sent On"
                .Range("G" & 1) = "Received Time"
                .Range("H" & 1) = "UnRead"
                .Range("I" & 1) = "Last Modification Time"
                .Range("J" & 1) = "User Properties"
                .Range("K" & 1) = "Categories"
                .Range("L" & 1) = "Last Verb Executed"
                .Range("M" & 1) = "Last Verb Executed Time"
                .Range("N" & 1) = "Conversation ID"
                .Range("O" & 1) = "Conversation Index"
                .Range("P" & 1) = "Conversation Topic"
                .Range("Q" & 1) = "Recipient Type"
            End With
            xlWB.SaveAs strPath
        End If
         
        Set cFolders = New Collection
        Set olNS = GetNamespace("MAPI")
        On Error GoTo lbl_Exit
        cFolders.Add olNS.PickFolder
        Do While cFolders.count > 0
            Set olFolder = cFolders(1)
            cFolders.Remove 1
            ProcessFolder olFolder, xlSheet
            For Each subFolder In olFolder.folders
                cFolders.Add subFolder
            Next subFolder
        Loop
        xlWB.Save
        xlWB.Close
        If bXStarted Then xlApp.Quit
        MsgBox ("All Emails exported to Excel..........")
         
    lbl_Exit:
        Set xlApp = Nothing
        Set xlWB = Nothing
        Set xlSheet = Nothing
        Set olNS = Nothing
        Exit Sub
    End Sub
     
    Sub ProcessFolder(iFolder As Folder, xlSheet As Object)
        Dim i As Long
        Dim olItem As Outlook.mailItem
        Dim vSubject As Variant
        Dim NextRow As Long
        Dim strColA As String, strColB As String, strColC As String, strColD As String
        Dim strColE As String, strColF As String, strColG As String, strColH As String
        Dim strColI As String, StrColJ As String, StrColK As String, StrColL As String
        Dim StrColM As String, StrColN As String, StrColO As String, StrColP As String, StrColQ As String
        Dim PA As Outlook.propertyAccessor
        Dim PropName As String
        Dim LVE As String
        Dim LVET As String
        Dim v As Variant
        Dim olRecip As Recipient
        Dim dtUTC As Date
        Dim dtLocal As Date
    
        On Error Resume Next
        If iFolder.Items.count > 0 Then
            For i = 1 To iFolder.Items.count
                NextRow = xlSheet.Range("A" & xlSheet.Rows.count).End(-4162).Row + 1
                Set olItem = iFolder.Items(i)
                strColA = olItem.SenderName
                strColB = olItem.CreationTime
                strColC = olItem.To
                strColD = olItem.Recipients
                strColE = olItem.ReceivedByName
                strColF = olItem.SentOn
                strColG = olItem.ReceivedTime
                strColH = olItem.UnRead
                strColI = olItem.LastModificationTime
                StrColJ = olItem.UserProperties
                StrColK = olItem.Categories
                LVE = "http://schemas.microsoft.com/mapi/proptag/0x10810003"
                Set PA = olItem.propertyAccessor
                LVE = PA.GetProperty(LVE)
                StrColL = LVE
                LVET = "http://schemas.microsoft.com/mapi/proptag/0x10820040"
                Set PA = olItem.propertyAccessor
                dtUTC = PA.GetProperty(LVET)
                dtLocal = PA.UTCToLocalTime(dtUTC)
                dtLocal = PA.GetProperty(LVET)
                StrColM = dtLocal + TimeSerial(1, 0, 0)
                StrColN = olItem.ConversationID
                StrColO = olItem.ConversationIndex
                StrColP = olItem.ConversationTopic
                StrColQ = olRecip.Type '?
                xlSheet.Range("A" & NextRow) = strColA
                xlSheet.Range("B" & NextRow) = strColB
                xlSheet.Range("C" & NextRow) = strColC
                xlSheet.Range("D" & NextRow) = strColD
                xlSheet.Range("E" & NextRow) = strColE
                xlSheet.Range("F" & NextRow) = strColF
                xlSheet.Range("G" & NextRow) = strColG
                xlSheet.Range("H" & NextRow) = strColH
                xlSheet.Range("I" & NextRow) = strColI
                xlSheet.Range("J" & NextRow) = StrColJ
                xlSheet.Range("K" & NextRow) = StrColK
                xlSheet.Range("L" & NextRow) = StrColL
                xlSheet.Range("M" & NextRow) = StrColM
                xlSheet.Range("N" & NextRow) = StrColN
                xlSheet.Range("O" & NextRow) = StrColO
                xlSheet.Range("P" & NextRow) = StrColP
                xlSheet.Range("Q" & NextRow) = StrColQ
                NextRow = NextRow + 1
                DoEvents
            Next i
        End If
    lbl_Exit:
        Exit Sub
    End Sub
     
    Private Function FileExists(filespec) As Boolean
         'An Outlook macro by Graham Mayor
        Dim fso As Object
        Set fso = CreateObject("Scripting.FileSystemObject")
        If fso.FileExists(filespec) Then
            FileExists = True
        Else
            FileExists = False
        End If
    lbl_Exit:
        Exit Function
    End Function
     
    Private Function FolderExists(fldr) As Boolean
         'An Outlook macro by Graham Mayor
        Dim fso As Object
        Set fso = CreateObject("Scripting.FileSystemObject")
        If (fso.FolderExists(fldr)) Then
            FolderExists = True
        Else
            FolderExists = False
        End If
    lbl_Exit:
        Exit Function
    End Function
     
    Private Function CreateFolders(strPath As String)
         'An Outlook macro by Graham Mayor
        Dim strTempPath As String
        Dim lngPath As Long
        Dim vPath As Variant
        vPath = Split(strPath, "\")
        strPath = vPath(0) & "\"
        For lngPath = 1 To UBound(vPath)
            strPath = strPath & vPath(lngPath) & "\"
            If Not FolderExists(strPath) Then MkDir strPath
        Next lngPath
    lbl_Exit:
        Exit Function
    End Function
    Sub DefraRawDataContent()
    Dim xlApp As Excel.Application
    Dim xlWB As Excel.Workbook
    Dim xlSh As Excel.Worksheet
    
    Set xlApp = New Excel.Application
    Set xlWB = xlApp.Workbooks.Open("D:\Email Metrics\Master Email Metrics.xlsm")
    Set xlSh = xlWB.Sheets("DefraRawData")
    
    Range("A2:Q20000").Select
    Selection.ClearContents
    Range("A2").Select
    
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSh = Nothing
    
    End Sub


    TKHussar

    Tuesday, January 5, 2016 9:31 AM
  •             dtUTC = PA.GetProperty(LVET)
                dtLocal = PA.UTCToLocalTime(dtUTC)
                dtLocal = PA.GetProperty(LVET)
                StrColM = dtLocal + TimeSerial(1, 0, 0)

    After the date/time value is retrieved by the property accessor and converted from UTC to local the contents of the dtLocal variable that received the data is overwritten by the UTC time by calling GetProperty again.

    What purpose is served by modifying the Outlook data/time information by using the TimeSerial function?

    Tuesday, January 5, 2016 12:13 PM
  • Hi

    Many thanks for your response.  Adding the TimeSerial part was my (basic) way of correct gthe 1 hour time difference that was appearing in the resultant extract.

    Happy to remove it if we can get the correct time being extracted.

    Thanks

    Tony


    TKHussar

    Tuesday, January 5, 2016 12:22 PM
  • You can use the UTC format for comparing time and date values without converting them to local values.

    Set PA = olItem.propertyAccessor
    dtUTC = PA.GetProperty(LVET)
    Hope it makes any sense.

    Tuesday, January 5, 2016 12:26 PM
  • Hi

    Many thanks for your response.  Adding the TimeSerial part was my (basic) way of correct gthe 1 hour time difference that was appearing in the resultant extract.

    Happy to remove it if we can get the correct time being extracted.

    Thanks

    Tony


    TKHussar

    The UTC time returned by Outlook will be correct.  What is the basis for the belief that these times are "an hour out"? 

    It's possible that you need to accommodate Daylight Savings Time and how that affects the conversion from UTC to Local Time.

    Tuesday, January 5, 2016 2:00 PM
  • Can I possibly send you a sample file to see what output I am getting which is causing me an issue please?

    Tony


    TKHussar


    • Edited by TKHussar Tuesday, January 5, 2016 2:39 PM
    Tuesday, January 5, 2016 2:39 PM
  • You can upload files to Onedrive or equivalent and share a link to them in the forum.

    BTW, did you consider that the formatting issue may be due to the way Excel is configured to display date values?

    Tuesday, January 5, 2016 3:57 PM
  • Thanks.  Here is the link and you will see the issue I have in column M and S.

    https://onedrive.live.com/?id=root&cid=3153606DE3CEC19C

    Any advice appreciated.

    Kind regards

    Tony


    TKHussar

    Tuesday, January 5, 2016 4:35 PM
  • When I tried to retrieve the file the link took me to an empty folder.
    Tuesday, January 5, 2016 8:24 PM
  • >>>For example if I run the code on a particular email that I am having issues with the forwarded date is shown in the actual email as "6/11/2015 16:14".  However when I run the routine provided by Graham it is displaying in Excel as "11/6/2015 17:14".<<<

    According to your description, it's possible that  you are returning a string and vba will assume US format if possible-perhaps use:

    If IsDate(StrColM) Then
       xlSheet.Range("M" & NextRow) = CDate(StrColM)
    Else
       xlSheet.Range("M" & NextRow) = StrColM
    End If

    • Marked as answer by David_JunFeng Sunday, January 17, 2016 2:48 PM
    Wednesday, January 6, 2016 8:03 AM