Exvel VBA to Powerpoint slides

[mahmed1]

Hi ZVI,

I have created another thread as advised

To recap - I need to copy my ranges as picture or best quality and paste it into my PP Templat Pres

I have a PP Template which contains 2 sheets (Title sheet with a text box named TitleText) and Content Slide with a textbox named ContentText

I found some code online that does some of this but this creates a new powerpoint presentation and pastes it there. My condition is slightly diff where I need to 1st update the Titke slide text and then use the Content slide template to paste each slide in as the text and theme is pre-formatted

I then need to resize my image so it looks nice and not overlapping the slide

This is the code I found - I tried to add my bits of code attempt in there and have commented bits where I would need to change to suit me (I have left the original code that I found in there for ref)

Hopefully this will make more sense

This is the code

Sub CreatePowerPointPresentation()
Dim DasboardSh As Worksheet
Dim Weekdash As Worksheet
Dim CalcSh As Worksheet
Dim MyTitle As Range
Dim PPTitleTextRange As Range
Dim PPCopyRange As Range
Dim PowerPointApp As Object
Dim PPTemmplatePath As String
Dim TitleTextRow As Long
Dim CopyPictureRow As Long
Set DasboardSh = Worksheets("DAILY SUMMARY")
Set Weekdash = Worksheets("WEEK DASHBOARD")
Set CalcSh = Worksheets("CALCULATION")
Set MyTitle = CalcSh.Range("TITLETEXT")
Set PPTitleTextRange = CalcSh.Range("PPTITLE")
'Set PPCopyRange = CalcSh.Range("COPYRANGE")
'Create an Instance of PowerPoint
  On Error Resume Next
    
    'Is PowerPoint Template already opened?
      
      'This is where i need to open up my PP Template but is its open then set a ref to it
      'Set PowerPointApp = GetObject("PowerPoint.Application")
    
    'Clear the error between errors
      Err.Clear
    'If PowerPoint is not already open then open PowerPoint
      'This is where i need to open up my PP Template but is its open then set a ref to it
      'If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject("PowerPoint.Application")
    
    'Handle if the PowerPoint Application is not found
      If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
      End If
  On Error GoTo 0
'Make PowerPoint Template Visible and Active
  
  'PowerPointApp.Visible = True
  'PowerPointApp.Activate
  
'Create a New Presentation
  'Set myPresentation = PowerPointApp.Presentations.Add
'Create a copy of Slide 1 (Title Slide) to the end of the slide - i have renamed the text box to TitleText
  'Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
  
'Add the MyTitle.value to TitleText
   
'CopyRanges
For i = 2 To 11
    'SlideTitle = CalcSh.Range("U" & i)
    'Create copy of Content Slide (Slide) - i have named the text box ContextText
    'Add the text SlideTitle to ContextText
    
    'Set PPCopyRange = Weekdash.Range("V" & i)
    
    'Copy Excel Range
    'PPCopyRange.Copy
    
    'I need to Paste to this content slide and resize and position
    
    'Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
    'Set myShapeRange = mySlide.Shapes(mySlide.Shapes.Count)
    
    'mySlide.Shapes.PasteSpecial DataType:=2
    
Next i
  
 
End Sub

 

[ZVI]

Hi Mahmed,

Glad it was exactly what you asked for!

As to your questions:

1. The presentation opens in Fit to window zoom mode which has sense and or course depends on monitor.
When you run the presentation it'll be in full screen mode.

2. Here is the code in PowerPoint to show location and sizes of the selected shapes:

' Put this macro into PowerPoint code module
Sub SelectedWindow()
  On Error GoTo exit_
  With ActiveWindow.Selection.ShapeRange(1)
    MsgBox "Top = " & .Top & vbLf _
         & "Left = " & .Left & vbLf _
         & "Height = " & .Height & vbLf _
         & "Width  = " & .Width   End With
exit_:
  If Err Then MsgBox "Select the shape!"
End Sub

To check existence of the presentation file in the folder use Dir function – see If Len(Dir(f)) = 0 Then in my code.

3. How to attach workbook was shown in the thread VBA code to convert excel to pdf and email it as attachment.

The full Excel VBA coding for automation Outlook and PowerPoint has been provided according to your requests.
Hope you understand that helping on spare time will not become the personal supporting with permanent changing of the nuances
So, please adjust the provided working suggestions by minor remains on you own taste. And of course be with forum.

I wish you Good Luck!

 

[mahmed1]

