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.
Related
I'm investigating how to automatically update a visio file created with one mastershape (v1.0.vssx) to the next version of the mastershape (v1.1.vssx). When updating each master shape, use Master.Name as the key.
With the code below, I was able to open the vsdx file and vssx and open their respective Masters.
vssx_Master = vssxMaster
vsdx_shape.master = vssx_Master
I wondered if I could update the master shape with the code, but unfortunately vssxMaster is the same as vssxMaster.Name and its type is String.
Is there a way to replace the Master of one shape with another?
not work...
Sub Visio_Update(ByRef VISIOpath As String, ByRef except_sheets() As String, ByRef VSSXpath As String)
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim vsoApp As Visio.Application
Dim vsoDoc As Visio.Document
Dim vsoPage As Visio.Page
Dim vsoItemsCnt As Long
Dim vsoShape As Visio.Shape
Dim FileName As String
Dim FileText As String
FileName = Dir(VISIOpath)
FileName = Replace(FileName, ".vsdx", "")
ChDir ThisWorkbook.path
Set vsoApp = CreateObject("Visio.Application")
Call vsoApp.Documents.OpenEx(VISIOpath, visOpenRW)
Set vsoDoc = vsoApp.Documents.Item(1)
vsoItemsCnt = vsoApp.Documents.Count
Call vsoApp.Documents.OpenEx(VSSXpath, visOpenRW)
Set vssxDoc = vsoApp.Documents.Item(vsoItemsCnt + 1)
Set vssxMasters = vssxDoc.Masters
For Each vsoPage In vsoDoc.Pages
For Each vsoShape In vsoPage.Shapes
If Not (vsoShape.Master Is Nothing) Then
On Error Resume Next
mastername = vsoShape.Master.Name
vsoShape.ReplaceShape vssxMasters.Item(vsoShape.Master.Name)
If Err.Number = 0 Then
Debug.Print ("Masters.Item")
Debug.Print "updated succeeded : ", mastername
Err.Clear
Else
Debug.Print ("Masters.Item")
Debug.Print Err.Description
Err.Clear
End If
End If
Next
Next
vsoDoc.SaveAs ThisWorkbook.path & "\data\" & FileName & "_updated_.vsdx"
Application.ScreenUpdating = True
End Sub
Sub test()
choosed_path = "C:\Users\11665307\Desktop\data\vs1.vsdx"
Update_Template = "C:\Users\11665307\Documents\test.vssx"
Call Visio_Update(choosed_path, except_sheets, (Update_Template))
End Sub
I wondered if I could update the master shape with the code
You dont need iterate all masters into stencil :)
For Each vsoPage In doc.Pages
For Each vsoShape In vsoPage.Shapes
If Not (vsoShape.Master Is Nothing) Then
vsoShape.ReplaceShape vssxMasters.Item(vsoShape.Master.Name)
End If
Next
Next
You must iterate through all the shapes on the page. If the shape was created based on the master from stencil v.1.0, then replace it with the corresponding master v.1.1. using the ReplaceShape method
Sub ttt()
Dim sh As Shape
For Each sh In ActivePage.Shapes
If sh.Master.NameU = "Circle" Then sh.ReplaceShape Application.Documents.Item("BLOCK_M.vssx").Masters.ItemU("Diamond")
Next
End Sub
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
I have a folder with 10 PowerPoint presentations. Each presentation has 20-25 slides.
Suppose I have a keyword "CX404","AR50". The macro should delete all slides having that keyword in the 10 presentations.
Public Sub DoFiles()
Dim strFileName As String
Dim strFolderName As String
Dim PP As Presentation
'set default directory here if needed
strFolderName = "D:\Users\Desktop\Shaon\pptss"
strFileName = Dir(strFolderName & "\*.pptx*")
Do While Len(strFileName) > 0
Set PP = Presentations.Open(strFolderName & "\" & strFileName)
'your code
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
If oShp.HasTextFrame Then
Select Case UCase(oShp.TextFrame.TextRange)
Case Is = "CX400", "AR50"
oSld.Delete
Case Else
'not found
End Select
End If
Next oShp
Next L
PP.Close
strFileName = Dir
Loop
End Sub
I can open all ppts in the folder. I am not be able to delete slides using my specific keywords.
I have slightly modified your listing and it works for me:
Option Explicit
Public Sub DoFiles()
Dim strFileName As String
Dim strFolderName As String
Dim PP As Presentation
Dim sText As String
strFolderName = "D:\111\"
strFileName = Dir(strFolderName & "\*.pptx*")
sText = "TEST"
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
PP.Save
PP.Close
strFileName = Dir
Loop
End Sub
I would like to loop through all the ppt from a folder and delete a string if found in any textbox in any slide.
I am new to working with powerpoint slides hence need some tips and advice how to work with it.
Option Compare Text
Option Explicit
Sub Test()
Dim Sld As Slide, Shp As Shape
Dim strFileName As String
Dim strFolderName As String
Dim PP As Presentation
Dim strf As String
'String to be deleted.
strf = InputBox("Enter the string.", "Delete String from PPT.", "AAAAA")
'Opens a PowerPoint Document from Excel
Dim objPPT As Object
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True
'set default directory here if needed
strFolderName = "C:\Users\Desktop\Files"
strFileName = Dir(strFolderName & "\*.ppt*")
Do While Len(strFileName) > 0
objPPT.Presentations.Open strFolderName & "\" & strFileName
objPPT.Presentations.Activate
For Each Sld In ActivePresentation.Slides 'Error - ActiveX Component can't create object.
For Each Shp In Sld.Shapes
Select Case Shp.Type
Case MsoShapeType.msoTextBox
Debug.Print Sld.Name, Shp.Name, Shp.TextFrame.TextRange.Text
Case Else
Debug.Print Sld.Name, Shp.Name, "This is not a text box"
End Select
Next Shp
Next Sld
objPPT.Presentations.Close
strFileName = Dir
Loop
End Sub
As you are running the macro in Excel, you forgot to say where the ActivePresentation is from. It should work if you have objPPT.ActivePresentation.Slides. Anyway, you can try below revised code:
'Option Compare Text
Option Explicit
Sub Test()
'Dim Sld As Slide, Shp As Shape ' <-- Excel doesn't know Slide if Reference not added
Dim Sld As Object, Shp As Object
Dim strFileName As String
Dim strFolderName As String
'Dim PP As Presentation
Dim PP As Object ' Use this Presentation Object!
Dim strf As String
'String to be deleted.
strf = InputBox("Enter the string.", "Delete String from PPT.", "AAAAA")
'Opens a PowerPoint Document from Excel
Dim objPPT As Object
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True ' <-- don't need this, for debug only
'set default directory here if needed
strFolderName = "C:\Users\Desktop\Files"
strFileName = Dir(strFolderName & "\*.ppt*")
Do While Len(strFileName) > 0
'objPPT.Presentations.Open strFolderName & "\" & strFileName
Set PP = objPPT.Presentations.Open(strFolderName & "\" & strFileName)
'objPPT.Presentations.Activate
PP.Activate ' <-- don't need this, for debug only
'For Each Sld In ActivePresentation.Slides 'Error - ActiveX Component can't create object.
' Should work if it's "objPPT.ActivePresentation.Slides"
For Each Sld In PP.Slides
For Each Shp In Sld.Shapes
With Shp
Select Case .Type
Case MsoShapeType.msoTextBox
If InStr(1, .TextFrame.TextRange.Text, strf, vbTextCompare) > 0 Then
Debug.Print Sld.Name, .Name, .TextFrame.TextRange.Text
Else
Debug.Print Sld.Name, .Name, """" & strf & """ not found in text body"
End If
Case Else
Debug.Print Sld.Name, .Name, "This is not a text box"
End Select
End With
Next Shp
Next Sld
'objPPT.Presentations.Close
PP.Close
Set PP = Nothing
strFileName = Dir
Loop
End Sub
UPDATE - To allow processing files already opened and some tweaks:
Option Explicit
Sub Test()
Const strFolderName = "C:\Users\Desktop\Files\"
Dim objPPT As Object, PP As Object, Sld As Object, Shp As Object
Dim strFileName As String
Dim strf As String
'String to be deleted.
strf = InputBox("Enter the string.", "Delete String from PPT.", "AAAAA")
If Len(Trim(strf)) = 0 Then Exit Sub ' Exit if blank text returned
'Opens a PowerPoint Document from Excel
Set objPPT = CreateObject("PowerPoint.Application")
'set default directory here if needed
strFileName = Dir(strFolderName & "*.ppt*")
Do While Len(strFileName) > 0
On Error Resume Next
' Try to get existing one with same name
Set PP = objPPT.Presentations(strFileName)
' If not opened, try open it
If PP Is Nothing Then Set PP = objPPT.Presentations.Open(strFolderName & strFileName)
On Error GoTo 0
' Process the Presentation Slides if it's opened
If PP Is Nothing Then
Debug.Print "Cannot open file! """ & strFolderName & strFileName & """"
Else
Application.StatusBar = "Processing PPT file: " & PP.FullName
Debug.Print String(50, "=")
Debug.Print "PPT File: " & PP.FullName
For Each Sld In PP.Slides
For Each Shp In Sld.Shapes
With Shp
If .Type = MsoShapeType.msoTextBox Then
If InStr(1, .TextFrame.TextRange.Text, strf, vbTextCompare) > 0 Then
Debug.Print Sld.Name, .Name, .TextFrame.TextRange.Text
Else
Debug.Print Sld.Name, .Name, """" & strf & """ not found in text body"
End If
End If
End With
Next Shp
Next Sld
PP.Close ' Close the Presentation
Set PP = Nothing
End If
strFileName = Dir
Loop
Application.StatusBar = False
' Quit PowerPoint app
objPPT.Quit
Set objPPT = Nothing
End Sub
I cannot explain the error you are getting. I also would have expected the code to work. Yet, I stumbled upon this problem before and found the following solution which (strangely) works:
Option Compare Text
Option Explicit
Sub Test()
Dim Sld As Long, Shp As Long
Dim strFileName As String
Dim strFolderName As String
Dim PP As PowerPoint.Presentation
Dim strf As String
'String to be deleted.
strf = InputBox("Enter the string.", "Delete String from PPT.", "AAAAA")
'Opens a PowerPoint Document from Excel
Dim objPPT As PowerPoint.Application
Set objPPT = New PowerPoint.Application
objPPT.Visible = True
'set default directory here if needed
strFolderName = "C:\Users\Desktop\Files"
strFileName = Dir(strFolderName & "\*.ppt*")
Do While Len(strFileName) > 0
Set PP = objPPT.Presentations.Open(strFolderName & "\" & strFileName)
'objPPT.Presentations.Activate
For Sld = 1 To PP.Slides.Count
For Shp = 1 To PP.Slides.Item(Sld).Shapes.Count
With PP.Slides.Item(Sld).Shapes.Item(Shp)
Select Case .Type
Case MsoShapeType.msoTextBox
Debug.Print .Name, .Name, .TextFrame.TextRange.Text
Case Else
Debug.Print .Name, .Name, "This is not a text box"
End Select
End With
Next Shp
Next Sld
PP.Close
Set PP = Nothing
strFileName = Dir
Loop
objPPT.Quit
Set objPPT = Nothing
End Sub
Note: this solution uses early binding instead of late binding. So, you will need to add a reference to Microsoft PowerPoint xx.x Object Library.
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).