vba count of Outlook emails, dates in incorrect format

[VeryForgetful]

Hi,

I use the code below to count emails in my inbox with a total count for each date.

The problem is that some of the dates come out incorrectly formatted and some show as in the future. Can someone have a look at my code please to help me identify the problem?

Sub EmailCount()
    Dim ns As Outlook.Namespace
    Dim f As Outlook.MAPIFolder
    Dim dateStr As String
    Dim myItems As Outlook.Items
    Dim dict As Object
    Dim msg As String
    Dim NextRow As Long
    Dim FirstRow As Long
    
    Application.ScreenUpdating = False
    Set ns = Outlook.GetNamespace("MAPI")
    On Error Resume Next
    Set f = ns.Folders("Personal Folders").Folders("Inbox")
    If Err.Number <> 0 Then
        Err.Clear
        MsgBox "No such folder.", vbExclamation
        Exit Sub
    End If
    Set dict = CreateObject("Scripting.Dictionary")
    Set myItems = f.Items
    myItems.Sort "[SentOn]", True
    myItems.SetColumns "[SentOn]"
    FirstRow = 2
    ActiveSheet.Rows(FirstRow & ":" & ActiveSheet.Rows.Count).Clear
    ActiveSheet.UsedRange.Borders.LineStyle = xlNone
    For Each myItem In myItems
        dateStr = GetDate(myItem.SentOn)
        If Not dict.Exists(dateStr) Then
            dict(dateStr) = 0
        End If
        dict(dateStr) = CLng(dict(dateStr)) + 1
    Next myItem
    ' Output dates that have emails
    For Each o In dict.Keys
        NextRow = ActiveSheet.Range("C" & Rows.Count).End(xlUp).Row + 1
        msg = o
        ActiveSheet.Range("C" & NextRow) = msg
    Next
    ' Output email count per day:
    For Each o In dict.Keys
        NextRow = ActiveSheet.Range("D" & Rows.Count).End(xlUp).Row + 1
        msg = dict(o)
        ActiveSheet.Range("D" & NextRow) = msg
    Next
    
    Range("C1").CurrentRegion.Sort key1:=Range("C1"), order1:=xlDescending, Header:=xlYes
    
    Application.ScreenUpdating = False
End Sub


Function GetDate(dt As Date) As String
    GetDate = Int(dt)
End Function

[IMG]http://i65.tinypic.com/b4vvk1.png[/IMG]<strike></strike>

Thanks

 

[Norie]

Are values from the [SentOn] field 'real' date values or are they text?

 

[VeryForgetful]

Not sure.

I think the GetDate function may be where the error is.

They are either being converted to American format or are being stored as text but cant quite put my finger on the issue.

The cell formatting shows as date so I think they are seen as dates by Excel.

Not sure if I need to incorporate the CDATE function somewhere to stop the format from changing.

 

[Norie]

Actually, I think that function could be the problem because that is converting the values from the SentOn field to strings which could cause problems later.

If you just want to get the date part from that field try using DateValue/CDate.

Mind you I'm not sure how that would work with the dictionary as you might still need to convert to text, if you do I would suggest you use Format to ensure you keep the correct date format, ie UK.

 

[VeryForgetful]

I have tried various combinations of DateValue and CDate but still the same problem.

Any other suggestions please?

 

[Norie]

What exactly did you try?

 

[VeryForgetful]

I've figured it now thanks. See bits in red below.

Sub EmailCount()
    Dim ns As Outlook.Namespace
    Dim f As Outlook.MAPIFolder
    Dim dateStr As String
    Dim myItems As Outlook.Items
    Dim dict As Object
    Dim msg As String
    Dim NextRow As Long
    Dim FirstRow As Long
    
    Application.ScreenUpdating = False
    Set ns = Outlook.GetNamespace("MAPI")
    On Error Resume Next
    Set f = ns.Folders("Personal Folders").Folders("Inbox")
    If Err.Number <> 0 Then
        Err.Clear
        MsgBox "No such folder.", vbExclamation
        Exit Sub
    End If
    Set dict = CreateObject("Scripting.Dictionary")
    Set myItems = f.Items
    myItems.Sort "[SentOn]", True
    myItems.SetColumns "[SentOn]"
    FirstRow = 2
    ActiveSheet.Rows(FirstRow & ":" & ActiveSheet.Rows.Count).Clear
    ActiveSheet.UsedRange.Borders.LineStyle = xlNone
    For Each myItem In myItems
        dateStr = GetDate(myItem.SentOn)
        If Not dict.Exists(dateStr) Then
            dict(dateStr) = 0
        End If
        dict(dateStr) = CLng(dict(dateStr)) + 1
    Next myItem
    ' Output dates that have emails
    For Each o In dict.Keys
        NextRow = ActiveSheet.Range("C" & Rows.Count).End(xlUp).Row + 1
        [COLOR=#ff0000]msg = Format(o, dd - mm - yyyy)[/COLOR]
        ActiveSheet.Range("C" & NextRow) = msg
    Next
    ' Output email count per day:
    For Each o In dict.Keys
        NextRow = ActiveSheet.Range("D" & Rows.Count).End(xlUp).Row + 1
        msg = dict(o)
        ActiveSheet.Range("D" & NextRow) = msg
    Next
    
    Range("C1").CurrentRegion.Sort key1:=Range("C1"), order1:=xlDescending, Header:=xlYes
    
    Application.ScreenUpdating = False
End Sub


Function GetDate(dt As Date) As String
    [COLOR=#ff0000]GetDate = Day(dt) & "-" & Month(dt) & "-" & Year(dt)[/COLOR]
End Function

 

[Norie]

Ah, so you did need to use Format as I suggested.