Excel VBA код продолжает работать

Question

У меня есть этот код, который открывает шаблон Word из Excel и вставить значения в закладки в шаблоне Word. Код работает нормально, но время от времени коды запускаются 6 раз подряд. Это я знаю, потому что у меня есть подсказка, которая останавливает код, чтобы можно было отредактировать текстовое слово перед отправкой. Иногда подсказка всплывает 6 раз за один запуск. Я думаю, что это как-то связано с моей обработкой ошибок в начале кода, см. Ниже. Код должен быть в состоянии выполнить оба, если слово работает или нет. Заранее спасибо, что нашли время посмотреть на это.

Dim objWord As Object

On Error Resume Next
   Set objWord = GetObject(, "Word.Application")
If objWord Is Nothing Then
   Set objWord = CreateObject("Word.Application")
End If

On Error Resume Next
If objWord = 0 Then
Call WTWord
End If

Это полный код, который ссылается на функции и сценарии, выполненные Роном де Брюином http://www.rondebruin.nl/

Sub WTWord()

Dim objWord As Object
Dim objDoc As Object
Dim objSelection As Object
Dim wb As Workbook
    Dim FileName As String
    Dim FolderName As String
    Dim Folderstring As String
    Dim FilePathName As String
    Dim strbody As String

If CheckAppleScriptTaskExcelScriptFile(ScriptFileName:="RDBMacOutlook.scpt") = False Then
        MsgBox "Sorry the RDBMacOutlook.scpt is not in the correct location"
        Exit Sub
End If

On Error Resume Next
   Set objWord = GetObject(, "Word.Application")
If objWord Is Nothing Then
   Set objWord = CreateObject("Word.Application")
End If

objWord.Visible = False
objDoc.Visible = False
objSelection.Visible = False

On Error Resume Next
If objWord = 0 Then
Call WTWord
End If

Set objDoc = objWord.Documents.Add("KONTRAKT.dotx")

   Set objSelection = objWord.Selection

Dim Navn As Excel.Range
Dim Adresse As Excel.Range

    FolderName = "PDFSaveFolder"
    FileName = objDoc.Name & " " & Format(Now, "dd-mmm-yyyy") & ".pdf"

    Folderstring = CreateFolderinMacOffice2016(NameFolder:=FolderName)
    FilePathName = Folderstring & Application.PathSeparator & FileName

Set Navn = Sheets("Sheet1").Range("A1")
Set Adresse = Sheets("Sheet1").Range("A2")

With objDoc.Bookmarks
.Item("NAVN1").Range.InsertAfter Navn
.Item("ADRESSE1").Range.InsertAfter Adresse
End With

Dim YN As String
Dim Que As String

Que = "Vil du tilføje eller ændre noget i kontrakten?"
ThisWorkbook.Activate

YN = MsgBox(Que, vbYesNo, "KONTRAKT")

If YN = vbYes Then

Word.Application.Activate

Set objWord = Nothing
Set objDoc = Nothing
Set objSelections = Nothing

Exit Sub

Else

objDoc.SaveAs2 FilePathName, 17

objDoc.Close saveChanges:=False
objWord.Quit

    strbody = "<FONT size=""3"" face=""Calibri"">"

    strbody = strbody & "Hi there" & "<br>" & "<br>" & _
     "This is line 1" & "<br>" & _
        "This is line 2" & "<br>" & _
        "This is line 3" & "<br>" & _
        "This is line 4"

    strbody = strbody & "</FONT>"

    MacExcel2016WithMacOutlookPDF _
    subject:="This is a test macro to mail the Activesheet as PDF", _
    mailbody:=strbody, _
    toaddress:="[e-mail]", _
    ccaddress:="", _
    bccaddress:="", _
    displaymail:="yes", _
    accounttype:="", _
    accountname:="", _
    attachment:=FilePathName

End If
Exit Sub

Set objWord = Nothing
Set objDoc = Nothing
Set objSelections = Nothing

End Sub

Answer 1

Socond Error Resume Next не нужна, так как она не изменялась с момента последней. Для 3-х строк ниже вы должны удалить это, так как это вызывает его собственный саб. Я поместил бы весь код поиска слова в цикл while и повторял бы это, пока objWord не станет равным 0.

Dim objWord As Object

Do While objWord = 0
   On Error Resume Next
   Set objWord = GetObject(, "Word.Application")
   If objWord Is Nothing Then
      Set objWord = CreateObject("Word.Application")
   End If
Loop