PowerPoint macro to toggle multi words on slide to change font size & color in order from left to right. MouseOver toggles the change - vba

I’m creating reading materials using PPT slide. Each slide contains a series of rectangle shapes containing a word - text color is black.Rectangles are named 1, 2, 3, 4, 5, 6 … Rectangle shapes run across the page. Macro MouseOver is assigned to all rectangle shape on slide. At the start of presentation: 1. several global variables are set. 2.Rectangle named 1 will increase in font size, text color to red. Mouseover on Rectangle 1, font size & font color returns to original size & color for Rectangle 1 and Rectangle 2, increase font size & change text color to red. When mouseover Rectangle 2, change font size & font color returns to original size for Rectangle 2 and for Rectangle 3, increase font size & change text color to red. In general, mouseover returns text to normal size & color and change color & size of next word in order. The order is 1, 2, 3 ... based on the name of Rectangles.
Thank you.
Trying to code with code found on website:
Update: I got StartSetUp to work. Having trouble declaring global variables - NumCnt & Last. I just discover Visual Studio Editor to type in code. Editor is a big help. Will work on MouseOver tomorrow.
Update 9/10/2022: Got it working. Need more testing. Macro is not pretty. I'm new to PPT. I learned a lot reading all the questions and answers on this site. Thank you everyone!
Update 9/11/2022: I believe it works. Closing.
Public NumCnt As Integer
Public Last As Integer
Public Sub Setting(ByRef oGraphic As Shape)
NumCnt = 1
Last = 3
Debug.Print "In Setting"
Debug.Print NumCnt
Debug.Print Last
SetBig(ByRef oGraphic As Shape)
End Sub
Public Sub SetBig(ByRef oGraphic As Shape)
Dim RGBColorBig As Long
Dim RGBColorSmall As Long
Dim oSld As Slide
Dim oShp As Shape
Dim RGBColorBig As Long
Dim NameStr As String
'
'For debug
Debug.Print "in TextHover"
Debug.Print "Last is " Last
Debug.Print "NumCnt is "; NumCnt; ""
'For debug
'
RGBColorBig = RGB(255, 0, 0)
RGBColorSmall = RGB(0, 0, 0)
Set oSld = oGraphic.Parent
'
' Find first word. Change font text size and font color
'
For Each oShp In oSld.Shapes
NameStr = oShp.Name
If NameStr = CStr(NumCnt) Then
If oShp.HasTextFrame Then
If oShp.TextFrame.HasText Then
With oShp.TextFrame.TextRange.Font
.Size = 30
.Color.RGB = RGBColorBig
End With
End If
End If
Exit Sub
End If
Next
End Sub
Public Sub TextHover2(ByRef oGraphic As Shape)
Dim oSld As Slide
Dim oShp As Shape
Dim RGBColorBig As Long
Dim RGBColorSmall As Long
Dim NameStr As String
'
'For debug
Debug.Print "in TextHover"
Debug.Print "Last is " Last
Debug.Print "NumCnt is "; NumCnt; ""
'For debug
'
RGBColorBig = RGB(255, 0, 0)
RGBColorSmall = RGB(0, 0, 0)
Set oSld = oGraphic.Parent
If NumCnt = 1 Then
NameStr = oGraphic.Name
If NameStr = CStr(NumCnt) Then
If oGraphic.HasTextFrame Then
If oGraphic.TextFrame.HasText Then
With oGraphic.TextFrame.TextRange.Font
.Size = 20
.Color.RGB = RGBColorSmall
End With
NumCnt = NumCnt + 1
'
'Find Next word on slide
'Change text font to big size and text font color to red
'
SetBig(ByRef oGraphic As Shape)
End If
End If
Else
'End Sub
Exit Sub
End If
ElseIf NumCnt > 1 Then
NameStr = oGraphic.Name
If NameStr = CStr(NumCnt) Then
With oGraphic.TextFrame.TextRange.Font
.Size = 20
.Color.RGB = RGBColorSmall
End With
NumCnt = NumCnt + 1
If NumCnt <= Last Then
'
'Find Next word on slide
'Change text font to big size and text font color to red
'
SetBig(ByRef oGraphic As Shape)
ElseIf NumCnt >= Last Then
'
'do some Reset here
'
Debug.Print "Hello World"
End If
End If
End If
End Sub

