对齐形状 flush/stacked/touching

Question

我正在尝试按从右到左的顺序获取 selection 形状。我在 vbaexpress 上找到了 John Wilson 的例程，我的代码基于该例程。

当我 select 通过单击形状逐项进行排序时，排序工作完美，但如果我 select 通过“套索”它们，它不尊重形状的“可见顺序”我的鼠标。

如果将我的鼠标拖到形状上 select，例程应遵守形状的可见顺序。

提前致谢。

  Sub AlignFlush()
  Dim oshpR As ShapeRange
  Dim oshp As Shape
  Dim L As Long
  Dim rayPOS() As Single
     
  Set oshpR = ActiveWindow.Selection.ShapeRange
  
  ReDim rayPOS(1 To oshpR.Count)
  'add to array
  For L = 1 To oshpR.Count
     rayPOS(L) = oshpR(L).Left
  Next L
  'sort
  Call sortray(rayPOS)
  
  'apply
  For L = 1 To oshpR.Count
      If L = 1 Then
          Set oshp = Windows(1).Selection.ShapeRange(1)
          PosTop = oshp.Top
          PosNext = oshp.Left + oshp.Width
      Else
          Set oshp = Windows(1).Selection.ShapeRange(L)
          oshp.Top = PosTop
          oshp.Left = PosNext
          PosNext = oshp.Left + oshp.Width
      End If
  Next L
  End Sub

   Sub sortray(ArrayIn As Variant)
  Dim b_Cont As Boolean
  Dim lngCount As Long
  Dim vSwap As Long
  Do
     b_Cont = False
     For lngCount = LBound(ArrayIn) To UBound(ArrayIn) - 1
        If ArrayIn(lngCount) > ArrayIn(lngCount + 1) Then
           vSwap = ArrayIn(lngCount)
           ArrayIn(lngCount) = ArrayIn(lngCount + 1)
           ArrayIn(lngCount + 1) = vSwap
           b_Cont = True
        End If
     Next lngCount
  Loop Until Not b_Cont

结束子

Answer 1

对您现有代码的一些评论：

数组计数始终从 0 开始，除非您使用 Option Base statement 将其设置为不同的数字。

当你使用 ReDim 时，大多数时候，你想要使用 Preserve 关键字，否则 ReDim 会抹掉现有的数组内容。但是在这种情况下，我们提前知道了数组的大小，所以Preserve是没有必要的。

您致电 sortray，但未将其包含在您的列表中。我添加了一个排序程序。

但是你在放置形状的部分没有使用排序数组。

工作宏（根据您对“可见顺序”是 left-to-right 序列的含义的描述）：

由于您使用最左侧形状的左侧位置来应用到其他形状，这里有一个更简单的方法：

Sub AlignFlushLeftWithLeftmostShape()
    Dim ShpCount As Long
    Dim oshpR As ShapeRange
    Dim L As Long
    Dim rayPOS() As Single
       
    Set oshpR = ActiveWindow.Selection.ShapeRange
    
    ShpCount = oshpR.Count
    
    ReDim rayPOS(ShpCount - 1)
    
    For L = 0 To ShpCount - 1
       rayPOS(L) = oshpR(L + 1).Left
    Next L

    Call BubbleSort(rayPOS)

    For x = 1 To ShpCount
        oshpR(x).Left = rayPOS(0)
    Next x
End Sub
  
Sub BubbleSort(arr)
    Dim lTemp As Long
    Dim i As Long
    Dim j As Long
    Dim lngMin As Long
    Dim lngMax As Long
    lngMin = LBound(arr)
    lngMax = UBound(arr)
    For i = lngMin To lngMax - 1
        For j = i + 1 To lngMax
            If arr(i) > arr(j) Then
                lTemp = arr(i)
                arr(i) = arr(j)
                arr(j) = lTemp
            End If
        Next j
    Next i
End Sub

对齐形状 flush/stacked/touching

Align shapes flush/stacked/touching

powerpoint

vba