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