使用VBA宏创建Word文档，然后在Word文档中运行宏…在结束子程序上使excel崩溃

Question

我根据使用宏输入到Excel电子表格中的数据创建销售建议，然后调用宏以根据输入到电子表格中的数据导入一些“库存”图片。 第二个宏保存在normal.dot文档中，并通过以下代码调用：

WordObj.Run（“ normal！Picture”）'这将在Word中调用一个宏，该宏可以完美地工作和调试

结束子

当宏完成并给出最后一条消息，表明文档已成功完成并转到Word宏上的“ end sub”时，我收到一条错误消息，指出Excel已崩溃，需要重新启动！

这些宏创建于2002年，并且可以在所有版本的Office中使用，但是我们开始升级到Office 2010，现在当我运行此宏时，它会使Excel崩溃（仅在Office 2010客户端上）。

我禁止显示消息，但是如果我取消抑制错误，则会收到以下相关消息：

“ Microsoft Excel正在等待另一个应用程序完成OLE操作”，但是我认为在尝试打开W​​ORD时会发生这种情况。

以我有限的VBA经验，我认为需要将焦点发送回Excel中的宏，以便可以正确结束子过程。 我认为Word宏可以正确完成，但不能让最后一个'end sub'在Excel宏中运行。 但是我不知道如何将焦点放回到Excel宏中。

我将定期检查我的电子邮件，并为此进行努力。 如果碰巧找到解决方案，我会立即发布。

Excel宏：

Sub Proposal1()

Dim appwd As Object
Dim bookmark1 As String
Dim test As String
Dim ans As String
Dim company As String
Dim goOn As Integer

company = Range("survey!D1")

goOn = MsgBox(prompt:="Do you want to create a proposal for  " & company & " at this         time?", _
    Buttons:=vbYesNo)
If goOn = vbNo Then Exit Sub

Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:="c:\sales\salescalc.xls"
Application.DisplayAlerts = True

Static WordObj As Word.Application
Set WordObj = Nothing
Set WordObj = CreateObject("Word.Application")

WordObj.Visible = True

With WordObj
    .Documents.Add Template:=("C:\sales\sales\proposal1.dot")
    On Error Resume Next

    'Bunch of logic here that reads cells and inputs text to word doc'
    'about 150 lines of code all runs normal'

End With

End Sub

字宏：

Sub picture()

Dim oExcel As Object
Dim oWorkbook As Object
Dim oWorkSheet As Object
Dim verbiage As String
Dim doc As Word.Document
Dim bkmname As String
Dim bkname2 As String
Dim bkname3 As String
Dim verbiage2 As String
Dim verbiage3 As String
Dim spec1 As InlineShape
Dim spec2 As InlineShape
Dim spec3 As InlineShape
Dim pic1 As InlineShape
Dim pic2 As InlineShape
Dim pic3 As InlineShape
Dim pic4 As InlineShape
Dim pic5 As InlineShape
Dim vpic1 As String
Dim company As String
Dim myfolder As String
Dim foldername As String

Set fs = CreateObject("Scripting.FileSystemObject")
Set oExcel = GetObject(, "Excel.Application")

oExcel.Visible = True

Set oWorkbook = oExcel.Workbooks.Open("c:\sales\salescalc.xls")
Set oWorkSheet = oWorkbook.Sheets("survey") 

bkmname = "SO1"
bkmname2 = "SO2"
bkmname3 = "SO3"
vpic1 = "pic1"
company = oWorkSheet.Range("d1").Value
myfolder = "C:\proposals\"

Set doc = ActiveDocument
If oWorkSheet.Range("b15").Value > 0 Then

Set pic1 = Selection.InlineShapes.AddPicture(FileName:= _
    myfolder & company & "\pics\pic1.jpg" _
    , linktofile:=False, savewithdocument:=True, Range:=doc.Bookmarks("pic1").Range)

With pic1
    .Width = InchesToPoints(2.46)
    .Height = InchesToPoints(1.69)
End With
End If

If oWorkSheet.Range("b16").Value > 0 Then

Set pic2 = Selection.InlineShapes.AddPicture(FileName:= _
  myfolder & company & "\pics\pic2.jpg" _
    , linktofile:=False, savewithdocument:=True, Range:=doc.Bookmarks("pic2").Range)

