Setup: I have a PowerPoint (16.0.4266.1001) presentation containing 8 identical slides. Each slide contains a lot of rectangles containing the text 1 (see https://imgur.com/a/7AQcXFR). Each rectangle's boldness is randomly set (via a macro, if that matters: https://pastebin.com/embed_js/6qcVa1xj).
Goal: I would like to find the fastest to set all rectangles' boldness to specific values. To test things, I have two macros (DoItSlow and DoItFast) that set everything to bold, in two different ways.
DoItSlow traverses shape by shape and sets the boldness for each shape.
Sub DoItSlow()
On Error Resume Next
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
shp.TextFrame2.TextRange.Font.Bold = msoTrue
Next shp
Next sld
End Sub
DoItFast selects all shapes per slide, and applies boldness at once.
Sub DoItFast()
On Error Resume Next
For Each sld In ActivePresentation.Slides
sld.Shapes.Range.TextFrame2.TextRange.Font.Bold = msoTrue
Next sld
End Sub
Both macros acchieve what I want, but DoItFast needs about 5 seconds, whereas DoItSlow needs about 20 seconds: So apparently batch-processing is much faster than doing it one by one. Could I acchieve the same speed while keeping the one-by-one approach?
Background: In the end, I do not want to set everything to bold, but decide on a per-rectangle-basis, and I'd prefer keeping work as local as possible without even touching the selection.
Solution to increase to make the bolding code faster is to firstly create an array of the shapes to be bolded and do the bolding after that, at once, using the mentioned array.
Please, test the next two ways of bolding half of the shapes:
Bolding each of them per iteration:
Sub testBoldByIteration()
Dim sl As Slide, shp As Shape, i As Long, t
Set sl = ActivePresentation.Slides(1)
sl.Shapes.Range.TextFrame2.TextRange.Font.Bold = msoFalse
t = Timer
For Each shp In sl.Shapes
i = i + 1
If i Mod 2 = 0 Then shp.TextFrame.TextRange.Font.Bold = msoTrue
Next
Debug.Print Timer - t
End Sub
Placing the shapes to be bolded in an array and bold them at the end, at once:
Sub testBoldByArray()
Dim sl As Slide, arrSh() As Long, i As Long, k As Long, t
Set sl = ActivePresentation.Slides(1)
sl.Shapes.Range.TextFrame2.TextRange.Font.Bold = msoFalse
ReDim arrSh(sl.Shapes.Count)
t = Timer
For i = 1 To sl.Shapes.Count
If i Mod 2 = 0 Then arrSh(k) = i: k = k + 1
Next
ReDim Preserve arrSh(k - 1)
sl.Shapes.Range(arrSh).TextFrame2.TextRange.Font.Bold = msoTrue
Debug.Print Timer - t
End Sub
The difference should be huge, for a big number of shapes...
Related
I'd like to change the proprieties of the lines in my schematics.
The code works, except if lines are in a group.
Dim shp As Visio.Shape
For Each shp In Visio.ActiveWindow.Selection
'// Add cell and formula/results here:
shp.Cells("linecolor") = 0
Next shp
Set shp = Nothing
End Sub
For each shape you need to check the number of shapes within the group, viz.
shp.shapes.count > 0
then iterate over those shapes setting your line color there as well.
For each shp2 in shp.shapes
Of course, each of these shapes may also be a group, so a recursive routine is called for here.
Here's my final code, in case someone else will be looking for the same problem:
For Each shp In Visio.ActiveWindow.Selection
shapeCount = shp.Shapes.Count
If shapeCount > 0 Then
For Each shp2 In shp.Shapes
'// Add cell and formula/results here:
shp2.Cells("linecolor") = 0
Next shp2
End If
Next shp
I have a lot of slides in Powerpoint. All have MS Object Connections to Excel tables. I am looking for a code, to changes the size and position of all this objects. I have some code already. But the problem is its also changes the size and position of texts. Do someone know how to changes it?
Sub ResizeAll()
For Each tSlide In ActiveWindow.Presentation.Slides
tSlide.Select
With tSlide.Shapes.Item(1)
'assume a blank slide with one image added only
.Select
.Height = 72 * 1000.39
.Width = 72 * 10.67
'algin middle (Horizontal Center)
.Left = 100
.Top = ActivePresentation.PageSetup.SlideHeight / 5
End With
Next
End Sub
I'd stay away from using the Selection object. This code checks that the shape is an OLE object, then resizes only that shape. If this doesn't answer your question, please clarify "also changes the size and position of texts".
Sub EnlargeExcelTables()
Dim oSlide As Slide
Dim oShape As Shape
For Each oSlide In ActivePresentation.Slides
For Each oShape In oSlide.Shapes
If oShape.Type = msoLinkedOLEObject Then
With oShape
'Insert Size process here.
End With
End If
Next oShape
Next oSlide
End Sub
Apologies for a badly researched question, but I have little knowledge of VBA in general and VBA in PowerPoint in particular and am stuck with what are probably basic concepts.
I'm trying to conditionally format all tables in my presentation, and am adapting this code from a SuperUser answer for my problem.
I've come up with this basic macro:
Sub FormatTheTable(oTbl As Table)
Dim x As Long
Dim y As Long
With oTbl
For x = 1 To .Rows.Count
For y = 1 To .Columns.Count
If .Cell(x, y).Shape.TextFrame.HasText Then
If CDbl(.Cell(x, y).Shape.TextFrame.TextRange.Text) > 0 Then
.Cell(x, y).Shape.Fill.ForeColor.RGB = RGB(255, 0, 0)
End If
End If
Next ' Column
Next ' Row
End With ' otbl
End Sub
Sub DoIT()
Dim sld As Slide
Dim shp As Shape
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.HasTable Then
FormatTheTable (shp.Table)
End If
Next shp
Next sld
End Sub
I don't think I'm calling the FormatTheTable function correctly, but I have no idea how it would be done correctly. Any help is much appreciated!
This line:
FormatTheTable (shp.Table)
Should be:
FormatTheTable shp.Table
Because you are not calling a procedure of type Function which returns a value but a Sub which does not. If it were a function, this would have been ok:
myValue = FormatTheTable (shp.Table)
Also this line looks a bit odd:
If CDbl(.Cell(x, y).Shape.TextFrame.TextRange.Text) > 0 Then
So you're checking each cell for the existence of text and if there is text, you're trying to convert the text to a number? That will raise an error. What are you trying to test for in that line?
I've just inherited an Excel app that draws an org chart. Each shape is connected by a Line
However, I need to remove the shadow that is drawn when each line is added. How do I get a collection of Lines so that I can do something like
Line.Shadow.Transparency = 1.0
I'm a bit of a vba newbie :-)
This should do the trick - it loops through all shapes, checks if they're a line, then removes the shadow.
Sub test()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim shapeObj
For Each shapeObj In ActiveSheet.Shapes
If shapeObj.Type = 9 Then
Dim objName$
objName = shapeObj.Name
ws.Shapes.Range(Array(objName)).Shadow.Visible = msoFalse
End If
Next shapeObj
End Sub
Edit: Turns out, per OP, the shapes are grouped, so he used this to get it:
Sub RemoveLineShadows()
For Each Shp In ORG.Shapes
If Shp.Type = msoGroup Then
For X = 1 To Shp.GroupItems.Count
If Shp.GroupItems(X).Type = msoLine Then
Shp.GroupItems(X).Shadow.Transparency = 1
End If
Next X
End If
Next Shp
End Sub
Sub qqq()
Dim x As Shape
For Each x In ActiveSheet.Shapes
x.Shadow.Visible = msoFalse
Next
End Sub
So I have written the following code to make the textboxes in my presentation visisible and then bring them to the front (they are made invisible by a separate macro):
Dim oSld As Slide
Dim oShp As Shape
Dim oPPT As Presentation
For Each oSld In ActivePresentation.Slides
For Each oShp In oSld.Shapes
If oShp.Type = msoTextBox Then
oShp.Visible = True
oShp.ZOrder msoBringToFront
End If
Next oShp
Next oSld
It worked perfectly before I added the bring to front command! Now only around half of the shapes are made visible when the code is run. I've been reading around online and it appears that ZOrder changes the number of shapes and that is why only some are made visible.... but cannot work out a way around it! Would really appreciate some help!
You've put your finger on the cause. The For Each/Next loop appears to take a snapshot of the shape order at the time it starts. If you change the shape order or delete shapes in the body of the loop it throws things off. Instead, try something like the (untested)(air)code below to build an array of references to the shapes and then process them one at a time from the array:
Dim aShapeArray() as Shape
Dim x as Long
ReDim aShapeArray(1 to oSld.Shapes.Count) as Shape
' Build an array of shapes
For Each oShp In oSld.Shapes
Set aShapeArray(x) = oShp
x = x+1
Next
' Then do what you need to do with each shape in the array
For x = 1 to Ubound(aShapeArray)
Set oShp = aShapeArray(x)
If oShp.Type = msoTextBox Then
oShp.Visible = True
oShp.ZOrder msoBringToFront
End If
Next
Thanks for all your help #SteveRindsberg, a couple a tweaks to your code and i cracked it :)
Dim oSld As Slide
Dim aShapeArray()
Dim x As Long
For Each oSld In ActivePresentation.Slides
x = 1
If oSld.Shapes.Count > 0 Then
ReDim aShapeArray(1 To oSld.Shapes.Count)
' Build an array of shapes
For Each oShp In oSld.Shapes
Set aShapeArray(x) = oShp
x = x + 1
Next
' Then do what you need to do with each shape in the array
For x = 1 To UBound(aShapeArray)
Set oShp = aShapeArray(x)
If oShp.Type = msoTextBox Then
oShp.Visible = True
oShp.ZOrder msoBringToFront
End If
Next
End If
Next