• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Create PPT from Excel - Version compatibility issues.

P

Pavan.Sada.PS

Member
Dear Friends,

Below is the code which updates data form the excel 2007 file to the chosen sample ppt file. One of my colleague have created this code and he is not there in the organization. this code will work fine if we use MS office 2007. However if we use this code in 2010 MS office it is not working. Any help in amending the code would really be helpful to me in completing my project.

Code: 
Sub PPT_Create()
On Error GoTo X
File_Name = ThisWorkbook.FullName
New_PPT = MsgBox("Do you want to create a new PPT?", vbYesNo)
If New_PPT = 6 Then
            S_Count = 1
            Set New_PowerPoint = Nothing
           
            If New_PowerPoint Is Nothing Then
            Set New_PowerPoint = CreateObject("PowerPoint.Application")
           
            New_PowerPoint.Visible = True
           
            ActiveWindow.Visible = True
            ActiveWindow.Activate
            ActiveWorkbook.Activate
            New_PowerPoint.WindowState = 2
            File_Name = Application.GetOpenFilename("Microsoft PowerPoint-Files (*.ppt), *.ppt")
            If File_Name = "False" Then End
            New_PowerPoint.Presentations.Open Filename:=File_Name
         
             
             
              While New_PowerPoint.ActivePresentation.Slides.Count > 0
                New_PowerPoint.ActivePresentation.Slides(S_Count).Delete
              Wend
           
            End If
            AppActivate New_PowerPoint.Name
           
           
            New_PowerPoint.ActivePresentation.Slides.Add New_PowerPoint.ActivePresentation.Slides.Count + 1, 12
            New_PowerPoint.ActiveWindow.View.GotoSlide New_PowerPoint.ActivePresentation.Slides.Count
            Set Active_Slide = New_PowerPoint.ActivePresentation.Slides(New_PowerPoint.ActivePresentation.Slides.Count)
           
            ActiveWorkbook.ActiveSheet.Range("C3:I6").Select
            Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
            Active_Slide.Shapes.Paste.Select
           
            Active_Slide.Shapes(Active_Slide.Shapes.Count).LockAspectRatio = False
            Active_Slide.Shapes(Active_Slide.Shapes.Count).Width = 650
            Active_Slide.Shapes(Active_Slide.Shapes.Count).Left = 28
            Active_Slide.Shapes(Active_Slide.Shapes.Count).Top = 50
           
           
           
            ActiveWorkbook.ActiveSheet.Range("B" & ActiveWorkbook.Names("Solid_First_Row").RefersToRange - 4 & ":M" & ActiveWorkbook.Names("Stretch_Last_Row").RefersToRange + 1).Select
            Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
            Active_Slide.Shapes.Paste.Select
           
            Active_Slide.Shapes(Active_Slide.Shapes.Count).LockAspectRatio = False
           
            Active_Slide.Shapes(Active_Slide.Shapes.Count).Left = 28
            Active_Slide.Shapes(Active_Slide.Shapes.Count).Top = 120
           
           
            Active_Slide.Shapes(Active_Slide.Shapes.Count).Height = 380
            Active_Slide.Shapes(Active_Slide.Shapes.Count).Width = 650
            Application.CutCopyMode = False
            ActiveWorkbook.Activate
            New_PowerPoint.WindowState = 2
           

Else
            S_Count = 1
           
            If New_PowerPoint Is Nothing Then End
           
           
           
            New_PowerPoint.ActiveWindow.View.GotoSlide New_PowerPoint.ActivePresentation.Slides.Count
            New_PowerPoint.ActivePresentation.Slides.Add New_PowerPoint.ActivePresentation.Slides.Count + 1, 12
            New_PowerPoint.ActiveWindow.View.GotoSlide New_PowerPoint.ActivePresentation.Slides.Count
            Set Active_Slide = New_PowerPoint.ActivePresentation.Slides(New_PowerPoint.ActivePresentation.Slides.Count)
           
            ActiveWorkbook.ActiveSheet.Range("C3:I6").Select
            Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
            Active_Slide.Shapes.Paste.Select
           
            Active_Slide.Shapes(Active_Slide.Shapes.Count).LockAspectRatio = False
            Active_Slide.Shapes(Active_Slide.Shapes.Count).Width = 650
            Active_Slide.Shapes(Active_Slide.Shapes.Count).Left = 28
            Active_Slide.Shapes(Active_Slide.Shapes.Count).Top = 50
           
           
            ActiveWorkbook.ActiveSheet.Range("B" & ActiveWorkbook.Names("Solid_First_Row").RefersToRange - 4 & ":M" & ActiveWorkbook.Names("Stretch_Last_Row").RefersToRange + 1).Select
            Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
            Active_Slide.Shapes.Paste.Select
            Active_Slide.Shapes(Active_Slide.Shapes.Count).LockAspectRatio = False
           
            Active_Slide.Shapes(Active_Slide.Shapes.Count).Left = 28
            Active_Slide.Shapes(Active_Slide.Shapes.Count).Top = 120
           
           
            Active_Slide.Shapes(Active_Slide.Shapes.Count).Height = 380
            Active_Slide.Shapes(Active_Slide.Shapes.Count).Width = 650
            Application.CutCopyMode = False
           

End If

X:
ActiveSheet.Range("$A$1").Select
End Sub

I am not able to update the said excel file and ppt file due to its confidentiality. But let me know if u need the file I will remove confidential info from that file and upload it.
 
try below code:

Code: 
Sub PPT_Create()
On Error GoTo X
File_Name = ThisWorkbook.FullName
New_PPT = MsgBox("Do you want to create a new PPT?", vbYesNo)
If New_PPT = 6 Then
            S_Count = 1
            Set New_PowerPoint = Nothing
         
            If New_PowerPoint Is Nothing Then
            Set New_PowerPoint = CreateObject("PowerPoint.Application")
         
            New_PowerPoint.Visible = True
         
            ActiveWindow.Visible = True
            ActiveWindow.Activate
            ActiveWorkbook.Activate
            New_PowerPoint.WindowState = 2
            File_Name = Application.GetOpenFilename("Microsoft PowerPoint-Files (*.ppt*), *.ppt*")
            If File_Name = "False" Then End
            New_PowerPoint.Presentations.Open Filename:=File_Name
       
           
           
              While New_PowerPoint.ActivePresentation.Slides.Count > 0
                New_PowerPoint.ActivePresentation.Slides(S_Count).Delete
              Wend
         
            End If
            AppActivate New_PowerPoint.Name
         
         
            New_PowerPoint.ActivePresentation.Slides.Add New_PowerPoint.ActivePresentation.Slides.Count + 1, 12
            New_PowerPoint.ActiveWindow.View.GotoSlide New_PowerPoint.ActivePresentation.Slides.Count
            Set Active_Slide = New_PowerPoint.ActivePresentation.Slides(New_PowerPoint.ActivePresentation.Slides.Count)
         
            ActiveWorkbook.ActiveSheet.Range("C3:I6").Select
            Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
            Active_Slide.Shapes.Paste.Select
         
            Active_Slide.Shapes(Active_Slide.Shapes.Count).LockAspectRatio = False
            Active_Slide.Shapes(Active_Slide.Shapes.Count).Width = 650
            Active_Slide.Shapes(Active_Slide.Shapes.Count).Left = 28
            Active_Slide.Shapes(Active_Slide.Shapes.Count).Top = 50
         
         
         
            ActiveWorkbook.ActiveSheet.Range("B" & ActiveWorkbook.Names("Solid_First_Row").RefersToRange - 4 & ":M" & ActiveWorkbook.Names("Stretch_Last_Row").RefersToRange + 1).Select
            Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
            Active_Slide.Shapes.Paste.Select
         
            Active_Slide.Shapes(Active_Slide.Shapes.Count).LockAspectRatio = False
         
            Active_Slide.Shapes(Active_Slide.Shapes.Count).Left = 28
            Active_Slide.Shapes(Active_Slide.Shapes.Count).Top = 120
         
         
            Active_Slide.Shapes(Active_Slide.Shapes.Count).Height = 380
            Active_Slide.Shapes(Active_Slide.Shapes.Count).Width = 650
            Application.CutCopyMode = False
            ActiveWorkbook.Activate
            New_PowerPoint.WindowState = 2
         

Else
            S_Count = 1
         
            If New_PowerPoint Is Nothing Then End
         
         
         
            New_PowerPoint.ActiveWindow.View.GotoSlide New_PowerPoint.ActivePresentation.Slides.Count
            New_PowerPoint.ActivePresentation.Slides.Add New_PowerPoint.ActivePresentation.Slides.Count + 1, 12
            New_PowerPoint.ActiveWindow.View.GotoSlide New_PowerPoint.ActivePresentation.Slides.Count
            Set Active_Slide = New_PowerPoint.ActivePresentation.Slides(New_PowerPoint.ActivePresentation.Slides.Count)
         
            ActiveWorkbook.ActiveSheet.Range("C3:I6").Select
            Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
            Active_Slide.Shapes.Paste.Select
         
            Active_Slide.Shapes(Active_Slide.Shapes.Count).LockAspectRatio = False
            Active_Slide.Shapes(Active_Slide.Shapes.Count).Width = 650
            Active_Slide.Shapes(Active_Slide.Shapes.Count).Left = 28
            Active_Slide.Shapes(Active_Slide.Shapes.Count).Top = 50
         
         
            ActiveWorkbook.ActiveSheet.Range("B" & ActiveWorkbook.Names("Solid_First_Row").RefersToRange - 4 & ":M" & ActiveWorkbook.Names("Stretch_Last_Row").RefersToRange + 1).Select
            Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
            Active_Slide.Shapes.Paste.Select
            Active_Slide.Shapes(Active_Slide.Shapes.Count).LockAspectRatio = False
         
            Active_Slide.Shapes(Active_Slide.Shapes.Count).Left = 28
            Active_Slide.Shapes(Active_Slide.Shapes.Count).Top = 120
         
         
            Active_Slide.Shapes(Active_Slide.Shapes.Count).Height = 380
            Active_Slide.Shapes(Active_Slide.Shapes.Count).Width = 650
            Application.CutCopyMode = False
         

End If

X:
ActiveSheet.Range("$A$1").Select
End Sub
 
Hello Mr.Karr,

I get the error message Runtime error 5 when I execute the line
AppActivate New_PowerPoint.Name

and object required error when I execute the line Active_Slide.Shapes.Paste.Select
 
This is almost there (I will come back to it in a couple of hours):

Code: 
Option Explicit

' Code mofidied by GMARK Ltd. http://www.youpresent.biz
' Date : 06 November 2014
' Author : Jamie Garroch

Sub PPT_Create()
Dim Filename As String
Dim response As VbMsgBoxResult
Dim appPPT As Object
Dim oSld As Object

On Error GoTo errorhandler
Filename = ThisWorkbook.FullName
response = MsgBox("Do you want to create a new PPT?", vbYesNo)
If response = vbYes Then
  Set appPPT = Nothing
  If appPPT Is Nothing Then
    Set appPPT = CreateObject("PowerPoint.Application")
   
    appPPT.Visible = True
   
    ActiveWindow.Visible = True
    ActiveWindow.Activate
    ActiveWorkbook.Activate
    appPPT.WindowState = 2
    Filename = Application.GetOpenFilename("Microsoft PowerPoint-Files (*.ppt*), *.ppt*")
    If Filename = "False" Then End
    appPPT.Presentations.Open Filename:=Filename
   
    ' Delete all slides from the presentation
    While appPPT.ActivePresentation.Slides.Count > 0
      appPPT.ActivePresentation.Slides(1).Delete
    Wend
  End If
  AppActivate appPPT.ActivePresentation.Name
  ' Create a new slide at the end of the target presentation
  appPPT.ActivePresentation.Slides.Add appPPT.ActivePresentation.Slides.Count + 1, 12
  ' Go to the new slide
  appPPT.ActiveWindow.View.GotoSlide appPPT.ActivePresentation.Slides.Count
  ' Set a reference to the new slide
  Set oSld = appPPT.ActivePresentation.Slides(appPPT.ActivePresentation.Slides.Count)
  ' Select the range in the Excel sheet
  ActiveWorkbook.ActiveSheet.Range("C3:I6").Select
  ' Copy the selected range
  Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
  appPPT.Activate
  ' Paste the range to the target presentation's slide
  oSld.Shapes.Paste.Select
  With oSld.Shapes(oSld.Shapes.Count)
    .LockAspectRatio = False
    .Width = 650
    .Left = 28
    .Top = 50
  End With
  ActiveWorkbook.ActiveSheet.Range("B" & ActiveWorkbook.Names("Solid_First_Row").RefersToRange - 4 & ":M" & ActiveWorkbook.Names("Stretch_Last_Row").RefersToRange + 1).Select
  Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
  oSld.Shapes.Paste.Select
  With oSld.Shapes(oSld.Shapes.Count)
    .LockAspectRatio = False
    .Left = 28
    .Top = 120
    .Height = 380
    .Width = 650
  End With
  Application.CutCopyMode = False
  ActiveWorkbook.Activate
  appPPT.WindowState = 2
Else
  ' If an instance of PowerPoint doesn't exist, exit the macro
  If appPPT Is Nothing Then Exit Sub
  appPPT.ActiveWindow.View.GotoSlide appPPT.ActivePresentation.Slides.Count
  appPPT.ActivePresentation.Slides.Add appPPT.ActivePresentation.Slides.Count + 1, 12
  appPPT.ActiveWindow.View.GotoSlide appPPT.ActivePresentation.Slides.Count
  Set oSld = appPPT.ActivePresentation.Slides(appPPT.ActivePresentation.Slides.Count)
  ActiveWorkbook.ActiveSheet.Range("C3:I6").Select
  Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
  oSld.Shapes.Paste.Select
  oSld.Shapes(oSld.Shapes.Count).LockAspectRatio = False
  oSld.Shapes(oSld.Shapes.Count).Width = 650
  oSld.Shapes(oSld.Shapes.Count).Left = 28
  oSld.Shapes(oSld.Shapes.Count).Top = 50
  ActiveWorkbook.ActiveSheet.Range("B" & ActiveWorkbook.Names("Solid_First_Row").RefersToRange - 4 & ":M" & ActiveWorkbook.Names("Stretch_Last_Row").RefersToRange + 1).Select
  Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
  oSld.Shapes.Paste.Select
  oSld.Shapes(oSld.Shapes.Count).LockAspectRatio = False
  oSld.Shapes(oSld.Shapes.Count).Left = 28
  oSld.Shapes(oSld.Shapes.Count).Top = 120
  oSld.Shapes(oSld.Shapes.Count).Height = 380
  oSld.Shapes(oSld.Shapes.Count).Width = 650
  Application.CutCopyMode = False
End If

errorhandler:
  ActiveSheet.Range("$A$1").Select
End Sub
 
Hi Pavan.

I've made a lot of changes to the code as follows:

1. Added Option Explicit
2. Declared all variables
3. Renamed key variables to make code reading/understanding easier
4. Removed the variable S_Count as it was obsolete (never set to anything other than 1)
5. Corrected the AppActivate line (it was trying to activate a window with a title equal to the app and not the presentation!)
6. Added lines to activate the PowerPoint instance before pasting the Excel content
7. Replaced numeric values with Office constants (e.g. vbYes for the initial question, assigned to the variable response)
8. Changed End to Exit Sub (as End is pretty abrupt and can cause Office to spew out unnecessary warnings to the user)
9. Added comments to indicate what the code is doing

This leaves two questions:

1. The opening question asks "Do you want to create a new PPT?" but if the users clicks the Yes button, the code asks for an existing presentation to be opened in the files system. Either the question or the action is wrong.
2. If the user selects No, then the second half of the code never gets run because there is no instance of PowerPoint set to the object variable appPPT!

So the code should run but I'm not sure it's doing what you expect without seeing an example spreadsheet with confidential dummy data. I tested it on a sheet with random data in the range C3:I6 and it copied the data to a test presentation I created (which first has all of its slides deleted which seems an odd thing to do).

With my test, it currently errors on the line with Solid_First_Row and Stretch_Last_Row because I don't know how those are defined in your sheet and hence aren't present in mine.

Code: 
Option Explicit

' Code mofidied by GMARK Ltd. http://www.youpresent.biz
' Date : 06 November 2014
' Author : Jamie Garroch

Sub PPT_Create()
Dim Filename As String
Dim response As VbMsgBoxResult
Dim appPPT As Object
Dim oSld As Object

On Error GoTo errorhandler
Filename = ThisWorkbook.FullName
response = MsgBox("Do you want to create a new PPT?", vbYesNo)
If response = vbYes Then
  Set appPPT = Nothing
  If appPPT Is Nothing Then
    Set appPPT = CreateObject("PowerPoint.Application")
   
    appPPT.Visible = True
   
    ActiveWindow.Visible = True
    ActiveWindow.Activate
    ActiveWorkbook.Activate
    appPPT.WindowState = 2
    Filename = Application.GetOpenFilename("Microsoft PowerPoint-Files (*.ppt*), *.ppt*")
    If Filename = "False" Then End
    appPPT.Presentations.Open Filename:=Filename
   
    ' Delete all slides from the presentation
    While appPPT.ActivePresentation.Slides.Count > 0
      appPPT.ActivePresentation.Slides(1).Delete
    Wend
  End If
  '
  AppActivate appPPT.ActivePresentation.Name
  ' Create a new slide at the end of the target presentation
  appPPT.ActivePresentation.Slides.Add appPPT.ActivePresentation.Slides.Count + 1, 12
  ' Go to the new slide
  appPPT.ActiveWindow.View.GotoSlide appPPT.ActivePresentation.Slides.Count
  ' Set a reference to the new slide
  Set oSld = appPPT.ActivePresentation.Slides(appPPT.ActivePresentation.Slides.Count)
  ' Select the range in the Excel sheet
  ActiveWorkbook.ActiveSheet.Range("C3:I6").Select
  ' Copy the selected range as a bitmap image
  Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
  ' Activate the PowerPoint app
  appPPT.Activate
  ' Paste the range to the target presentation's slide
  oSld.Shapes.Paste.Select
  ' Move and resize the picture
  With oSld.Shapes(oSld.Shapes.Count)
    .LockAspectRatio = False
    .Width = 650
    .Left = 28
    .Top = 50
  End With
  ' Make a new selection range from the Excel sheet using custom names in the sheet
  ActiveWorkbook.ActiveSheet.Range("B" & ActiveWorkbook.Names("Solid_First_Row").RefersToRange - 4 & _
    ":M" & ActiveWorkbook.Names("Stretch_Last_Row").RefersToRange + 1).Select
  ' Copy the selected range as a bitmap image
  Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
  ' Activate the PowerPoint app
  appPPT.Activate
  ' Paste the range to the target presentation's slide
  oSld.Shapes.Paste.Select
  ' Paste the range to the target presentation's slide
  ' Move and resize the picture
  With oSld.Shapes(oSld.Shapes.Count)
    .LockAspectRatio = False
    .Left = 28
    .Top = 120
    .Height = 380
    .Width = 650
  End With
  Application.CutCopyMode = False
  ActiveWorkbook.Activate
  ' Minimise the PowerPoint window using PowerPoint enumeration
  ' ppWindowNormal = 1
  ' ppWindowMinimized = 2
  ' ppWindowMaximized = 3
  appPPT.WindowState = 2
Else
  ' THE CODE BELOW IS NEVER RUN BECAUSE appPPT IS ALWAYS NOTHING!!!
  ' If an instance of PowerPoint doesn't exist, exit the macro
  If appPPT Is Nothing Then Exit Sub
  appPPT.ActiveWindow.View.GotoSlide appPPT.ActivePresentation.Slides.Count
  appPPT.ActivePresentation.Slides.Add appPPT.ActivePresentation.Slides.Count + 1, 12
  appPPT.ActiveWindow.View.GotoSlide appPPT.ActivePresentation.Slides.Count
  Set oSld = appPPT.ActivePresentation.Slides(appPPT.ActivePresentation.Slides.Count)
  ActiveWorkbook.ActiveSheet.Range("C3:I6").Select
  Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
  oSld.Shapes.Paste.Select
  oSld.Shapes(oSld.Shapes.Count).LockAspectRatio = False
  oSld.Shapes(oSld.Shapes.Count).Width = 650
  oSld.Shapes(oSld.Shapes.Count).Left = 28
  oSld.Shapes(oSld.Shapes.Count).Top = 50
  ActiveWorkbook.ActiveSheet.Range("B" & ActiveWorkbook.Names("Solid_First_Row").RefersToRange - 4 & ":M" & ActiveWorkbook.Names("Stretch_Last_Row").RefersToRange + 1).Select
  Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
  oSld.Shapes.Paste.Select
  oSld.Shapes(oSld.Shapes.Count).LockAspectRatio = False
  oSld.Shapes(oSld.Shapes.Count).Left = 28
  oSld.Shapes(oSld.Shapes.Count).Top = 120
  oSld.Shapes(oSld.Shapes.Count).Height = 380
  oSld.Shapes(oSld.Shapes.Count).Width = 650
  Application.CutCopyMode = False
