I would like do detele all picture png from an active window from MS Visio in VBA so I tried this:
Sub DeleteAllShapes()
Dim vsoSelection As Visio.Selection
Set vsoSelection = ActiveWindow.Selection
Dim shp As Shape
For Each shp In vsoSelection
If shp.Type <> msoPicture Then shp.Delete
Next shp
End Sub
But it deletes just the last select and not all in the page
When deleting shapes you need to use a plain For loop and count backwards.
For shp = vsoSelection.Count To 1 Step -1
more code
Next shp
Related
Goal:
-Loop through presentation checking each slide for a certain title
-Once title is found
-Copy the shapes for the charts and footnote
-Then paste them into a separate presentation.
Notes:
-The slides in the presentations don't have titles but are located at Shapes(1)
-I receive a
run-time error '-2147024809 (80070057)': The specified value is out of
range.
-This error occurs on the line of the If statement
Sub library_update()
Dim NTppt As Presentation
Set NTppt = Application.Presentations("Z:\NTPath\NLibrary.pptx")
Dim ppt As Presentation
Set ppt = Application.Presentations("Z:\NTPath\Library.pptm")
Dim sld as slide
For Each sld In NTppt.Slides
If sld.Shapes(1).TextFrame.TextRange.Text = "Fixed Income - Yield Curves" Then
With NTppt
sld.Shapes.Range(Array(2, 3)).Copy
ppt.Slides(1).Shapes.Paste
End With
End If
Next sld
End Sub
The solution below worked. I am not sure why my code produced the original run time error but I assume it has something to do with not finding shapes(1) in some of my powerpoint slides.
To fix the problem, I searched for "Fixed Income - Yield Curves" in all shapes of all slides.
Sub library_update()
Dim NTppt As Presentation
Set NTppt = Application.Presentations("Z:\NTPath\NLibrary.pptx")
Dim ppt As Presentation
Set ppt = Application.Presentations("Z:\NTPath\Library.pptm")
Dim sld As Slide
Dim shp As Shape
For Each sld In NTppt.Slides
For Each shp In sld.Shapes
If shp.HasTextFrame Then
Set txt_range = shp.TextFrame.TextRange
'Confirm exact spelling and capitalization of the slides or an error will return
If txt_range = "Fixed Income – Yield Curves" Then
With NTppt
sld.Shapes.Range(Array(2, 3)).Copy
ppt.Slides(2).Shapes.Paste
End With
End If
End If
Next shp
Next sld
End Sub
I want to delete everything in my powerpoint presentation, except the charts that are already there. I have been searching for day with no avail.
I did however find this VBA that deletes all charts. Unfortunately, it is the opposite of what I am trying to achieve. I have tried using VBA found in other code and adding it, but nothing helps. Any help would be much appreciated.
Sub RemoveAllCharts()
Dim sld As Slide
Dim i, num
'Loop Through Each Slide in ActivePresentation
For Each sld In ActivePresentation.Slides
num = sld.Shapes.Count
For i = num To 1 Step -1
If sld.Shapes(i).HasChart Then
sld.Shapes(i).Delete
End If
Next i
Next sld
End Sub
You might be able to add a Not to achieve this, i.e. change
If sld.Shapes(i).HasChart Then
to
If Not sld.Shapes(i).HasChart Then
Sub RemoveAllButCharts()
Dim sld As Slide
Dim i As Long, num As Long
'Loop Through Each Slide in ActivePresentation
For Each sld In ActivePresentation.Slides
num = sld.Shapes.Count
For i = num To 1 Step -1
If Not sld.Shapes(i).HasChart Then
sld.Shapes(i).Delete
End If
Next i
Next sld
End Sub
Is there a way to add periods to the whole PowerPoint presentation excluding the titles of each slide?
I currently am using the below code which puts a period after everything:
Sub AddPeriod()
Dim sld As Slide
Dim shp As Shape
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
shp.TextFrame.TextRange.AddPeriods
Next shp
Next sld
End Sub
The easiest way I found to do this is:
Sub AddPeriod()
Dim sld As Slide
Dim shp As Shape
Dim strTitle As String
For Each sld In ActivePresentation.Slides
If sld.Shapes.HasTitle = True Then 'check if there is a title
strTitle = sld.Shapes.Title.TextFrame.TextRange.Text
Else
strTitle = ""
End If
For Each shp In sld.Shapes
'add periods only if text of shape is not equal to title text.
If strTitle <> shp.TextFrame.TextRange.Text Then
shp.TextFrame.TextRange.AddPeriods
End If
Next shp
Next sld
End Sub
This will check the text of the title vs. the text of your shape. If they are the same, it will not add the periods. Perhaps there is some sort of indicator on the shape that states whether the shape is the title, but I couldn't find it. You need to check to make sure the slide has a title, otherwise getting the string from the text of the title shape will cause an error.
I'm trying to create a macro in word that deletes everything other than text.
So charts/tables/excel tables/images.
I've tried recording one and manipulating it but to no avail.
This is working for images & charts but not tables/excel tables.
Sub deleteimages()
Dim i As Integer
With ActiveDocument
For i = 1 To .InlineShapes.Count
.InlineShapes(i).ConvertToShape
Next i
Dim Shp As Shape
For Each Shp In ActiveDocument.Shapes
If Shp.Type = msoTextBox Then Shp.Delete
Next Shp
For Each Shp In ActiveDocument.Shapes
If Shp.Type = msoTable Then Shp.Delete
Next Shp
ActiveDocument.Shapes.SelectAll
Selection.Delete
End With
End Sub
For tables, use this:
Sub deletetables()
Dim i As Integer
With ActiveDocument
For i = .Tables.Count To 1 Step -1
.Tables(i).Delete
Next i
End With
End Sub
The same logic use for charts and other objects.
For further information, please see: Word Object Model Reference
By The Way: i suggest to delete objects starting from the last one, because of set of reasons. Another way is to use Do While... loop:
Do While ActiveDocument.Tables.Count>1
ActiveDocument.Tables(1).Delete
Loop
This macro deletes Charts, MS Tables, Excel copied tables & images.
Sub deleteNoise()
Dim objPic As InlineShape
For Each objPic In ActiveDocument.InlineShapes
objPic.Delete
Next objPic
Dim tbl As Table
For Each tbl In ActiveDocument.Tables
tbl.Delete
Next tbl
Dim shp As Shape
ActiveDocument.Shapes.SelectAll
Selection.Delete
End Sub
I'm new to PowerPoint VBA so please bear with me.
I would like to:
loop through all the slides on a given pptx,
loop through all the shapes on a given slide,
find chart shapes
loop through the chart's series collection
set the datalabel color property to dark black.
So far I have been able to complete the first 3 tasks but I need help with the last 2. Here is my code:
Sub test()
Dim slide As Object
Dim shape As Object
Dim shapeNames As Object
Dim chSeries As Series
i = 0
For Each slide In ActivePresentation.Slides
For Each shape In slide.Shapes
If shape.HasChart Then
i = i + 1
Debug.Print "found a chart on slide", i
End If
Next
Next
End Sub
Solved.
Sub test()
Dim sld As Slide
Dim shp As Shape
Dim sr As Series
Dim chrt As Chart
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.HasChart Then
Debug.Print shp.Chart.ChartType
If shp.Chart.ChartType = 57 Then
shp.Chart.SeriesCollection(1).DataLabels.Font.Color = RGB(0, 0, 0)
End If
End If
Next shp
Next sld
End Sub
Though I didn't successfully loop over the series in chart but this works.