如何在 PowerPoint VBA 中获取超链接的形状

Question

我想获取 PowerPoint 中带有超链接的形状。

我将使用 pdf.js 将 powerpoint 显示为 pdf，并且需要在渲染的 pdf 上使用具有正确大小形状的覆盖 html 来附加超链接。

但如果我尝试使用该LinkFormat.SourceFullName方法，它会抛出错误

无效的请求

我已经用明确链接的图像和形状对其进行了测试。另外，我链接的形状的类型是 autoShapeTypes。

我使用 Office 356。我主要对演示文稿中幻灯片的链接感兴趣。我可以通过 pptSlide.Hyperlinks(i) 及其子地址访问它们，但是如何获得该链接的引用形状？

任何想法为什么形状不会显示为链接对象以及我如何能够从形状中获取链接？

Dim pptPresentation As Presentation
Dim pptSlide As Slide
Dim pptShape As Shape
Dim i As Integer
dim linkstring as String

Dim hl As Hyperlink

'Set the variable to the PowerPoint Presentation
Set pptPresentation = ActivePresentation

'Loop through each slide in the presentation
For Each pptSlide In pptPresentation.Slides

    'Loop through each shape in each slide

    For Each pptShape In pptSlide.Shapes
        'Find out if the shape is a linked object or a linked picture
        If pptShape.Type = msoLinkedPicture Or pptShape.Type _
        = msoLinkedOLEObject Or pptShape.Type = msoLinked3DModel Then
        'won't make it into the loop, ad Or 1 for AutoShapeTyps
            linkstring = pptShape.LinkFormat.SourceFullName

            oFile.WriteLine "link:" & linkstring & vbNewLine & _
                                "height:" & pptShape.Height & vbNewLine & _
                                "width:" & pptShape.Width & vbNewLine & _
                                "pos-left" & pptShape.Left & vbNewLine & _
                                "pos-top " & pptShape.Top & vbNewLine & _
                                vbNewLine

        End If
    Next
 Next

'test to see if vba finds any links at all
For Each hl In ActivePresentation.Slides(1).Hyperlinks
   linkstring = hl.Address
   linkstring = hl.SubAddress
   linkstring = hl.Application
   linkstring = hl.Type
Next

Answer 1

超链接位置和类型

可以指定超链接

• 到形状本身
• 到形状的文本框
• 单个字符（甚至一个文本中的多个字符）

它们可以指定为ActionSettings(ppMouseClick).Hyperlink或ActionSettings(ppMouseOver).Hyperlink。

它们Hyperlink.Type是msoHyperlinkShape（在形状上）或msoHyperlinkRange（在文本框或字符上）。

循环所有超链接并得到对应的Shape

您可以循环幻灯片的所有超链接并在父结构中获取它们的形状，具体取决于超链接类型：

Private Sub GetShapeOfEachHyperLink()
    Dim pptSlide As Slide
    Dim pptHyperlink As Hyperlink
    Dim pptShape As Shape
    
    For Each pptSlide In ActivePresentation.Slides
        For Each pptHyperlink In pptSlide.Hyperlinks
            Select Case pptHyperlink.Type
            Case msoHyperlinkShape
                Set pptShape = pptHyperlink.Parent.Parent
            Case msoHyperlinkRange
                Set pptShape = pptHyperlink.Parent.Parent.Parent.Parent
            End Select
        Next pptHyperlink
    Next pptSlide
End Sub

循环所有形状并获取相应的超链接

反之则稍微复杂一些：

Private Sub GetHyperlinkOfEachShape()
    Dim pptSlide As Slide
    Dim pptShape As Shape
    Dim pptActionSetting As ActionSetting
    Dim pptHyperlink As Hyperlink
    Dim pptMouseActivation As Variant
    Dim strURL As String
    Dim i As Integer
        
    For Each pptSlide In ActivePresentation.Slides
        For Each pptShape In pptSlide.Shapes
            
            ' Hyperlink assigned to shape:
            For Each pptActionSetting In pptShape.ActionSettings
                If pptActionSetting.Action = ppActionHyperlink Then
                    Set pptHyperlink = pptActionSetting.Hyperlink
                    strURL = pptHyperlink.Address: Debug.Print strURL
                End If
            Next pptActionSetting

            ' Hyperlinks assigned to text or text parts:
            If pptShape.TextFrame.HasText Then
                For Each pptMouseActivation In Array(ppMouseClick, ppMouseOver)
                    Set pptActionSetting = pptShape.TextFrame.TextRange.ActionSettings(pptMouseActivation)
                    If pptActionSetting.Action = ppActionHyperlink Then
                        Set pptHyperlink = pptActionSetting.Hyperlink
                        strURL = pptHyperlink.Address: Debug.Print strURL
                    Else
                        strURL = ""
                        For i = 1 To pptShape.TextFrame.TextRange.Characters.Count
                            Set pptActionSetting = pptShape.TextFrame.TextRange.Characters(i).ActionSettings(pptMouseActivation)
                            If pptActionSetting.Action = ppActionHyperlink Then
                                If strURL <> pptActionSetting.Hyperlink.Address Then
                                    Set pptHyperlink = pptActionSetting.Hyperlink
                                    strURL = pptHyperlink.Address: Debug.Print strURL
                                End If
                            End If
                        Next i
                    End If
                Next pptMouseActivation
            End If
        
        Next pptShape
    Next pptSlide
End Sub