Вставьте диапазон из Excel в PowerPoint, сохраняя при этом форматирование - PullRequest
Новая
       17

Вставьте диапазон из Excel в PowerPoint, сохраняя при этом форматирование

0 голосов
/ 02 июля 2018

Я пытаюсь автоматизировать создание презентации PowerPoint из отчета Excel. Ранее я делал это вручную, и у меня не было проблем.

Когда я копирую диапазон из Excel, я вставляю его в PowerPoint и выбираю «Сохранить исходное форматирование» в настройках. Затем я изменил бы размер таблицы так, как я хочу, чтобы она отображалась на слайде, и при необходимости изменил бы размер шрифта.

Делая это в VBA, я не могу найти эквивалентный метод для вставки таблицы.

После настройки моей рабочей книги и PowerPoint и точного копирования диапазона я использую это для вставки таблицы. 

Slide2.Shapes.PasteSpecial ppPasteEnhancedMetafile

Я тоже пробовал 

Slide2.Shapes.PasteSpecial ppPasteOLEObject

Обе таблицы вставляются нормально, но как только я изменяю размер фигуры, текст искажается, и я не могу изменить размер текста, в отличие от того, когда я вставляю его вручную.

Какой метод я должен использовать, чтобы сохранить функциональность, которую я получил бы, делая это вручную? Мне не особенно нужна таблица, связанная с Excel, это может быть просто текстовая таблица в PowerPoint.

Любое руководство будет высоко ценится.

Для информации, я использую Office 2010.

Вот мой полный код .. 

'Define public variables
  'PowerPoint variables
  Public PPApp As PowerPoint.Application
  Public PPPres As PowerPoint.Presentation

  'Data variables
  Public YYYY   As String
  Public YYMM   As String
  Public MonYy7 As String
  Public Mth    As String
  Public Qtr    As String

  'Location variables
  Public rptPath As String

Public Function GetLayout(LayoutName As String, _
                          Optional ParentPresentation As Presentation = Nothing) As CustomLayout

 If ParentPresentation Is Nothing Then
  Set ParentPresentation = PPPres
 End If

 Dim oLayout As CustomLayout
 For Each oLayout In ParentPresentation.SlideMaster.CustomLayouts
  If oLayout.Name = LayoutName Then
   Set GetLayout = oLayout
   Exit For
  End If
 Next
End Function

Sub Dates()
 Dim MthEnd As Date
 MthEnd = DateSerial(Year(Date), Month(Date), 0)

 YYYY = Format(MthEnd, "YYYY")
 YYMM = Format(MthEnd, "YYMM")
 MonYy7 = Format(MthEnd, "MMMM YYYY")
 Mth = Format(MthEnd, "MMM")

 'Quarter
 Quarter = Round(Month(MthEnd) / 3, 0)
 If Quarter = 1 Then
  Qtr = "Q" & Quarter & " " & YYYY
 ElseIf Quarter = 2 Then
  Qtr = "H1 " & YYYY
 ElseIf Quarter = 3 Then
  Qtr = "Q" & Quarter & " " & YYYY
 End If
End Sub

Sub Produce_Pack()
 'Setup dates
 Call Dates

 'Setup reference to the ARA workbook
 Dim wb As Workbook
 Set wb = ThisWorkbook

 'Setup reference to worksheet range
 Dim rng As Range

 'Setup reference to the worksheet
 Dim ws As Worksheet
 Set ws = wb.Worksheets("Pack Source Tables")

 'Setup reference to PowerPoint shape
 Dim pShape As PowerPoint.Shape

 'Open PowerPoint
 Set PPApp = CreateObject("PowerPoint.Application")

 'Create a new presentation
 Set PPPres = PPApp.Presentations.Add
 Application.Wait (Now + TimeValue("0:00:05"))

 'Set presentation slide references
 Dim oSlides As Slides
 Dim oSlide As Slide

 Set oSlides = PPPres.Slides

 'Set slide dimensions
  'Conversion of CMs to Points is * 28.34646
  PPPres.PageSetup.SlideHeight = 21# * 28.34646
  PPPres.PageSetup.SlideWidth = 29.7 * 28.34646

 'Apply the Risk template
 PPPres.ApplyTemplate ("C:\Template.potx")

 'Text variable
 Dim txt As String

 'Slide 1
   'Create slide
   Dim Slide1 As PowerPoint.Slide
   Set Slide1 = PPPres.Slides.Add(1, ppLayoutCustom) 'Default front cover

   'Text 1
   If Mth = "Dec" Then
    txt = "Title 1" & YYYY
   Else
    txt = "Sub Title" & vbNewLine & Qtr
   End If

   Slide1.Shapes("Title 1").TextFrame.TextRange.Text = txt

   'Text 2
   txt = "Sub Title 2"

   Slide1.Shapes("Text Placeholder 2").TextFrame.TextRange.Text = txt

   'Text 3
   txt = MonYy7

   Slide1.Shapes("Text Placeholder 3").TextFrame.TextRange.Text = txt

 'Slide 2
   'Create slide
    Set oSlide = oSlides.AddSlide(oSlides.Count + 1, GetLayout("Slide Layout 5"))

    Dim Slide2 As PowerPoint.Slide
    Set Slide2 = oSlide

    Slide2.Shapes("Content Placeholder 1").Delete

    'Title text
    txt = "Annual Report & Accounts (ARA)"
    Slide2.Shapes("Title 1").TextFrame.TextRange.Text = txt

    'Copy tables from Excel
    Set rng = ws.Range("A:A")

    rng.ColumnWidth = 22.75

    Set rng = ws.Range("A4:C27")

    'Copy the table range
    Application.CutCopyMode = False
    rng.Copy
    Application.Wait (Now + TimeValue("0:00:02"))

    'Paste the table in to the slide
    Slide2.Shapes.PasteSpecial ppPasteOLEObject

    'Name the new shape object
    Set pShape = Slide2.Shapes(Slide2.Shapes.Count)
    pShape.Name = "Slide_2_Table_1"
    pShape.LockAspectRatio = False

    'Set the position and size of the new shape.
     'Conversion of CMs to Points is * 28.34646
     pShape.Left = 1.3 * 28.34646
     pShape.Top = 5.64 * 28.34646
     pShape.Height = 13.66 * 28.34646
     pShape.Width = 22.75 * 28.34646

