Extract text from SmartArt

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

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

            Next

        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)

        oSldCopy.Shapes.Range.Delete

        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

        oSAShp.GroupItems.Range(sShpArray).Select

        Application.ActiveWindow.Selection.Copy

        Set oShp = oSldCopy.Shapes.Paste(1)

        Application.ActiveWindow.Selection.Unselect

        Set UngroupSA = oSldCopy

Else

    Set UngroupSA = Nothing

End If

Exit Function

UngroupSA_Err:

     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.

    Endif

    oSld.Delete

End Sub