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?
Related
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...
I've successfully added shapes into cells (msoShapeOval) in a pivot table. I need to clear and recreate these shapes if the pivot / slicer selection changes. My current method works, but it is slow. Is there any better method to clear shapes in bulk? Note: I do know the exact cell range where all these shapes exist. I've also appied :
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Current code:
Dim Shp as Shape
For Each Shp In rng.Parent.Shapes
If InStrB(Shp.Name, "$") > 0 Then Shp.Delete
Next
It is possible to delete the shapes at once without selecting, with some fine tuning. Let's imagine you want to delete the rectangulars from this:
What you need to do is the following:
loop through all the objects
make an array with all the rectangular's names
delete the objects in the array
Tricky part is the looping through the objects, because you need to increment your array every time, which is not a built-in functionality (like in collection). incrementArray is the function for this.
Furthermore, the first time you increment to the unassigned array, you need to check whether it is allocated (achieved with the IsArrayAllocated function below).
Option Explicit
Sub TestMe()
Dim shp As Shape
Dim arrOfShapes() As Variant 'the () are important!
With ActiveSheet
For Each shp In .Shapes
If InStrB(shp.Name, "Rec") > 0 Then
arrOfShapes = incrementArray(arrOfShapes, shp.Name)
End If
Next
If IsArrayAllocated(arrOfShapes) Then
Debug.Print .Shapes.Range(arrOfShapes(0)).Name
.Shapes.Range(arrOfShapes).Delete
End If
End With
End Sub
The additional functions:
Public Function incrementArray(arrOfShapes As Variant, nameOfShape As String) As Variant
Dim cnt As Long
Dim arrNew As Variant
If IsArrayAllocated(arrOfShapes) Then
ReDim arrNew(UBound(arrOfShapes) + 1)
For cnt = LBound(arrOfShapes) To UBound(arrOfShapes)
arrNew(cnt) = CStr(arrOfShapes(cnt))
Next cnt
arrNew(UBound(arrOfShapes) + 1) = CStr(nameOfShape)
Else
arrNew = Array(nameOfShape)
End If
incrementArray = arrNew
End Function
Function IsArrayAllocated(Arr As Variant) As Boolean
On Error Resume Next
IsArrayAllocated = IsArray(Arr) And _
Not IsError(LBound(Arr, 1)) And _
LBound(Arr, 1) <= UBound(Arr, 1)
End Function
Credits to this guy for the finding that the arrOfShapes should be declared with parenthesis (I have spent about 30 minutes researching why I could not pass it correctly) and to CPearson for the IsArrayAllocated().
To delete all shapes except slicers:
Sub RemoveAllExceptSlicers()
Dim sh As Shape
For Each sh In ActiveSheet.Shapes
If Not sh.Type = MsoShapeType.msoSlicer Then
sh.Delete
End If
Next
End Sub
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
I am trying to replace a set of tags in the text of a powerpoint slide from Excel using VBA. I can get the slide text as follows:
Dim txt as String
txt = pptSlide.Shapes(jj).TextFrame.TextRange.Characters.text
I then run through replacing my tags with the requested values. However when I set do
pptSlide.Shapes(jj).TextFrame.TextRange.Characters.text = txt
Problem: All the formatting which the user has set up in the text box is lost.
Background:
The shape object is msoPlaceHolder and contains a range of text styles including bullet points with tags which should be replaced with numbers for instance. The VBA should be unaware of this formatting and need only concern itself with the text replacement.
Can anyone tell me on how to modify the text while keeping the style set up by the user.
Thanks.
Am using Office 2010 if that is helpful.
The solution by Krause is close but the FIND method returns a TextRange object that has to be checked. Here is a complete subroutine that replaces FROM-string with TO-string in an entire presentation, and DOESN'T mess up the formatting!
Sub Replace_in_Shapes_and_Tables(pPPTFile As Presentation, sFromStr As String, sToStr As String)
Dim sld As Slide
Dim shp As Shape
Dim i As Long
Dim j As Long
Dim m As Long
Dim trFoundText As TextRange
On Error GoTo Replace_in_Shapes_and_Tables_Error
For Each sld In pPPTFile.Slides
For Each shp In sld.Shapes
If shp.HasTextFrame Then
If shp.TextFrame.HasText Then ' only perform action on shape if it contains the target string
Set trFoundText = shp.TextFrame.TextRange.Find(sFromStr)
If Not (trFoundText Is Nothing) Then
m = shp.TextFrame.TextRange.Find(sFromStr).Characters.Start
shp.TextFrame.TextRange.Characters(m).InsertBefore (sToStr)
shp.TextFrame.TextRange.Find(sFromStr).Delete
End If
End If
End If
If shp.HasTable Then
For i = 1 To shp.Table.Rows.Count
For j = 1 To shp.Table.Columns.Count
Set trFoundText = shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Find(sFromStr)
If Not (trFoundText Is Nothing) Then
m = shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Find(sFromStr).Characters.Start
shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Characters(m).InsertBefore (sToStr)
shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Find(sFromStr).Delete
End If
Next j
Next i
End If
Next shp
Next sld
For Each shp In pPPTFile.SlideMaster.Shapes
If shp.HasTextFrame Then
If shp.TextFrame.HasText Then
Set trFoundText = shp.TextFrame.TextRange.Find(sFromStr)
If Not (trFoundText Is Nothing) Then
m = shp.TextFrame.TextRange.Find(sFromStr).Characters.Start
shp.TextFrame.TextRange.Characters(m).InsertBefore (sToStr)
shp.TextFrame.TextRange.Find(sFromStr).Delete
End If
End If
End If
If shp.HasTable Then
For i = 1 To shp.Table.Rows.Count
For j = 1 To shp.Table.Columns.Count
Set trFoundText = shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Find(sFromStr)
If Not (trFoundText Is Nothing) Then
m = shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Find(sFromStr).Characters.Start
shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Characters(m).InsertBefore (sToStr)
shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Find(sFromStr).Delete
End If
Next j
Next i
End If
Next shp
On Error GoTo 0
Exit Sub
Replace_in_Shapes_and_Tables_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Replace_in_Shapes_and_Tables of Module modA_Code"
Resume
End Sub
While what Steve Rindsberg said is true I think I have come up with a decent workaround. It is by no means pretty but it gets the job done without sacrificing the formatting. It uses Find functions and Error Controlling for any text box that doesn't have the variable you are looking to change out.
i = 1
Set oPs = oPa.ActivePresentation.Slides(oPa.ActivePresentation.Slides.Count)
j = 1
Do Until i > oPa.ActivePresentation.Slides.Count
oPa.ActivePresentation.Slides(i).Select
Do Until j > oPa.ActivePresentation.Slides(i).Shapes.Count
If oPa.ActivePresentation.Slides(i).Shapes(j).HasTextFrame Then
If oPa.ActivePresentation.Slides(i).Shapes(j).TextFrame.HasText Then
On Error GoTo Err1
If oPa.ActivePresentation.Slides(i).Shapes(j).TextFrame.TextRange.Find("[specific search term]") = "[specific search term]" Then
m = oPa.ActivePresentation.Slides(i).Shapes(j).TextFrame.TextRange.Find("[specific search term]").Characters.Start
oPa.ActivePresentation.Slides(i).Shapes(j).TextFrame.TextRange.Characters(m).InsertBefore ([replace term])
oPa.ActivePresentation.Slides(i).Shapes(j).TextFrame.TextRange.Find("[specific search term]").Delete
ExitHere:
End If
End If
End If
j = j + 1
Loop
j = 1
i = i + 1
Loop
Exit Sub
Err1:
Resume ExitHere
End Sub
Hope this helps!
I found the solution using the code below. It edits the notes by replacing "string to replace" with "new string". This example is not iterative and will only replace the first occurrence but it should be fairly easy to make it iterative.
$PowerpointFile = "C:\Users\username\Documents\test.pptx"
$Powerpoint = New-Object -ComObject powerpoint.application
$ppt = $Powerpoint.presentations.open($PowerpointFile, 2, $True, $False)
$ppt.Slides[3].Shapes[2].TextFrame.TextRange.Text
$ppt.Slides[3].NotesPage.Shapes[2].TextFrame.TextRange.Text
foreach($slide in $ppt.slides){
$TextRange = $slide.NotesPage.Shapes[2].TextFrame.TextRange
$find = $TextRange.Find('string to replace').Start
$TextRange.Find('string to replace').Delete()
$TextRange.Characters($find).InsertBefore('new string')
$TextRange.Text
}
$ppt.SaveAs("C:\Users\username\Documents\test2.pptx")
$Powerpoint.Quit()
I want to find and replace all instances of the grave accent ` with the font named Rupee Forandian
Recently the rupee symbol was launched and there is no keyboard symbol for that...
When I try the excel replace function CRTL+H with the format function, it changes the font of the entire text string, while I want it to change only the grave accent `
I found a solution for Excel, but I need a similar one for Powerpoint 2007.
The VBA used in Excel is:
Sub InsertRupeeForandianSymbol()
Dim X As Long, Cell As Range
For Each Cell In Selection
For X = 1 To Len(Cell.Value)
If Mid(Cell.Value, X, 1) = "`" Then Cell.Characters(X, 1).Font.Name = "Rupee Foradian"
Next
Next
End Sub
Easiest way to do this I can think of would be
Sub InsertRupeeForandianSymbol()
Dim oSld As Slide
Dim oShp As Shape
Dim x As Long
Dim y As Long
For Each oSld In ActivePresentation.Slides
For Each oShp In oSld.Shapes
For y = 1 To Len(oShp.TextFrame.TextRange)
If Mid(oShp.TextFrame.TextRange, y, 1) = "`" Then
oShp.TextFrame.TextRange.Characters(y).Font.Name = "Rupee Foradian"
End If
Next y
Next oShp
Next oSld
End Sub
In Powerpoint you have to iterate through Shapes to get texts:
Sub InsertRupeeForandianSymbol()
Dim sl As Slide, sh As Shape, X As Long
For Each sl In ActiveWindow.Selection.SlideRange
For Each sh In sl.Shapes
With sh.TextFrame.TextRange.Characters
For X = 1 To .Count
If .Characters(X, 1).Text = "'" Then .Characters(X, 1).Font.Name = "Rupee Forandian"
Next
End With
Next
Next
End Sub
This will change font for all currently selected slides. You may change ActiveWindow.Selection.SlideRange to ActivePresentation.Slides and apply to all slides in current presentation.