End Sub

1 Ответ

0 голосов
/ 05 июля 2018

проблема заключается в том, что вы вставляете изображение как изображение, из-за которого проблемы растяжения, окраски или изменения размера шрифта невозможны.

Что вам нужно сделать, это вставить как обычную таблицу, а затем вы можете поиграть с форматом.

Ниже приведен код, извлеченный из вашего кода, который отлично работает, и вы можете вносить изменения в таблицу, вставленную в PowerPoint.

Вставьте код в Excel VBA разработчика.

В Excel введите некоторый контент, как показано на рисунке ниже

excel file content

затем обновите этот код в Excel VBA и выполните его 

    'Define public variables

  'Data variables
  Dim YYYY   As String
  Dim YYMM   As String
  Dim MonYy7 As String
  Dim Mth    As String
  Dim Qtr    As String

  'Location variables
  Dim rptPath As String

Sub Dates()
 Dim MthEnd As Date
 MthEnd = DateSerial(Year(Date), Month(Date), 0)

 YYYY = Format(MthEnd, "YYYY")
 YYMM = Format(MthEnd, "YYMM")
 MonYy7 = Format(MthEnd, "MMMM YYYY")
 Mth = Format(MthEnd, "MMM")

 'Quarter
 Quarter = Round(Month(MthEnd) / 3, 0)
 If Quarter = 1 Then
  Qtr = "Q" & Quarter & " " & YYYY
 ElseIf Quarter = 2 Then
  Qtr = "H1 " & YYYY
 ElseIf Quarter = 3 Then
  Qtr = "Q" & Quarter & " " & YYYY
 End If
End Sub

Sub Produce_Pack()

  Dim PPApp As PowerPoint.Application
  Dim PPPres As PowerPoint.Presentation


 'Setup dates
 Call Dates

 'Setup reference to the ARA workbook
 Dim wb As Workbook
 Set wb = ThisWorkbook

 'Setup reference to worksheet range
 Dim rng As Range

 'Setup reference to the worksheet
 Dim ws As Worksheet
 Set ws = wb.Worksheets("Sheet1")

 'Setup reference to PowerPoint shape
 Dim pShape As PowerPoint.Shape

 'Open PowerPoint
 Set PPApp = CreateObject("PowerPoint.Application")

 'Create a new presentation
 Set PPPres = PPApp.Presentations.Add
 'Application.Wait (Now + TimeValue("0:00:05"))

 'Set presentation slide references
 Dim oSlides As Slides
 Dim oSlide As Slide

 Set oSlides = PPPres.Slides

 'Set slide dimensions
  'Conversion of CMs to Points is * 28.34646
  'PPPres.PageSetup.SlideHeight = 21# * 28.34646
  'PPPres.PageSetup.SlideWidth = 29.7 * 28.34646

 'Apply the Risk template
 'PPPres.ApplyTemplate ("C:\Template.potx")

 'Text variable
 Dim txt As String

 'Slide 1
   'Create slide
   Dim Slide1 As PowerPoint.Slide
   Set Slide1 = PPPres.Slides.Add(1, pplayoutcustom) 'Default front cover

   'Text 1
   If Mth = "Dec" Then
    txt = "Title 1" & YYYY
   Else
    txt = "Sub Title" & vbNewLine & Qtr
   End If

   Slide1.Shapes("Title 1").TextFrame.TextRange.Text = txt


    'Copy tables from Excel
    Set rng = ws.Range("A:A")

    rng.ColumnWidth = 22.75

    Set rng = ws.Range("A1:C15")

    'Copy the table range
    Application.CutCopyMode = False
    rng.Copy
    'Application.Wait (Now + TimeValue("0:00:02"))

    'Paste the table in to the slide
    Slide1.Shapes.PasteSpecial ppPasteHTML, msoFalse  '<---- the actual change

    'Name the new shape object
    Set pShape = Slide1.Shapes(Slide1.Shapes.Count)
    pShape.Name = "Slide_1_Table_1"
    pShape.LockAspectRatio = False

    'Set the position and size of the new shape.
     'Conversion of CMs to Points is * 28.34646
     pShape.Left = 1.3 * 28.34646
     pShape.Top = 5.64 * 28.34646
     pShape.Height = 13.66 * 28.34646
     pShape.Width = 22.75 * 28.34646

End Sub

Указанная стрелка - единственное изменение, я сделал так, чтобы код работал быстрее и комментировал остальные

Отдыхайте, вы можете играть с кодом, и он будет работать.

Надеюсь, это ответ, который вы ищете

Приветствия

...