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

你假设每一个都是一个邮件项目。

如果项目不是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

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

1 个答案: