将所有选定的形状调整为最小的形状

Question

我已经搜索了一个宏，可以将所有选定形状的大小调整为与最小的选定形状相同的高度和宽度，但没有成功。我确实找到了以下代码，它成功地将所有选定形状的大小调整为与最大选定形状相同的高度和宽度。我想如果我简单地反转每个“>"s and "<"s then the code would meet my need, but it doesn't work. It resizes everything to .01"x.01”，无论最小的选定形状的大小如何。有人介意让我知道我需要在下面的代码中调整什么吗？提前为格式道歉 - 首先 post.

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

Answer 1

试试这个：

Sub ResizeToSmallest()
    ' PPT coordinates are Singles rather than Doubles
    Dim sngNewWidth As Single
    Dim sngNewHeight As Single
    Dim oSh As Shape

    ' Start with the height/width of first shape in selection
    With ActiveWindow.Selection.ShapeRange
        sngNewWidth = .Item(1).Width
        sngNewHeight = .Item(1).Height
    End With

    ' First find the smallest shape in the selection
    For Each oSh In ActiveWindow.Selection.ShapeRange
        If oSh.Width < sngNewWidth Then
            sngNewWidth = oSh.Width
        End If
        If oSh.Height < sngNewHeight Then
            sngNewHeight = oSh.Height
        End If
    Next

    ' now that we know the height/width of smallest shape
    For Each oSh In ActiveWindow.Selection.ShapeRange
        oSh.Width = sngNewWidth
        oSh.Height = sngNewHeight
    Next

End Sub

请注意，这会扭曲形状或导致宽度被调整为不同的大小，以便根据形状的 .LockAspectRatio 设置保持形状的纵横比。

Answer 2

Sub ImageSizeToShortest()
    Dim sAspectRatio As Single, i As Integer, r As Range, h As Single
    h = Selection.PageSetup.PageHeight
    Set r = Selection.Range
    With ActiveDocument
        For i = 1 To .Shapes.count
            .Shapes(i).Select
            If Selection.Start >= r.Start And Selection.End <= r.End Then
                If h > .Shapes(i).Height Then h = .Shapes(i).Height
            End If
        Next i
        For i = 1 To .InlineShapes.count
            .InlineShapes(i).Select
            If Selection.Start >= r.Start And Selection.End <= r.End Then
                If h > .InlineShapes(i).Height Then h = .InlineShapes(i).Height
            End If
        Next i
        For i = 1 To .Shapes.count
            .Shapes(i).Select
            If Selection.Start >= r.Start And Selection.End <= r.End Then
                sAspectRatio = .Shapes(i).Width / .Shapes(i).Height
                .Shapes(i).Height = h
                .Shapes(i).Width = .Shapes(i).Height * sAspectRatio
            End If
        Next i
        For i = 1 To .InlineShapes.count
            .InlineShapes(i).Select
            If Selection.Start >= r.Start And Selection.End <= r.End Then
                sAspectRatio = .InlineShapes(i).Width / .InlineShapes(i).Height
                .InlineShapes(i).Height = h
                .InlineShapes(i).Width = .InlineShapes(i).Height * sAspectRatio
            End If
        Next i
    End With
    r.Select
End Sub

将所有选定的形状调整为最小的形状

Resizing all shapes selected to the smallest shape

powerpoint

vba