PowerPoint VBA Get Shapes Array for Small Basic

GetShapes.bas

Sub GetShapes()
    ' Get shapes array from PowerPoint VBA
    ' Version 0.4
    ' Copyright (c) 2015-2016 Nonki Takahashi.  The MIT License.
    ' Last update 2016-01-08
    '
    Dim index As Long
    Dim myDocument As Slide
    Dim x(300) As Integer, y(300) As Integer
    Dim xmin As Integer, ymin As Integer
    Dim s1(100) As String, s2(300) As String
    index = ActiveWindow.View.Slide.SlideIndex
    Set myDocument = ActivePresentation.Slides(index)
    c = myDocument.Shapes.Count
    For i = 2 To c
        With myDocument.Shapes(i)
            func = "?"
            If .Type = msoTextBox Then
                func = "text"
            ElseIf .Type = msoLine Then
                func = "line"
            ElseIf .Type = msoAutoShape Then
                If .AutoShapeType = msoShapeRectangle Then
                    func = "rect"
                ElseIf .AutoShapeType = msoShapeOval Then
                    func = "ell"
                ElseIf .AutoShapeType = msoShapeIsoscelesTriangle Then
                    func = "tri"
                ElseIf .AutoShapeType = msoShapeMixed Then
                    func = "line"
                ElseIf .AutoShapeType = msoShapeTrapezoid Then
                    func = "trap"
                ElseIf .AutoShapeType = msoShapeHexagon Then
                    func = "hex"
                End If
            End If
            s1(i) = "  shape[" & (.ZOrderPosition - 1) & "] = ""func=" & func
            If func = "text" Then
                If .TextFrame.TextRange.Font.Bold Then
                    fb = "True"
                Else
                    fb = "False"
                End If
                If .TextFrame.TextRange.Font.Italic Then
                    fi = "True"
                Else
                    fi = "False"
                End If
                s2(i) = ";text=" & .TextFrame.TextRange.Text & _
                    ";fn=" & .TextFrame.TextRange.Font.Name & _
                    ";fs=" & .TextFrame.TextRange.Font.Size & _
                    ";fb=" & fb & ";fi=" & fi
                bc = ColorToHex(.TextFrame.TextRange.Font.Color.RGB)
            Else
                bc = ColorToHex(.Fill.ForeColor.RGB)
            End If
            pc = ColorToHex(.Line.ForeColor.RGB)
            pw = Int(.Line.Weight)
            If pw < 0 Or .Line.Visible = msoFalse Then
                pw = 0
            End If
            If func = "tri" Then
                x(i) = Int(.Left)
                y(i) = Int(.Top)
                If i = 2 Then
                    xmin = x(i)
                    ymin = y(i)
                Else
                    xmin = Min(x(i), xmin)
                    ymin = Min(y(i), ymin)
                End If
                s2(i) = ";x1=" & Int(.Width / 2) & ";y1=0" & _
                    ";x2=0;y2=" & Int(.Height) & _
                    ";x3=" & Int(.Width) & ";y3=" & Int(.Height)
            ElseIf func = "line" Then
                If .VerticalFlip Xor .HorizontalFlip Then
                    x1 = 0
                    y1 = .Height
                    x2 = .Width
                    y2 = 0
                Else
                    x1 = 0
                    y1 = 0
                    x2 = .Width
                    y2 = .Height
                End If
                x(i) = Int(.Left)
                y(i) = Int(.Top)
                If .Rotation <> 0 Then
                    a = .Rotation / 180 * 3.14
                    cx = (x1 + x2) / 2
                    cy = (y1 + y2) / 2
                    xs = (x1 - cx) * Math.Cos(a) - (y1 - cy) * Math.Sin(a) + .Left + cx
                    ys = (x1 - cx) * Math.Sin(a) + (y1 - cy) * Math.Cos(a) + .Top + cy
                    xe = (x2 - cx) * Math.Cos(a) - (y2 - cy) * Math.Sin(a) + .Left + cx
                    ye = (x2 - cx) * Math.Sin(a) + (y2 - cy) * Math.Cos(a) + .Top + cy
                    x(i) = Min(Int(xs), Int(xe))
                    y(i) = Min(Int(ys), Int(ye))
                    If (ye < ys) Xor (xe < xs) Then
                        x1 = 0
                        y1 = Abs(ye - ys)
                        x2 = Abs(xe - xs)
                        y2 = 0
                    Else
                        x1 = 0
                        y1 = 0
                        x2 = Abs(xe - xs)
                        y2 = Abs(ye - ys)
                    End If
                End If
                If i = 2 Then
                    xmin = x(i)
                    ymin = y(i)
                Else
                    xmin = Min(x(i), xmin)
                    ymin = Min(y(i), ymin)
                End If
                s2(i) = ";x1=" & Int(x1) & ";y1=" & Int(y1) & _
                    ";x2=" & Int(x2) & ";y2=" & Int(y2)
            Else
                x(i) = Int(.Left - pw / 2)
                y(i) = Int(.Top - pw / 2)
                If i = 2 Then
                    xmin = x(i)
                    ymin = y(i)
                Else
                    xmin = Min(x(i), xmin)
                    ymin = Min(y(i), ymin)
                End If
                s2(i) = ";width=" & Int(.Width + pw) & ";height=" & Int(.Height + pw)
            End If
            If func = "trap" Or func = "hex" Then
                s2(i) = s2(i) & ";ratio=" & .Adjustments.Item(1)
            End If
            If func <> "line" And .Rotation <> 0 Then
                s2(i) = s2(i) & ";angle=" & .Rotation
            End If
            If pw = 0 Then
                s2(i) = s2(i) & ";pw=" & pw
            Else
                s2(i) = s2(i) & ";pw=" & pw & ";pc=" & pc
            End If
            s2(i) = s2(i) & ";bc=" & bc & ";name=" & .Name & ";""" & vbCrLf
        End With
    Next
    msg = "Sub Shapes_Init" & vbCrLf
    msg = msg & "  ' Shapes | Initialize shapes data" & vbCrLf
    msg = msg & "  ' return shX, shY - current position of shapes" & vbCrLf
    msg = msg & "  ' return shape - array of shapes" & vbCrLf
    msg = msg & "  shX = " & xmin & " ' x offset" & vbCrLf
    msg = msg & "  shY = " & ymin & " ' y offset" & vbCrLf
    For i = 2 To c
        msg = msg & s1(i) & ";x=" & (x(i) - xmin) & _
            ";y=" & (y(i) - ymin) & s2(i)
    Next
    msg = msg & "EndSub"
    With myDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, _
        10, 10, 938, 428)
        .TextFrame.TextRange.Font.Size = 14
        .TextFrame.TextRange.Font.Color.RGB = RGB(128, 128, 128)
        .TextFrame.TextRange.Text = msg
    End With
End Sub
Function ColorToHex(c As Long) As String
    ' Convert color c to hex
    ' param c - RGB color
    '
    r = Hex(c Mod 256)
    If Len(r) = 1 Then
      r = "0" & r
    End If
    g = Hex(c \ 256 Mod 256)
    If Len(g) = 1 Then
      g = "0" & g
    End If
    b = Hex(c \ 65536 Mod 256)
    If Len(b) = 1 Then
      b = "0" & b
    End If
    ColorToHex = "#" & r & g & b
End Function
Function Min(number1 As Integer, number2 As Integer) As Integer
    ' param number1 - the first number to compare
    ' param number2 - the second number to compare
    If number1 < number2 Then
        Min = number1
    Else
        Min = number2
    End If
End Function

See more detail in a document PowerPoint VBA - GetShapes Macro.