将 Powerpoint 形状复制到 Excel - 外观相同的幻灯片，不同的形状顺序

Question

我有一个包含 32 张外观相同的幻灯片的演示文稿（最初是宏生成的，后来有了人情味）。

简化外观：

标题（但未格式化为标题）
图片
内容1
内容2
内容3

我现在想将文本复制回 Excel。尽管所有幻灯片看起来都相同，但 slide.Shapes 中形状的顺序似乎不同。

对于每张幻灯片，我想要一行，列的顺序相同：
Title, Content1, Content2,Content3
但有些是
Content1,Content3,Title,Content2 （或任何其他顺序）

这是为什么？

我的代码：

    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

Answer 1

最终帮助我的是将每个文本框的左侧和顶部位置相乘。该值足够独特，相关内容最终会出现在每张幻灯片的同一列中。在 Excel 中对列本身进行排序，我仍然需要手动完成，但这是一项简单的任务。我从另一个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