With pic2
    .Width = InchesToPoints(2.46)
    .Height = InchesToPoints(1.69)
End With
End If

If oWorkSheet.Range("b17").Value > 0 Then

Set pic3 = Selection.InlineShapes.AddPicture(FileName:= _
    myfolder & company & "\pics\pic3.jpg" _
    , linktofile:=False, savewithdocument:=True, Range:=doc.Bookmarks("pic3").Range)

With pic3
    .Width = InchesToPoints(2.46)
    .Height = InchesToPoints(1.69)
End With
End If

If oWorkSheet.Range("b18").Value > 0 Then

Set pic4 = Selection.InlineShapes.AddPicture(FileName:= _
    myfolder & company & "\pics\pic4.jpg" _
    , linktofile:=False, savewithdocument:=True, Range:=doc.Bookmarks("pic4").Range)

With pic4
    .Width = InchesToPoints(2.46)
    .Height = InchesToPoints(1.69)
End With
End If

If oWorkSheet.Range("b19").Value > 0 Then
Set pic5 = Selection.InlineShapes.AddPicture(FileName:= _
    myfolder & company & "\pics\pic5.jpg" _
    , linktofile:=False, savewithdocument:=True, Range:=doc.Bookmarks("pic5").Range)

With pic5
    .Width = InchesToPoints(2.46)
    .Height = InchesToPoints(1.69)
End With
End If

Set doc = ActiveDocument
If oWorkSheet.Range("b7") > 0 Then
verbiage = oWorkSheet.Range("H27").Value
Set spec1 = Selection.InlineShapes.AddPicture(FileName:="c:\sales\spec\" & verbiage &  ".gif" _
, linktofile:=False, savewithdocument:=True, Range:=doc.Bookmarks(bkmname).Range)

With spec1
    .Width = InchesToPoints(4.17)
    .Height = InchesToPoints(2.83)
End With
End If

If oWorkSheet.Range("b8") > 0 Then
verbiage2 = oWorkSheet.Range("H28").Value
Set spec2 = Selection.InlineShapes.AddPicture(FileName:= _
    "C:\sales\spec\" & verbiage2 & ".gif" _
    , linktofile:=False, savewithdocument:=True, Range:=doc.Bookmarks(bkmname2).Range)

With spec2
    .Width = InchesToPoints(4.17)
    .Height = InchesToPoints(2.83)
End With
End If

If oWorkSheet.Range("b9") > 0 Then
verbiage3 = oWorkSheet.Range("H29").Value
Set spec3 = Selection.InlineShapes.AddPicture(FileName:= _
    "C:\sales\spec\" & verbiage3 & ".gif" _
    , linktofile:=False, savewithdocument:=True, Range:=doc.Bookmarks(bkmname3).Range)
With spec3
    .Width = InchesToPoints(4.17)
    .Height = InchesToPoints(2.83)
End With
End If

ActiveDocument.SaveAs FileName:=("c:\proposals\" & company & "\" & company & ".doc")

MsgBox "A new company proposal for " & company & " has been created"

End Sub

Answer 1

如果它在End Sub上崩溃，则可能与对象的破坏有关。 确保在代码退出之前手动销毁对象。 这将使您准确了解哪个对象使代码崩溃。

在应用程序之间进行编码时，我不会使用两个不同的MACROS。 可以告诉Word（或excel）彼此运行。

将所有代码放在1个应用程序中的仅1个宏中。 例如，excel会填充内容，然后打开单词。 因此，要让excel直接说出要做什么。

Sub test()
Dim wdApp As New Word.Application
wdApp.Visible = True
wdApp.Documents.Add
wdApp.ActiveDocument.Paragraphs(1).Range.Text = "Hello World"
End Sub

通过引用正确的库（用于2010的Microsoft Word 14.0对象库和用于2013的Microsoft Word 15.0对象库），您可以告诉excel在word文档中做什么，如我的示例所示。

通常，这很容易，只需复制并粘贴代码，然后将其包含在with语句中即可：

with wdAPP
    'All your word specific code here (might need to add a '.' before each command
end with

我尝试从其他应用程序调用宏时发现的另一个问题是，很难知道宏是否在另一侧。 可能是用户安装不正确（我的宏分配给了约300个人）