1

Outlook2010の特定のフォルダに関連するすべてのデータを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
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 に答える