Question

我正在尝试使用On Error GoTo Handle来捕捉不一致的

运行时错误-2147188160（80048240）

我的代码从Excel模板生成4个powerpoint，保存并关闭它们。这是我在底部的实验性错误处理：

'Exit PowerPoint
PPT.Quit
Exit Sub

Handle:
If Err.Number = -2147188160 Then
    PPT.Quit
    MsgBox "Hey look I broke!"
End If
End Sub

但在我的测试中，当我遇到错误时，我没有收到任何错误消息，但我的代码也没有运行。这让我相信我是捕获错误，但其他东西没有被触发。我之前尝试解决错误的根本原因，但解决方案是在我的代码中添加Application.Wait，我觉得这是不必要的。

在一个完美的世界里，我只想抓住错误，关闭PowerPoint并让它立即重新运行代码。有什么见解吗？

感兴趣的人的完整子程序 - 错误的位置不一致：

Public Declare Function GetWindowThreadProcessId Lib "user32" _
      (ByVal hwnd As Long, lpdwprocessid As Long) As Long
Sub GeneratePowerPoints()

'For using powerpoint
Dim dummyfile As String
Dim PPT As PowerPoint.Application
Dim myPresentation As PowerPoint.Presentation
Dim MySlide As Object
Dim MyShape As Object

Dim j As Long, allhotels() As Variant, sourcerange As Range, sourcebook As String
Dim d As Date, e As Date, f As Date, lastmonth As String, twomonthsago As String, threemonthsago As String

'Get some month names
d = DateAdd("m", -1, Now)
e = DateAdd("m", -2, Now)
f = DateAdd("m", -3, Now)
lastmonth = Format(d, "mmmm")
twomonthsago = Format(e, "mmmm")
threemonthsago = Format(f, "mmmm")

sourcebook = "BT Strat Sheet.xlsm"
allhotels = Array("SBH", "WBOS", "WBW", "WCP")
dummyfile = "P:\BT\BT 2017\BT Strategy Meetings\2017\Hotel Strat Meeting Dummy File.pptx"

On Error GoTo Handle
For j = 0 To 3

    Set PPT = New PowerPoint.Application
    PPT.Visible = True
    PPT.Presentations.Open Filename:=dummyfile

    'SLIDE ONE
    Set sourcerange = Workbooks(sourcebook).Worksheets(allhotels(j)).Range("A2:J21")
    sourcerange.Copy
    PPT.ActivePresentation.Slides(1).Shapes.PasteSpecial DataType:=2
    Set MyShape = PPT.ActivePresentation.Slides(1).Shapes(PPT.ActivePresentation.Slides(1).Shapes.Count)

    'Set size
    MyShape.Left = 152
    MyShape.Top = 152
    MyShape.Height = 500
    MyShape.Width = 650

    'SLIDE TWO
    Set sourcerange = Workbooks(sourcebook).Worksheets(allhotels(j)).Range("A82:J91")
    sourcerange.Copy
    PPT.ActivePresentation.Slides(2).Shapes.PasteSpecial DataType:=2
    Set MyShape = PPT.ActivePresentation.Slides(2).Shapes(PPT.ActivePresentation.Slides(2).Shapes.Count)

    'Set size
    MyShape.Left = 152
    MyShape.Top = 92
    MyShape.Height = 500
    MyShape.Width = 650

    'SLIDE TWO
    Set sourcerange = Workbooks(sourcebook).Worksheets(allhotels(j)).Range("A94:J103")
    sourcerange.Copy
    PPT.ActivePresentation.Slides(2).Shapes.PasteSpecial DataType:=2
    Set MyShape = PPT.ActivePresentation.Slides(2).Shapes(PPT.ActivePresentation.Slides(2).Shapes.Count)

    'Set size
    MyShape.Left = 152
    MyShape.Top = 300
    MyShape.Height = 500
    MyShape.Width = 650

    'SLIDE THREE
    Set sourcerange = Workbooks(sourcebook).Worksheets(allhotels(j)).Range("A24:J43")
    sourcerange.Copy
    PPT.ActivePresentation.Slides(3).Shapes.PasteSpecial DataType:=2
    Set MyShape = PPT.ActivePresentation.Slides(3).Shapes(PPT.ActivePresentation.Slides(3).Shapes.Count)

    'Set size
    MyShape.Left = 152
    MyShape.Top = 152
    MyShape.Height = 500
    MyShape.Width = 650

    'SLIDE FOUR
    Set sourcerange = Workbooks(sourcebook).Worksheets(allhotels(j)).Range("A58:J67")
    sourcerange.Copy
    PPT.ActivePresentation.Slides(4).Shapes.PasteSpecial DataType:=2
    Set MyShape = PPT.ActivePresentation.Slides(4).Shapes(PPT.ActivePresentation.Slides(4).Shapes.Count)

    'Set size
    MyShape.Left = 152
    MyShape.Top = 120
    MyShape.Height = 500
    MyShape.Width = 650

    'SLIDE FOUR
    Set sourcerange = Workbooks(sourcebook).Worksheets(allhotels(j)).Range("A46:J55")
    sourcerange.Copy
    PPT.ActivePresentation.Slides(4).Shapes.PasteSpecial DataType:=2
    Set MyShape = PPT.ActivePresentation.Slides(4).Shapes(PPT.ActivePresentation.Slides(4).Shapes.Count)

    'Set size
    MyShape.Left = 152
    MyShape.Top = 335
    MyShape.Height = 500
    MyShape.Width = 650

    'SLIDE FIVE
    Set sourcerange = Workbooks(sourcebook).Worksheets(allhotels(j)).Range("A70:J79")
    sourcerange.Copy
    PPT.ActivePresentation.Slides(5).Shapes.PasteSpecial DataType:=2
    Set MyShape = PPT.ActivePresentation.Slides(5).Shapes(PPT.ActivePresentation.Slides(5).Shapes.Count)

    'Set size
    MyShape.Left = 152
    MyShape.Top = 152
    MyShape.Height = 500
    MyShape.Width = 650

    'Find and replace month placeholders
    'Straight boilerplate
    Dim sld As Slide, shp As PowerPoint.Shape, i As Long

    For Each sld In PPT.ActivePresentation.Slides
        For Each shp In sld.Shapes
            If shp.HasTextFrame Then
                If shp.TextFrame.HasText Then
                    shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "LastMonth", lastmonth)
                End If
            End If
        Next shp
    Next sld

    For Each sld In PPT.ActivePresentation.Slides
        For Each shp In sld.Shapes
            If shp.HasTextFrame Then
                If shp.TextFrame.HasText Then
                    shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "TwoMonthsAgo", twomonthsago)
                End If
            End If
        Next shp
    Next sld

    For Each sld In PPT.ActivePresentation.Slides
        For Each shp In sld.Shapes
            If shp.HasTextFrame Then
                If shp.TextFrame.HasText Then
                    shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "ThreeMonthsAgo", threemonthsago)
                End If
            End If
        Next shp
    Next sld

    'Save it
    PPT.ActivePresentation.SaveAs "P:\BT\BT File Drop-off Location\" & allhotels(j) & " " & lastmonth & " Strat Meeting.pptx"

    'Close it
    PPT.ActivePresentation.Close
Next j

'Exit PowerPoint
PPT.Quit
Exit Sub

Handle:
Call KillProcess(PPT)
MsgBox "Hey look I broke!"

End Sub
Sub KillProcess(ByVal app As PowerPoint.Application)

    ' This is OK Here, Because We Can Assume If We Get No Handle Back, There's No Handle To Cleanup
    ' Don't Normally Do This
    On Error Resume Next

    Dim windowProcessId As Long
    windowProcessId = ProcIDFromWnd(app.ActiveWindow.hwnd)

    Dim oServ As Object
    Dim cProc As Variant
    Dim oProc As Object

    Set oServ = GetObject("winmgmts:")
    Set cProc = oServ.ExecQuery("Select * from Win32_Process Where ProcessId=" & windowProcessId)

    For Each oProc In cProc

          MsgBox "Killing Process " & windowProcessId   ' used to display a message for testing pur
          errReturnCode = oProc.Terminate()
    Next

End Sub
Function ProcIDFromWnd(ByVal hwnd As Long) As Long
   Dim idProc As Long

   ' Get PID for this HWnd
   GetWindowThreadProcessId hwnd, idProc
   ProcIDFromWnd = idProc
End Function

编辑：在Absinthe的建议后，我能够debug.print确认错误号确实是-2147188160。我现在能够成功地运行代码，只有在发生错误时，我才能让PowerPoint退出 - 我必须自己关闭PowerPoint，然后我可以看到MsgBox在我的Excel屏幕上显示：

'Exit PowerPoint
PPT.Quit
Exit Sub

Handle:
Debug.Print Err.Number
If Err.Number = -2147188160 Then
PPT.Quit
MsgBox "Oh look I broke!"
End If

Answer 1

如果PowerPoint没有退出，可能是因为有一些公开的参考文献。由于错误，你处于一种奇怪的状态，所以我建议你杀死与主窗口句柄相关的进程（不会在异常状态下推荐这个）。

在这种情况下，您需要知道哪些PPT流程是由自动化启动的并将其杀死。

此过程在开始时（仅限PPT）和最后的流程获取流程，并终止新流程。

Public PpProcesses() As Integer

Sub GeneratePowerPoints()


    Call SaveProcesses

'For using powerpoint
Dim dummyfile As String
Dim PPT As PowerPoint.Application
Dim myPresentation As PowerPoint.Presentation
Dim MySlide As Object
Dim MyShape As Object

Dim j As Long, allhotels() As Variant, sourcerange As Range, sourcebook As String
Dim d As Date, e As Date, f As Date, lastmonth As String, twomonthsago As String, threemonthsago As String

'Get some month names
d = DateAdd("m", -1, Now)
e = DateAdd("m", -2, Now)
f = DateAdd("m", -3, Now)
lastmonth = Format(d, "mmmm")
twomonthsago = Format(e, "mmmm")
threemonthsago = Format(f, "mmmm")

sourcebook = "BT Strat Sheet.xlsm"
allhotels = Array("SBH", "WBOS", "WBW", "WCP")
dummyfile = "P:\BT\BT 2017\BT Strategy Meetings\2017\Hotel Strat Meeting Dummy File.pptx"

On Error GoTo Handle
For j = 0 To 3

    Set PPT = New PowerPoint.Application
    PPT.Visible = True
    PPT.Presentations.Open Filename:=dummyfile

    'SLIDE ONE
    Set sourcerange = Workbooks(sourcebook).Worksheets(allhotels(j)).Range("A2:J21")
    sourcerange.Copy
    PPT.ActivePresentation.Slides(1).Shapes.PasteSpecial DataType:=2
    Set MyShape = PPT.ActivePresentation.Slides(1).Shapes(PPT.ActivePresentation.Slides(1).Shapes.Count)

    'Set size
    MyShape.Left = 152
    MyShape.Top = 152
    MyShape.Height = 500
    MyShape.Width = 650

    'SLIDE TWO
    Set sourcerange = Workbooks(sourcebook).Worksheets(allhotels(j)).Range("A82:J91")
    sourcerange.Copy
    PPT.ActivePresentation.Slides(2).Shapes.PasteSpecial DataType:=2
    Set MyShape = PPT.ActivePresentation.Slides(2).Shapes(PPT.ActivePresentation.Slides(2).Shapes.Count)

    'Set size
    MyShape.Left = 152
    MyShape.Top = 92
    MyShape.Height = 500
    MyShape.Width = 650

    'SLIDE TWO
    Set sourcerange = Workbooks(sourcebook).Worksheets(allhotels(j)).Range("A94:J103")
    sourcerange.Copy
    PPT.ActivePresentation.Slides(2).Shapes.PasteSpecial DataType:=2
    Set MyShape = PPT.ActivePresentation.Slides(2).Shapes(PPT.ActivePresentation.Slides(2).Shapes.Count)

    'Set size
    MyShape.Left = 152
    MyShape.Top = 300
    MyShape.Height = 500
    MyShape.Width = 650

    'SLIDE THREE
    Set sourcerange = Workbooks(sourcebook).Worksheets(allhotels(j)).Range("A24:J43")
    sourcerange.Copy
    PPT.ActivePresentation.Slides(3).Shapes.PasteSpecial DataType:=2
    Set MyShape = PPT.ActivePresentation.Slides(3).Shapes(PPT.ActivePresentation.Slides(3).Shapes.Count)

    'Set size
    MyShape.Left = 152
    MyShape.Top = 152
    MyShape.Height = 500
    MyShape.Width = 650

    'SLIDE FOUR
    Set sourcerange = Workbooks(sourcebook).Worksheets(allhotels(j)).Range("A58:J67")
    sourcerange.Copy
    PPT.ActivePresentation.Slides(4).Shapes.PasteSpecial DataType:=2
    Set MyShape = PPT.ActivePresentation.Slides(4).Shapes(PPT.ActivePresentation.Slides(4).Shapes.Count)

    'Set size
    MyShape.Left = 152
    MyShape.Top = 120
    MyShape.Height = 500
    MyShape.Width = 650

    'SLIDE FOUR
    Set sourcerange = Workbooks(sourcebook).Worksheets(allhotels(j)).Range("A46:J55")
    sourcerange.Copy
    PPT.ActivePresentation.Slides(4).Shapes.PasteSpecial DataType:=2
    Set MyShape = PPT.ActivePresentation.Slides(4).Shapes(PPT.ActivePresentation.Slides(4).Shapes.Count)

    'Set size
    MyShape.Left = 152
    MyShape.Top = 335
    MyShape.Height = 500
    MyShape.Width = 650

    'SLIDE FIVE
    Set sourcerange = Workbooks(sourcebook).Worksheets(allhotels(j)).Range("A70:J79")
    sourcerange.Copy
    PPT.ActivePresentation.Slides(5).Shapes.PasteSpecial DataType:=2
    Set MyShape = PPT.ActivePresentation.Slides(5).Shapes(PPT.ActivePresentation.Slides(5).Shapes.Count)

    'Set size
    MyShape.Left = 152
    MyShape.Top = 152
    MyShape.Height = 500
    MyShape.Width = 650

    'Find and replace month placeholders
    'Straight boilerplate
    Dim sld As Slide, shp As PowerPoint.Shape, i As Long

    For Each sld In PPT.ActivePresentation.Slides
        For Each shp In sld.Shapes
            If shp.HasTextFrame Then
                If shp.TextFrame.HasText Then
                    shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "LastMonth", lastmonth)
                End If
            End If
        Next shp
    Next sld

    For Each sld In PPT.ActivePresentation.Slides
        For Each shp In sld.Shapes
            If shp.HasTextFrame Then
                If shp.TextFrame.HasText Then
                    shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "TwoMonthsAgo", twomonthsago)
                End If
            End If
        Next shp
    Next sld

    For Each sld In PPT.ActivePresentation.Slides
        For Each shp In sld.Shapes
            If shp.HasTextFrame Then
                If shp.TextFrame.HasText Then
                    shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "ThreeMonthsAgo", threemonthsago)
                End If
            End If
        Next shp
    Next sld

    'Save it
    PPT.ActivePresentation.SaveAs "P:\BT\BT File Drop-off Location\" & allhotels(j) & " " & lastmonth & " Strat Meeting.pptx"

    'Close it
    PPT.ActivePresentation.Close
