'---------------------------------------------------------------------
' Copyright (c) 2013 GMARK Ltd.
'
' Macro to replace all text in supported shapes* across a presentation
' with Lorem Ipsum text.
'
' Processes all visible shapes on all visible slides.
'
' Supported shapes:
' - Textboxes
' - Shapes (rectangles, circles, freeform etc.)
' - Placeholders (excluding slide numbers)
' - Tables
' - Charts (chart/axes titles and data point text only, legend is hidden, axes values have to be changed in the source data)
'
' Unsupported shapes:
' - SmartArt
'
' Written By : Jamie Garroch
' Date : 11th November 2013
' Website : http://i-present.co.uk and http://www.gmark.co
'
'---------------------------------------------------------------------
    
Option Explicit
    
' Start of module level definitions
Private Const loremDefault = "Lorem ipsum dolor sit amet, consectetuer adipiscing elit. Maecenas porttitor congue massa. " & _
  "Fusce posuere, magna sed pulvinar ultricies, purus lectus malesuada libero, sit amet commodo magna eros quis urna. " & _
  "Nunc viverra imperdiet enim. Fusce est. Vivamus a tellus. " & _
  "Pellentesque habitant morbi tristique senectus et netus et malesuada fames ac turpis egestas. Proin pharetra nonummy pede. Mauris et orci."
Private lorem As String
Private curSlide As Integer
Private counter As Single
Private Const MSG_STATUS = "GMARK_Status_Message"
Private restartLorum As VbMsgBoxResult
Private loremCounter As Integer
' End of module level definitions
    
Public Sub ReplaceTextWithLorem()
    
  On Error GoTo errorhandler
    
  Dim response
  Dim osld As Slide
  Dim oshp As Shape
  Dim ogrp As Shape
  Dim oRefresh As Shape
    
  ' Get a reference to the current slide
  curSlide = ActiveWindow.View.Slide.SlideIndex
    
  ' Add a temporary message to the current slide
  AddStatusMessage
  
  response = MsgBox("This macro replaces text across a presentation with Lorem Ipsum text." & Chr(13) & Chr(13) & _
  "It processes the following:" & Chr(13) & Chr(13) & _
  " - All visible slides" & Chr(13) & _
  " - All visible shapes (including placeholders, but not slide numbers)" & Chr(13) & _
  " - All visible groups" & Chr(13) & _
  " - All visible tables" & Chr(13) & _
  " - All visible charts (chart/axes titles and data point text only, legend is hidden, axes values have to be changed in the source data)" & Chr(13) & Chr(13) & _
  "It is not designed to change SmartArt or Pictures.", _
  vbOKCancel + vbInformation, "GMARK Macro : Lorem Ipsum by i-present.co.uk")
  If response = vbCancel Then
    DeleteStatusMessage
    Exit Sub
  End If
  
  restartLorum = MsgBox("Do you want to restart the Lorum text substitution with each new shape that is found?", _
    vbYesNo + vbQuestion, "How do you want to process the text?")

  lorem = InputBox("Change the default substitution text if required:", "Substitution Text", loremDefault)
  If lorem = "" Then
    MsgBox "The substitution text cannot be empty!", vbOKOnly + vbCritical, "Stopping..."
    Exit Sub
  End If
  
  counter = 0
    
  For Each osld In ActivePresentation.Slides
    ActiveWindow.View.GotoSlide osld.SlideIndex
    DoEvents
    ' If the slide is visible, process it
    If osld.SlideShowTransition.Hidden = msoFalse Then
      For Each oshp In osld.Shapes
        ' If the shape is visible, process it
        If oshp.Visible = msoTrue Then
          'oshp.Select msoTrue
          'DoEvents
          Select Case oshp.Type
            Case msoGroup
              For Each ogrp In oshp.GroupItems
                SwapCharacters ogrp
              Next
            Case msoPlaceholder
              If Not oshp.PlaceholderFormat.Type = ppPlaceholderSlideNumber Then
                If oshp.HasChart Then ProcessChart oshp.Chart, oshp.Parent.SlideIndex
                'If oshp.HasSmartArt Then
                If oshp.HasTable Then ProcessTable oshp
                If oshp.HasTextFrame Then SwapCharacters oshp
              End If
            Case msoTable
              ProcessTable oshp
            Case msoChart
              ProcessChart oshp.Chart, oshp.Parent.SlideIndex
            Case Else
              SwapCharacters oshp
          End Select
        End If
        ' Delete/comment out the next 3 lines to speed things up but remove on-screen viewing of changes
        If osld.SlideIndex > 1 Then ActiveWindow.View.GotoSlide osld.SlideIndex - 1
        ActiveWindow.View.GotoSlide osld.SlideIndex
        DoEvents
      Next
    End If
  Next
    
  DeleteStatusMessage
  
  MsgBox counter & " characters have been replaced across this presentation." & Chr(13) & Chr(13) & _
    "Click OK and check the result. Press Ctrl+Z to revert the changes.", vbOKOnly + vbInformation, "Finished!"
  Exit Sub
    
