使用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個人）