MyTetra Share
Делитесь знаниями!
Экспорт диаграмм из Excel в Power Point с помощью VBA
16.03.2019
23:43
Текстовые метки: VBA Excel, VBA Power Point
Раздел: !Закладки - VBA - Excel

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

Задача переноса графиков, диаграмм, таблиц из 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


Если нужно создать презентацию не с нуля, а из заранее созданного шаблона, то вместо 2 и 3 строчек:


tmplPath = "C:\Template\"

tmplName = "Шаблон.pptx"

'Проверка существования файла tmplName

If Dir(tmplPath & tmplName) = "" Then

MsgBox "Файл не найден:" & Chr(13) & tmplPath & tmplName

Exit Sub

End If

Set pr = CreateObject("PowerPoint.Application")

Set mpr = pr.Presentations.Open(Filename:=tmplPath & tmplName)


Источники

Так же в этом разделе:
 
MyTetra Share v.0.52
Яндекс индекс цитирования