使用Excel VBA将收到的电子邮件每日记录从Outlook导出到文件
因此,我发现人们可以在Outlook中的一个文件夹中导出他们每天收到的电子邮件数量。问题是我需要对数百个文件夹执行此操作,因此我要尝试使其查看主文件夹中的所有子文件夹。如果我在一个文件夹中查找,并将其很好地导出,那么这种方法很好用。我想我已经达到了我的能力极限。我是朝着正确的方向前进,还是朝着效率低下的方向前进 非常接近一个解决方案现在只是崩溃,这可能是因为我有数以万计的电子邮件使用Excel VBA将收到的电子邮件每日记录从Outlook导出到文件,excel,vba,outlook,Excel,Vba,Outlook,因此,我发现人们可以在Outlook中的一个文件夹中导出他们每天收到的电子邮件数量。问题是我需要对数百个文件夹执行此操作,因此我要尝试使其查看主文件夹中的所有子文件夹。如果我在一个文件夹中查找,并将其很好地导出,那么这种方法很好用。我想我已经达到了我的能力极限。我是朝着正确的方向前进,还是朝着效率低下的方向前进 非常接近一个解决方案现在只是崩溃,这可能是因为我有数以万计的电子邮件 Option Explicit Sub CheckInbox() On Error GoTo
Option Explicit
Sub CheckInbox()
On Error GoTo Err_CheckEmail
'Disable Screen Updating
Application.ScreenUpdating = False
'Application Variables
Dim olApp As Outlook.Application
Dim objNS As Outlook.Namespace
Dim item As Object
Dim myOlItems As Object
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set myOlItems = objNS.Folders("erashelp@aamc.org").Folders("Cabinet")
Dim intCount As Long: intCount = 0
Dim strFolder As String
Dim tmpDate As String
Dim i As Long: i = 0
'Folder Level 1
Dim olFolderA
'-----Parent Folder (Inbox)-----
strFolder = myOlItems.FolderPath
'Get Item Count
intCount = myOlItems.Items.Count
'Update Run Log
Call RunLog(strFolder, intCount)
'Loop Through Items
For i = intCount To 1 Step -1
'Set the Item index
Set item = myOlItems.Items(i)
If item.Class = olMail Then
'Get The Date/Subject
tmpDate = Format(item.ReceivedTime, "MM/dd/yyyy")
'Update Log
Call LogCounts(tmpDate, strFolder)
End If
Next
'-----Folder Level 1 (\\Inbox\Folder1)-----
For Each olFolderA In myOlItems.Folders
strFolder = olFolderA.FolderPath
'Get Item Count
intCount = olFolderA.Items.Count
'Update Run Log
Call RunLog(strFolder, intCount)
'Loop Through Items
For i = intCount To 1 Step -1
'Set the Item index
Set item = olFolderA.Items(i)
'Get The Date/Subject
tmpDate = Format(item.ReceivedTime, "MM/dd/yyyy")
'Update Log
Call LogCounts(tmpDate, strFolder)
Next
Next
'---Sort Worksheets / Format Columns---
'EmailCount
Worksheets("EmailCount").Select
Columns("A:C").Select
ActiveWorkbook.Worksheets("EmailCount").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("EmailCount").Sort.SortFields.Add Key:=Range("A2:A500000"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("EmailCount").Sort.SortFields.Add Key:=Range("B2:B500000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("EmailCount").Sort
.SetRange Range("A1:C10001")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Worksheets("EmailCount").Columns("A:B").EntireColumn.AutoFit
'RunLog
Worksheets("RunLog").Select
Columns("A:C").Select
ActiveWorkbook.Worksheets("RunLog").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("RunLog").Sort.SortFields.Add Key:=Range("A2:A500000"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("RunLog").Sort.SortFields.Add Key:=Range("B2:B500000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("RunLog").Sort
.SetRange Range("A1:C10001")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Worksheets("RunLog").Columns("A:C").EntireColumn.AutoFit
'Enable Screen Updating
Application.ScreenUpdating = True
'Exit Befor Error Handler
Exit Sub
Err_CheckEmail:
MsgBox Err.Description
'Enable Screen Updating
Application.ScreenUpdating = True
End Sub
Sub LogCounts(strInDate, strFolder)
On Error GoTo Err_Counts
'Set Worksheet to Log Emails
Worksheets("EmailCount").Select
'Declare Variables
Dim x As Long
Dim startRow As Long: startRow = 2 'Start Row
Dim endRow As Long: endRow = 100000 'End Row
'Loop through Log Worksheet
For x = startRow To endRow
'See if a row for the particular date already exists
If Format(Cells(x, 1).Value, "MM/DD/YYYY") = Format(strInDate, "MM/DD/YYYY") And Cells(x, 2).Value = strFolder Then
Cells(x, 3).Value = Cells(x, 3).Value + 1
Exit Sub
End If
'Exit Loop for Nulls
If Cells(x, 1).Value = "" Then
Exit For
End If
Next
'Prevent Log from Getting too large
If x = endRow Then
MsgBox "The Email Count worksheet contains too many records. Either extend the size or move the data to another spreadsheet."
Exit Sub
End If
'Create New Entry for Date
Cells(x, 1).Value = strInDate
Cells(x, 2).Value = strFolder
Cells(x, 3).Value = 1
'Exit before Error Handler
Exit Sub
Err_Counts:
MsgBox Err.Description
End
End Sub
Sub RunLog(strFolder, strCount)
On Error GoTo Err_Log
'Set Worksheet to Log Emails
Worksheets("RunLog").Select
'Declare Variables
Dim x As Long
Dim startRow As Long: startRow = 2 'Start Row of Log Worksheet
Dim endRow As Long: endRow = 100000 'End Row of the Log Worksheet
'Loop through Worksheet to find Empty Row
For x = startRow To endRow
'Exit Loop for Nulls
If Cells(x, 1).Value = "" Then
Exit For
End If
Next
'Prevent Log from Getting too large
If x = endRow Then
MsgBox "The run log contains too many records. Either extend the log size or move the data to another spreadsheet."
Exit Sub
End If
'Create New Entry for Date
Cells(x, 1).Value = Now
Cells(x, 2).Value = strFolder
Cells(x, 3).Value = strCount
'Exit Before Error Handler
Exit Sub
Err_Log:
MsgBox Err.Description
End
End Sub
在开发过程中,在出错时删除转到,以便更容易地查看出错的行 在处理所有子文件夹之前,您无需关注当前错误 试试这个:
Private Sub LoopFolders_Test()
'Application Variables
Dim olApp As Outlook.Application
Dim objNS As Outlook.Namespace
Dim myolItems As Folder
Dim Start As Date
Dim EndTime As Date
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
'Set myOlItems = objNS.GetDefaultFolder(olFolderInbox)
Set myolItems = objNS.PickFolder
If myolItems Is Nothing Then GoTo exitRoutine
Start = Now
Debug.Print "Start: " & Start
Debug.Print "Startfolder Name: " & myolItems.Name
'Disable Screen Updating
'Application.ScreenUpdating = False
LoopFolders myolItems.Folders
' Finalize Excel display here
exitRoutine:
Set olApp = Nothing
Set objNS = Nothing
Set myolItems = Nothing
'Enable Screen Updating
'Application.ScreenUpdating = True
EndTime = Now
Debug.Print "End : " & EndTime
Debug.Print Format((EndTime - Start) * 86400, "#,##0.0") & " seconds"
End Sub
Private Sub LoopFolders(olFolders As Folders)
Dim F As Folder
For Each F In olFolders
DoEvents
Debug.Print "Subfolder Name: " & F.Name ' Code has not crashed
' Count mail here
LoopFolders F.Folders
Next
End Sub
您的不匹配项在哪里?修复了不匹配项,将item设置为Object而不是MailItem。不匹配项设置为item=myOlItems.Itemsi。现在我不知道代码是崩溃了还是要花很长时间,因为我有21k封电子邮件要处理。