Задача переноса графиков, диаграмм, таблиц из 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 |
Продолжить чтение »
Задача: необходимость добавить к графику горизонтальную линию на уровне определенного значения одной из осей. Для решения этой задачи можно либо составить ряд одинаковых чисел и добавить соответствующий график на диаграмму, либо воспользоваться VBA:
Const Num = 0.8 'Значение уровня Dim objSeries As Series Dim arrValues() ActiveWorkbook.Sheets("Имя_листа").ChartObjects("Имя_диаграммы").Activate arrValues = ActiveChart.SeriesCollection(1).Values For i = LBound(arrValues) To UBound(arrValues) arrValues(i) = Num Next Set objSeries = ActiveChart.SeriesCollection.NewSeries objSeries.Values = arrValues objSeries.ChartType = xlLine |
Источник: Форум программистов
Продолжить чтение »
Пополняемый список полезных отрывков кода VBA для выполнения часто востребованных действий в MS Excel.
Служебные команды для ускорения скорости выполнения макроса:
'Отключение отображения выполняемых действий Application.ScreenUpdating = False 'Предотвращение появления предупреждающих сообщений Application.DisplayAlerts = False 'Предотвращение появления предупреждения об обновлении связей данных Application.AskToUpdateLinks = False 'Очистка буфера обмена Application.CutCopyMode = False |
Продолжить чтение »
Если после выполнения макроса необходимо отправить в качестве вложения получившийся документ Excel, можно использовать следующий код. Он создаёт письмо с нужным перечнем адресатов в полях «Кому» и «Копия», с указанной темой, текстом и прикреплённым Excel файлом. Остаётся толкьо дописать письмо в случае необходимости и нажать кнопку «Отправить».
Dim OutlookApp As Object, SM As Object Set OutlookApp = CreateObject("Outlook.Application") Set SM = OutlookApp.CreateItem(olMailItem) 'SM.SentOnBehalfOfName = "mail@example.ru" 'Поле "От", если нужен другой отправитель SM.To = "mail@example.ru" 'Поле "Кому" SM.CC = "mail@example.ru" 'Поле "Копия" SM.Subject = "Тема письма" On Error Resume Next SM.Body = "Текст письма" SM.Attachments.Add ("C:\Test.xls") 'Адрес вложения SM.Display Set SM = Nothing Set OutlookApp = Nothing |
Продолжить чтение »