Question

我有这个代码，它从Excel打开一个Word模板，并将值粘贴到Word模板中的书签。代码运行正常，但代码连续运行6次。我知道这是因为我有一个提示停止代码，因此可以在发送之前编辑word文档。有时，提示会在一次运行中弹出6次。我认为它与我在代码开头的错误处理有关，见下文。如果word运行与否，代码需要能够运行。提前感谢您花时间看看这个。

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

这是完整的代码，引用Ron de Bruin 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:="test@gmail.com", _
    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

Excel vba代码一直在运行

1 个答案: