在 VBA 中创建指向特定 powerpoint 幻灯片的单个超链接而不覆盖答案

【问题标题】：Creating single hyperlinks to specifc powerpoint slides in VBA without overwritting在 VBA 中创建指向特定 powerpoint 幻灯片的单个超链接而不覆盖
【发布时间】：2020-09-20 22:22:11
【问题描述】：

所以我之前有一个 Excel 表格，其中包含指向其他表格的超链接 --> hyperlinks

我在 vba 中创建了一个 powerpoint 生成器，其中的超链接也应该传输到创建的 powerpoint。我在这里寻找一些建议，这就是我到目前为止所创建的：

Sub pptGenerator()

Application.ScreenUpdating = False

Dim oRng As TextRange, i As Integer, j As Integer, pptC As Integer, wsCnt As Long
Dim indexText As String, indexText2 As String, t As Table, lRow As Long, lCol As Long
Dim PowerPointApp As PowerPoint.Application, myPresentation As PowerPoint.Presentation

wsCnt = ThisWorkbook.Worksheets.Count

DestinationPPT = Application.ActiveWorkbook.Path & "\PPT_template_16_9.pptx"
Set PowerPointApp = CreateObject("PowerPoint.Application")
Set myPresentation = PowerPointApp.Presentations.Open(DestinationPPT)


For pptC = 1 To 2

    For i = 1 To wsCnt
        Sheets(i).Activate
        lRow = Cells(Rows.Count, 1).End(xlUp).Row
        lCol = Cells(1, Columns.Count).End(xlToLeft).Column

        For j = 3 To lRow 'counter begins after the subtitle

            'Link to the indices point before
            If Range("A2").Value = "Subtitle" Then
                indexText2 = ActiveSheet.Range("B" & j).Offset(0, -1).Value & vbCrLf
                'Stop

                If Range("A" & j).Value = "Hyperlink 1" Then
                    Set t = PowerPointApp.ActivePresentation.slides(i).shapes(1).Table.Cell(4, 1)                                                                                                                                       
                    With t.Cell(4, 1).shape.TextFrame.TextRange.ActionSettings(ppMouseClick).Hyperlink
                        .TextToDisplay = "01 Hyperlink"
                        .SubAddress = PowerPointApp.ActivePresentation.slides(2).SlideNumber _
                            & ". " & PowerPointApp.ActivePresentation.slides(2).Name
                    End With

                End If
            End If
        Next j

        PowerPointApp.ActivePresentation.slides(i - 1).shapes(1).TextFrame.TextRange.InsertAfter indexText2

    Next i

Next pptC

Application.ScreenUpdating = True
MsgBox "Done!"

End Sub

现在我遇到的问题是 Excel 向我显示 运行时错误 80004005，其中对象 Shape 的方法 Table 失败。否则，不要使用表格，如果我会这样做：

Set oRng = PowerPointApp.ActivePresentation.slides(i - 1).shapes(1).TextFrame.TextRange.ActionSettings(ppMouseClick).Hyperlink
With oRng
    .SubAddress = PowerPointApp.ActivePresentation.slides(2).SlideNumber _
        & ". " & PowerPointApp.ActivePresentation.slides(2).Name
End With

最后一个超链接将用于整个工作表，因此将被覆盖。

我该如何解决这个问题？

【问题讨论】：

标签： excel vba powerpoint

【解决方案1】：

我通过使用 oRng 而不是使用表格对象解决了这个问题

If Range("A" & j).Value = "Hyperlink 1" Then
   Set oRng = PowerPointApp.ActivePresentation.slides(i - 1).Shapes(1).TextFrame.TextRange.InsertAfter(indexText2)
   With oRng.ActionSettings(ppMouseClick).Hyperlink
            .SubAddress = PowerPointApp.ActivePresentation.slides(2).SlideNumber _
             & ". " & PowerPointApp.ActivePresentation.slides(2).Name
   End With
End If

【讨论】：