Copy Powerpoint Shapes to Excel - identically looking slides, different shape order

Question

I have a presentation with 32 identically looking slides (initally macro generated, later had human touch).

Simplified look:

Title (not formatted as a headline, though)
picture
Content1
Content2
Content3

I now want to copy the text back to Excel. Although all slides look identical, the order of the shapes in slide.Shapes seems different.

For every slide I want a row, with the colums in the same order:
Title, Content1, Content2,Content3
but some are
Content1,Content3,Title,Content2 (or any other order)

Why is this?

My code:

    Sub CopyFromPowerpoint()

        'Prepare variables
        Dim PowerPoint As PowerPoint.Application
        Dim activeSlide As PowerPoint.Slide
        Dim curShape As PowerPoint.shape
        Dim RowCounter As Integer
        Dim ColumnCounter As Integer
        Dim tmp As String

        'Set powerPoint
        Set PowerPoint = GetObject(, "PowerPoint.Application")

        tmp = "XXX" 'this should never be pasted
        RowCounter = 1
        ColumnCounter = 1
        For Each Slide In PowerPoint.Presentations(1).Slides
        Set activeSlide = PowerPoint.Presentations(1).Slides(RowCounter)
            For Each shape In activeSlide.Shapes
                Set curShape = activeSlide.Shapes(ColumnCounter)
                If curShape.TextFrame.HasText Then tmp = curShape.TextFrame.TextRange
                If curShape.TextFrame.HasText Then Worksheets("nameofsheet").Cells(RowCounter, ColumnCounter).Value = tmp
                ColumnCounter = ColumnCounter + 1
            Next
            ColumnCounter = 1
            RowCounter = RowCounter + 1
         Next


End Sub

If you are asking _why_ the order varies, the answer would be _thats a result of how the objects were created or manipulated_. If you are asking _how to deal with it_ then the answer is you need some other way to identify which object is which. Perhaps position on the slide? — chris neilsen, May 30 '18 at 08:25
Thank you. Exactly my two questions. So teh Shapes array is tracked by 'last edited' ? I could not find that online. Will try and work around with position. — SLLegendre, May 30 '18 at 08:30
@SLLegendre No, not by last edited, but some types of editing (send forward/backward/to back/to front) would change the order. As Chris suggested, a way of uniquely identifying the shapes would help. When you create the shape, you can add a .Tag whose name/value would identify it, then when you go to copy the shape, a function that returns the shape with a given tag would hand you back the shape you're after. There's more detail and sample code on this page in the PPT faq I maintain: Tags http://www.pptfaq.com/FAQ00815_Working_with_Tags_-and_a_bit_about_Functions-.htm — Steve Rindsberg, May 30 '18 at 15:40

score 0 · Accepted Answer · answered Jun 20 '18 at 10:14

What helped me in the end was multiplying the left and top position for each textbox. That value was unique enough for the relevant content to end up in the same column for each slide. Ordering the columns themselves in Excel, I still needed to do manually but that was an easy task. The quick sort algorithm I got from another stackoverflow question

Sub CopyFromPowerpoint()

        'Prepare variables
        Dim PowerPoint As PowerPoint.Application
        Dim activeSlide As PowerPoint.Slide
        Dim curShape As PowerPoint.shape
        Dim RowCounter As Integer
        Dim ColumnCounter As Integer
        Dim shapeCounter As Long
        Dim tmp(20) As String
        Dim arr(20) As Long
        Dim tmpMult As Long

        'Set powerPoint
        Set PowerPoint = GetObject(, "PowerPoint.Application")

        RowCounter = 1
        ColumnCounter = 1
        For Each Slide In PowerPoint.Presentations(1).Slides
        Set activeSlide = PowerPoint.Presentations(1).Slides(RowCounter)

           'Loop through shapes, note their position from top and left, multiply them and sort it
            shapeCounter = LBound(arr)
            For Each shape In activeSlide.Shapes
                arr(CInt(shapeCounter)) = shape.Top * shape.Left
                shapeCounter = shapeCounter + 1
            Next
            Call QuickSort(arr, LBound(arr), UBound(arr))



            'Loop through shapes again and copy shape text into relevant position in text array
            For Each shape In activeSlide.Shapes
            If shape.TextFrame.HasText Then
                For i = LBound(arr) To UBound(arr)
                    tmpMult = shape.Top * shape.Left
                    If arr(i) = tmpMult Then tmp(i) = shape.TextFrame.TextRange
                    tmpMult = 0
                Next i
            End If

            Next

            'Loop through text array and paste into worksheet
            For i = LBound(tmp) To UBound(tmp)
                Worksheets("uebergabe").Cells(RowCounter, i + 1).Value = tmp(i)
            Next i

            'Reset for next slide
            RowCounter = RowCounter + 1
            shapeCounter = 0
            For i = LBound(arr) To UBound(arr)
                arr(i) = 0
                tmp(i) = ""
            Next i


         Next


End Sub

Public Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)

  Dim pivot   As Variant
  Dim tmpSwap As Variant
  Dim tmpLow  As Long
  Dim tmpHi   As Long

  tmpLow = inLow
  tmpHi = inHi

  pivot = vArray((inLow + inHi) \ 2)

  While (tmpLow <= tmpHi)

     While (vArray(tmpLow) < pivot And tmpLow < inHi)
        tmpLow = tmpLow + 1
     Wend

     While (pivot < vArray(tmpHi) And tmpHi > inLow)
        tmpHi = tmpHi - 1
     Wend

     If (tmpLow <= tmpHi) Then
        tmpSwap = vArray(tmpLow)
        vArray(tmpLow) = vArray(tmpHi)
        vArray(tmpHi) = tmpSwap
        tmpLow = tmpLow + 1
        tmpHi = tmpHi - 1
     End If

  Wend

  If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
  If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi

End Sub

Copy Powerpoint Shapes to Excel - identically looking slides, different shape order

1 Answers1