Макрос для экспорта даты, категории и количества писем из Outlook - PullRequest
Новая
       11

Макрос для экспорта даты, категории и количества писем из Outlook

0 голосов
/ 04 июня 2018

Я пытаюсь написать макрос для экспорта даты, категории и количества писем в файл Excel из Outlook.Запрос, который я изменил по сравнению с тем, что нашел в Интернете, работает, чтобы получить категории и количество адресов электронной почты, но я не могу понять, как добавить дату.

Sub CategoriesEmails()

Dim objOL As Outlook.Application
Set objOL = New Outlook.Application

Dim oFolder As MAPIFolder
Dim oDict As Object
Dim sStartDate As String
Dim sEndDate As String
Dim oItems As Outlook.Items
Dim sStr As String
Dim sMsg As String
Dim oExcelWorkbook As Excel.Workbook
Dim oExcelWorksheet As Excel.Worksheet
Dim ArrayKey As Variant
Dim ArrayItem As Variant
Dim i As Long
Dim nRow As Integer

On Error Resume Next

Set oExcelWorkbook = ActiveWorkbook
Set oExcelWorksheet = oExcelWorkbook.Sheets("Emails")

Set oFolder = Outlook.Application.Session.PickFolder

Set oDict = CreateObject("Scripting.Dictionary")

sStartDate = InputBox("Type the start date (format MM/DD/YYYY)")
sEndDate = InputBox("Type the end date (format MM/DD/YYYY)")

Set oItems = oFolder.Items.Restrict("[Received] >= '" & sStartDate & "' And [Received] <= '" & sEndDate & "'")
oItems.SetColumns ("Categories")

For Each aItem In oItems
sStr = aItem.Categories
If Not oDict.Exists(sStr) Then
oDict(sStr) = 0
End If
oDict(sStr) = CLng(oDict(sStr)) + 1
Next aItem

ArrayKey = oDict.Keys
ArrayItem = oDict.Items
nRow = oExcelWorksheet.Range("C" & Rows.Count).End(xlUp).Row + 1

'Input the information into the Excel file
For i = LBound(ArrayKey) To UBound(ArrayKey)
    oExcelWorksheet.Cells(nRow, 3) = ArrayKey(i)
    oExcelWorksheet.Cells(nRow, 4) = ArrayItem(i)
    nRow = nRow + 1
Next

'Save the new Excel file
oExcelWorksheet.Columns("A:B").AutoFit
'oExcelWorkbook.Select
Application.Dialogs(xlDialogSaveAs).Show

Set oFolder = Nothing

 End Sub

Результаты выглядят примерно так: 

Red 3
Yellow 4
Green 6
...