Невозможно L oop через указанную папку c в Microsoft Outlook и извлечь каждую таблицу из элементов электронной почты, используя VBA

Question

Я столкнулся с проблемой при реализации следующего кода. Этот фрагмент кода, прилагаемый ниже, предназначен для итерации указанной папки c в Microsoft Outlook, извлечения таблицы в каждом из элементов электронной почты и установки этого сообщения для чтения. Но я столкнулся с проблемой, что не могу продолжить l oop после выполнения строки вставки. Microsoft Outlook будет Cru sh и автоматический перезапуск. Кто-нибудь может помочь решить мои проблемы?

p / s: строка кода, которая вызывает остановку l oop, равна objExcelWorksheet.Paste. Я не уверен, является ли это правильным способом вставки таблицы в Microsoft Excel при использовании al oop, но если я выполню без l oop, таблицу можно будет вставить. Когда он вставляет al oop, он не может работать во второй раз и обрабатывает sh после вставки первой таблицы в Microsoft Excel.

Sub ExportTablesinEmailtoExcel()
    Dim objMail As Outlook.MailItem
    Dim objWordDocument As Word.Document
    Dim objTable As Word.Table
    Dim lTableCount As Long
    Dim objExcelApp As Excel.Application
    Dim objExcelWorkbook As Excel.Workbook
    Dim objExcelWorksheet As Excel.Worksheet
    Dim i As Long
    Dim objNS As Outlook.NameSpace
    Dim objFolder As Outlook.MAPIFolder
    Dim Item As Object

    Set objNS = GetNamespace("MAPI")
    Set objFolder = objNS.Folders("some_email@some.com") ' folders of your current account
    Set objFolder = objFolder.Folders("Buyer advise (IO)")
    Set Item = objFolder.Items
    'Create a new excel workbook
               Set objExcelApp = CreateObject("Excel.Application")
               Set objExcelWorkbook = objExcelApp.Workbooks.Add
               objExcelApp.Visible = True

     For Each Item In objFolder.Items
        If TypeOf Item Is Outlook.MailItem Then
            ' ... do stuff here ...
             Item.UnRead = False
               'Get the table(s) in the selected email
               Set objMail = Outlook.Application.ActiveExplorer.Selection.Item(1)
               Set objWordDocument = objMail.GetInspector.WordEditor
               lTableCount = objWordDocument.Tables.Count - 1
               'If there is only one table
               'Just copy it into the first worksheet
               Set objTable = objWordDocument.Tables(1)
               objTable.Range.Copy

               Set objExcelWorksheet = objExcelWorkbook.Sheets(1)
               objExcelWorksheet.Paste
               objExcelWorksheet.Columns.AutoFit
               Debug.Print Item.ConversationTopic

        End If
    Next



End Sub

Answer 1

Взаимодействие с Excel требует особой осторожности.

Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
'
' If desperate declare as variant

Sub ExportTablesinEmailtoExcel_WithCare()

    ' Interacting with Excel requires extreme care

    Dim objMail As Outlook.MailItem
    Dim objWordDocument As Word.Document
    Dim objTable As Word.Table

    Dim objExcelApp As Excel.Application
    Dim objExcelWorkbook As Excel.Workbook
    Dim objExcelWorksheet As Excel.Worksheet

    Dim objNS As Outlook.Namespace
    Dim objFolder As Outlook.mapiFolder

    Dim Item As Object

    Set objNS = GetNamespace("MAPI")

    Set objFolder = objNS.folders("some_email@some.com") ' folders of your current account

    Set objFolder = objFolder.folders("Buyer advise (IO)")

    'Create a new excel instance
    Set objExcelApp = CreateObject("Excel.Application")
    objExcelApp.Visible = True

    For Each Item In objFolder.items

        If TypeOf Item Is Outlook.MailItem Then

            Item.UnRead = False

            'Get a table from the item in this iteration of the loop
            Set objMail = Item

            Set objWordDocument = objMail.GetInspector.WordEditor

            'If there is only one table
            If objWordDocument.Tables.count = 1 Then

                'Just copy it into the first worksheet
                Set objTable = objWordDocument.Tables(1)
                objTable.Range.Copy

                'Create a new excel workbook
                Set objExcelWorkbook = objExcelApp.Workbooks.Add

                Set objExcelWorksheet = objExcelWorkbook.Sheets(1)
                objExcelWorksheet.Paste

                objExcelWorksheet.Columns.AutoFit

                Debug.Print Item.ConversationTopic

            End If

            ' Release memory. Apparently not reused in next iteration.
            Set objMail = Nothing
            Set objWordDocument = Nothing
            Set objTable = Nothing
            Set objExcelWorkbook = Nothing
            Set objExcelWorksheet = Nothing

        End If
    Next

    Debug.Print "Done."

End Sub