Question

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

每次运行时运行时错误都不同。例如，有时我收到-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配置文件？

不使用循环遍历所有项目，而是使用Table对象（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

对于Table对象（在Outlook 2007中引入），请参阅http://msdn.microsoft.com/en-us/library/office/ff860769.aspx。如果需要在早期版本的Outlook中使用它，可以使用MAPITable中的Redemption对象（它还有一个MAPITable.ExecSQL方法，它接受标准SQL查询并返回ADODB.Recordset对象）。

通过Outlook项循环运行时错误

1 个答案: