Question

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

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

Answer 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

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

1 个答案: