Копирование настроек контура фигуры в powerpoint

Question

Некоторые формы в powerpoint позволяют изменять контур с помощью маленьких желтых ручек:

Иногда у меня есть другая форма той же категрии (например, другой шестиугольник), которую я хочу придать тому же точному контуру, что и первый. Есть ли способ скопировать и вставить эти изменения контура?

Answer 1

Я не думаю, что есть прямой способ сделать это в PowerPoint, но несколько строк VBA сделают эту работу. Во-первых, нажмите на форму, которую вы хотите скопировать настройки ОТ. Затем удерживайте CTRL и щелкните форму, в которую вы хотите скопировать настройки. Затем запустите код:

Sub CopyAdjustments()

    Dim x As Long

    With ActiveWindow.Selection.ShapeRange(1)
        For x = 1 To .Adjustments.Count
            ActiveWindow.Selection.ShapeRange(2).Adjustments(x) = .Adjustments(x)
        Next
    End With

End Sub

Если в презентации есть много фигур, которые нужно отрегулировать, это будет лучше. SaveAdjustments сохраняет настройки выбранной фигуры в скрытых "тегах" в презентации. ApplySavedAdjustments выбирает сохраненные настройки и применяет их к выбранной фигуре. Это зависит от пользователя, чтобы быть разумным ... выбрать форму, прежде чем брать / применять корректировки. И если вы сохраните настройки для одного вида фигуры и примените их к другому типу ... что ж, удачи.

Sub SaveAdjustments()

    Dim x As Long

    With ActiveWindow.Selection.ShapeRange(1)
        If .Adjustments.Count > 0 Then
            ActivePresentation.Tags.Add "Adjustments", CStr(.Adjustments.Count)
            For x = 1 To .Adjustments.Count
                ActivePresentation.Tags.Add "Adj" & CStr(x), CStr(.Adjustments(x))
            Next
        End If
    End With

End Sub

Sub ApplySavedAdjustments()

    Dim x As Long

    If Len(ActivePresentation.Tags("Adjustments")) > 0 Then
        With ActiveWindow.Selection.ShapeRange(1)
            For x = 1 To CLng(ActivePresentation.Tags("Adjustments"))
                ActiveWindow.Selection.ShapeRange(1).Adjustments(x) = _
                CDbl(ActivePresentation.Tags("Adj" & CStr(x)))
            Next
        End With
    End If
End Sub