用excel计算电子邮件VBA
问题描述:
第一次发布 - 希望我已经清楚了。用excel计算电子邮件VBA
我没有用excel VBA查看过,但已经设法通过这些论坛查找和更改(在我的IT区域的帮助下)一些代码,这些代码根据单元格中的日期统计Outlook文件夹中的电子邮件数量。在一个文件夹中计算电子邮件时,代码工作正常。我需要的代码是将多个文件夹中的电子邮件(其中的列表存储在工作簿的工作表中)计数并将计数输出到单独的列中。 (!希望能发布图片作为一个例子,但我需要更高的REP)
这里是我的代码至今:
Sub CountingEmails()
' Set Variables
Dim objOutlook As Object, objnSpace As Object, objFolder As Object
Dim EmailCount As Integer, DateCount As Integer, iCount As Integer
Dim myDate As Date
Dim myCell As Object
Dim dictEmailDates As New Scripting.Dictionary
Dim folder1 As String, folder2 As String, folder3 As String
folder1 = Sheets("Sheet1").Cells.Cells(2, 5)
folder2 = Sheets("Sheet1").Cells.Cells(2, 6)
folder3 = Sheets("Sheet1").Cells.Cells(2, 7)
' Get Outlook Object
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
' Get Folder Object
On Error Resume Next
Set objFolder = objnSpace.Folders(folder1)
If Not IsEmpty(folder2) Then
Set objFolder = objFolder.Folders(folder2)
End If
If Not IsEmpty(folder3) Then
Set objFolder = objFolder.Folders(folder3)
End If
If Err.Number <> 0 Then
Err.Clear
MsgBox "Folder doesn't exist. Please ensure you have input the correct folder details."
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
Exit Sub
End If
EmailCount = objFolder.Items.Count
FolderCount = objFolder.Folders.Count
' Put ReceivedTimes in array
CountEmails objFolder, dictEmailDates
' Clear Outlook objects
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
' Count the emails dates equal to active cell
Sheets("Sheet1").Range("A2").Select
Do Until IsEmpty(ActiveCell)
DateCount = 0
myDate = ActiveCell.Value
If dictEmailDates.Exists(myDate) Then
DateCount = dictEmailDates(myDate)
End If
Selection.Offset(0, 1).Activate
ActiveCell.Value = DateCount
Selection.Offset(1, -1).Activate
Loop
MsgBox "Count Complete", vbInformation, "Count of Emails."
End Sub
Sub CountEmails(objFolder, dictEmailDates)
EmailCount = objFolder.Items.Count
FolderCount = objFolder.Folders.Count
' Put ReceivedTimes in array
EmailCount = objFolder.Items.Count
For iCount = 1 To EmailCount
With objFolder.Items(iCount)
dateKey = DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime))
If dictEmailDates.Exists(dateKey) Then
dictEmailDates(dateKey) = dictEmailDates(dateKey) + 1
Else
dictEmailDates.Add dateKey, 1
End If
End With
Next iCount
For iCount = 1 To FolderCount
CountEmails objFolder.Folders(iCount), dictEmailDates
Next iCount
End Sub
希望有人能帮助?如果有什么额外的,或者我需要更多的解释,请让我知道!
干杯,阿德里安
答
如果我以下,这个问题是,folder1
(或2或3)是被计数的唯一文件夹。这个问题似乎是,你只有一个文件夹加载到你的字典中(根据我认为它是folder3
的代码)。我会通过重构代码来解决这个问题(我还添加了一些性能改进,并删除了一堆看起来什么都不做的东西):
Sub CountingEmails()
' Set Variables
Dim objOutlook As Object, objnSpace As Object, objFolder As Object
Dim myDate As Date
Dim dictEmailDates As New Scripting.Dictionary
Dim i As Integer
Dim dcell As Range 'refering to range saves you having to keep retyping range to use,
'reducing likelihood of typo
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'refering to ws saves having to type out
'Sheet1 each time, and also makes it easier to update code if sheet name ever changes
'Turn off screen updates for faster run
Application.ScreenUpdating = False
'Get the Outlook items setup
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
'Start looping through the folders
i = 0
Do Until IsEmpty(ws.Cells.Cells(2, 5 + i))
' Get Folder Object
On Error Resume Next
Set objFolder = objnSpace.Folders(ws.Cells.Cells(2, 5 + i))
'Get count of items and put in array based on ReceivedTimes
CountEmails objFolder, dictEmailDates
Loop
'Notice I completely removed Date and Folder count from this sub, they were only ever
'set here, not used. Looked like legacy code from attempting to perform the count in
'this sub rather than the self-referencing sub you created.
' Clear Outlook objects
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
' Count the emails dates equal to current cell
i = 2
Set dcell = ws.Range("A" & i)
Do Until IsEmpty(dcell)
DateCount = 0
myDate = dcell.Value
If dictEmailDates.Exists(myDate) Then
DateCount = dictEmailDates(myDate)
End If
dcell.Offset(0, 1).Value = DateCount
i = i + 1
Set dcell = ws.Range("A" & i)
Loop
Application.ScreenUpdating = True
MsgBox "Count Complete", vbInformation, "Count of Emails."
End Sub
Sub CountEmails(objFolder, dictEmailDates)
EmailCount = objFolder.Items.Count
FolderCount = objFolder.Folders.Count
' Put ReceivedTimes in array
For iCount = 1 To EmailCount
With objFolder.Items(iCount)
dateKey = DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime))
If dictEmailDates.Exists(dateKey) Then
dictEmailDates(dateKey) = dictEmailDates(dateKey) + 1
Else
dictEmailDates.Add dateKey, 1
End If
End With
Next iCount
For iCount = 1 To FolderCount
CountEmails objFolder.Folders(iCount), dictEmailDates
Next iCount
End Sub
您收到了什么错误消息? – WorkSmarter 2015-03-02 23:04:27
我还没有收到任何错误消息,它只是计数第一个文件夹,并将计数输出到日期范围旁边的列中。我希望代码能够移动到列表中的下一个文件夹,并将计数输出到下一个可用列,依此类推。 – ajvaleri 2015-03-03 04:52:26