每天从Excel导出收到的电子邮件使用Excel VBA

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