End If

errorhandler:
  ActiveSheet.Range("$A$1").Select
End Sub
 
Hello Jamie G,

Thanks for the codes, however I am getting the error when I execute the code oSld.Shapes.Paste.Select.


Answer to your question.

Let me explain what was happening when I execute the macro.

Firstly, it will ask us to select yes or no for creating the ppt file. if we say yes then it will ask us to open the previous week ppt file (which can be used as a template). after that It will delete the old slides and use to add one slide to have the excel range pasted into it.

In case of No... it still asks us to open the previous file and then at the end of the slide it will add one more slide and paste the data into it. this never used to delete the existing slides but use to add additional slide.
 

Attachments

  • Dashboard.zip
    729.3 KB · Views: 4
LOTS of modification Pavan. It's working for my with Excel 2013 and PowerPoint 2013 from within your XLSX file (saved as XLSM with the code embedded).

Here is my working code which you may not recognise any more!

Code: 
Option Explicit

' ===================================================================
' Code significantly mofidied by GMARK Ltd. http://www.youpresent.biz
' Date : 06 November 2014
' Author : Jamie Garroch
' Copyright (c) 2014 Pavan.Sada.PS
' ===================================================================

Private appPPT As Object
Private sFilename As String

' Main macro
Sub CreatePresentation()
Dim response As VbMsgBoxResult
Dim oSld As Object, oShp As Object

On Error GoTo errorhandler
sFilename = ThisWorkbook.FullName
response = MsgBox("Do you want to create a new presentation?" & _
  vbCrLf & vbCrLf & ChrW(8226) & " Click Yes to select an existing presentation template" & _
  vbCrLf & ChrW(8226) & " Click No to append a new slide to an existing presentation", _
  vbQuestion + vbYesNoCancel, "PowerPoint Builder by YOUpresent.biz")
  If response = vbYes Then
    ' Get the user to open a presentation and delete all the slides, ready to add the new one as slide 1
    OpenPres DeleteSlides:=True
  Else
    ' Get the user to open a presentation without deleting the slides, ready to add the new one at the end of the deck
    OpenPres DeleteSlides:=False
  End If
  ' Create a new slide at the end of the target presentation
  appPPT.ActivePresentation.Slides.Add appPPT.ActivePresentation.Slides.Count + 1, 12
  ' Go to the new slide
  appPPT.ActiveWindow.View.GotoSlide appPPT.ActivePresentation.Slides.Count
  ' Set a reference to the new slide
  Set oSld = appPPT.ActivePresentation.Slides(appPPT.ActivePresentation.Slides.Count)

  ' Select the range in the Excel sheet
  ActiveWorkbook.ActiveSheet.Range("C3:I6").Select
  ' Copy the selected range as a bitmap image
  Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
  ' Paste the range to the target presentation's slide (no need to select it and this adds windowing complexity)
  Set oShp = oSld.Shapes.Paste '.Select
  ' Move and resize the newly added picture (which is the last in the shapes collection)
  MoveAndSizeShape oShp, 28, 50, 650, 0, False
  ' Make a new selection range from the Excel sheet using custom names in the sheet
  ActiveWorkbook.ActiveSheet.Range("B" & ActiveWorkbook.Names("Solid_First_Row").RefersToRange - 4 & _
    ":M" & ActiveWorkbook.Names("Stretch_Last_Row").RefersToRange + 1).Select
   
  ' Copy the selected range as a bitmap image
  Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
  ' Paste the range to the target presentation's slide (no need to select it and this adds windowing complexity)
  Set oShp = oSld.Shapes.Paste '.Select
  ' Move and resize the picture
  MoveAndSizeShape oShp, 28, 120, 650, 380, False
  Application.CutCopyMode = False
  ActiveWorkbook.Activate
  ' Minimise the PowerPoint window using PowerPoint enumeration
  ' ppWindowNormal = 1
  ' ppWindowMinimized = 2
  ' ppWindowMaximized = 3
  appPPT.WindowState = 2

  Set appPPT = Nothing: Set oSld = Nothing: Set oShp = Nothing

