VBA MACRO - Excelに電子メールアドレスをエクスポート

Question

私はここにVBAコードを持っており、選択したサブフォルダの電子メールアドレスをExcelファイルにエクスポートします。私の問題は、それは自分のフォルダのうちの1つにしか働かないということです。

このマクロを他のフォルダに使用すると、「Run Time Error 13 TYPE MISMATCH」というエラーが表示されます。なぜ私はこのエラーが出ているのか分かりません。誰かが問題がどこから来たのかを発見するのを助けてくれることを願っています

は、ここに私のコードです：

Sub ExportToExcel() 


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.xlsx" 
strPath = "C:\Users\Gabriel.Alejandro\Desktop\" 
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. 


    '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 'The part where I am getting the ERROR 

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 


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 

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 

Answer 1

あなたはすべてのITMがmailitemであると仮定します。

それはmailitemでない場合は、アイテムをスキップできます。

For Each itm In fld.items 

    intColumnCounter = 1 

    If itm.Class = olMail Then 

     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 

    Else 

     Debug.Print " Item is not a mailitem." 

    End If 

Next itm 

項目はあなたが必要なプロパティを持っていない場合は、代わりにエラーを回避することができます。

For Each itm In fld.items 

    intColumnCounter = 1 

    intRowCounter = intRowCounter + 1 
    Set rng = wks.Cells(intRowCounter, intColumnCounter) 
    On Error Resume Next 
    rng.Value = itm.To 
    On Error GoTo 0 

    intColumnCounter = intColumnCounter + 1 
    Set rng = wks.Cells(intRowCounter, intColumnCounter) 
    On Error Resume Next 
    rng.Value = itm.senderemailaddress 
    On Error GoTo 0 

Next itm