Программно копировать фигуры с исходным форматированием (PowerPoint 2007) - PullRequest
Новая
       47

Программно копировать фигуры с исходным форматированием (PowerPoint 2007)

1 голос
/ 08 ноября 2010

Мне нужно иметь возможность программно копировать фигуры (диаграммы, таблицы и т. Д.) С одного слайда на другой в PowerPoint 2007, сохраняя их исходные цвета. Исходные и конечные слайды представлены в разных презентациях с разными темами.

Эти фигуры могут быть сложными и включать много цветов, например, диаграммы, таблицы и т. Д. Целевой слайд должен сохранять свою тему, поэтому я не могу просто скопировать весь исходный слайд colorScheme.

При копировании фигуры вручную в PowerPoint, я получаю опцию «Сохранить исходное форматирование». Это копирует все исходные цвета фигуры, преобразуя цвета темы в абсолютные значения RGB.

Какой самый простой способ сделать это программно?

1 Ответ

0 голосов
/ 30 сентября 2016

Вам нужно перейти на слайд и использовать Application.CommandBars.ExecuteMso

Если вам не нужно впоследствии возвращаться к ранее выбранному слайду, вы можете пропустить DoEvents и второй вызов Application.CommandBars..ExecuteMso

Казалось, что положение новой фигуры иногда немного искажается после вставки, поэтому я получаю ссылку на последнюю фигуру в коллекции Shapes второго слайда и копирую позицию оригинала.shape.

По крайней мере, на моем компьютере, без DoEvents, макрос ничего не будет делать, когда я его выполню (но он будет работать, если я его пройду). 

Sub CopySelectedShapeToNextSlide()
    Dim oShape As Shape
    Dim oSlide As Slide
    Dim nextSlide As Slide
    Dim newShape As Shape

    Set oShape = Application.ActiveWindow.Selection.ShapeRange(1)
    Set oSlide = Application.ActiveWindow.Selection.SlideRange(1)
    Set nextSlide = oSlide.Parent.Slides(oSlide.SlideIndex + 1)

    oShape.Copy

    Application.ActiveWindow.View.GotoSlide nextSlide.SlideIndex

    Application.CommandBars.ExecuteMso "PasteSourceFormatting"
    Set newShape = nextSlide.Shapes(nextSlide.Shapes.Count)
    newShape.Left = oShape.Left
    newShape.Top = oShape.Top

    DoEvents

    Application.ActiveWindow.View.GotoSlide oSlide.SlideIndex

    Debug.Print newShape.Name

End Sub
...