求vba代码对对象在图层的顺序重排

petergh

初学vba，请高手支招，谢谢！


有1、2、3、4、5、6、7个对象，视觉上是从左到右按顺序排列的，但是创建顺序不同。
如图，用VBA代码如何能按视顺序重排对象在图层上的顺序？

                               
登录/注册后可看大图

xiyanghxc

可以试试deepseek。也曾经试着做个动作，要求是把图层顺序自上而下对应着工作区中对象自左到右的、自上到下。可惜一直没实现

苍穹之翼

xiyanghxc 发表于 2025-5-7 11:01
可以试试deepseek。也曾经试着做个动作，要求是把图层顺序自上而下对应着工作区中对象自左到右的、自上到下 ...

可以，你的思路很对了但是可能缺少做程序的基础把，我也有这种想法，可能ai给你东西了但是还需要加以调试

xiyanghxc

苍穹之翼 发表于 2025-5-7 12:56
可以，你的思路很对了但是可能缺少做程序的基础把，我也有这种想法，可能ai给你东西了但是还需要加以调试 ...

deepseek出来的代码只能作为参考，具体还是要表达准确，按问题提示进行一步步排查、最终调试正常为止。

夜的影子

碰巧我也刚研究这个代码，不知道你是用什么属性进行排序的。
总不能用内容排序吧？

我用的是颜色排序，关键代码：Shapes(I).OrderToBack  ‘移动到最下方，你也可以用移动到最上方Shapes(I).OrderToFront

这是我的代码：
Sub 按颜色排序()
    VGCore.ActiveDocument.BeginCommandGroup "宏操作"
    Dim userSelect As VGCore.ShapeRange
    Set userSelect = VGCore.ActiveSelectionRange
   'PrintShapesName userSelect.Shapes
    userSelect.Sort "@shape1.fill.color.com().HexValue>@shape2.fill.color.com().HexValue"
    Dim S1 As VGCore.Shape
    Set S1 = userSelect.Shapes(userSelect.Count)
   
    For I = 1 To userSelect.Count
        userSelect.Shapes(I).OrderToBack
    Next
    VGCore.ActiveDocument.EndCommandGroup
End Sub

xiyanghxc

夜的影子 发表于 2025-5-7 14:44
碰巧我也刚研究这个代码，不知道你是用什么属性进行排序的。
总不能用内容排序吧？

刚刚用这段代码到2024版本里，运行异常，
不知道用到哪个版本上可以正常

夜的影子

先选中要排序的全部对象，然后运行代码。

夜的影子

排序前：


选中所有需要排序的对象。

排序后：

petergh

xiyanghxc 发表于 2025-5-7 13:37
deepseek出来的代码只能作为参考，具体还是要表达准确，按问题提示进行一步步排查、最终调试正常为止。 ...

我也求教deepseek，但是因为我基础差，总是试不成功。
以下是deepseek给出的代码：
Sub SortSelectionOrder()
    ' 按坐标排序后，调整ActiveSelection的顺序（其他程序可通过此顺序读取）
    Dim arr(), i&, j&, s As Shape
    ReDim arr(1 To ActiveSelection.Shapes.Count, 1 To 3)
   
    ' 提取坐标和对象
    i = 1
    For Each s In ActiveSelection.Shapes
        arr(i, 1) = s.PositionY  ' Y优先（从上到下）
        arr(i, 2) = s.PositionX  ' X其次（从左到右）
        Set arr(i, 3) = s         ' 对象引用
        i = i + 1
    Next
   
    ' 冒泡排序
    For i = 1 To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            If (arr(j, 1) < arr(i, 1)) Or _
               (arr(j, 1) = arr(i, 1) And arr(j, 2) < arr(i, 2)) Then
                Swap arr, i, j
            End If
        Next
    Next
   
    ' 输出排序后的对象顺序（供其他程序使用）
    For i = 1 To UBound(arr)
        Debug.Print "顺序" & i & ": " & arr(i, 3).Name
    Next
End Sub

Sub Swap(arr, i, j)
    Dim temp(1 To 3)
    temp(1) = arr(i, 1): temp(2) = arr(i, 2): Set temp(3) = arr(i, 3)
    arr(i, 1) = arr(j, 1): arr(i, 2) = arr(j, 2): Set arr(i, 3) = arr(j, 3)
    arr(j, 1) = temp(1): arr(j, 2) = temp(2): Set arr(j, 3) = temp(3)
End Sub

petergh

在deepseek的帮助下，以下程序可以实现从左到右重排。
Sub SortLeftToRight()
    ' 1. 检查选择
    If ActiveSelection.Shapes.Count = 0 Then Exit Sub
   
    ' 2. 将对象存入数组
    Dim arr() As Shape, i As Long, j As Long
    ReDim arr(1 To ActiveSelection.Shapes.Count)
    i = 1
    For Each s In ActiveSelection.Shapes
        Set arr(i) = s
        i = i + 1
    Next
   
    ' 3. 按X坐标冒泡排序（从左到右）
    For i = 1 To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            If arr(j).PositionX < arr(i).PositionX Then
                Swap arr, i, j
            End If
        Next
    Next
   
    ' 4. 打印排序结果（验证用）
    For i = 1 To UBound(arr)
        Debug.Print "对象 " & i & ": X=" & arr(i).PositionX & " (" & arr(i).Name & ")"
        set sh=arr(i)
        sh.delete
    Next
   
    MsgBox "已按从左到右顺序排序 " & UBound(arr) & " 个对象"
End Sub

' 交换数组元素
Sub Swap(arr() As Shape, i As Long, j As Long)
    Dim temp As Shape
    Set temp = arr(i)
    Set arr(i) = arr(j)
    Set arr(j) = temp
End Sub