Suppose I wanted to delete specific type files, like JPEG images across specific slides; not sure how to go about this; this what I'm using:
Dim osld As Slide
Dim opic As Shape
Dim lngCount As Long
On Error GoTo err
err.Clear
For Each osld In ActiveWindow.Selection.SlideRange
For lngCount = osld.Shapes.Count To 1 Step -1
Set opic = osld.Shapes(lngCount)
Select Case opic.Type
Case Is = msoBlogImageTypeJPEG
opic.Delete
End Select
Next lngCount
Next osld
Exit Sub
err:
MsgBox "Did you select slides?"
End Sub
Related
I am trying to copy all true or checked boxes on all slides and paste them onto one slide within my presentation. I can't seem to figure it out. Below is the code that I am using. Any help is appreciated.
`Sub ckbxCopy()
Dim shp As Shape
Dim sld As Slide
Dim i As Integer
On Error Resume Next
For Each sld In ActivePresentation.Slides
For i = 1 To 4
shp = ActivePresentation.Slides("CheckBox" & CStr(i))
If Err.Number = 0 Then ' shape exists
If shp.OLEFormat.Object.Value = True Then
shp.Copy
ActivePresentation.Slides(3).Shapes.Paste
End If
End If
Next i
Next sld
End Sub`
This works for me:
Sub ckbxCopy()
Dim shp As Shape, pres As Presentation
Dim sld As Slide, sldDest As Slide
Dim i As Integer, t As Long
Set pres = ActivePresentation
Set sldDest = pres.Slides(3) 'where shapes are to be pasted
sldDest.Shapes.Range.Delete 'remove existing shapes
t = 20
For Each sld In pres.Slides
If sld.SlideIndex <> sldDest.SlideIndex Then
For i = 1 To 4
Set shp = Nothing
Set shp = SlideShape(sld, "CheckBox" & CStr(i))
If Not shp Is Nothing Then
If shp.OLEFormat.Object.Value = True Then
shp.Copy
pres.Slides(3).Shapes.Paste.Top = t 'paste and position
t = t + 20
End If
End If
Next i
End If
Next sld
End Sub
'Return a named shape from a slide (or Nothing if the shape doesn't exist)
Function SlideShape(sld As Slide, shapeName As String) As Shape
On Error Resume Next
Set SlideShape = sld.Shapes(shapeName)
End Function
I am trying to delete ppt slides using specific keywords.my code is given below:
Private Sub CommandButton1_Click()
Dim strFileName As String
Dim strFolderName As String
Dim PP As Presentation
Dim ppMaster
Dim sText As Variant
strFolderName = "D:\Shaon_Paul\pptss"
strFileName = Dir(strFolderName & "\*.pptx*")
sText = InputBox("Give me some input")
Do While Len(strFileName) > 0
Set PP = Presentations.Open(strFolderName & "\" & strFileName)
Dim oSld As Slide
Dim oShp As Shape
Dim L As Long
For L = ActivePresentation.Slides.Count To 1 Step -1
Set oSld = ActivePresentation.Slides(L)
For Each oShp In oSld.Shapes
On Error Resume Next
If oShp.HasTextFrame Then
If UBound(Split(oShp.TextFrame.TextRange, sText)) > 0 Then
PP.Slides(L).Delete
End If
End If
Next oShp
Next L
Set ppMaster = PP.SlideMaster
With ppMaster
If UBound(Split(.HeadersFooters.Footer.Text, sText)) > 0 Or UBound(Split(.HeadersFooters.Header.Text, sText)) > 0 Then
PP.Slides(L).Delete
End If
End With
PP.Save
PP.Close
strFileName = Dir
Loop
End Sub
Now this code will open a input box where I have to give my keywords and It will delete the slides in a ppt available in the folder where I have mentioned the path name.
Unfortunately while debugging the code
If UBound(Split(oShp.TextFrame.TextRange, sText)) > 0 Then
PP.Slides(L).Delete
End If
it will jump without executing this code above and unable to delete the slide by giving specific keyword name. Need help to resolve this issue.
Trying to change the Excel source file for charts and objects linked in a PowerPoint deck.
I found this:
Sub ChangeOLELinks()
Dim oSld As Slide
Dim oSh As Shape
Dim sOldPath As String
Dim sNewPath As String
' EDIT THIS TO REFLECT THE PATHS YOU WANT TO CHANGE
sOldPath = InputBox("Enter Old Project ie: \Development\", "Old Path")
sNewPath = InputBox("Enter New Project ie: \Test\", "New Path")
On Error GoTo ErrorHandler
For Each oSld In ActivePresentation.Slides
For Each oSh In oSld.Shapes
If oSh.Type = msoLinkedOLEObject Then
Dim stringPath As String
stringPath = Replace(oSh.LinkFormat.SourceFullName, sOldPath, sNewPath, 1, , vbTextCompare)
oSh.LinkFormat.SourceFullName = stringPath
' set update mode to auto and update then set it back to manual
oSh.LinkFormat.AutoUpdate = ppUpdateOptionAutomatic
oSh.LinkFormat.Update
oSh.LinkFormat.AutoUpdate = ppUpdateOptionManual
End If
Next oSh
Next oSld
ActivePresentation.Save
MsgBox ("Done!")
NormalExit:
Exit Sub
ErrorHandler:
MsgBox ("Error " & Err.Number & vbCrLf & Err.Description)
Resume NormalExit
End Sub
This works for OLE objects/links. It isn't updating any of the linked charts.
How can I include charts?
As your charts are paste-linked (4th option) from Excel, they're of msoChart type.
The LinkFormat.SourceFullName property works for this type too so you just have to replace your
If oSh.Type = msoLinkedOLEObject
with
if oSh.Type = msoChart
I have some objects named"MYobject" in a PowerPoint presentation. I need a macro to delete those objects named "Myobject". How can I do that?
The code I use to tag objects:
Sub TagObject()
On Error GoTo ErrorHandler
Dim oSh As Shape
For Each oSh In ActiveWindow.Selection.ShapeRange
oSh.Tags.Add "Myobject", "YES"
Next
MsgBox "Done! Object has now been tagged.", vbInformation
Exit Sub
ErrorHandler:
MsgBox "Please select an object before tagging.", vbExclamation
End Sub
This will delete all shapes with a Myobject tag = "YES"
Sub DeleteMyObjects()
Dim oSl As Slide
Dim oSh As Shape
Dim x As Long
' note that this will not delete shapes
' within groups
For Each oSl In ActivePresentation.Slides
For x = oSl.Shapes.Count To 1 Step -1
If UCase(oSl.Shapes(x).Tags("Myobject")) = "YES" Then
oSl.Shapes(x).Delete
End If
Next ' Shape
Next ' Slide
End Sub
I'm getting a type mismatch 13 error in the line that loops through the shapes in a slide. I can see that the oSh is Nothing, but if I .Count the shapes, there are plenty of shapes in the slide. How does this make sense?
Brief code:
Dim oPP As PowerPoint.Presentation
Dim oS As Slide
Dim oSh As Shape
For Each oS In oPP.Slides
For Each oSh In oS.Shapes '<-- this line is the error line
On Error Resume Next
If oSh.Type = 14 _
Or oSh.Type = 1 Then
'do stuff
End If
On Error GoTo 0
Next oSh
Next oS
Full code:
Sub PPLateBinding()
Dim pathString As String
'no reference required
Dim PowerPointApplication As PowerPoint.Application
Dim oPP As PowerPoint.Presentation
Dim oS As Slide
Dim oSh As Object
Dim pText As String
Dim cellDest As Integer
Dim arrBase() As Variant
Dim arrComp() As Variant
ReDim Preserve arrBase(1)
ReDim Preserve arrComp(1)
Dim fd As FileDialog
Dim FileChosen As Integer
Dim FileName As String
Dim iPresentations As Integer
Set fd = Application.FileDialog(msoFileDialogFilePicker)
'use the standard title and filters, but change the
fd.InitialView = msoFileDialogViewList
'allow multiple file selection
fd.AllowMultiSelect = True
FileChosen = fd.Show
If FileChosen = -1 Then
'open each of the files chosen
For iPresentations = 1 To fd.SelectedItems.Count
'On Error Resume Next
Set PowerPointApplication = CreateObject("PowerPoint.Application")
Set oPP = PowerPointApplication.Presentations.Open(fd.SelectedItems(iPresentations))
If Err.Number <> 0 Then
Set oPP = Nothing
End If
If Not (oPP Is Nothing) Then
cellDest = 0
'We assume PP is already open and has an active presentation
For Each oS In oPP.Slides
'Debug.Print oPP.Slides.Count
If oS.Shapes.Count > 0 Then
Debug.Print oS.Shapes.Count
For Each oSh In oS.Shapes
Debug.Print "hey"
On Error Resume Next
If oSh.Type = 14 Or oSh.Type = 1 Then
pText = oSh.TextFrame.TextRange.Text
ReDim Preserve arrBase(UBound(arrBase) + 1)
arrBase(UBound(arrBase)) = pText
'Debug.Print pText
ElseIf (oSh.HasTable) Then
Dim i As Integer
For i = 2 To oSh.Table.Rows.Count
ReDim Preserve arrComp(UBound(arrComp) + 1)
arrComp(UBound(arrComp)) = Replace(oSh.Table.Cell(i, 1).Shape.TextFrame.TextRange.Text, vbLf, "") & ":::" & oSh.Table.Cell(i, 3).Shape.TextFrame.TextRange.Text
Next i
End If
On Error GoTo 0
Next oSh
'x = InputData(arrBase, arrComp)
End If
Next oS
'Debug.Print tbl.Shape.TextFrame.TextRange.Text '.Cell(1, 1).Shape.TextRange.Text
oPP.Close
PowerPointApplication.Quit
Set oPP = Nothing
Set PowerPointApplication = Nothing
End If
Next iPresentations
End If
End Sub
Excel has its own Shape type (which is not the same as PowerPoint.Shape type), so you should change
Dim oSh As Shape
to (for earlier binding)
Dim oSh As PowerPoint.Shape
or (for late binding)
Dim oSh As Object
Also note, if you're going to use powerpoint with late binding (as suggests your function name Sub PPLateBinding()), you should change all types PowerPoint.Something to Object (unless you add reference to powerpoint object model, but in this case I don't see any reason for using late binding).