1

我正在尝试将与 Outlook 2010 中特定文件夹相关的所有数据导出到 Excel。我需要收件人、发件人、正文、所有日期字段、有附件等。有没有一种方法可以在不逐字段定义的情况下包含所有字段？

当我运行下面的代码时，我有一个编译错误：Next without For。

我相信所有的IF都关闭了。

Sub ExportToExcel()

    On Error GoTo ErrHandler
    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 intColumnCounter As Integer    
Dim msg As Outlook.MailItem    
Dim nms As Outlook.NameSpace    
Dim fld As Outlook.MAPIFolder    
Dim itm As Object
    strSheet = "OutlookItems.xls"
    strPath = "C:\"

strSheet = strPath & strSheet    
Debug.Print strSheet
'Select export folder Set nms = Application.GetNamespace("MAPI")    
Set fld = nms.PickFolder
'Handle potential errors with Select Folder dialog box.

If fld Is Nothing Then    
MsgBox "There are no mail messages to export", vbOKOnly, "Error"    
Exit Sub    
ElseIf fld.DefaultItemType <> olMailItem Then    
MsgBox "There are no mail messages to export", vbOKOnly, "Error"    
Exit Sub    
ElseIf fld.Items.Count = 0 Then    
MsgBox "There are no mail messages to export", vbOKOnly, "Error"    
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
    'Copy field items in mail folder. For Each itm In fld.Items    
intColumnCounter = 1    
Set msg = itm    
intRowCounter = intRowCounter + 1    
Set rng = wks.Cells(intRowCounter, intColumnCounter)    
rng.Value = msg.To    
intColumnCounter = intColumnCounter + 1    
Set rng = wks.Cells(intRowCounter, intColumnCounter)    
rng.Value = msg.SenderEmailAddress    
intColumnCounter = intColumnCounter + 1    
Set rng = wks.Cells(intRowCounter, intColumnCounter)    
rng.Value = msg.Subject    
intColumnCounter = intColumnCounter + 1    
Set rng = wks.Cells(intRowCounter, intColumnCounter)    
rng.Value = msg.Body    
intColumnCounter = intColumnCounter + 1    
Set rng = wks.Cells(intRowCounter, intColumnCounter)    
rng.Value = msg.SentOn    
intColumnCounter = intColumnCounter + 1    
Set rng = wks.Cells(intRowCounter, intColumnCounter)    
rng.Value = msg.ReceivedTime    
Next itm    
Set appExcel = Nothing        
Set wkb = Nothing    
Set wks = Nothing    
Set rng = Nothing    
Set msg = Nothing    
Set nms = Nothing    
Set fld = Nothing    
Set itm = Nothing    
Exit Sub    
ErrHandler:  If Err.Number = 1004 Then    
MsgBox strSheet & " doesn't exist", vbOKOnly, "Error"    
Else    
MsgBox Err.Number & "; Description: ", vbOKOnly, "Error"    
End If    
Set appExcel = Nothing    
Set wkb = Nothing    
Set wks = Nothing    
Set rng = Nothing    
Set msg = Nothing    
Set nms = Nothing    
Set fld = Nothing    
Set itm = Nothing
End Sub
4

2 回答 2

2

这不是 For/Next 循环的问题。

换行

ErrHandler: If Err.Number = 1004 Then

至

ErrHandler:
If Err.Number = 1004 Then

提示：始终缩进您的代码 :) 您可能还想看到这个（第 4 点）？

编辑：请参阅上面链接中的第 6 点：) 要在您的代码中说明这一点，请参阅此部分

    Set appExcel = Nothing
    Set wkb = Nothing
    Set wks = Nothing
    Set rng = Nothing
    Set msg = Nothing
    Set nms = Nothing
    Set fld = Nothing
    Set itm = Nothing
    Exit Sub
 ErrHandler:
    If Err.Number = 1004 Then
        MsgBox strSheet & " doesn't exist", vbOKOnly, "Error"
    Else
        MsgBox Err.Number & "; Description: ", vbOKOnly, "Error"
    End If

    Set appExcel = Nothing
    Set wkb = Nothing
    Set wks = Nothing
    Set rng = Nothing
    Set msg = Nothing
    Set nms = Nothing
    Set fld = Nothing
    Set itm = Nothing
End Sub

这也可以写成

LetsContinue:
    Set appExcel = Nothing
    Set wkb = Nothing
    Set wks = Nothing
    Set rng = Nothing
    Set msg = Nothing
    Set nms = Nothing
    Set fld = Nothing
    Set itm = Nothing
    Exit Sub
