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

Question

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

我将把powerpoint与pdf.js一起显示为pdf，并需要在呈现的pdf上具有适当大小的形状的html叠加层以将超链接附加到该html。

但是，如果我尝试使用LinkFormat.SourceFullName方法，则会引发错误

  

无效请求

我已经用绝对链接的图像和形状对其进行了测试。同样，链接形状的类型也是autoShapeTypes。

我使用Office356。我主要对演示文稿中的幻灯片链接感兴趣。我可以通过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（在文本框或字符上）。

---

遍历所有超链接并获得相应的形状

您可以遍历幻灯片的所有超链接，并根据超链接类型在父结构中获取其形状：

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