Related

Issues with Textboxes Individually Hyperlinked to Slide with Matching Titles

I have put together an e-learning module. I am still very new at vba though. I am trying to make a dynamic main menu which contains multiple text boxes. If the text in a text box matches the title of a slide, that shape should then then be hyperlinked to the corresponding slide. Ideally, the text boxes on the Main Menu would contain the names of Sections and hyperlink to the first slide in the named section, but I couldn't figure that out, so instead I made the title of the first slide in each section match the text. I've searched and searched and gotten as close as I could. I am hoping someone can help me finish it. I have gotten past several errors, and have the text hyperlinked, however all linked take the user to the last slide in the presentation instead of the proper slide. Thank you in advance for any guidance!!
Here is the code:
Sub TestMe()
'Original Source: http://www.steverindsberg.com/pptlive/FAQ00056.htm
Dim aSl As Slide 'active slide
Dim dSl As Slide 'destination slide
Dim Slde As Slide
Dim oSh As Shape
Dim aSl_ID As Integer
Dim aSl_Index As Integer
Dim dSl_ID As Integer
Dim dSl_Index As Integer
Dim sTextToFind As String
Dim hypstart As String
Dim Titl As String
Set aSl = Application.ActiveWindow.View.Slide 'active slide
aSl_Index = Application.ActiveWindow.View.Slide.SlideIndex 'active slide index
' Set ActiveSld_Index =
' Set DestinationSld_ID = oSl.SlideID
' Set DestinationSld_Index = oSl.SlideIndex
For Each oSh In aSl.Shapes
'If IsSafeToTouchText(oSh) = True Then
sTextToFind = oSh.TextFrame.TextRange.Text
'loop through slides looking for a title that matches the text box value
On Error Resume Next
Set dSl = FindSlideByTitle(sTextToFind)
' get the information required for the hyperlink
dSl_ID = CStr(dSl.SlideID)
dSl_Index = CStr(dSl.SlideIndex)
' find the text string in the body
hypstart = InStr(1, sTextToFind, sTextToFind, 1)
'make the text a hyperlink
With oSh.TextFrame.TextRange.Characters(hypstart, Len(sTextToFind)).ActionSettings(ppMouseClick).Hyperlink
.SubAddress = dSl_ID & "," & dSl_Index & "," & sTextToFind
End With
'End If
Next oSh
End Sub
Public Function FindSlideByTitle(sTextToFind As String) As Slide
'Source: http://www.steverindsberg.com/pptlive/FAQ00056.htm
Dim oSl As Slide
Dim oSh As Shape
With ActivePresentation
For Each oSl In .Slides
For Each oSh In oSl.Shapes
With oSh
'If .HasTextFrame Then
'If Not .TextFrame.TextRange.Text Is Nothing Then
'myPres.Slides(1).Shapes.Title.TextFrame.TextRange
On Error Resume Next
If UCase(.TextFrame.TextRange.Text) = UCase(sTextToFind) Then
'If UCase(.TextRange.Text) = UCase(sTextToFind) Then
Set FindSlideByTitle = oSl
'End If
End If
'End If
End With
Next
Next
End With
End Function
Public Function IsSafeToTouchText(pShape As Shape) As Boolean
'Source: http://www.steverindsberg.com/pptlive/FAQ00056.htm
On Error GoTo ErrorHandler
If pShape.HasTextFrame Then
If pShape.TextFrame.HasText Then
' Errors here if it's a bogus shape:
If Len(pShape.TextFrame.TextRange.Text) > 0 Then
' it's safe to touch it
IsSafeToTouchText = True
Exit Function
End If ' Length > 0
End If ' HasText
End If ' HasTextFrame
Normal_Exit:
IsSafeToTouchText = False
Exit Function
ErrorHandler:
IsSafeToTouchText = False
Exit Function
End Function
Here is the revised code. I have gone in circles and am now stuck. Any suggestions are much appreciated!
After I restored the original function (FindSlideByTitle), I kept getting an error on got an error on .textframe.textrange, making me think that the type of shape I used on my slide (freeform) needed TextFrame2, so I edited that, which fixed the error, but since then I've not been able to make the hyperlink work and have tried instead to use GoTo Slide by including the parent.
I even tried making an array of all freeform shapes on the slide, but I'm still new at this and perhaps I don't fully understand the concepts yet. As it currently stands, I don't get any errors, however, when I click one of the shapes, the shape's appearance changes from the click, but it doesn't go anywhere.
I have also included an image of the actual slide.
Sub TestLinkShapesToSlideTitles()
Dim aSl, dSl, oSl As Slide 'active slide, destination slide
Dim oSh As PowerPoint.Shape
Dim aSl_ID, dSl_ID As Integer
Dim aSl_Index, dSl_Index As Long
Dim dSl_Title, hypstart, Titl As String
Dim sTextToFind As String
Dim numshapes, numFreeformShapes As Long
Dim FreeformShpArray As Variant
Dim ShpRange As Object
Dim oPres As Presentation
Set aSl = Application.ActiveWindow.View.Slide 'active slide
aSl_Index = Application.ActiveWindow.View.Slide.SlideIndex 'active slide index
''''''''''''''''''''''''''''
'In this section I tried to make an array of all the freeform shapes on the slide, thinking that would help.
With aSl.Shapes
numshapes = .Count
'Continues if there are Freeform shapes on the slide
If numshapes > 1 Then
numFreeformShapes = 0
ReDim FreeformShpArray(1 To numshapes)
For i = 1 To numshapes
'Counts the number of Freeform Shapes on the Slide
If .Item(i).Type = msoFreeformShape Then
numFreeformShapes = numFreeformShapes + 1
FreeformShpArray(numFreeformShapes) = .Item(i).Name
End If
Next
'Adds Freeform Shapes to ShapeRange
If numFreeformShapes > 1 Then
ReDim Preserve FreeformShpArray(1 To numFreeformShapes)
Set ShpRange = .Range(FreeformShpArray)
'asRange.Distribute msoDistributeHorizontally, False
End If
End If
End With
''''''''''''''''''''''''''
On Error Resume Next
'Loop through all the shapes on the active slide
For Each oSh In aSl.Shapes
If oSh.Type = msoFreeform Then 'oSh.Type = 5
'If oSh.HasTextFrame Then
If oSh.TextFrame2.HasText Then 'results in -1
With oSh
sTextToFind = .TextFrame2.TextRange.Characters
'sTextToFind results in "Where to Begin"
'.TextFrame2.TextRange.Characters results in "Learn the Lingo", which is the shape after Where to Begin.
End With
End If
'End If
'If IsSafeToTouchText(oSh) = True Then
'With oSh.TextFrame
'sTextToFind = .TextRange.Characters.Text
'loop through slides looking for a title that matches the text box value
'For Each oSl In ActivePresentation.Slides
'If oSl.Shapes.HasTitle Then
'Titl = Slde.Shapes.Title.TextFrame.TextRange <<<<< I kept getting the error here...
On Error Resume Next
Set dSl = FindSlideByTitle_Original(sTextToFind)
' get the information required for the hyperlink
dSl_Title = dSl.Shapes.Title.TextFrame.TextRange
dSl_ID = dSl.SlideID
dSl_Index = dSl.SlideIndex
With oSh
.ActionSettings(ppMouseClick).Parent.Parent.View.GoToSlide dSl_Index, msoFalse 'Go to slide and don't reset animations
End With
' find the text string in the body
'hypstart = InStr(1, sTextToFind, dSl_Title, 1)
'make the text a hyperlink
'With oSh.TextFrame.TextRange.Characters(hypstart, Len(sTextToFind)).ActionSettings(ppMouseClick).Hyperlink
'.SubAddress = dSl_ID & "," & dSl_Index & "," & sTextToFind
'End With
'End With
End If
'End If
Next oSh
End Sub
Public Function FindSlideByTitle_Original(sTextToFind As String) As Slide
'Source: https://stackoverflow.com/questions/25038952/vba-powerpoint-select-a-slide-by-name
Dim oSl As Slide
For Each oSl In ActivePresentation.Slides
With oSl.Shapes.Title.TextFrame
If .HasText Then
If UCase(.TextRange.Text) = UCase(sTextToFind) Then
Set FindSlideByTitle_Original = oSl
End If
End If
End With
Next
End Function

VBA TO copy text from textbox into slideTitle

I have created a macro in Powerpoint that will search for slides that are using a textbox for their title and are replacing them with a Title box. The steps are
1) find the slides that have a textbox in the title area
2) Copy the text in the textbox to a variable called slTitle.
3) Delete the texbox
4) Create a Title Holder for the current slide
5) Copy the text into the Title holder
6) Move on to the next slide
My macro currently is able to get as far as step 4 but I can't figure out how to get the text in slTitle into the Title box. This should be fairly easy to do but I've tried several ways and nothing seems to work. If anyone can help me figure out this step it would be much appreciated.
I am getting a compile error "Invalid Qualifier" on the line:
Set ppPlaceholderTitle.TextFrame.TextRange.Text = slTitle
Here is my current macro.
Sub AddMiMissingTitles()
Dim shpCurrShape As Object
Dim x As Integer
Dim sl As PowerPoint.Slide
Dim sld As Slide
Dim ctr As Integer
Dim s As Shape
'x = ActivePresentation.Slides.Count
'counter ctr used to count number of slides that needed titles added
ctr = 0
'**************************************************************
Set sourcePres = ActivePresentation
x = 1 ' slide counter
'get the title text
For Each sl In sourcePres.Slides
'delete all the empty title text boxes first
For Each s In sl.Shapes
If s.Top < 45 Then ' it's in the title area
'MsgBox s.PlaceholderFormat.Type
If s.Type <> ppPlaceholderTitle Then ' it isn't a proper Title placeholder
If s.HasTextFrame = msoTrue Then
If Trim(s.TextFrame.TextRange.Text) = "" Then
s.Delete ' delete empty text holders
Else
slTitle = s.TextFrame.TextRange.Text
s.Delete
sl.CustomLayout = sl.CustomLayout 'reset the slide
Set ppPlaceholderTitle.TextFrame.TextRange.Text = slTitle
End If
End If
End If
End If
Next
'Is there a title placeholder on the current layout?
If sl.CustomLayout.Shapes.HasTitle Then
lngType = sl.CustomLayout.Shapes.Title.PlaceholderFormat.Type
'*********************************
' With ActivePresentation.Slides()
End If
Next
MsgBox "Done! " & vbCrLf & ctr & " Slides needed Titles."
'*********************************
'sl.Shapes.AddPlaceholder lngType
sl.Shapes.Title.TextFrame.TextRange = slTitle
End Sub

Automatic slide numbering in PowerPoint using VBA

I have added a label in PowerPoint 2013 with the following code to show "x of y" at the bottom of all slides, where x is current slide number and y is total number of slides:
Private Sub Label1_Click()
Dim p1 As String
p1 = " of "
Dim p2 As Integer
Dim slideNumber As String
slideNumber = ActiveWindow.Selection.SlideRange.slideNumber
p2 = ActivePresentation.Slides.Count
Label1.Caption = slideNumber & p1 & p2
End Sub
The code works perfectly for the slide on which I have added the label e.g. it shows "9 of 29" for slide 9 of my total 29 slides, however when I copy and paste the label on other slides, it still shows "9 of 29" which is wrong as I expect it to automatically reflect the current slide number.
If you want this to work across all slides, wouldn't it be simpler to have a single button whose click updates all of the slide numbers at one time?
Assuming you have a shape named "SlideNumber" on every slide:
Sub ForExample()
Dim oSl As Slide
For Each oSl In ActivePresentation.Slides
With oSl.Shapes("SlideNumber").TextFrame.TextRange
.Text = "Slide " & CStr(oSl.SlideIndex) & " of " _
& CStr(ActivePresentation.Slides.Count)
End With
Next
End Sub
Here is my solution. Add a new textbox if it does not exist; otherwise use the existing one. That way, you can rerun the macro after making changes to slides.
Sub SlideNum()
For Each oSl In ActivePresentation.Slides
exist = False
For Each oS in Osl.Shapes
If oS.name = "SlideNum" Then
exist = True
Exit For
End If
Next
If exist = False Then
' convert from inch *72
Set oshp = oSl.Shapes.AddTextbox(msoTextOrientationHorizontal, 25.55*72, 14.21*72, 1.12*72, 20)
oshp.name = "SlideNum"
Else
Set oshp = oS
End If
With oshp.TextFrame.TextRange
' .Text = CStr(oSl.SlideIndex) & "/" & CStr(ActivePresentation.Slides.Count)
.Text = CStr(oSl.SlideIndex)
.Font.Size = 40
End With
Next
End Sub

VBA powerpoint - code to change table's cell shading

I have a PowerPoint 2010 presentation with a table on one slide.
I want to create a VBA modeless form that will work like a pallete of
formats/colors for formatting cells of that table.
Basically, the buttons on the form would just simulate clicking
specific Shading color in Table Tools/Design menu.
example:
I place the cursor to the cell then click on a button in activated modeless form. The shading of that cell will change according to the color in the code.
The reason I want to do this is that some other people will use it and the colors must be easily accessible (format painter doesn't not seem to copy the shading)
But I cannot find a way to make this VBA. I have tried recording macro in Word (not possible in PP) with no success.
Try this... (Not polished code, but should give you what you need(ed))
Public sub TblCellColorFill()
Dim X As Integer
Dim Y As Integer
Dim oTbl as Table
set oTbl = ActiveWindow.Selection.Shaperange(1).Table 'Only works is a single table shape is selected - add some checks in your final code!
For X = 1 To otbl.Columns.Count
For Y = 1 To otbl.Rows.Count
With otbl.Cell(Y, X)
If .Selected <> False Then 'Strange bug - will ignore if statement entirely if you use "= True"
'Debug.Print "Test worked " & Now
'We have the shape we need
.shape.Fill.ForeColor.RGB = RGB(100, 150, 200) 'Add your color here
End If
End With
Next 'y
Next 'x
End Sub
For table styling in MSPowerPoint 2013 I use
Sub STYLE_TABLE_2()
' Change table style
' Two rows Dark Gray and White Font
' Next odd rows Light Gray/ even Moderate Gray/ and Black Font
Dim iCols As Integer
Dim iRows As Integer
Dim oTbl As Table
' Debug.Print (ActiveWindow.Selection.ShapeRange(1).Type)
With ActiveWindow.Selection
If .Type = ppSelectionShapes Then ' Shape is selected ppSelectionShapes=2 ppSelectionSlides=3 ppSelectionNone=0
If .ShapeRange(1).Type = msoTable Then ' If first shape Type=19 is msoTable
' (--- note not all table-looking shapes are Table style Can be Type=14 msoPlaceholder
Debug.Print ("We are certain inside table") '
Set oTbl = ActiveWindow.Selection.ShapeRange(1).Table 'Only works if single table or its part is selected
For iCols = 1 To oTbl.Columns.Count
For iRows = 1 To oTbl.Rows.Count
With oTbl.Cell(iRows, iCols)
.Shape.TextFrame.TextRange.Font.Name = "Arial"
.Shape.TextFrame.TextRange.Font.Size = 12
If iRows Mod 2 <> 0 Then ' Odd numbers
Debug.Print ("Ymod2 2") '
.Shape.Fill.ForeColor.RGB = RGB(236, 234, 241)
Else
.Shape.Fill.ForeColor.RGB = RGB(215, 210, 225)
End If
If (.Selected <> False) And (iRows < 3) Then 'Cannot be "= True"
.Shape.Fill.ForeColor.RGB = RGB(166, 166, 166)
.Shape.TextFrame.TextRange.Font.Name = "Arial"
.Shape.TextFrame.TextRange.Font.Color = RGB(255, 255, 255)
.Shape.TextFrame.TextRange.Font.Size = 12
End If
End With
Next 'iRows
Next 'iCols
End If
End If
End With
End Sub

Powerpoint VBA: Search for an character Arrow and replace with a shape arrow

What I need to be able to do is find a up arrow character and replace it with an up arrow shape and do the same thing for down arros. I am a novice to VBA but have an idea for how I want the Macro to work. It should loop through all slides on the powerpoint.
1) Find the location of the arrow character? (using the INSTR command? and the CHR code command. Not sure if INSTR works in ppt or is the appropriate code here)
2) Add shape with the location returned from the previous line of code. My code is below that already adds this shape to my specifications.
Dim i As Integer
Dim shp As Shape
Dim sld As Slide
Set sld = Application.ActiveWindow.View.Slide
Set shp = sld.Shapes.AddShape(36, 10, 10, 5.0399, 8.6399)
shp.Fill.ForeColor.RGB = RGB(89, 0, 0)
shp.Fill.BackColor.RGB = RGB(89, 0, 0)
shp.Line.ForeColor.RGB = RGB(89, 0, 0)
3) Find and delete all character arrows so the shapes are the only ones left behind.
I've been struggling my way through VBA in PPT and would appreciate any help you could give me.
You're on the right track. Assume I have a shape like this, where it has letters and also a special character, represented by the hex value &H25B2.
First, you need to identify what is the value of your character. There are lots of places where you can find these references.
Then, how to work with in your code, here is one example that finds the shape, and covers it with your arrow, revised per #SteveRindsberg's suggestion, below :)
Public Const upArrow As String = &H25B2 'This is the Hex code for the upward triangle/arrow
Public Const downArrow As String = &H25BC 'This is the Hex code for the downward triangle/arrow
Sub WorkWithSpecialChars()
Dim pres As Presentation
Dim sld As Slide
Dim shp As Shape
Dim foundAt As Long
Dim arrowTop As Double
Dim arrowLeft As Double
Dim arrow As Shape
Set pres = ActivePresentation
For Each sld In pres.Slides
For Each shp In sld.Shapes
If shp.HasTextFrame Then
foundAt = InStr(shp.TextFrame.TextRange.Characters.Text, ChrW(upArrow))
If foundAt > 0 Then
MsgBox "Slide " & sld.SlideIndex & " Shape " & shp.Name & " contains " & _
"the character at position " & foundAt, vbInformation
'Select the text
With shp.TextFrame.TextRange.Characters(foundAt, 1)
'Get the position of the selected text & add the arrow
Set arrow = sld.Shapes.AddShape(36, _
.BoundLeft, .BoundTop, .BoundWidth, .BoundHeight)
'additional code to format the shape
' or call a subroutine to format the shape, etc.
End With
Else:
Debug.Print "Not found in shape " & shp.Name & ", Slide " & sld.SlideIndex
End If
End If
Next
Next
End Sub
To add a bit to what David's done already, once you get a reference to a text range (pretty much any chunk of text), you can get the text's bounding box and use that to position your shape. Here's a start:
Sub testMe()
Dim oSh As Shape
Dim oRng As TextRange
' As an example, use the currently selected shape:
Set oSh = ActiveWindow.Selection.ShapeRange(1)
With oSh.TextFrame.TextRange
' Does it contain the character we're looking for?
If InStr(.Text, "N") > 0 Then
' Get a range representing that character
Set oRng = .Characters(InStr(.Text, "N"), 1)
' And tell us the top
Debug.Print TopOf(oRng)
' And as an exercise for the reader, do companion
' BottomOf, LeftOf, WidthOf functions below
' then use them here to position/size the shape
' atop the existing character
End If
End With
End Sub
Function TopOf(oRng As TextRange)
TopOf = oRng.BoundTop
End Function