Excel VBA 无法识别 Powerpoint 中的形状选择答案

【问题标题】：Excel VBA doesn't recognize shape selection in PowerpointExcel VBA 无法识别 Powerpoint 中的形状选择
【发布时间】：2018-08-06 16:21:01
【问题描述】：

Dim ppapp As PowerPoint.Application
Dim pppres As PowerPoint.Presentation

Sub getshapedata()
On Error GoTo line1
Set ppapp = GetObject(, "Powerpoint.application")
Set pppres = ppapp.ActivePresentation

Dim shapeslide
Dim shapename
Dim shapetext
Dim nextrow

shapeslide = ppapp.ActiveWindow.View.Slide.SlideIndex
shapename = ppapp.ActiveWindow.Selection.ShapeRange(1).Name
shapetext = pppres.Slides(shapeslide).Shapes(shapename).TextEffect.Text
friendlyname = InputBox("Insert Friendly Name for " & shapetext, "Friendly Name", "")

nextrow = Sheet1.Range("a" & Rows.Count).End(xlUp).Row + 1

Sheet1.Range("a" & nextrow) = shapeslide
Sheet1.Range("b" & nextrow) = shapename
Sheet1.Range("c" & nextrow) = shapetext
Sheet1.Range("d" & nextrow) = friendlyname

Exit Sub



line1:
MsgBox "No item selected"

End Sub

Sub writedata()
Dim c As Object
Dim shapeslide
Dim shapename
Dim shapetext

Set ppapp = GetObject(, "Powerpoint.application")
Set pppres = ppapp.ActivePresentation

For Each c In Sheet1.Range("a2:a" & Sheet1.Range("a" & Rows.Count).End(xlUp).Row)

shapeslide = Sheet1.Range("a" & c.Row)
shapename = Sheet1.Range("b" & c.Row)
shapetext = Sheet1.Range("c" & c.Row).Text
friendlyname = Sheet1.Range("d" & c.Row)
pppres.Slides(shapeslide).Shapes(shapename).TextEffect.Text = shapetext

Next c

End Sub

大家好我正在使用上面的代码从 Excel VBA 更新 powerpoint 中的数据，我在 Windows 7 上的 Office 2016 上使用它。

完全按照代码，当我选择一个形状时，它会识别框和内容，然后要求我分配一个友好的名称，但随后跳转到错误：没有选择项目，调试中指示的行是：

nextrow = Sheet1.Range("a" & Rows.Count).End(xlUp).Row + 1

如果您能告诉我如何解决此问题，我将不胜感激

【问题讨论】：

注释掉错误处理程序并查看实际错误在哪里（和什么）。
除非我不知道什么是有效的方法，但是我已经尝试过并且我知道是哪一行出现了错误，但理论上它应该可以工作......
@TimWilliams 谢谢，我找到了解决方案并添加了答案

标签： excel vba automation powerpoint

【解决方案1】：

我找到了我的问题的答案，我会把它放在这里以供将来可能使用它的任何人使用：

Dim ppapp As PowerPoint.Application
Dim pppres As PowerPoint.Presentation

Sub getshapedata()
Dim shapeslide As Integer
Dim shapename As String
Dim shapetext As String
Dim friendlyname As String
Dim nextrow As Long

On Error GoTo line1
Set ppapp = GetObject(, "Powerpoint.application")
Set pppres = ppapp.ActivePresentation
shapeslide = ppapp.ActiveWindow.View.Slide.SlideIndex
shapename = ppapp.ActiveWindow.Selection.ShapeRange(1).Name
shapetext = pppres.Slides(shapeslide).Shapes(shapename).TextEffect.Text
friendlyname = InputBox("Insert Friendly Name for " & shapetext, "Friendly Name", "")

With ActiveSheet
    nextrow = .Range("a" & .Rows.Count).End(xlUp).Row + 1

    .Range("a" & nextrow) = shapeslide
    .Range("b" & nextrow) = shapename
    .Range("c" & nextrow) = shapetext
    .Range("d" & nextrow) = friendlyname
End With
Exit Sub

line1:
    MsgBox "No item selected"
End Sub

Sub writedata()
Dim c As Range
Dim shapeslide As Integer
Dim shapename As String
Dim shapetext As String
Dim friendlyname As String

Set ppapp = GetObject(, "Powerpoint.application")
Set pppres = ppapp.ActivePresentation

With ActiveSheet
    For Each c In .Range("a2:a" & .Range("a" & .Rows.Count).End(xlUp).Row)
        shapeslide = .Range("a" & c.Row)
        shapename = .Range("b" & c.Row)
        shapetext = .Range("c" & c.Row).Text
        friendlyname = .Range("d" & c.Row)
        pppres.Slides(shapeslide).Shapes(shapename).TextEffect.Text = shapetext
    Next c
End With
End Sub

【讨论】：