ajjava
Board Regular
- Joined
- Dec 11, 2018
- Messages
- 57
- Office Version
- 365
- Platform
- Windows
In a nutshell, the code below takes several picture objects from an Excel workbook (they are charts, but the source system puts them into Excel as pics) and pastes them into a PowerPoint presentation. As it stands, the code works. I just need some modifications to make a bit more dynamic.
For instance:
* Would like to NOT have a hard-coded value for starting number of slides (note in the 'assumptions' section, it is currently defined as 23. In the actual code, I may have modified the values that correspond to this, in case it seems like it doesn't line up)
* As it stands, the code is written to just loop through ALL of the worksheets, grabbing any pics that might be there. Would like to add code to reference ONLY specific worksheets, based on permanent and predefined names (so for example, the first sheet is named "New Total", the next is "New Where", etc.) If I could just see the correct syntax for one sheet, I can then code the rest, based on that.
* And here is what is likely the biggest change: There are three different Excel workbooks that need to be combined into one PowerPoint deck. So, in English, the flow would go like this:
Here is the existing code:
<strike></strike>
For instance:
* Would like to NOT have a hard-coded value for starting number of slides (note in the 'assumptions' section, it is currently defined as 23. In the actual code, I may have modified the values that correspond to this, in case it seems like it doesn't line up)
* As it stands, the code is written to just loop through ALL of the worksheets, grabbing any pics that might be there. Would like to add code to reference ONLY specific worksheets, based on permanent and predefined names (so for example, the first sheet is named "New Total", the next is "New Where", etc.) If I could just see the correct syntax for one sheet, I can then code the rest, based on that.
* And here is what is likely the biggest change: There are three different Excel workbooks that need to be combined into one PowerPoint deck. So, in English, the flow would go like this:
- Open the first workbook
- Select the first specific worksheet
- Copy/paste each picture object into a new, blank ppt deck
- 2 pics per slide, plus a rectangle shape box
- Go back to Excel
- Select the next specific worksheet....repeat steps 2-3 until all defined worksheets have been addressed
- Close that workbook
- Open the next workbook....repeat above steps 2-6
- Finished result is a many-slides PowerPoint, with ALL the picture objects from ALL the worksheets in all 3 workbooks
- Each slide has 2 pics, plus a rectangle shape box
Here is the existing code:
Code:
Sub CreateExecSummary2()
'Assumptions
'There will always be ONLY 4 images on each worksheet in the ERP workbook.
'The "base" PPT pres will ALWAYS start with 23 slides, each with only a Title Box (look into changing code to make this dynamic)
'That each of the image slides will ONLY have three shapes. Two images and 1 title box
'The first image on the slide will ALWAYS BE THE TOP ONE.
'The second image on the slide will ALWAYS BE THE BOTTOM ONE.
'Declare PowerPoint Variables
Dim PPTApp As PowerPoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.Slide
Dim PPTShape As PowerPoint.Shape
Dim SldArray(44) As Variant
Dim i As Integer
'Declare Excel Variables.
Dim filePath As String
Dim WrkSht As Worksheet
Dim PicCntr, SldCntr, ShpCount, StartingSld As Integer
Dim Shp As Shape
'Open a file dialog to go and fetch the file path, if invalid file path is presented it will exit sub.
filePath = Excel.Application.GetOpenFilename("Executive Summary (*.pptm*),*.pptm*", _
1, "Executive Summary Template to Populate", , False)
If filePath = "" Then GoTo noFile
'Check if the PowerPoint App is open, if not create a new instance of PowerPoint and finally make the PowerPoint Visible.
On Error Resume Next
Set PPTApp = GetObject(, "PowerPoint.Application")
On Error GoTo 0
If PPTApp Is Nothing Then
Set PPTApp = New PowerPoint.Application
End If
'Make PowerPoint Visible
PPTApp.Visible = True
'Set the Presentation to the file select.
Set PPTPres = PPTApp.Presentations.Open(filePath)
'Build a slide array so that way we can easily paste the pictures on the right slide.
StartingSld = 2
For i = 0 To 42 Step 2
SldArray(i) = StartingSld
SldArray(i + 1) = StartingSld
StartingSld = StartingSld + 1
Next
PicCntr = 0
'Loop through each of the worksheets in the ERP Generated Workbook
For Each WrkSht In ActiveWorkbook.Worksheets
'Activate the Worksheet, for stability issues that may arise.
WrkSht.Activate
'Loop through each shape on the Worksheet.
For Each Shp In WrkSht.Shapes
'If the shape is a picture, then continue.
If Shp.Type = msoPicture Then
'Set a reference to the slide, we select the right slide by leveraging the PicCntr.
Set PPTSlide = PPTPres.Slides(SldArray(PicCntr))
'Copy the shape, and pause for stability issues thay may arise.
Shp.Copy
Application.Wait Now() + #12:00:01 AM#
'Paste the shape and increase the PicCntr by 1, so that we proceed to the next element in our SldArray on the next pic.
PPTSlide.Shapes.Paste
PicCntr = PicCntr + 1
'Get the total shape count, and set a reference to the shape we want to work with.
ShpCount = PPTSlide.Shapes.Count
Set PPTShape = PPTSlide.Shapes(ShpCount)
'Assume the First Shape is the Top one, the reason I put ShpCount 2 is because we have to include the title box.
If ShpCount = 2 Then
'Set the dimensions of the shape.
With PPTShape
.Top = Excel.Application.InchesToPoints(1.04)
.Left = Excel.Application.InchesToPoints(3.09)
.Height = Excel.Application.InchesToPoints(3.07)
.Width = Excel.Application.InchesToPoints(6.42)
End With
'Assume the Second Shape is the bottom one, the reason I put ShpCount 3 is because we have to include the title box.
ElseIf ShpCount = 3 Then
'Set the dimensions of the shape.
With PPTShape
.Top = Excel.Application.InchesToPoints(4.33) 'CHANGE THIS SO IT MATCHES WHAT YOU HAVE FOR THE BOTTOM IMAGE.
.Left = Excel.Application.InchesToPoints(3.09)
.Height = Excel.Application.InchesToPoints(2.81)
.Width = Excel.Application.InchesToPoints(6.42)
End With
'Add the text box.
PPTSlide.Shapes.AddShape(Type:=msoShapeRoundedRectangle, Left:=27.36, Top:=84.96, Width:=159.12, Height:=400.32).TextFrame.TextRange.Text = "Please Enter Analysis Here."
End If
End If
Next
Next
'Let the user know the macro finished running.
MsgBox "The Macro has finished running, you may now work with the PowerPoint Presentation."
Exit Sub
'Handle the No File Error.
noFile:
MsgBox "We Couldn't find the file, exiting the Macro."
End Sub