CODEWITHSUNDEEP
vbapowerpointpowerpoint-2010
Schmoozer
Schmoozer

Reputation: 45

Picture added via VBA (Powerpoint) gets insertet into placeholder

I've got a Powerpoint 2010 Macro to insert a specific picture to a fixed place on the active slide.

Dim oSlide As Slide
Dim oPicture As Shape

' Set oSlide to the active slide.
Set oSlide = Application.ActiveWindow.View.Slide

' Insert Image to Footer
 Set oPicture = oSlide.Shapes.AddPicture("PathToFile.png", _
  msoFalse, msoTrue, 630, 390, 15, 15)

' Move the picture to the center of the slide. Select it.
With ActivePresentation.PageSetup
  oPicture.Select
  oPicture.Name = "Dokumentverknüpfung"
End With

This code works fine if there is no unused placeholder on the slide. If there is a placeholder the Picture automatically gets inserted into this placeholder.

Is there a way to tell the script to avoid placeholders and just accept the given coordinates?

Thank you, Jens

Upvotes: 4

Views: 2176

Answers (2)

Jamie Garroch - MVP
Jamie Garroch - MVP

Reputation: 2979

There is no way to explicitly tell PowerPoint not to use populate empty placeholders with pictures but you can stop it from doing so by making sure that there are no empty placeholders. If you call the sub ProtectEmptyPlaceholders before and after inserting your picture, then the picture gets inserted as a new shape.

Sub InsertPicture()
  Dim oSlide As Slide
  Dim oPicture As Shape

  ' Set oSlide to the active slide.
  Set oSlide = Application.ActiveWindow.View.Slide

  ' Protect empty placeholders from being auto-filled by PowerPoint
  ProtectEmptyPlaceholders oSlide, True

  ' Insert Image to Footer
   Set oPicture = oSlide.Shapes.AddPicture("PathToFile.png", _
    msoFalse, msoTrue, 630, 390, 15, 15)

  ' Reset empty placeholders
  ProtectEmptyPlaceholders oSlide, False

  ' Move the picture to the centre of the slide. Select it.
  With ActivePresentation.PageSetup
    oPicture.Select
    oPicture.Name = "Dokumentverknüpfung"
  End With
End Sub

' Purpose:  Adds dummy text to empty placeholders so that pictures can
'           be inserted without PowerPoint automatically placing them
'           within the first empty placeholder that supports pictures.
' Inputs:   oSld - the slide to process.
'           bProtect - if true, adds the dummy text to empty
'           placeholders and if false, deletes the dummy text from.
' Author:   Jamie Garroch of YOUpresent.co.uk 04MAR2016
Sub ProtectEmptyPlaceholders(oSld As Slide, bProtect As Boolean)
  Const sText As String = "PROTECTED"
  Dim oShp As Shape
  For Each oShp In oSld.Shapes
    If oShp.Type = msoPlaceholder Then
      If oShp.PlaceholderFormat.ContainedType = msoAutoShape Then
        If bProtect And Not oShp.TextFrame2.HasText Then oShp.TextFrame2.TextRange.text = sText
        If Not bProtect And oShp.TextFrame2.TextRange.text = sText Then oShp.TextFrame2.DeleteText
      End If
    End If
  Next
End Sub

Upvotes: 1

OfficeAddinDev
OfficeAddinDev

Reputation: 1125

Try adding the picture to a new, temporary slide with a blank layout that contains no placeholders whatsoever. Then, cut the picture and paste it onto the original slide, and delete the temporary slide.

sldTemp = pres.Slides.Add(1, PowerPoint.PpSlideLayout.ppLayoutBlank)

The advantages of this approach are that (a) it works whether the placeholders are multi-purpose or picture-specific and, to a lesser extent, (b) it not does require looping through all shapes on the slide twice. The disadvantage is that you'll see some screen flicker as the temporary slide is inserted and deleted.

Update:

Here is perhaps a better approach that avoids inserting a blank slide. After inserting the picture, check to see if the newly inserted shape type is a placeholder. If so, then we need to Cut() the picture and paste it back onto the slide and adjust some of the shape's properties:

shpNew = Selection.SlideRange.Shapes.AddPicture(strImagePath, Office.MsoTriState.msoFalse, Office.MsoTriState.msoTrue, x, y)
If shpNew.Type = Office.MsoShapeType.msoPlaceholder Then
    'PowerPoint put the picture into a placeholder, against our wishes
    shpNew.Cut()
    ppApp.ActiveWindow.View.Paste()
    shpNew = ppApp.ActiveWindow.Selection.ShapeRange(1)
    With shpNew
        With .PictureFormat
            .CropBottom = 0
            .CropLeft = 0
            .CropRight = 0
            .CropTop = 0
        End With
        .ScaleHeight(1, Office.MsoTriState.msoTrue)
        .ScaleWidth(1, Office.MsoTriState.msoTrue)
        .Top = y
        .Left = x
    End With
End If

Upvotes: 1

Related Questions