2

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

每当我运行时，运行时错误都会有所不同。例如，有时我收到 -970718969 (c6240107) 和另一次收到 -2044460793 (86240107)。

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

For Each itm In subFld.Items

这是屏幕截图： http://i.stack.imgur.com/y3Jcw.png

这是完整的代码：

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
4

1 回答 1

0

您是立即收到该错误还是仅在处理大量项目后才收到该错误？很可能您打开了太多项目并用完了 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 中使用它，您可以在Redemption中使用MAPITable对象（它还有一个 MAPITable.ExecSQL 方法，该方法采用标准 SQL 查询并返回 ADODB.Recordset 对象）。

于 2013-07-09T16:55:42.740 回答