Как получить фигуры с гиперссылками в PowerPoint VBA - PullRequest
Новая
       38

Как получить фигуры с гиперссылками в PowerPoint VBA

1 голос
/ 17 апреля 2019

Я хочу получить фигуры с гиперссылкой в ​​PowerPoint.

Я буду отображать powerpoint в формате pdf с pdf.js и мне понадобится наложение html с фигурами нужного размера поверх визуализированного pdf, чтобы прикрепить гиперссылкик.

Но если я попытаюсь использовать метод 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

1 Ответ

0 голосов
/ 18 апреля 2019

Расположение и типы гиперссылок

Гиперссылки могут быть назначены

  • до самой формы
  • к текстовому фрейму фигуры
  • на отдельные символы (даже несколько в одном тексте)

Их можно назначить как 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
...