errorhandler:
  response = MsgBox("Uh oh. There was an unexpected error. with:" & Chr(13) & Chr(13) & _
    "Slide : " & oshp.Parent.SlideIndex & Chr(13) & _
    "Shape : " & oshp.Name & Chr(13) & Chr(13) & _
    "Ignore this error?" & Chr(13) & Chr(13) & _
    "Error : " & Err.Number & ", " & Err.Description, vbYesNo + vbCritical, "Macro Error")
  If response = vbYes Then
    Resume Next
Else
  DeleteStatusMessage
End If

End Sub
    
Private Sub ProcessTable(oshp As Shape)
  Dim lRow As Long, lCol As Long
  Dim oCellShp As Shape
  With oshp.Table
    For lRow = 1 To .Rows.Count
      For lCol = 1 To .Columns.Count
        SwapCharacters .Cell(lRow, lCol).Shape, True, "[R:" & CStr(lRow) & ", C:" & CStr(lCol) & "]"
      Next
    Next
  End With
End Sub

Private Sub ProcessChart(oChart As Chart, Optional ParentSlideIndex As Integer)
  Dim oSeries As Object 'Series
  Dim oDataPoint As Object 'Point
  Dim oAxis As Object  'Axis
    ' Number of series : oChart.SeriesCollection.Count
    ' Number of data points : oChart.SeriesCollection(1).Points.Count
    ' Point HasDataLabel : oChart.SeriesCollection(1).Points(1).HasDataLabel
    ' Point Data Label : oChart.SeriesCollection(1).Points(1).DataLabel.Text
    With oChart
      ' Process the chart title if it exists
      If .HasTitle Then .ChartTitle.text = SwapText(.ChartTitle.text, ParentSlideIndex)
      
      ' Process the axes title text if any exists
      For Each oAxis In .Axes
        ' .Axes(xlCategory, xlPrimary).HasTitle
        ' .Axes(xlValue, xlPrimary).HasTitle
        If oAxis.HasTitle Then oAxis.AxisTitle.text = SwapText(oAxis.AxisTitle.text, ParentSlideIndex)
      Next
      ' Process the axes category text if any exists
      ' -> Can't do this without changing the data
      
      ' Process the legend text if any exists
      ' -> Can't do this without changing the data so just hide it
      If .HasLegend Then .HasLegend = False
      
      ' Process the data label text if any exists
      For Each oSeries In oChart.SeriesCollection
        For Each oDataPoint In oSeries.Points
          With oDataPoint
            If .HasDataLabel Then .DataLabel.text = SwapText(.DataLabel.text, ParentSlideIndex)
          End With
        Next
      Next
    End With
End Sub

