Counting категории в Outlook, с помощью VBA макросов

Question

Код ниже не учитываются категории от конкретного дня должным образом:

Sub HowManyEmails() 
Dim objOutlook As Object, objnSpace As Object, objFolder As MAPIFolder 
Dim EmailCount As Integer 
Set objOutlook = CreateObject("Outlook.Application") 
Set objnSpace = objOutlook.GetNamespace("MAPI") 
    On Error Resume Next 
    Set objFolder = Session.GetFolderFromID(Application.ActiveExplorer.CurrentFolder.EntryID) 
    If Err.Number <> 0 Then 
    Err.Clear 
    MsgBox "No such folder." 
    Exit Sub 
    End If 
EmailCount = objFolder.Items.Count 
MsgBox "Number of emails in the folder: " & EmailCount, , "email count" 
Dim dateStr As String 
Dim myItems As Outlook.Items 
Dim dict As Object 
Dim msg As String 
Dim oDate As String 

Set dict = CreateObject("Scripting.Dictionary") 
oDate = InputBox("Date for count (Format D-M-YYYY") 
Set myItems = objFolder.Items.Restrict("[Received] >= '" & oDate & "'") 
myItems.SetColumns ("Categories") 
For Each myItem In myItems 
    dateStr = myItem.Categories 
    If Not dict.Exists(dateStr) Then 
     dict(dateStr) = 0 
    End If 
    dict(dateStr) = CLng(dict(dateStr)) + 1 
Next myItem 
msg = "" 
For Each o In dict.Keys 
    msg = msg & o & ": " & dict(o) & vbCrLf 
Next 
MsgBox msg 
Set objFolder = Nothing 
Set objnSpace = Nothing 
Set objOutlook = Nothing 
End Sub 

Когда вы пишете дату, выход только категории и письма подсчитывать, которые не соответствуют выбранной Дата. Я совершенно не знаком с vba, так что, может быть, вы могли бы рассказать мне, как это можно исправить? Спасибо за помощь!

Answer 1

Формат даты, действительный для кого-то еще, скорее всего недействителен для вас.

Option Explicit 

Private Sub HowManyEmails() 

    Dim objFolder As Folder 
    Dim EmailCount As Integer 

    Dim myItem As Object 
    Dim o As Variant 

    Dim dateStr As String 
    Dim myItems As items 
    Dim dict As Object 
    Dim msg As String 
    Dim oDate As String 

    On Error Resume Next 
    Set objFolder = ActiveExplorer.CurrentFolder 

    If err.number <> 0 Then 
     err.Clear 
     MsgBox "No such folder." 
     Exit Sub 
    End If 

    ' Must closely follow an On Error Resume Next 
    On Error GoTo 0 

    EmailCount = objFolder.items.count 
    MsgBox "Number of emails in the folder: " & EmailCount, , "email count" 

    Set dict = CreateObject("Scripting.Dictionary") 

    ' oDate = InputBox("Date for count (Format D-M-YYYY") 
    oDate = InputBox("Date for count (Format YYYY-m-d") 

    Set myItems = objFolder.items.Restrict("[Received] >= '" & oDate & "'") 

    ' myItems.SetColumns ("Categories") ' You will find this error due to On Error GoTo 0 

    For Each myItem In myItems 
     dateStr = myItem.Categories 
     If Not dict.exists(dateStr) Then 
      dict(dateStr) = 0 
     End If 
     dict(dateStr) = CLng(dict(dateStr)) + 1 
    Next myItem 

    msg = "" 
    For Each o In dict.Keys 
     If o = "" Then 
      msg = msg & dict(o) & ": " & "Not categorized" & vbCrLf 
     Else 
      msg = msg & dict(o) & ": " & o & vbCrLf 
     End If 
    Next 
    MsgBox msg 

ExitRoutine: 
    Set objFolder = Nothing 
    Set dict = Nothing 

End Sub