VBA MACRO - 將電子郵件地址導出到Excel

Question

我在這裏有一個VBA代碼，用於將所選子文件夾的電子郵件地址導出到Excel文件。我的問題是，它只適用於我的文件夾中的一個。

當我嘗試將此宏用於其他文件夾時，出現「運行時錯誤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