编译错误：下一个没有For

时间：2012-10-03 11:23:36

标签： excel vba outlook export

我正在尝试将与Outlook 2010中特定文件夹相关的所有数据导出到Excel。我需要To，From，Body，All date字段，Has Attachement等。有没有一种方法可以包含所有字段而无需逐字段定义？

当我运行以下代码时，我有一个编译错误：下一个没有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

2 个答案:

答案 0 :(得分：2)

这不是For / Next Loop的问题。

更改行

ErrHandler: If Err.Number = 1004 Then

到

ErrHandler:
If Err.Number = 1004 Then

提示：始终缩进代码:)您可能还想查看this（第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

您可以将其余代码放在IF

的Else部分

实际上，请勿在代码中使用Exit Sub。原因是，您的代码将在不破坏和清理您创建的对象的情况下退出子代码。优雅退出程序：）

<强>后续

试试这段代码。 （的 UNTESTED ）

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

答案 1 :(得分：1)

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

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

请注意，循环的部分内容是您评论的一部分吗？

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")
相关问题
最新问题