基于幻灯片上形状位置的 PowerPoint VBA z 顺序

Question

我想根据形状的位置重新排序（z 顺序）我的“套索”形状选择。我当前的宏忽略它们的位置，并且循环根据现有的 z 顺序循环遍历形状，这违背了循环的目的！

例如，我在网格中有 3 个形状，其中“1 行”和“3 列”。当我用鼠标套索选择形状并运行此宏时，我希望最左边的形状位于前面，下一个形状（中间形状）位于 z 顺序后面，最右边的形状位于后面z 顺序位于中间形状后面。

当前代码如下：

Dim shp As Shape

For each shp in Activewindow.Selection.ShapeRange
shp.zorder msoBringToFront
Next

Answer 1

据我了解，主要任务是按位置对形状列表进行排序。

以下函数将对形状列表进行排序并以正确的顺序返回形状数组。您可以使用 ShapeRange 或 Shapes 作为参数来调用它：使用

ShapeRange

进行选择或使用

slide.Shapes

处理幻灯片的所有形状。

该函数使用简单的快速排序来按形状的位置进行排序。我使用

round

函数，因为即使您对齐形状，形状的位置也可能略有不同。

Function orderShapes(shapeRange) As shape()
    ' shapeRange can be either of type ShapeRange or of type Shapes
  
    If shapeRange.Count = 0 Then Exit Function
  
    ' Fill an array with all shapes.
    ReDim shapeArray(1 To shapeRange.Count) As shape
    Dim i As Long, j As Long
    For i = 1 To shapeRange.Count
        Set shapeArray(i) = shapeRange(i)
    Next
    
    ' Sort by position (left/top). 
    For i = 1 To UBound(shapeArray) - 1
        For j = i To UBound(shapeArray)
            Dim left1 As Double, left2 As Double, top1 As Double, top2 As Double
            left1 = Round(shapeArray(i).Left, 1)
            top1 = Round(shapeArray(i).Top, 1)
            left2 = Round(shapeArray(j).Left, 1)
            top2 = Round(shapeArray(j).Top, 1)
            If left1 > left2 Or (left1 = left2 And top1 > top2) Then
                ' Use this to sort from top to bottom:
                ' If top1 > top2 Or (top1 =  top2 And left1 > left2) Then
                Dim tmpShape As shape
                Set tmpShape = shapeArray(i)
                Set shapeArray(i) = shapeArray(j)
                Set shapeArray(j) = tmpShape
            End If
        Next
    Next
    
    orderShapes = shapeArray
End Function

现在有了结果数组，您可以做任何您想做的事情。以下例程将对幻灯片的形状进行排序并将索引写入文本：

Sub slTest()
    Dim sl As Slide
    Set sl = ActivePresentation.Slides(1)
    Dim a() As shape
    a = orderShapes(sl.Shapes)
    ' Use this to sort only the selected shapes: 
    ' a = orderShapes(ActiveWindow.Selection.shapeRange)

    Dim i As Long
    For i = 1 To UBound(a)
        a(i).TextFrame.TextRange.Text = "  I am shape " & i
    Next
End Sub

当然，你也可以用它来设置zOrder：

Sub setZOrderOfShapes(shapeRange)
    Dim a() As shape, i As Long
    a = orderShapes(shapeRange)
    
    For i = 1 To UBound(a)
        a(i).ZOrder msoBringToFront
    Next
End Sub