每天從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