Изменение размера всех выбранных форм до минимальных - PullRequest
Новая
       7

Изменение размера всех выбранных форм до минимальных

0 голосов
/ 22 мая 2018

Я искал макрос, который изменит все выбранные фигуры до той же высоты и ширины, что и самая маленькая выбранная фигура, но безуспешно.Я нашел следующий код, который успешно изменяет размеры всех выбранных фигур до той же высоты и ширины, что и самая большая выбранная форма.Я подумал, что если я просто поменяю местами все «>» и «<», тогда код удовлетворит мою потребность, но это не сработает.Он изменяет размер всего до 0,01 x,01 независимо от размера наименьшей выбранной фигуры.Кто-нибудь возражал бы, дайте мне знать, что мне нужно настроить в коде ниже?Заранее извиняюсь за форматирование - первый пост. </p> 

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

1 Ответ

0 голосов
/ 22 мая 2018

Попробуйте вместо этого: 

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.

...