ErrHandler:
    If Err.Number = 1004 Then
        MsgBox strSheet & " doesn't exist", vbOKOnly, "Error"
    Else
        MsgBox Err.Number & "; Description: ", vbOKOnly, "Error"
    End If

    Resume LetsContinue
End Sub

另一个例子

If fld Is Nothing Then
    MsgBox "There are no mail messages to export", vbOKOnly, "Error"
    Exit Sub
ElseIf fld.DefaultItemType <> olMailItem Then
    MsgBox "There are no mail messages to export", vbOKOnly, "Error"
    Exit Sub
ElseIf fld.Items.Count = 0 Then
    MsgBox "There are no mail messages to export", vbOKOnly, "Error"
    Exit Sub
End If 'Open and activate Excel workbook. Set appExcel = CreateObject("Excel.Application")

Set wkb = appExcel.Workbooks.Open(strSheet)
Set wks = wkb.Sheets(1)
wks.Activate

你不需要使用Exit Sub那么多次

您可以将其余代码放在ElseIF 部分

事实上，不要Exit Sub在你的代码中使用。原因是，您的代码将退出子程序，而不会破坏和清理您创建的对象。优雅地退出程序:)

跟进

试试这个代码。（未经测试）

Sub ExportToExcel()
    On Error GoTo ErrHandler

    '~~> Excel Objects / Variables
    Dim appExcel As Excel.Application
    Dim wkb As Excel.Workbook
    Dim wks As Excel.Worksheet

    Dim strSheet As String, strPath As String
    Dim intRowCounter As Long, intColumnCounter As Long

    '~~> Outlook Objects
    Dim msg As Outlook.MailItem
    Dim nms As Outlook.Namespace
    Dim fld As Outlook.MAPIFolder
    Dim itm As Object

    strSheet = "OutlookItems.xls"
    strPath = "C:\"

    strSheet = strPath & strSheet

    Set nms = Application.GetNamespace("MAPI")
    Set fld = nms.PickFolder

    If fld Is Nothing Then
        MsgBox "There are no mail messages to export", vbOKOnly, "Error"
    ElseIf fld.DefaultItemType <> olMailItem Then
        MsgBox "There are no mail messages to export", vbOKOnly, "Error"
    ElseIf fld.Items.Count = 0 Then
        MsgBox "There are no mail messages to export", vbOKOnly, "Error"
    Else
        'Open and activate Excel workbook.
        Set appExcel = CreateObject("Excel.Application")

        Set wkb = appExcel.Workbooks.Open(strSheet)
        Set wks = wkb.Sheets(1)
        appExcel.Visible = True

        'Copy field items in mail folder.
        For Each itm In fld.Items
            Set msg = itm

            With wks
                intRowCounter = intRowCounter + 1
                .Cells(intRowCounter, intColumnCounter) = msg.To

                intColumnCounter = intColumnCounter + 1
                .Cells(intRowCounter, intColumnCounter) = msg.SenderEmailAddress

                intColumnCounter = intColumnCounter + 1
                .Cells(intRowCounter, intColumnCounter) = msg.Subject

                intColumnCounter = intColumnCounter + 1
                .Cells(intRowCounter, intColumnCounter) = msg.Body

                intColumnCounter = intColumnCounter + 1
                .Cells(intRowCounter, intColumnCounter) = msg.SentOn

                intColumnCounter = intColumnCounter + 1
                .Cells(intRowCounter, intColumnCounter) = msg.ReceivedTime
            End With
        Next itm
    End If
LetsContinue:
    Set appExcel = Nothing
    Set wkb = Nothing
    Set wks = Nothing
    Set msg = Nothing
    Set nms = Nothing
    Set fld = Nothing
    Set itm = Nothing
    Exit Sub
ErrHandler:
    If Err.Number = 1004 Then
        MsgBox strSheet & " doesn't exist", vbOKOnly, "Error"
    Else
        MsgBox "Error Number: " & Err.Number & vbNewLine & _
               "Error Description: " & Err.Description, vbOKOnly, "Error"
    End If
    Resume LetsContinue
End Sub
于 2012-10-03T11:41:02.357 回答
1

假设您的代码看起来像您粘贴的内容，那么您收到错误的原因是这一行：

'Copy field items in mail folder. For Each itm In fld.Items

请注意循环的 for 部分是您的评论的一部分？

Siddharth 给了你很多很好的技巧来帮助避免这些问题，但是要让你的代码编译，只需将我展示给你的行替换为：

'Copy field items in mail folder. 
For Each itm In fld.Items

您还注释掉了另一行：

'Select export folder Set nms = Application.GetNamespace("MAPI")

应该：

'Select export folder 
Set nms = Application.GetNamespace("MAPI")
于 2012-10-03T12:29:02.203 回答