Question

背景

我添加了一个执行以下操作的加载项：对于所有选定的powerpoint对象（例如4个矩形），加载项将调整所有对象的高度和宽度，以匹配选择中最大对象的高度和宽度。

我尝试编写VBA宏来复制此加载项但没有任何反应（调整以下问题中的代码：Powerpoint VBA Macro to copy object's size and location and paste to another object）：

Sub test()
    Dim w As Double
    Dim h As Double
    Dim obj As Shape

    w = 0
    h = 0

    For i = 1 To ActiveWindow.Selection.ShapeRange.Count
        Set obj = ActiveWindow.Selection.ShapeRange(i)
        If obj.Width > w Then
            w = obj.Width
        Else
            obj.Width = w
        End If

        If obj.Height > h Then
            h = obj.Height
        Else
            obj.Height = h
        End If
    Next
End Sub

问题

关于如何制作此代码的任何想法都有用吗？

Answer 1

经过一些更多的研究，这里有一个有效的代码（不确定它是否真的很有效，因为我是VBA的新手）：

Sub resizeAll()
    Dim w As Double
    Dim h As Double
    Dim obj As Shape

    w = 0
    h = 0

    ' Loop through all objects selected to assign the biggest width and height to w and h
    For i = 1 To ActiveWindow.Selection.ShapeRange.Count
        Set obj = ActiveWindow.Selection.ShapeRange(i)
        If obj.Width > w Then
            w = obj.Width
        End If

        If obj.Height > h Then
            h = obj.Height
        End If
    Next

    ' Loop through all objects selected to resize them if their height or width is smaller than h/w
    For i = 1 To ActiveWindow.Selection.ShapeRange.Count
        Set obj = ActiveWindow.Selection.ShapeRange(i)
        If obj.Width < w Then
            obj.Width = w
        End If

        If obj.Height < h Then
            obj.Height = h
        End If
    Next
End Sub

Powerpoint VBA宏用于调整所选对象的最大对象

1 个答案: