使用 Excel VBA 將收到的電子郵件每日統計從 Outlook 導出到文件

Question

因此，我發現人們能夠在 Outlook 中為一個文件夾導出他們每天收到的電子郵件數量的記錄。 問題是我需要對數百個文件夾執行此操作，因此我打算嘗試查看主文件夾中的所有子文件夾。 如果我正在查看一個文件夾，這很好用，並且可以很好地導出它。 我想我已經達到了我的能力極限。 我是在朝着正確的方向前進，還是在走一條非常低效的道路？

現在真的接近解決方案只是崩潰，可能是因為我有數萬封電子郵件？

   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

Answer 1

在開發過程中刪除“On Error GoTo”以更輕松地查看有錯誤的行。

在您可以處理所有子文件夾之前，您無需關注當前的錯誤。

嘗試這個：

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