I try to use a selected picture on the slide and copy/paste it into the Placeholder (I can not load the picture from a file, it has to be from the slide itself.)
It works fine when I go through the code with F8 step by step. But when I run the macro, the placeholder stays empty.
I tried to set Delays in order to give PPT enough time but no matter how high I make the delay, it won't work (Placeholder doesn't get filled)
Any ideas, what could cause this weird behavior? Better ideas how to place the selected image into the template Placeholder (should work on Mac too though). Thank you for your time!
Sub SetImageIntoPlaceholder()
Dim sImage As Shape
Dim iSl As Integer
Dim oSl As Slide
Dim oPl As Shape
On Error GoTo ErrorHandler
If ActiveWindow.Selection.ShapeRange().Count <> 1 Then
MsgBox "Please select only the picture you wish to place in the Placeholder", vbOKOnly Or vbCritical, Application.Name
Exit Sub
End If
iSl = ActiveWindow.View.Slide.SlideIndex
Set oSl = ActivePresentation.Slides(iSl)
Set sImage = ActiveWindow.Selection.ShapeRange(1)
sImage.Copy
For Each oPl In oSl.Shapes
If oPl.Type = msoPlaceholder Then
With oPl
Select Case oPl.PlaceholderFormat.Type
Case Is = 18
'Its a picture placeholder
Delay 4
oPl.Select
Delay 4
ActiveWindow.View.Paste
Delay 5
'oSl.Shapes.Paste
Application.CommandBars.ExecuteMso ("SlideReset")
'Delay 1.5
'sImage.Delete
Exit Sub
Case Else
' ignore other shape types
End Select
End With
End If
Next oPl
ErrorHandler:
'Resume Next
End Sub
Try adding DoEvents after you copy and after you paste. Also, try separating your copy and paste operations into separate procedures. VBA should wait until the operations are complete before entering and exiting a procedure. I haven't tested it, but maybe something like this . . .
Option Explicit
Sub SetImageIntoPlaceholder()
Dim sImage As Shape
Dim iSl As Integer
Dim oSl As Slide
On Error GoTo ErrorHandler
If ActiveWindow.Selection.ShapeRange().Count <> 1 Then
MsgBox "Please select only the picture you wish to place in the Placeholder", vbOKOnly Or vbCritical, Application.Name
Exit Sub
End If
iSl = ActiveWindow.View.Slide.SlideIndex
Set oSl = ActivePresentation.Slides(iSl)
Set sImage = ActiveWindow.Selection.ShapeRange(1)
sImage.Copy
DoEvents
PastePictureInSlide oSl
ErrorHandler:
'Resume Next
End Sub
Private Sub PastePictureInSlide(ByVal oSl As Slide)
Dim oPl As Shape
For Each oPl In oSl.Shapes
If oPl.Type = msoPlaceholder Then
With oPl
Select Case .PlaceholderFormat.Type
Case Is = 18
'Its a picture placeholder
.Select
ActiveWindow.View.Paste
'oSl.Shapes.Paste
Application.CommandBars.ExecuteMso ("SlideReset")
DoEvents
Exit Sub
Case Else
' ignore other shape types
End Select
End With
End If
Next oPl
End Sub
Related
I want to 'Delete Texts' from All Slides or Current Slide depending on my choice.
I have textboxes that I needed to clear all at once and I also want to choose whether to Delete from all Slides or just this Current Slide.
I getting the error
"Object doesn't support this property or method"
on For Each sh In Application.ActiveWindow.View.Slide
I copied some of the code from Microsoft.
Sub ClearAllTextBox()
Dim sh As Shape
Dim sld As Slide
Dim SldDelType As Boolean
SldDelType = False
Select Case MsgBox("Delete Texts From All Slides?", vbExclamation + vbYesNoCancel)
Case vbYes:
SldDelType = True
Case vbNo:
SldDelType = False
Case vbCancel:
Exit Sub
End Select
Select Case MsgBox("Are you Sure you want To Delete " & vbNewLine & "all Text from all Shapes/TextBoxes?", vbExclamation + vbYesNo)
Case vbNo:
Exit Sub
Case vbYes:
If SldDelType Then
For Each sld In ActivePresentation.Slides
For Each sh In sld.Shapes
If sh.HasTextFrame Then
sh.TextFrame.DeleteText
End If
Next sh
Next sld
Else:
For Each sh In Application.ActiveWindow.View.Slide
If sh.HasTextFrame Then
sh.TextFrame.DeleteText
End If
Next sh
End If
End Select
End Sub
If you want to loop over all shapes of a slide, you need to say so. You are doing it right already in the upper part, there you write For Each sh In sld.Shapes. You need to do the same if you want to loop over all shapes of a single slide:
(...)
Else
For Each sh In Application.ActiveWindow.View.Slide.Shapes
If sh.HasTextFrame Then
(...)
End If
Next sh
End If
or use a slide variable to split that long statement:
Else
Set sl = Application.ActiveWindow.View.Slide
For Each sh sl.Shapes
(...)
Next sh
End If
I'm a new stackoverflow user so I'm not sure if I'm doing this right, but I'm trying to post a question on a previously given solution by Steve Rindsberg. I don't have enough reputation to comment, and there doesn't appear to be a way to message another user directly, so I'm posting a new question here.
I can't seem to get the code below to work. I'm using PowerPoint O365 Version 1901 and I have two type of shapes I'm trying to convert, msoChart and msoLinkedOLEObject (some Excel worksheets). I originally changed ppPasteEnhancedMetafile to ppPastePNG because I want PNG's, but it fails with either.
Here is the code:
Sub ConvertAllShapesToPic()
Dim oSl As Slide
Dim oSh As Shape
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
' modify the following depending on what you want to
' convert
Select Case oSh.Type
Case msoChart, msoEmbeddedOLEObject, msoLinkedOLEObject
ConvertShapeToPic oSh
Case msoPlaceholder
If oSh.PlaceholderFormat.ContainedType = msoEmbeddedOLEObject _
Or oSh.PlaceholderFormat.ContainedType = msoLinkedOLEObject _
Or oSh.PlaceholderFormat.ContainedType = msoChart _
Then
ConvertShapeToPic oSh
End If
Case Else
End Select
Next
Next
End Sub
Sub ConvertShapeToPic(ByRef oSh As Shape)
Dim oNewSh As Shape
Dim oSl As Slide
Set oSl = oSh.Parent
oSh.Copy
Set oNewSh = oSl.Shapes.PasteSpecial(ppPastePNG)(1)
With oNewSh
.Left = oSh.Left
.Top = oSh.Top
Do
.ZOrder (msoSendBackward)
Loop Until .ZOrderPosition < oSh.ZOrderPosition
End With
oSh.Delete
End Sub
I noticed if I run ConvertAllShapesToPic from an link/action in Slide Show mode, it doesn't complete and fails silently. If I add a Command Button (ActiveX control) and run it from there I get the following:
Run-time error '-2147188160 (80048240)':
Shapes (unknown member): Invalid request. The specified data type is unavailable.
It's failing on Set oNewSh = sld.Shapes.PasteSpecial(ppPastePNG)(1). After the error, if I go back to the slide and Ctrl-V I get the image, so I know it's working up to that point.
I've tried various solutions I found online for this such as adding DoEvents or ActiveWindow.Panes(1).Activate after the copy, but it doesn't seem to make a difference. Any suggestions?
Thanks
I found some other code to convert the charts and then I break links on the worksheets which automatically turns them in to images.
One thing I figured out was you must be out of slide show mode to break msoLinkedOLEObject links. I'm not 100% sure why... but this is the code that works for me:
Sub DoStuff()
Call LinkedGraphsToPictures
ActivePresentation.SlideShowWindow.View.Exit
Call BreakAllLinks
End Sub
Sub LinkedGraphsToPictures()
Dim shp As Shape
Dim sld As Slide
Dim pic As Shape
Dim shp_left As Double
Dim shp_top As Double
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = msoChart Then
'Retrieve current positioning
shp_left = shp.Left
shp_top = shp.Top
'Copy/Paste as Picture
shp.Copy
DoEvents
sld.Shapes.PasteSpecial DataType:=ppPastePNG
Set pic = sld.Shapes(sld.Shapes.Count)
'Delete Linked Shape
shp.Delete
'Reposition newly pasted picture
pic.Left = shp_left
pic.Top = shp_top
End If
Next shp
Next sld
End Sub
Sub BreakAllLinks()
Dim shp As Shape
Dim sld As Slide
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = msoLinkedOLEObject Then
shp.LinkFormat.BreakLink
End If
Next shp
Next sld
End Sub
I have a shape in an Excel sheet, and I have to add/remove hyperlink to it as a part of my code. How can we check if the shape contains a hyperlink? Something like the below code:
if shape.hyperlink.exists is True then
shape.hyperlink.delete
end if
Public Sub TestMe()
Dim sh As Shape
For Each sh In ActiveSheet.Shapes
On Error Resume Next
sh.Hyperlink.Delete
On Error GoTo 0
Next sh
End Sub
The idea is to delete the hyperlink of every shape. If the shape does not have one, it is quite ok, the code continues. In this solution, the hyperlink is declared as a variable - How do I refer to a shape's hyperlinks using Excel VBA - as a workaround something similar can be used.
It is possible to loop over all the hyperlinks on a sheet and determine whether those hyperlinks are in cells or in Shapes (this avoids using OnError):
Sub HyperActive()
Dim h As Hyperlink, n As Long
If ActiveSheet.Hyperlinks.Count = 0 Then
MsgBox "no hyperlinks"
Exit Sub
End If
For Each h In ActiveSheet.Hyperlinks
n = h.Type
If n = 0 Then
MsgBox "in cell: " & h.Parent.Address
ElseIf n = 1 Then
MsgBox "in shape: " & h.Shape.Name
End If
Next h
End Sub
To check if a Shape has a Hyperlink, call this function (instead of the 'shape.hyperlink.exists') in your post:
Public Function HasHyperlink(shpTarget As Shape) As Boolean
Dim hLink As Hyperlink: Set hLink = Nothing
On Error Resume Next: Set hLink = shpTarget.Hyperlink: On Error GoTo 0
HasHyperlink = Not (hLink Is Nothing)
End Function
I would like to open every PowerPoint (*.pptx) in current folder and clear the Slide Master of all images and text boxes and then save.
(It says my post is mostly code so I need to add more detail, so here is a quote by George Washington, "Associate with men of good quality if you esteem your own reputation; for it is better to be alone than in bad company")
New code
Sub DeleteSlideMasterShapes()
Dim i As Long
Dim shp As Shape
With ActivePresentation
For i = .Designs.Count To 1 Step -1
For Each shp In .Designs(i).SlideMaster.Shapes
shp.Delete
Next
Next i
End With
End Sub
Sub loopFiles()
Dim fso As New FileSystemObject
Dim fil As File
Dim fold As Folder
Dim yourfolder As String
Set fold = fso.GetFolder(Application.ActivePresentation.Path)
For Each fil In fold.Files
If InStr(1, fil.Name, ".pptx") > 0 Then
Application.Presentations.Open fil.Path
Call DeleteSlideMasterShapes
ActivePresentation.Save
ActivePresentation.Close
End If
Next fil
End Sub
Another approach, in case you want to delete all the shapes from all Slide Masters AND the master's layouts:
Sub DeleteSlideMasterShapes()
' Including shapes on layouts
Dim oDes As Design
Dim oLay As CustomLayout
With ActivePresentation
' For each slide master:
For Each oDes In .Designs
' Delete the shapes on the master
oDes.SlideMaster.Shapes.Range.Delete
' Then delete the shapes from each layout under
' the slide master:
For Each oLay In oDes.SlideMaster.CustomLayouts
oLay.Shapes.Range.Delete
Next
Next
End With
End Sub
Further to my comments, if you want to delete the slide master then use this
Sub DeleteSlideMaster()
Dim i As Long
With ActivePresentation
On Error Resume Next
For i = .Designs.Count To 1 Step -1
.Designs(i).SlideMaster.Delete
Next i
On Error GoTo 0
End With
End Sub
To delete Shapes of a slidemaster, use this
Sub DeleteSlideMasterShapes()
Dim i As Long
Dim shp As Shape
With ActivePresentation
For i = .Designs.Count To 1 Step -1
For Each shp In .Designs(i).SlideMaster.Shapes
shp.Delete
Next
Next i
End With
End Sub
If I have not understood your query then please feel free to ask
I would like this particular code to be run on multiple powerpoint files in a folder. But it would be even better if it would open the powerpoint file, run this code below, save it and then open the next one. Any suggestions are welcome! I have been through code on this website, but can't seem to adapt it to my code below (e.g. this one Loop through files in a folder using VBA?)
LOOPING ATTEMPT
flag
Sub LoopThroughFiles()
Dim MyObj As Object, MySource As Object, file As Variant
file = Dir("c:\testfolder\")
While (file <> "")
If InStr(file, "test") > 0 Then
MsgBox "found " & file
Exit Sub
End If
file = Dir
Wend
End Sub
Existing Code
Option Explicit
' Selects the shape that support text which is closest to the top of the slide
' Written by Jamie Garroch of YOUpresent Ltd (http://youpresent.co.uk)
Sub SelectHigestTextShape()
Dim oSld As Slide
Dim oShp As Shape, oShpTop As Shape
Dim sShpTop As Single
On Error Resume Next
Set oSld = ActiveWindow.View.Slide
If Err Then Exit Sub
On Error GoTo 0
' Set the top to the bottom of the slide
sShpTop = ActivePresentation.PageSetup.SlideHeight
' Check each shape on the slide is positioned above the stored position
' Shapes not supporting text and placeholders are ignored
For Each oShp In oSld.Shapes
If oShp.Top < sShpTop And oShp.HasTextFrame And Not oShp.Type = msoPlaceholder Then
sShpTop = oShp.Top
Set oShpTop = oShp
End If
Next
' Select the topmost shape
If Not oShpTop Is Nothing Then oShpTop.Select msoTrue
ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
' Clean up
Set oSld = Nothing
Set oShp = Nothing
Set oShpTop = Nothing
End Sub
That's my code sample for the SelectHigestTextShape sub but I'm not sure it'll work the way you want for multiple files. The reason is that it was designed to SELECT a textbox object within the ACTIVE PRESENTATION using the ACTIVE VIEW. None of this exists when you loop through files in a folder as you'd need to open each one in turn but even then, what would be the point of selecting a shape only to close the presentation afterwards? I guess we really need to know the end goal. In the type of batch processing you're attempting, it would not be a good idea to select anything at all as that requires the object's view to be active which is a debugging nightmare and slows everything down a lot. If you want to do something with a particular object, it's much better to use a reference to it without requiring an active view or even an active window (you could open each file invisibly, process it and then close it).
This example will loop through a folder, open each presentation it finds (without a window), loop through all shapes on all slides, output a count of slides and shapes to the immediate pane, and then close the file:
' Loop through all PowerPoint files in a specified folder
' Open each and then loop through each shape of each slide
' Output a count of slides and shapes in immediate pane before closing the file
' Modified by Jamie Garroch of YOUpresent Ltd (http://youpresent.co.uk)
Sub LoopThroughPPTFiles()
Dim oPres As Presentation, oSld As Slide, oShp As Shape
Dim SldCount As Long, ShpCount As Long
Dim MyFile As String
Const MyFolder = "c:\testfolder\"
On Error GoTo errorhandler
MyFile = Dir(MyFolder)
While (MyFile <> "")
If Right(MyFile, 5) Like ".ppt*" Then
Set oPres = Presentations.Open(FileName:=MyFolder & MyFile, ReadOnly:=msoTrue, Untitled:=msoFalse, WithWindow:=msoFalse)
For Each oSld In oPres.Slides
SldCount = SldCount + 1
For Each oShp In oSld.Shapes
ShpCount = ShpCount + 1
Next
Next
Debug.Print oPres.Name & " has " & SldCount & " slide(s) and " & ShpCount & " shapes."
SldCount = 0: ShpCount = 0
oPres.Close
End If
MyFile = Dir
Wend
' clean up
Set oPres = Nothing: Set oSld = Nothing: Set oShp = Nothing
Exit Sub
errorhandler:
If Not oPres Is Nothing Then oPres.Close: Set oPres = Nothing
End Sub
You could use this to then examine the shapes after the "For Each oShp In oSld.Shapes" line to find the one positioned highest on the slide and then process it (without selecting it).