Next j

'Exit PowerPoint
PPT.Quit
Exit Sub

Handle:
MsgBox Err.Number
Call KillProcess
MsgBox "Hey look I broke!"

End Sub


Public Sub SaveProcesses()

    ReDim PpProcesses(1 To 1)

    Dim oServ As Object
    Dim cProc As Variant
    Dim oProc As Object

    Set oServ = GetObject("winmgmts:")
    Set cProc = oServ.ExecQuery("Select * from Win32_Process")

    For Each oProc In cProc

        If UCase(oProc.Name) = "POWERPNT.EXE" Or UCase(oProc.Name) = "POWERPNT" Then

            ReDim Preserve PpProcesses(1 To UBound(PpProcesses) + 1)
            PpProcesses(UBound(PpProcesses)) = oProc.ProcessId

        End If
    Next

End Sub

Sub KillProcess()

    Dim index As Integer
    index = -1

    Dim oServ As Object
    Dim cProc As Variant
    Dim oProc As Object

    Set oServ = GetObject("winmgmts:")
    Set cProc = oServ.ExecQuery("Select * from Win32_Process")

    For Each oProc In cProc

         If UCase(oProc.Name) = "POWERPNT.EXE" Or UCase(oProc.Name) = "POWERPNT" Then


            For i = LBound(PpProcesses) To UBound(PpProcesses)
                If PpProcesses(i) = oProc.ProcessId Then
                    index = i
                    Exit For
                End If
            Next i

            If index >= 0 Then
                'MsgBox ("Process Found " & oProc.ProcessId)
            Else
                oProc.Terminate
            End If
         End If
    Next

End Sub

Answer 2

这可能是由于在宏运行时引发了另一个错误并带有另一个错误号的事实。为避免错过此错误，如果数字不是您想要的数字，则可以添加其他消息。

Handle:
If Err.Number = -2147188160 Then
    PPT.Quit
    MsgBox "Hey look I broke!"
else
    MsgBox("Run-time error '" & Err.Number & "': " & Err.Description, vbCritical, "Error")
End If

尝试使用处理来捕获运行时错误-2147188160（80048240）

2 个答案: