Экспорт диаграмм из Excel в Power Point с помощью VBA

16 февраля 2012, VBA, Konstantin

Задача переноса графиков, диаграмм, таблиц из Excel в презентацию PowerPoint осложняется тем, что в последних версиях редактора презентаций (2007, 2010) разработчики убрали возможность записи производимых действий в макрос. Поэтому, для настройки внешнего вида презентации под собственные условия, нужно перерыть документацию по VBA для PowerPoint, либо просмотреть множество специализированных форумов. Ниже приведен код примера создания презентации из диаграмм Excel.

Private Sub export_to_pp()
Set pr = CreateObject("PowerPoint.Application")
Set mpr = pr.Presentations.Add
'Определение имени создаваемой презентации
ppName = "Имя_для_презентации"
'Добавление пустого слайда
Set ppSlide = mpr.Slides.Add(mpr.Slides.Count, ppLayoutBlank)
'Цвет фона слайда
ppSlide.Master.Background.Fill.ForeColor.RGB = RGB(200, 200, 200)
'Добавление блока (Orientation, Left, Top, Width, Height)
'функция Application.CentimetersToPoints переводит сантиметры в пиксели
Set TextShape = ppSlide.Shapes.AddTextbox(1, _
   Application.CentimetersToPoints(1.09), _
   Application.CentimetersToPoints(1.2), _
   Application.CentimetersToPoints(22.86), _
   Application.CentimetersToPoints(1.2))
TextShape.TextFrame.TextRange.Text = "Текст надписи"
'Настройка параметров блока с текстом
TextShape.TextFrame.TextRange.Font.Name = "Calibri"
TextShape.TextFrame.TextRange.Font.Size = 18
TextShape.TextFrame.TextRange.Font.Bold = True
'Отключение автоматического подгона размера блока под текст
TextShape.TextFrame.AutoSize = 0
TextShape.Height = Application.CentimetersToPoints(1.2)
TextShape.TextFrame.TextRange.Font.Color = vbWhite
'Вертикальное выравнивание текста по центру
TextShape.TextFrame.VerticalAnchor = msoAnchorMiddle
'Копируем диаграмму в PowerPoint
ListName.ChartObjects("ChartName").Copy
Set chart1 = ppSlide.Shapes.PasteSpecial(ppPastePNG)
   chart1.Left = Application.CentimetersToPoints(1.52)
   chart1.Top = Application.CentimetersToPoints(3.65)
'Копируем таблицу как OLE object
ListName.Range("H51:M60").Copy
Set table1 = ppSlide.Shapes.PasteSpecial(ppPasteOLEObject)
   table1.Left = Application.CentimetersToPoints(1.52)
   table1.Top = Application.CentimetersToPoints(13.72)
'Копируем таблицу как рисунок
ListName.Range("H61:M70").Copy
Set table2 = ppSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile)
   table2.Left = Application.CentimetersToPoints(13.16)
   table2.Top = Application.CentimetersToPoints(13.72)
Application.CutCopyMode = False
'Сохраняем презентацию в папке с текущей книгой Excel
mpr.SaveAs (ThisWorkbook.Path + "\" + ppName)
mpr.Close
pr.Quit
End Sub

Продолжить чтение »

Теги: • • • • •
 
4 Комментарии
Комментировать

На Верх