errorhandler:
  ActiveSheet.Range("$A$1").Select
End Sub

' Opens an existing presentation as specified by the user and optionally deetes all slides
Private Function OpenPres(DeleteSlides As Boolean)
  Set appPPT = CreateObject("PowerPoint.Application")
  appPPT.Visible = True
  ActiveWindow.Visible = True
  ActiveWindow.Activate
  ActiveWorkbook.Activate
  appPPT.WindowState = 2
  sFilename = Application.GetOpenFilename("Microsoft PowerPoint-Files (*.ppt*), *.ppt*")
  If sFilename = "False" Then End
  appPPT.Presentations.Open Filename:=sFilename
  If DeleteSlides Then
    ' Delete all slides from the presentation
    While appPPT.ActivePresentation.Slides.Count > 0
      appPPT.ActivePresentation.Slides(1).Delete
    Wend
  End If
  ' Activate the PowerPoint window by its title which is the presentation's filename
  AppActivate appPPT.ActivePresentation.Name
End Function

' Moves and sizes the selected shape
Private Function MoveAndSizeShape(oShp As Object, _
                                   PosLeft As Single, _
                                   PosTop As Single, _
                                   SizeW As Single, _
                                   Optional SizeH As Single, _
                                   Optional LockAspectRatio As Boolean)
  With oShp
    .LockAspectRatio = LockAspectRatio
    .Left = PosLeft
    .Top = PosTop
    .Width = SizeW
    If SizeH > 0 Then .Height = SizeH
  End With
End Function
 
Hello Jamie G,

I have tested the code on MS office 2013 system. I am experiencing error while executing the below vba

Require Object error

Code: 
' Moves and sizes the selected shape

Private Function MoveAndSizeShape(oShp As Object, _
                                    PosLeft As Single, _
                                    PosTop As Single, _
                                    SizeW As Single, _
                                    Optional SizeH As Single, _
                                    Optional LockAspectRatio As Boolean)
  With oShp
    .LockAspectRatio = LockAspectRatio
    .Left = PosLeft
    .Top = PosTop
    .Width = SizeW
    If SizeH > 0 Then .Height = SizeH
  End With
End Function
 
Hi Pavan ,

Can we go back to the code you posted first , since you say that code works the way you want it to ?

Remove the first line which says On Error ....

Never have this line when you are trying to debug a program ; this line is a dangerous line , especially if all it does is never tell you where the error is ! This line is supposed to be used only when :

1. You know all the possible errors that can crop up during program execution

2. You know what kind of actions are to be taken for each of the error situations

3. Your error handler really handles the situations which can be handled , and informs the user with descriptive error messages when the situations are such that they cannot be handled

If not , this line should never be used.

Once you remove this line , start your troubleshooting.

Narayan
 
Hello Narayan Sir,

Thanks for the advice.. I have removed the line of code.

@Jamie G,

' Moves and sizes the selected shape
Private Function MoveAndSizeShape(oShp As Object, _
PosLeft As Single, _
PosTop As Single, _
SizeW As Single, _
Optional SizeH As Single, _
Optional LockAspectRatio As Boolean)
With oShp
.LockAspectRatio = LockAspectRatio
.Left = PosLeft
.Top = PosTop
.Width = SizeW
If SizeH > 0 Then .Height = SizeH
End With
End Function
Click to expand...

I have replaced the above code with this and it did work as expected. And am not sure on why the above code dint get executed

' Move and resize the picture With oSld.Shapes(oSld.Shapes.Count)
.LockAspectRatio = False
.Width = 650
.Left = 28
.Top = 50
End With
 
You must log in or register to reply here.
Back
Top