VBA MACRO - 将电子邮件地址导出到 Excel

Question

我在这里有一个 VBA 代码，可以将所选子文件夹的电子邮件地址导出到 Excel 文件。我的问题是，它只适用于我的一个文件夹。

当我尝试将此宏用于其他文件夹时，我收到“运行时错误 13 类型不匹配”错误。我真的不知道为什么会收到此错误。我希望有人能帮我找出问题出在哪里。

这是我的代码：

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

你假设每个它都是一个邮件。

如果它不是邮件项，您可以跳过它：

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