Hi ZVI, i do appreciate all your help - you have been awesome

Once I resize each shape/picture correctly and position each 1 to to where it should be, how shall I implement this in code?
do i need to create another colum next to the Named range column which holds that information? Not sure the best way to do it..

In regards to pasting the range in the body of the outlook email, i couldnt find it in the Outlook thread.

 

[mahmed1]

Hi ZVI,

I tested your code n it works beautifully with transferring to powerpoint

I Used the above code to get exact locarion and height/width of the picture for each slide pic

I put the top - left - height - width for each picture next to the cell that contains the named range ..

whats ths best way way to implement this so when it copies to PowerPoint- it positions and resizes accordingly?

Appreciate all your help -- In regards to copying a named range (1st named range) into the body of outlook, thats bot on the other thread..Is there any chance you could help me with that also please..

really do appreciate your help - you have been so helpful and i cant thank you enough

 

[ZVI]

I Used the above code to get exact locarion and height/width of the picture for each slide pic
I put the top - left - height - width for each picture next to the cell that contains the named range ..
whats ths best way way to implement this so when it copies to PowerPoint- it positions and resizes accordingly?

The below are updated lines of the code for that:

  ' ...
 
  ' Prepare Slides
   a() = Range(Data).Resize(, 6).Value
   
  ' ...
 
      With .Item(i + 1).Shapes.PasteSpecial(DataType:=2)
        .LockAspectRatio = msoFalse
        .Top = a(i, 3)    ' t
        .Left = a(i, 4)   ' 0
        .Width = a(i, 5)  ' w
        .Height = a(i, 6) ' h - t
      End With
  ' ...

In regards to copying a named range (1st named range) into the body of outlook, thats bot on the other thread..Is there any chance you could help me with that also please..

Has no experience with it, thus nothing to share.

 

[mahmed1]

Thank You so so so much

You have been so awesome and i hope you get rewarded for all your help towards everyone


Im really happy with all your help..


Ive been asked to make a slight alteration..


I have been asked to create a comment slide template and and another template slide with a different background


So in total on this template slide, i will have 4 default slides


Title Slide
Template slide 1 (Which has blue background)
Template slide 2 (Which has Green background)
Comment Slide


In my named ranged cells next to the cell which has the width a(i,6) so cell 7 - i have the word blue or green


Is it possible to duplicate the blue slide (2) or Green slide (3) depending on which slide i need to create and then at the end of the slide - move the Comment slide?


So the presentation should look something like this


Title Slide Temp
Blue slide Temp
Blue slide Temp
Blue slide Temp
Green slide Temp
Green slide Temp
Comment Slide


If thats going to be harder to implement can i just move the comment slide to the end of the presentation?


Would be awesome if i could have a certain slide background for the sections i want


Thank you ZVI

 

[mahmed1]

HI ZVI

I managed to be able to move the comment slide to the end of my presentation..

I wanted to not show PowerPoint when i was updating the presentation..

I commented out the visibilty and the activate part of the code but it still shows PowerPoint updating the slides..

I also added the screenupdating to false but that dont change me watching the presentation updating the slides..

 

[ZVI]

There is no ScreenUpdating property in PowerPoint application.
To prevent blinking add this line of code below the On Error GoTo 0:
objPowerPoint.WindowState = 2

 

[mahmed1]

Hi ZVI,

Thank you

I tried adding this line of code but it didn't work for some reason. I also get an issue some times on the Lock ratio part giving an error something to do with Remote Server (That's occasionally though)

Here is the slightly amended full code

I just need a couple of things

1) I don't want to see the updates happening in Powerpoint and 2) I want to 1st check to see that if the file name I am going to be saving with already exists, if it does then no need to generate the report

Don't know wht I get that remove server message now and again (I trued adding DoEvents and activating the powerpoint but couldn't get around the occasional glitch

