CODEWITHSUNDEEP
vbahyperlinkpowerpoint
lennytubby
lennytubby

Reputation: 23

How to obtain shapes to hyperlinks in PowerPoint VBA

I want to obtain the shapes carring a hyperlink in PowerPoint.

I will display the powerpoint as pdf with pdf.js and need an overlay html with the right sized shapes over the rendered pdf to attach the hyperlinks to.

But if I try to use the LinkFormat.SourceFullName method, it throws the error

Invalid Request

I have tested it with definitely linked images and shapes. Also somehow the Type of my linked shapes are autoShapeTypes.

I use Office 356. I am mainly interested in links to slides inside the presentation. I can access them by pptSlide.Hyperlinks(i) and its SubAddress, but how would I get the referring shape to that link?

Any Ideas why the shapes would not show up as Linked Object and how I would be able to get the links from the shapes?

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

Upvotes: 2

Views: 1516

Answers (1)

Asger
Asger

Reputation: 3877

Hyperlink Locations and Types

Hyperlinks can be assigned

  • to the shape itself
  • to the shape's textframe
  • to individual characters (even multiple within one text)

They can be assigned either as ActionSettings(ppMouseClick).Hyperlink or ActionSettings(ppMouseOver).Hyperlink.

Their Hyperlink.Type is either msoHyperlinkShape (on shape) or msoHyperlinkRange (on textframe or character).

Loop over all Hyperlinks and get corresponding Shape

You can loop over all hyperlinks of a slide and get their shape within the parent structure, depending on the hyperlink type:

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

Loop over all Shapes and get correspondig Hyperlink(s)

The other way round is a bit more complicated:

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

Upvotes: 5

Related Questions