VBA MACRO — экспорт адреса электронной почты в Excel

У меня есть код 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

outlook excel vba office-2013
person alejandraux    schedule 07.09.2016    source источник
comment
На какую версию Outlook/Office вы ориентируетесь? Разница между Outlook.Folder и Outlok.MAPIFolder, по-видимому, указывает на то, что Outlook.Namespace и Outlook.MAPIFolder устарели.   -  person Filburt    schedule 07.09.2016
comment
Я пытаюсь экспортировать в Office 2013. Этот код работает с одной из моих подпапок в Outlook, но не с другими папками.   -  person alejandraux    schedule 07.09.2016
comment
Пространство имен и MAPIFolder предназначены только для выбора папок, которые я хочу экспортировать. я не думаю, что это проблема   -  person alejandraux    schedule 07.09.2016

Ответы (1)


arrow_upward
0
arrow_downward

Вы предполагаете, что каждый товар является почтовым отправлением.

Вы можете пропустить элемент, если он не является почтовым:

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
person niton    schedule 07.09.2016
comment
Я попробую этот и дам вам обновление, если оно сработает. Спасибо тебе за это . - person alejandraux; 07.09.2016