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

Question

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

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

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

无效请求

我已经用绝对链接的图像和形状对其进行了测试。不知何故，我的链接形状的类型是 autoShapeTypes。

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

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

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