运行时错误通过Outlook项目

Question

我使用VBA在Outlook中提取的mainfolder和子项邮件信息循环。主文件夹无法将子文件夹属性设置（捕获）到其中，并导致运行时错误。

运行时错误的区别，每当我跑。例如，有时我收到-970718969（c6240107），另一次收到-2044460793（86240107）。

当我点击调试，它指向这行代码：

For Each itm In subFld.Items 

下面是截图：

下面是完整的代码：

Public monthValue As Integer 
Public yearValue As String 

'Ensure Microsoft Excel 11.0 Object Library is ticked in tools. 
Sub ExportToExcel1() 

Dim appExcel As Excel.Application 
Dim wkb As Excel.Workbook 
Dim wks As Excel.Worksheet 
Dim rng As Excel.Range 
Dim strSheet As String 
Dim strPath As String 
Dim intRowCounter As Integer 
Dim msg As Outlook.MailItem 
Dim nms As Outlook.NameSpace 
Dim mainFld As Outlook.MAPIFolder 
Dim subFld As Outlook.MAPIFolder 
Dim itm As Object 
Dim offsetRow As Long 
Dim emailCount As Long 

'Set the path of the excel file. 
strSheet = "For fun.xlsx" 
strPath = "C:\Users\xxxxxx\Desktop\xxxxx\" 
strSheet = strPath & strSheet 

Debug.Print strSheet 

Set nms = Application.GetNamespace("MAPI") 
Set mainFld = nms.PickFolder 'Open the box to select the file. 

'Handle potential errors with Select Folder dialog box. 
If mainFld Is Nothing Then 
    MsgBox "Thank you for using this service.", vbOKOnly, "Error" 
    Set nms = Nothing 
    Set mainFld = Nothing 
    Exit Sub 
ElseIf mainFld.DefaultItemType <> olMailItem Then 
    MsgBox "Please select the correct folder.", vbOKOnly, "Error" 
    Set nms = Nothing 
    Set mainFld = Nothing 
    Exit Sub 
ElseIf mainFld.Items.Count = 0 Then 
    MsgBox "There are no mail messages to export", vbOKOnly, "Error" 
    Set nms = Nothing 
    Set mainFld = Nothing 
    Exit Sub 
End If 

mainForm.Show 
'If user clicks cancel, it will exit sub. 
If yearValue = "" Then 
    Set nms = Nothing 
    Set mainFld = Nothing 
    Exit Sub 
End If 

'Open and activate Excel workbook. 
Set appExcel = CreateObject("Excel.Application") 
    appExcel.Workbooks.Open (strSheet) 
Set wkb = appExcel.ActiveWorkbook 
Set wks = wkb.Sheets(1) 
wks.Activate 
appExcel.Application.Visible = True 'Show my workbook. 

'Check if there are any subfolders. 
If mainFld.Folders.Count = 0 Then '1 
    'No subfolder. 
    For Each itm In mainFld.Items 
     If itm.Class <> olMail Then '2 
      'do nothing 
     Else 
      Set msg = itm 
      'Validate the month and year for the email. 
      If Month(msg.ReceivedTime) = monthValue And Year(msg.ReceivedTime) = yearValue Then '3 
       With wks 
        offsetRow = .Cells(.Rows.Count, 1).End(xlUp).Row 
       End With 
       intRowCounter = 1 + offsetRow 
       Set rng = wks.Cells(intRowCounter, 1) 
        rng.Value = msg.ReceivedTime 
       Set rng = wks.Cells(intRowCounter, 2) 
        rng.Value = msg.SentOn 
       Set rng = wks.Cells(intRowCounter, 3) 
        rng.Value = msg.Subject 
       emailCount = 1 + emailCount 'Track the number of email. 
      Else 
       'Do nothing 
      End If '3 
     End If '2 
    Next itm 
Else 
    'With subfolder 
    For Each itm In mainFld.Items 
     If itm.Class <> olMail Then '4 
      'do nothing 
     Else 
      Set msg = itm 
      If Month(msg.ReceivedTime) = monthValue And Year(msg.ReceivedTime) = yearValue Then '5 
       With wks 
        offsetRow = .Cells(.Rows.Count, 1).End(xlUp).Row 
       End With 
       intRowCounter = 1 + offsetRow 
       Set rng = wks.Cells(intRowCounter, 1) 
        rng.Value = msg.ReceivedTime 
       Set rng = wks.Cells(intRowCounter, 2) 
        rng.Value = msg.SentOn 
       Set rng = wks.Cells(intRowCounter, 3) 
        rng.Value = msg.Subject 
       emailCount = 1 + emailCount 
      Else 
       'Do nothing 
      End If '5 
     End If '4 
    Next itm 
    For Each subFld In mainFld.Folders 
     For Each itm In subFld.Items 
      If itm.Class <> olMail Then '6 
       'do nothing 
      Else 
       Set msg = itm 
       If Month(msg.ReceivedTime) = monthValue And Year(msg.ReceivedTime) = yearValue Then '7 
        With wks 
         offsetRow = .Cells(.Rows.Count, 1).End(xlUp).Row 
        End With 
        intRowCounter = 1 + offsetRow 
        Set rng = wks.Cells(intRowCounter, 1) 
         rng.Value = msg.ReceivedTime 
        Set rng = wks.Cells(intRowCounter, 2) 
         rng.Value = msg.SentOn 
        Set rng = wks.Cells(intRowCounter, 3) 
         rng.Value = msg.Subject 
        emailCount = 1 + emailCount 
       Else 
        'Do nothing 
       End If '7 
      End If '6 
     Next itm 
    Next subFld 
End If '1 


Set appExcel = Nothing 
Set wkb = Nothing 
Set wks = Nothing 
Set rng = Nothing 
Set msg = Nothing 
Set nms = Nothing 
Set mainFld = Nothing 
Set subFld = Nothing 
Set itm = Nothing 

'Inform the user that there are no email. 
If emailCount = 0 Then 
    MsgBox "No emails associated with this date: " & MonthName(monthValue, True) & " " & yearValue, vbOKOnly, "No Emails" 
End If 

Exit Sub 

Set appExcel = Nothing 
Set wkb = Nothing 
Set wks = Nothing 
Set rng = Nothing 
Set msg = Nothing 
Set nms = Nothing 
Set mainFld = Nothing 
Set subFld = Nothing 
Set itm = Nothing 

End Sub 

Answer 1

你立即或仅在处理大量项目后才能获得该错误？最有可能的是你打开了太多的项目并用完RPC通道。这是一个缓存或在线Exchange配置文件？

而是通过全项循环中，使用表对象（MAPITable.GetTable） - 如果不出意外，这将是一个速度快了很多。

编辑：如果您使用的是Exchange，每个存储对象（邮件，文件夹，存储）打开一个RPC通道。 Exchange Server将每个客户端的RPC通道数限制为255（可在服务器上更改）。不要使用“for each”循环（它会保留所有项目直到循环结束）并避免使用多点表示法（因为您将有隐式变量，您无法显式取消引用）。您还需要在完成所有Outlook对象后立即释放它们。

set fldItems = mainFld.Items 
For i = 1 to fldItems.Count do 
    set itm = fldItems.Item(i) 
    'do stuff 
    set itm = Nothing 
next 

为表对象（在Outlook 2007引入），见http://msdn.microsoft.com/en-us/library/office/ff860769.aspx。如果您需要在Outlook的早期版本中使用此，您可以使用Redemption的MAPITable对象（它也有一个MAPITable.ExecSQL方法，它采用标准的SQL查询并返回ADODB.Recordset对象）。