Sub ExcelToPP()
 
  '--> Setttings, change to suit
  Const Title1 = "TITLETEXT"                ' Range for Title of the 1st slide
  Const Data = "PPTITLES"                   ' Range for Titles with Addresses/Names on the next column
  Const Template = "COMPANY DASHBOARD.pptx" ' Template of Presentation with two Slides
  Const TemplatePath = ""                   ' Path or an empty string if Tempalete is in the folder of workbook
  '<-- End of Settings
 
  Dim objPowerPoint As Object, objPresentation As Object
  Dim i As Long
  Dim f As String
  Dim pth As String
  Dim a(), v, w, h, t
 
  Application.ScreenUpdating = False
  
  ' Determine PathName to the template of the presentation
  
 
  If Len(TemplatePath) > 0 Then
    f = TemplatePath
    If LCase(Left(f, 8)) = "desktop\" Then
      f = Environ("USERPROFILE") & Mid(f, 8)
    End If
  Else
    f = ActiveWorkbook.Path
  End If
  If Right(f, 1) <> "\" Then f = f & "\"
  f = f & Template
  ' Check it presense
  If Len(Dir(f)) = 0 Then
    MsgBox "Template Presentation not found:" & vbLf & f, vbExclamation, "Exit"
    Exit Sub
  End If
 
  ' Find/Create PowerPoint instance of Application
  On Error Resume Next
  Set objPowerPoint = GetObject(, "PowerPoint.Application")
  If Err Then
    Set objPowerPoint = CreateObject("PowerPoint.Application")
    objPowerPoint.Visible = True
  End If
  On Error GoTo 0
  'objPresentation.WindowState = 2
   
  ' Open template of the presentation
  Set objPresentation = objPowerPoint.Presentations.Open(f)
  With objPresentation.PageSetup
    h = .SlideHeight
    w = .SlideWidth
  End With
 
  ' Prepare Slides
  a() = Range(Data).Resize(, 6).Value
 
  ' Prepare Slide #1
  With objPresentation.Slides(1).Shapes(2)
    ' Title for Slide #1 is in the 1st cell of Range(Ref)
    .TextFrame.TextRange.Text = Range(Title1).Value
    t = .Top + .Height
  End With
 
  ' Copy slide #2
  With objPresentation.Slides(2)
    For i = 2 To UBound(a)
      .Duplicate
    Next
  End With
 
  ' Put content to the slides
  DoEvents
  
  objPowerPoint.Activate
  With objPresentation.Slides
    For i = 1 To UBound(a)
      .Item(i + 1).Shapes(2).TextFrame.TextRange.Text = a(i, 1)
      Range(a(i, 2)).Copy
      With .Item(i + 1).Shapes.PasteSpecial(DataType:=2)
        .LockAspectRatio = msoFalse
        .Top = a(i, 3)    ' t
        .Left = a(i, 4)   ' 0
        .Height = a(i, 5) ' h - t
        .Width = a(i, 6)  ' w
      End With
      Application.CutCopyMode = False
    Next
  End With
 
 
  ' Activate PP
  objPowerPoint.Activate
 
 'Update Comment Header
 
 For i = 1 To 4
    objPresentation.Slides(objPresentation.Slides.Count).Shapes(i).Table.Cell(1, 1).Shape.TextFrame.TextRange.Text = Worksheets("CALCULATION").Range("AB" & i + 2).Value
 Next i
 
 
  ' Save it
  pth = Left(f, InStrRev(f, "\"))
  objPresentation.SaveAs pth & "\" & Worksheets("CALCULATION").Range("P2").Value & ".pptx"
   
  objPresentation.Close
  objPowerPoint.Quit
  
  
  ' Empty memory of object variables
  Set objPresentation = Nothing
  Set objPowerPoint = Nothing
   
  Application.Goto Worksheets("DAILY SUMMARY").Range("A1"), True
    
  Application.ScreenUpdating = True
   
End Sub

 

[mahmed1]

Looking at google in regards to the server issue, it appears that i probably have something unqualified to do with excel or PowerPoint but i cant see what

i sometimes get an error also in the item copy part when i select PowerPoint presentation manually and continue to run the code, it works

all this happens occasionally which is weird

 

[ZVI]

Here is ready to use version of the code which creates presentation invisibly.
Three slides have to be in the template presentation:
1. Slide#1 - The Title slide with a title shape
2. Slide#2 - Template for slides #2...#15 with a title shape
3. Slide#3 - The Resume (comments) slide with one-cell table in each of 4 shapes

Option Explicit
 
Sub ExcelToPP()
' ZVI:2016-09-30 http://www.mrexcel.com/forum/excel-questions/966393-exvel-visual-basic-applications-powerpoint-slides.html#post4646266
 
  '--> Settings, change to suit
  Const cTitle1 = "TITLETEXT"                  ' Range with text for Title in the 1st slide
  Const cData = "PPTITLES"                     ' Range with slides info: Title | Top | Left | Width | Height
  Const cTemplate = "COMPANY DASHBOARD.pptx"   ' Filename of Template of Presentation
  Const cTemplatePath = ""                     ' Path or an empty string if Template is in the folder of workbook
  Const cFileNameAddr = "Calculation!P2"       ' Address of cell with value of the output presentation filename
  Const cCommentsAddr = "Calculation!AB3:AB6"  ' Address of the range with comments for the last slide
  Const cShapeForText = 1                      ' Shape number in slides for text updating. May be 2 ?
  '<-- End of Settings
 
  Dim objPowerPoint As Object, objPresentation As Object
  Dim i As Long
  Dim p As String, f1 As String, f2 As String
  Dim a(), v, w, h, t
  Dim IsCreated As Boolean
 
  ' Determine path to the template and output presentation
  If Len(cTemplatePath) > 0 Then
    p = cTemplatePath
    If LCase(Left(p, 8)) = "desktop\" Then
      p = Environ("USERPROFILE") & Mid(p, 8)
    End If
  Else
    p = ActiveWorkbook.Path
  End If
  If Right(p, 1) <> "\" Then p = p & "\"
 
  ' Check if output presentation is already present
  f1 = p & Range(cFileNameAddr) & ".pptx"
  If Len(Dir(f1)) Then
    If MsgBox("Presentation is already present:" & vbLf _
           & f1 & vbLf & vbLf & "Would you like to update it?", _
           vbQuestion + vbOKCancel + vbDefaultButton2, _
           "Update or exit") <> vbOK Then Exit Sub
  End If
 
  ' Check presence of the template
  f2 = p & cTemplate
  If Len(Dir(f2)) = 0 Then
    MsgBox "Template of Presentation not found:" & vbLf & f2, vbExclamation, "Exit"
    Exit Sub
  End If
 
  ' Trap errors
  On Error GoTo exit_
 
  ' Disable screen updating of Excel
  Application.ScreenUpdating = False
 
  ' Open invisibly the template of presentation
  Set objPresentation = GetObject(f2)
  Set objPowerPoint = objPresentation.Application
  With objPresentation.PageSetup
    h = .SlideHeight
    w = .SlideWidth
  End With
 
  ' Copy settings of slides to the array a()
  a() = Range(cData).Resize(, 6).Value
 
  ' Prepare Slide #1
  With objPresentation.Slides(1).Shapes(cShapeForText)
    .TextFrame.TextRange.Text = Range(cTitle1).Value
    t = .Top + .Height
  End With
 
  ' Copy slides #2...#15
  With objPresentation.Slides(2)
    For i = 2 To UBound(a)
      .Duplicate
    Next
  End With
 
  ' Put content to the slides
  With objPresentation.Slides
    For i = 1 To UBound(a)
      .Item(i + 1).Shapes(cShapeForText).TextFrame.TextRange.Text = a(i, 1)
      Range(a(i, 2)).Copy
      With .Item(i + 1).Shapes.PasteSpecial(DataType:=2)
        .LockAspectRatio = msoFalse
        .Top = a(i, 3)    ' t
        .Left = a(i, 4)   ' 0
        .Width = a(i, 5)  ' w
        .Height = a(i, 6) ' h - t
      End With
      Application.CutCopyMode = False
    Next
  End With
 
  ' Update comments in tables of 4 shapes in the last slide
  a() = Range(cCommentsAddr).Value
  With objPresentation
    For i = 1 To UBound(a)
      .Slides(.Slides.Count).Shapes(i).Table.Cell(1, 1).Shape.TextFrame.TextRange.Text = a(i, 1)
    Next
  End With
 
  ' Save presentation
  objPresentation.SaveAs f1
 
  ' Close Presentation
  objPresentation.Close
 
  ' Close PP in case it was created via this code
  If Not objPowerPoint.Visible Then objPowerPoint.Quit
 
  ' Empty memory of object variables
  Set objPresentation = Nothing
  Set objPowerPoint = Nothing
 
  ' Select the 1st cell in sheet DAILY_SUMMARY
  With Worksheets("DAILY SUMMARY")
    .Select
    Range("A1").Select
  End With
 
exit_:
 
  ' Restore Excel screen updating
  Application.ScreenUpdating = True
 
  ' Show status
  If Err Then
    MsgBox Err.Description, vbCritical, "Error"
    If Not objPowerPoint Is Nothing Then objPowerPoint.Visible = True
  Else
    MsgBox "The Presentation is saved successfully here:" & vbLf & f1, vbInformation, "Well done!"
  End If
 
End Sub