Private Function SwapText(text As String, Optional ParentSlideIndex As Integer) As String
  Dim sourceChar As Integer
  Dim newChar As Integer
  For sourceChar = 1 To Len(text)
    If restartLorum = vbNo Then loremCounter = loremCounter + 1
    If loremCounter > Len(lorem) Then loremCounter = 1
    newChar = IIf(restartLorum = vbYes, sourceChar Mod (Len(lorem) + 1), loremCounter)
    If newChar = 0 Then newChar = 1
    ' Spew out the characters in the VBE immediate window (Ctrl+G) for debugging
    Debug.Print Mid(text, sourceChar, 1) & ":" & AscW(Mid(text, sourceChar, 1)) & "->"; Mid(lorem, newChar, 1) & _
      " from slide:" & ParentSlideIndex & ", shape:" & "Chart"
    ' Replace the character
    Mid(text, sourceChar, 1) = Mid(lorem, newChar, 1)
    counter = counter + 1
  Next
  SwapText = text
End Function

Private Sub SwapCharacters(swapShp As Shape, Optional shapeTypeCell As Boolean, Optional tableCellRef As String)
  Dim sourceChar As Integer
  Dim newChar As Integer
  Dim shpRef As String

  ' Skip the name check as table cells don't support this shape method
  If shapeTypeCell = True Then GoTo skipNameCheck
  ' If the non-table-cell shapes is not the status message shape, process it
  If swapShp.Name = MSG_STATUS Then Exit Sub

skipNameCheck:
  With swapShp
    ' If the shape has a text frame, process it
    If .HasTextFrame Then
      With .TextFrame
        ' If the textframe has text, process it
        If .HasText Then
          With .TextRange
            ' Loop through the text, searching each character individually
            For sourceChar = 1 To Len(.text)
              If restartLorum = vbNo Then loremCounter = loremCounter + 1
              If loremCounter > Len(lorem) Then loremCounter = 1
              newChar = IIf(restartLorum = vbYes, sourceChar Mod (Len(lorem) + 1), loremCounter)
              If newChar = 0 Then newChar = 1
              Select Case AscW(.Characters(sourceChar, 1))
                ' Don't replace non-printable characters
                Case 9, 10, 11, 13 ' TAB, CR, LF, VTAB
                  ' Do nothing
                  Debug.Print AscW(.Characters(sourceChar, 1))
                Case Else
                  ' Spew out the characters in the VBE immediate window (Ctrl+G) for debugging
                  If shapeTypeCell = True Then shpRef = tableCellRef Else shpRef = swapShp.Name
                  Debug.Print .Characters(sourceChar, 1) & ":" & AscW(.Characters(sourceChar, 1)) & "->"; Mid(lorem, newChar, 1) & _
                    " from slide:" & swapShp.Parent.SlideIndex & ", shape:" & shpRef
                  ' Replace the character
                  .Characters(sourceChar, 1) = Mid(lorem, newChar, 1)
                  counter = counter + 1
              End Select
            Next
          End With
        End If
      End With
    End If
  End With
End Sub
    
Private Sub AddStatusMessage()
  Dim slideWidth As Integer
  Dim slideHeight As Integer
  Dim msgShape As Shape
  On Error Resume Next
  slideWidth = ActivePresentation.PageSetup.slideWidth
  slideHeight = ActivePresentation.PageSetup.slideHeight
  With ActivePresentation.Slides(curSlide).Shapes
    Set msgShape = .AddShape(msoShapeRectangle, 0, 0, slideWidth, slideHeight)
    With msgShape
      .Name = MSG_STATUS
      .Fill.Visible = msoTrue
      .Fill.ForeColor.RGB = RGB(0, 0, 0)
      .Fill.Transparency = 0.3
      With .TextFrame.TextRange
        .text = "processing shapes..." & Chr(13) & Chr(13) & "(may take a LONG time)"
        With .Font
          .Name = "Calibri"
          .Size = 60
          .Color.RGB = RGB(255, 255, 255)
        End With
      End With
    End With
  End With
  ActiveWindow.ViewType = ppViewNormal
  ActiveWindow.View.GotoSlide curSlide
  DoEvents
End Sub
    
Private Sub DeleteStatusMessage()
  On Error Resume Next
  ActivePresentation.Slides(curSlide).Shapes(MSG_STATUS).Delete
  loremCounter = 0
  ActiveWindow.View.GotoSlide curSlide
End Sub