Search code examples
vbapowerpointpowerpoint-2010

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.


Solution

  • 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.

    enter image description here

    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