I'm trying to make a PP slideshow from an Excel spreadsheet. I have this VBA module:
Sub CreatePowerPointQuestions()
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim Question As String
Dim Options As String
Dim Answer As String
Dim limit As Integer
limit = 3
On Error Resume Next
Set newPowerPoint = GetObject(, "PowerPoint.Application")
On Error GoTo 0
If newPowerPoint Is Nothing Then
Set newPowerPoint = New PowerPoint.Application
End If
'Make a presentation in PowerPoint
If newPowerPoint.Presentations.Count = 0 Then
newPowerPoint.Presentations.Add
End If
'Show the PowerPoint
newPowerPoint.Visible = True
'Select worksheet and cells activate
Worksheets("Sheet1").Activate
'Loop through each question
For i = 1 To limit
'Add a new slide where we will paste the Question and Options:
newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, 3
newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)
'Set the variables to the cells
Question = ActiveSheet.Cells(i, 1).Value
Options = ActiveSheet.Cells(i, 2).Value
Answer = ActiveSheet.Cells(i, 3).Value
activeSlide.Shapes(1).TextFrame.TextRange.Text = Question
activeSlide.Shapes(2).TextFrame.TextRange.Text = Options
activeSlide.Shapes(3).TextFrame.TextRange.Text = Answer
Next
Set activeSlide = Nothing
Set newPowerPoint = Nothing
End Sub
The problem is that it creates slides with a title and two entries side by side with a bullet. I want the slide to be three lines, without the bullets. Is there a way to do this? I don't know how to do the layouts
There is a list of layouts that you can use at https://msdn.microsoft.com/en-us/library/office/ff745137.aspx
However, only two of them match your criteria
ppLayoutObjectOverText, and
ppLayoutTextOverObject
Try this after your Set activeslide line:
activeSlide.layout = ppLayoutObjectOverText
Related
I'm trying to copy formatted text content from Excel to Powerpoint in VBA--preferably without copy-and-paste, as it just crashes every time I run it (even with multiple DoEvents to slow it down... there are hundreds of cells of heavily formatted text).
That's why I've been trying to get it to work by addressing the cells directly like in the code below.
For i = 1 To WS.Range("A65536").End(xlUp).Row
If WS.Cells(i, 1) > 0 Then
Set newSlide = ActivePresentation.Slides(1).Duplicate
newSlide.MoveTo (ActivePresentation.Slides.Count)
With newSlide.Shapes(1).TextFrame.TextRange
.Text = WS.Cells(i, 1).Value ' Inserts the (non-formatted) text from Excel. Have also tried WS.Cells(i, 1).Text
.Font.Name = WS.Cells(i, 1).Font.Name ' This works fine
.Font.Size = WS.Cells(i, 1).Font.Size ' This works fine too
' Neither of the below work because there is a mixture of font styled and colours within individual cells
.Font.FontStyle = WS.Cells(i, 1).Font.FontStyle ' Font Style (Regular, Bold, Italic, Bold Italic)
.Font.Color = WS.Cells(i, 1).Font.Color ' Font Color
End With
End If
Next
It works (very quickly) transferring the cell content, font name, and font size... but NOT for FontStyle (bold, italics, etc.) or FontColor because there is more than one style/color in individual cells.
Is there any way around this? I haven't the foggiest idea what the potential solution (if any) could be, so don't even know where to start looking. Even a push in the right direction would help enormously.
here is a proof-of-concept
copying cells from excel into powerPoint
specifics: cells have multiple text formatting per cell
achieved by copying into msWord document and then from msWord into powerPoint
Sub copyMultipleColorTextPerCell()
' this program copies excel cells that contain multiply formatted text in each cell
' the text is copiend into an msWord document, because the formatting is retained
' and then copied into powerpoint
' -------------------------- create powerpoint presentation
Const ppLayoutBlank = 12
Dim ppApp As PowerPoint.Application
On Error Resume Next
Set ppApp = GetObject(, "PowerPoint.Application")
On Error GoTo 0
If ppApp Is Nothing Then
Set ppApp = New PowerPoint.Application
End If
ppApp.Visible = True
Dim ppPres As Presentation
Set ppPres = ppApp.Presentations.Add
Dim ppSlid As PowerPoint.Slide
Set ppSlid = ppPres.Slides.Add(1, 1)
ppSlid.Layout = ppLayoutBlank
Dim ppShp As PowerPoint.Shape
Set ppShp = ppPres.Slides(1).Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 100, 500, 200)
Dim ppTxRng As PowerPoint.TextRange
Set ppTxRng = ppShp.TextFrame.TextRange
' ---------------------------------------------------------------
Dim wdApp As Word.Application ' not necessary
Set wdApp = New Word.Application
Dim xlRng As Excel.Range
Set xlRng = Sheets("Sheet1").Range("c6:c7") ' this is the range that gets copied into powerPoint, via msWord
xlRng.Cells(1) = "this is multicolor text" ' some multicolour test text, so you don't have to type any
xlRng.Cells(1).Characters(1, 13).Font.Color = vbGreen
xlRng.Cells(1).Characters(14, 20).Font.Color = vbRed
xlRng.Cells(2) = "this is also multicolor"
xlRng.Cells(2).Characters(1, 12).Font.Color = vbBlue
xlRng.Cells(2).Characters(13, 20).Font.Color = vbMagenta
Dim wdDoc As Word.Document
Set wdDoc = New Word.Document
Dim wdRng As Word.Range
Set wdRng = wdDoc.Range
xlRng.Copy ' copy whole excel range
wdRng.PasteExcelTable False, False, False ' paste to msWord doc, because formatting is kept
Dim wdTb As Table
Set wdTb = wdDoc.Tables(1)
' copy the two cells from msWord table
wdDoc.Range(start:=wdTb.Cell(1, 1).Range.start, End:=wdTb.Cell(2, 1).Range.End).Copy
ppTxRng.Paste ' paste into powerPoint text table
ppTxRng.PasteSpecial ppPasteRTF
Stop ' admire result ...... LOL
wdDoc.Close False
ppPres.Close
ppApp.Quit
Set wdDoc = Nothing
Set wdApp = Nothing
Set ppSlid = Nothing
Set ppPres = Nothing
Set ppApp = Nothing
End Sub
I have the code below which I found online to copy paste a tble from excel to powerpoint. After pasting the table into the slide, it fails on PPSlide.Shapes(1).Select with a Run-time error '-2147188160 (80048240)': Shape.Select : Invalide request. To select a shape, its view must be active.
I've been searching and trying different things but can't seem to figure it out.. I thought after the paste that the table would be active and the code would jsut continue but it doesn't unless I activate/select the table in the slide and then click Run. Any help is appreciated. Thanks.
Dim pp As Object
Dim PPPres As Object
Dim PPSlide As Object
Dim Rng As Range
DestinationPPT = "C:\Users\username\Desktop\Data_Display.pptx"
Set pp = CreateObject("PowerPoint.Application")
Set PPPres = pp.Presentations.Open(DestinationPPT)
pp.Visible = True
Set Rng = ActiveSheet.Range("CA1:CJ" & Count + 1)
Rng.Copy
SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.Add(SlideCount, 12)
pp.ActivePresentation.Application.CommandBars.ExecuteMso ("PasteSourceFormatting")
PPSlide.Shapes(1).Select
pp.ActiveWindow.Selection.ShapeRange.Align msoAlignTops, True
pp.ActiveWindow.Selection.ShapeRange.Top = 65
pp.ActiveWindow.Selection.ShapeRange.Left = 7.2
pp.ActiveWindow.Selection.ShapeRange.Width = 700
Set PPSlide = Nothing
Set PPPres = Nothing
Set pp = Nothing
Try the code below:
Set pp = CreateObject("PowerPoint.Application")
Set ppPres = pp.Presentations.Open(DestinationPPT)
pp.Visible = True
' first set the Slide and select it
SlideCount = ppPres.Slides.Count
Set ppSlide = ppPres.Slides.Add(SlideCount, 12)
ppSlide.Select
' have the Copy part right beofre youe Paste it to PowerPoint
Set Rng = ActiveSheet.Range("CA1:CJ" & Count + 1)
Rng.Copy
pp.ActivePresentation.Application.CommandBars.ExecuteMso ("PasteSourceFormatting")
Dim myShape As Object
' set up the Pasted shape to an object
Set myShape = ppSlide.Shapes(ppSlide.Shapes.Count)
With myShape
' set-up the shape properties
End With
Answer: TL;DR: pasting a chart with embedded data takes a long time so you have to install a delay to prevent vba from moving on before the paste operation completes.
Question:I'm trying to paste an excel chart with embedded data into a powerpoint presentation. The only thing I am getting hung up on is referring to and positioning the chart in ppt once it has been pasted.
Dim newPowerPoint As PowerPoint.Application
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.ChartArea.Copy
newPowerPoint.CommandBars.ExecuteMso ("PasteExcelChartDestinationTheme")
Since I need to paste multiple charts into single slides, repositioning them is necessary. I try to do that with this piece of code:
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 0
but am always met with the error: "Method 'ShapeRange' of object 'Selection' failed".
What's particularly odd is that running the code from start to finish results in this error, but stepping through the code using the F8 key does not.
I have tried every way I can think of to move this chart around but I am totally stuck. Does anyone know how I can do this? Also, please keep in mind that is necessary that the chart have data in it (I can't paste the chart as a picture and I would strongly prefer that the data not be linked).
Thanks,
Steve
edit new modified code with multiple chart objects. I needed to add an if conditional:
If activeSlide.Shapes.Count = 1 Then
GoTo NextiLoop
End If
for additional chart objects because the delay pasting chart 2 makes the loop name chart 1 "pptcht2" since chart2 did not exist yet.
Sub CreatePPT()
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim cht1 As Excel.ChartObject
Dim Data As Excel.Worksheet
Dim pptcht1 As PowerPoint.Shape
Dim iLoopLimit As Long
Application.ScreenUpdating = False
'Look for existing instance
On Error Resume Next
Set newPowerPoint = GetObject(, "PowerPoint.Application")
On Error GoTo 0
'Let's create a new PowerPoint
If newPowerPoint Is Nothing Then
Set newPowerPoint = New PowerPoint.Application
End If
'Make a presentation in PowerPoint
If newPowerPoint.Presentations.Count = 0 Then
newPowerPoint.Presentations.Add
End If
'Show the PowerPoint
newPowerPoint.Visible = True
Application.ScreenUpdating = False
'Add a new slide where we will paste the chart
newPowerPoint.ActivePresentation.Slides.Add _
newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText
newPowerPoint.ActiveWindow.View.GotoSlide _
newPowerPoint.ActivePresentation.Slides.Count
Set activeSlide = newPowerPoint.ActivePresentation.Slides _
(newPowerPoint.ActivePresentation.Slides.Count)
activeSlide.Shapes(1).Delete
activeSlide.Shapes(1).Delete
'ActiveSheet.ChartObjects("Chart 1").Activate
Set Data = ActiveSheet
Set cht1 = Data.ChartObjects("Share0110")
Set cht2 = Data.ChartObjects("SOW0110")
Set cht3 = Data.ChartObjects("PROP0110")
cht1.Copy
newPowerPoint.CommandBars.ExecuteMso "PasteExcelChartDestinationTheme"
DoEvents
On Error Resume Next
Do
DoEvents
Set pptcht1 = activeSlide.Shapes(activeSlide.Shapes.Count)
If Not pptcht1 Is Nothing Then Exit Do
iLoopLimit = iLoopLimit + 1
If iLoopLimit > 100 Then Exit Do
Loop
On Error GoTo 0
Debug.Print "iLoopLimit = " & iLoopLimit
With pptcht1
.Left = 25
.Top = 150
End With
iLoopLimit = 0
'ActiveSheet.ChartObjects("Chart 2").Activate
'Set Data = ActiveSheet
cht2.Copy
newPowerPoint.CommandBars.ExecuteMso "PasteExcelChartDestinationTheme"
DoEvents
On Error Resume Next
Do
DoEvents
If activeSlide.Shapes.Count = 1 Then
GoTo NextiLoop
End If
Set pptcht2 = activeSlide.Shapes(activeSlide.Shapes.Count)
If Not pptcht2 Is Nothing Then Exit Do
NextiLoop:
iLoopLimit = iLoopLimit + 1
If iLoopLimit > 100 Then Exit Do
Loop
On Error GoTo 0
Debug.Print "iLoopLimit = " & iLoopLimit
With pptcht2
.Left = 275
.Top = 150
End With
iLoopLimit = 0
AppActivate ("Microsoft PowerPoint")
Set activeSlide = Nothing
Set newPowerPoint = Nothing
End Sub
edit: OLD not working code:
Sub CreatePPT()
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim cht As Excel.ChartObject
Application.ScreenUpdating = False
'Look for existing instance
On Error Resume Next
Set newPowerPoint = GetObject(, "PowerPoint.Application")
On Error GoTo 0
'Let's create a new PowerPoint
If newPowerPoint Is Nothing Then
Set newPowerPoint = New PowerPoint.Application
End If
'Make a presentation in PowerPoint
If newPowerPoint.Presentations.Count = 0 Then
newPowerPoint.Presentations.Add
End If
'Show the PowerPoint
newPowerPoint.Visible = True
Application.ScreenUpdating = False
'Add a new slide where we will paste the chart
newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText
newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)
activeSlide.Shapes(1).Delete
activeSlide.Shapes(1).Delete
'ActiveSheet.ChartObjects("Chart 1").Activate
Set Data = ActiveSheet
Set cht1 = Data.ChartObjects("Chart 1")
cht1.Copy
newPowerPoint.CommandBars.ExecuteMso ("PasteExcelChartDestinationTheme")
Set pptcht1 = newPowerPoint.ActiveWindow.Selection
With pptcht1
.Left = 0
End With
AppActivate ("Microsoft PowerPoint")
Set activeSlide = Nothing
Set newPowerPoint = Nothing
End Sub
Do yourself a favor and enter this as the first line of the code module:
Option Explicit
This will force you to declare all variables. You have a lot of undeclared variables, including a couple that are almost the same as the few you did declare. Then go to VBA's Tools menu > Options, and check the Require Variable Declaration on the first tab of the dialog, which will put Option Explicit at the top of every new module.
Declare the shape as a PowerPoint.Shape, then find it using this, since any newly added shape is the last one on the slide:
Set pptcht1 = activeSlide.Shapes(activeSlide.Shapes.Count)
The following line first of all does not need the parentheses, despite the poorly written Microsoft Help article. Second, it takes a long time to run. Excel is already trying to move the shape long before the shape has been created. DoEvents is supposed to help with this by making Excel wait until everything else happening on the computer is finished, but the line is still too slow.
newPowerPoint.CommandBars.ExecuteMso ("PasteExcelChartDestinationTheme")
So I cobbled together a little loop that tries to set the variable to the shape, and keeps looping until the shape is finished being created.
On Error Resume Next
Do
DoEvents
Set pptcht1 = activeSlide.Shapes(activeSlide.Shapes.Count)
If Not pptcht1 Is Nothing Then Exit Do
iLoopLimit = iLoopLimit + 1
If iLoopLimit > 100 Then Exit Do
Loop
On Error GoTo 0
In a small number of tests, I found that the loop would have to run 20 to 60 times. I also crashed PowerPoint a few times. Weird.
I'm sure there are better ways to paste the copied chart and keep the slide's color theme, but off the top of my head I don't know one.
This is unreliable, since the application caption changes with different versions of Office (and again the parentheses are not needed):
AppActivate ("Microsoft PowerPoint")
Use this instead:
AppActivate newPowerPoint.Caption
So your whole code becomes:
` Sub CreatePPT()
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim cht1 As Excel.ChartObject
Dim Data As Excel.Worksheet
Dim pptcht1 As PowerPoint.Shape
Dim iLoopLimit As Long
Application.ScreenUpdating = False
'Look for existing instance
On Error Resume Next
Set newPowerPoint = GetObject(, "PowerPoint.Application")
On Error GoTo 0
'Let's create a new PowerPoint
If newPowerPoint Is Nothing Then
Set newPowerPoint = New PowerPoint.Application
End If
'Make a presentation in PowerPoint
If newPowerPoint.Presentations.Count = 0 Then
newPowerPoint.Presentations.Add
End If
'Show the PowerPoint
newPowerPoint.Visible = True
Application.ScreenUpdating = False
'Add a new slide where we will paste the chart
newPowerPoint.ActivePresentation.Slides.Add _
newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText
newPowerPoint.ActiveWindow.View.GotoSlide _
newPowerPoint.ActivePresentation.Slides.Count
Set activeSlide = newPowerPoint.ActivePresentation.Slides _
(newPowerPoint.ActivePresentation.Slides.Count)
activeSlide.Shapes(1).Delete
activeSlide.Shapes(1).Delete
'ActiveSheet.ChartObjects("Chart 1").Activate
Set Data = ActiveSheet
Set cht1 = Data.ChartObjects("Chart 1")
cht1.Copy
newPowerPoint.CommandBars.ExecuteMso "PasteExcelChartDestinationTheme"
DoEvents
On Error Resume Next
Do
DoEvents
Set pptcht1 = activeSlide.Shapes(activeSlide.Shapes.Count)
If Not pptcht1 Is Nothing Then Exit Do
iLoopLimit = iLoopLimit + 1
If iLoopLimit > 100 Then Exit Do
Loop
On Error GoTo 0
Debug.Print "iLoopLimit = " & iLoopLimit
With pptcht1
.Left = 0
End With
AppActivate newPowerPoint.Caption
Set activeSlide = Nothing
Set newPowerPoint = Nothing
End Sub`
I'm an amateur coder. I'm trying to put something together to transfer all charts in an excel file to different slides on a powerpoint. I've tested several modules online (some from here as well). I've found this one below to be the most comprehensive for me so far. I have 3 graphs on a worksheet and for some reason I can't figure out, the code only copies one graph (first created), makes new slide and sticks it on that second slide. No idea what's going on, any help would be appreciated:
Sub ChartsAndTitlesToPresentation()
' Set a VBE reference to Microsoft PowerPoint Object Library
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim PresentationFileName As Variant
Dim SlideCount As Long
Dim iCht As Integer
Dim sTitle As String
' Reference existing instance of PowerPoint
Set PPApp = GetObject(, "Powerpoint.Application")
' Reference active presentation
Set PPPres = PPApp.ActivePresentation
PPApp.ActiveWindow.ViewType = ppViewSlide
For iCht = 1 To ActiveSheet.ChartObjects.Count
With ActiveSheet.ChartObjects(iCht).Chart
' get chart title
If .HasTitle Then
sTitle = .ChartTitle.Text
Else
sTitle = ""
End If
' remove title (or it will be redundant)
.HasTitle = False
' copy chart as a picture
.CopyPicture _
Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
' restore title
If Len(sTitle) > 0 Then
.HasTitle = True
.ChartTitle.Text = sTitle
End If
End With
' Add a new slide and paste in the chart
SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutTitleOnly)
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
With PPSlide
' paste and select the chart picture
.Shapes.Paste.Select
' align the chart
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
.Shapes.Placeholders(1).TextFrame.TextRange.Text = sTitle
End With
Next
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End Sub
I've cobbled together a VBA script (I'm no expert, but thanks to the kind folks around here, I've been able to get something together and mostly working) to copy from multiple excel sheets into a powerpoint file (used a template, as you will see from the code.
Sub ATestPPTReport()
Dim PPApp As PowerPoint.Application
Dim PPSlide As PowerPoint.Slide
Dim PPPres As PowerPoint.Presentation
Set PPApp = CreateObject("Powerpoint.Application")
Dim SlideNum As Integer
Dim PPShape As PowerPoint.Shape
Set XLApp = GetObject(, "Excel.Application")
''define input Powerpoint template
Dim strPresPath As String, strExcelFilePath As String, strNewPresPath As String
''# Change "strPresPath" with full path of the Powerpoint template
strPresPath = "C:\template.ppt"
''# Change "strNewPresPath" to where you want to save the new Presentation to be created
strNewPresPath = "C:\macro_output-" & Format(Date, "dd-mmm-yyyy") & ".ppt"
Set PPPres = PPApp.Presentations.Open(strPresPath)
PPPres.Application.Activate
PPApp.Visible = True
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''define destination slide
SlideNum = 1
PPPres.Slides(SlideNum).Select
Set PPShape = PPPres.Slides(SlideNum).Shapes("slide1box")
Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
''define source sheet
Sheets("Info1").Activate
'copy/paste from
XLApp.Range("Info1Block").Copy
PPSlide.Shapes.PasteSpecial DataType:=ppPasteOLEObject, Link:=msoFalse
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''define destination slide
SlideNum = 2
PPPres.Slides(SlideNum).Select
' Set PPShape = PPPres.Slides(SlideNum).Shapes("slide2box")
Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
''define source sheet
Sheets("Info2").Activate
'copy/paste from
XLApp.Range("Info2Block").Copy
PPSlide.Shapes.PasteSpecial DataType:=ppPasteOLEObject, Link:=msoFalse
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Close presentation
PPPres.SaveAs strNewPresPath
'PPPres.Close
'Quit PowerPoint
'PPApp.Quit
' MsgBox "Presentation Created", vbOKOnly + vbInformation
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End Sub
My problem is: how do I resize/reposition the object once it's been pasted?
The function "PasteSpecial" returns a shape object, which you can use to resize or reposition.
For example:
Dim ppShape as PowerPoint.Shape
set ppShape = PPSlide.Shapes.PasteSpecial(DataType:=ppPasteOLEObject, Link:=msoFalse)
Then you can use this shape object to resize it. For example:
ppShape.Height = xyz
ppShape.Top = abc
etc etc.
Hope this helps.
Vikas B
This has been working for me:
Set shp = myPresentation.Slides(x).Shapes.PasteSpecial(DataType:=2)
shp.Left = topLeft + 1
shp.Top = midTop + 1
shp.Width = midLeft - topLeft - 1
Note the variables are set locally to place the image where I want it in relation to the slide. You can easily replace with integers.
It also works for DataType:=10 items as well