Переменная объекта VBA или переменная блока не установлена ​​- ошибка 91 - PullRequest
Новая
       17

Переменная объекта VBA или переменная блока не установлена ​​- ошибка 91

0 голосов
/ 09 июля 2019

Я использовал этот замечательный код из https://www.slipstick.com/developer/vba-copy-outlook-email-excel-workbook/ и изменил его для своего случая, чтобы извлечь строку из тела письма.

Вместо того, чтобы использовать его в Outlook, я запустил его из целевой книги Excel после включения библиотеки MS Outlook 16.0 Object.

Клянусь, это сработало при первом запуске, но позже в тот же день я получил ошибку во время выполнения 91 - "Переменная объекта или переменная блока не установлена" в строке 

Set xlSheet = xlWB.Sheets("IMPORT")

Я смог сделать вывод, что эта ошибка возникает только при запуске кода из целевой книги. Он отлично работает при запуске из Outlook или другой книги.

В чем может быть причина такой ошибки в этом случае? 

Option Explicit
Private Const xlUp As Long = -4162

Sub Extract_string_from_email_body()
    Dim objOL As Outlook.Application
    Dim objItems As Outlook.Items
    Dim objFolder As Outlook.MAPIFolder
    Dim olItem As Outlook.MailItem
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim vText, vText2, vText3, vText4, vText5 As Variant
    Dim sText As String
    Dim rCount As Long
    Dim bXStarted As Boolean
    Dim enviro As String
    Dim strPath As String
    Dim Reg1 As Object
    Dim M1 As Object
    Dim M As Object

    'original code to run from Outlook and output string to existing workbook
    'enviro = CStr(Environ("USERPROFILE"))
    'strPath = enviro & "\Documents\test.xlsx"

    'my target workbook I've launched my code from
    strPath = "X:\02 Workbooks\Workbook.xlsm"
    On Error Resume Next

    Set xlApp = GetObject(, "Excel.Application")

    If Err <> 0 Then
        Set xlApp = CreateObject("Excel.Application")
        bXStarted = True
    End If
    On Error GoTo 0

    Set xlWB = xlApp.Workbooks.Open(strPath)
    Set xlSheet = xlWB.Sheets("IMPORT") 'error occurs here

    rCount = xlSheet.Range("Q" & xlSheet.Rows.Count).End(xlUp).Row
    rCount = rCount + 1

    Set objOL = Outlook.Application
    Set objFolder = objOL.Session.GetDefaultFolder(olFolderInbox).Parent.Folders("Data").Folders("Register")
    Set objItems = objFolder.Items

    For Each olItem In objItems
        On Error Resume Next
        With olItem
            sText = olItem.Body

            Set Reg1 = CreateObject("VBScript.RegExp")

            With Reg1
                .Pattern = "((OPO\/\d{2}\/[CLRPWBDFGIMSKT]\/\S{10}\/[SO|DL|MM]{2}\/\d{3}))"
            End With

            If Reg1.test(sText) Then

                Set M1 = Reg1.Execute(sText)

                For Each M In M1
                    vText = Trim(M.SubMatches(1))

                Next

                xlSheet.Range("Q" & rCount) = vText

                rCount = rCount + 1

            End If
        End With
    Next

    xlWB.Close 1

    If bXStarted Then
        xlApp.Quit
    End If

    Set M = Nothing
    Set M1 = Nothing
    Set Reg1 = Nothing
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSheet = Nothing
    Set objItems = Nothing
    Set objFolder = Nothing
    Set objOL = Nothing
End Sub

1 Ответ

1 голос
/ 09 июля 2019

Прежде всего, если вы запускаете код в Excel, нет необходимости получать экземпляр приложения Excel или создавать новый в коде: 

Set xlApp = GetObject(, "Excel.Application")

    If Err <> 0 Then
        Set xlApp = CreateObject("Excel.Application")
        bXStarted = True
    End If
    On Error GoTo 0

Используйте свойство Applicaiton, доступное для макросов VBA из коробки.

Во-вторых, вам нужно правильно инициализировать приложение Outlook: 

Set objOL = Outlook.Application

Но это должно быть: 

Set objOL = New Outlook.Application

Подробнее об этом можно прочитать в статье Автоматизация Outlook из приложения Visual Basic .

...