OfficeTips Home || VBA Section || General Section || Download Section || Privacy Policy

Extract text from SmartArt

The SmartArt object model is read-only which means that it is possible to iterate through the shapes and their properties but one cannot assign any values or properties. The way to do it is to treat the SmartArt as a regular group.


Sub SmartArtText()

    Dim oSh As Shape
    Dim oSubShape As Shape
    Dim x As Long
    Set oSh = ActiveWindow.Selection.ShapeRange(1)
    With oSh
        If .Type = msoSmartArt Then
            For x = 1 To .GroupItems.Count
                With .GroupItems(x)
                    Debug.Print .Type 
                End With
        End If
    End With

End Sub


While the above example is expected to work it fails to do so in cases where your goal is to extract all the text or hyperlinks on that SmartArt because some bugs have crept in the object model. The way to get around this issue is to extract the shapes within the SmartArt and then extract all the info from the regular shapes.

This subroutine accepts the smartart shape and the slide on which it resides. It will create a duplicate slide with shapes of the smartart. We will use that new slide to extract the slide text and then delete the slide.

Function UngroupSA(oSAShp As Object, oSASld As Slide) As Slide
On Error GoTo UngroupSA_Err
Dim oShp As PowerPoint.Shape
Dim oSldCopy As Slide
Dim sShpArray() As Long
Dim I As Long

If oSAShp.Type = msoSmartArt Or _
    (oSAShp.Type = msoPlaceholder And _
            oSAShp.PlaceholderFormat.ContainedType = msoSmartArt) Then
        Set oSldCopy = oSASld.Duplicate(1)
        If oSldCopy.Shapes.Count > 0 Then oSldCopy.Shapes.Range.Delete
        Application.ActiveWindow.View.GotoSlide oSASld.SlideIndex
        ReDim sShpArray(1 To oSAShp.GroupItems.Count)
        For I = 1 To oSAShp.GroupItems.Count
            sShpArray(I) = I
        Next I
        Set oShp = oSldCopy.Shapes.Paste(1)
        Set UngroupSA = oSldCopy
    Set UngroupSA = Nothing
End If
Exit Function
     Call MsgBox(Err.Description & "in UngroupSA " & "at line " & Erl)
     Resume Next
End Function


Sub Example()
    Dim oSld as Slide

    Set oSld = UngroupSA(ActiveWindow.Selection.ShapeRange(1), ActiveWindow.Selection.SlideRange(1))
    If Not oSld Is Nothing then
            'Extract text from shapes on this slide and then delete the slide. Left as exercise.
End Sub





Copyright 1999-2018 (c) Shyam Pillai. All rights reserved.