Как кодировать макрос PowerPoint VBA, который «складывает» фигуры поверх друг друга / касаясь друг друга? - PullRequest
Новая
       66

Как кодировать макрос PowerPoint VBA, который «складывает» фигуры поверх друг друга / касаясь друг друга?

0 голосов
/ 19 апреля 2020

Я пытаюсь найти способ создания макроса, который "складывает" фигуры прямо рядом друг с другом, примерно так, как сложен тотемный столб, причем фигуры в основном касаются друг друга. Идея здесь в том, что это было бы очень полезно для таких элементов, как временные шкалы шеврона, или для обеспечения того, чтобы фигуры были как можно ближе друг к другу, не перекрывая друг друга.

До сих пор мой процесс мышления кода был примерно таким, при условии, что я хочу складывать снизу вверх:

Выбрать все фигуры

Для фигур в выделении:

Собрать нижнюю позицию и верхнюю позицию каждой фигуры

Используя наименьшую форму в качестве ориентира, поместите вторую наименьшую фигуру в положение (координаты наименьшей фигуры за вычетом высоты фигуры)

Используя в качестве ориентира вторую наименьшую фигуру, поместите третью наименьшую фигуру в положение ( вторая самая низкая форма минус вторая самая низкая высота формы)

И так до тех пор, пока все фигуры не будут сложены друг на друга. Я полагаю, что код может быть легко изменен для размещения сверху вниз или для размещения слева направо.

Самый большой вопрос, как мне создать этот код? Я прошел учебники о том, как перемещать объекты, но я не могу заставить его делать это с более чем двумя объектами.

Вот что у меня так далеко: 

Sub Stack_on_top()
Dim Shp1 As Shape
Dim Shp2 As Shape
Dim x As Integer
Dim y As Integer

  x = Windows(1).Selection.ShapeRange.Count
  For y = 1 To x
    If Shp1 Is Nothing Then
      Set Shp1 = Windows(1).Selection.ShapeRange(y)
    Else
      Set Shp2 = Windows(1).Selection.ShapeRange(y)
          Shp2.Top = Shp1.Top - Shp2.Height
      End If
  Next y
End Sub

Проблема в том, что этот код делает это только с 2 объектами, остальные просто складываются на основе одной ссылки. Любая помощь будет высоко ценится!

Спасибо!

-Джон

1 Ответ

0 голосов
/ 20 апреля 2020

Попробуйте так: 

Sub Stack_on_top()

Dim Shp1 As Shape
Dim Shp As Shape
Dim x As Long
Dim sngLastY As Single

    Set Shp1 = ActiveWindow.Selection.ShapeRange(1)
    sngLastY = Shp1.Top

    For x = 2 To ActiveWindow.Selection.ShapeRange.Count
        Set Shp = ActiveWindow.Selection.ShapeRange(x)
        With Shp
            .Left = Shp1.Left
            .Top = sngLastY - .Height
            sngLastY = .Top
        End With
    Next

End Sub

[Позже ... добавление фигур в массив] 

Function SelectedShapesToArray(ShRange As ShapeRange) As Variant

    Dim aTemparray() As Shape
    ReDim aTemparray(1 To ShRange.Count)
    Dim x As Long

    For x = 1 To ShRange.Count
        Set aTemparray(x) = ShRange(x)
    Next

    SelectedShapesToArray = aTemparray

End Function

Sub Test()

    Dim x As Long
    Dim ShArray() As Shape

    ShArray = SelectedShapesToArray(ActiveWindow.Selection.ShapeRange)

    ' Test: do we have all the shapes we expected?
    For x = LBound(ShArray) To UBound(ShArray)
        Debug.Print ShArray(x).Name
    Next

    ' Here you could sort ShArray on ShArray(x).top

End Sub
...