TPE
Tavvafi@gmail.com |
≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡
Sub ReplaceCommas() ' With a deep bow to Andy Pope who thought this one up ' We're going to replace all commas in titles with ALT+0130, ' the "low quotation mark" character, which looks for all the world like a comma ' but doesn't mess up hyperlinks Dim oSl As Slide Dim oSh As Shape Dim oHl As Hyperlink Dim tmpText1 As String Dim tmpText2 As String Dim tmpText3 As String Dim tmpText4 As String For Each oSl In ActivePresentation.Slides Set oSh = SlideTitle(oSl) If Not oSh Is Nothing Then With oSh.TextFrame.TextRange .Text = Replace(.Text, ",", Chr$(130)) End With End If ' fix up hyperlinks For Each oHl In oSl.Hyperlinks If oHl.Address = "" And oHl.SubAddress <> "" Then If InStr(oHl.SubAddress, ",") > 0 Then ' .SubAddress looks like xx,yy,slide_title ' get the text up to and including the first comma tmpText1 = Mid$(oHl.SubAddress, 1, InStr(oHl.SubAddress, ",")) ' tmpText1 is now "xx," ' strip off the text we just grabbed tmpText2 = Right$(oHl.SubAddress, Len(oHl.SubAddress) - Len(tmpText1)) ' yy,This is the old title ' tmpText2 is now "yy,slide_title" ' get the text up to and including the second comma tmpText3 = Mid$(tmpText2, 1, InStr(tmpText2, ",")) ' tmpText3 is now "yy," ' strip off the text we just grabbed tmpText4 = Right$(tmpText2, Len(tmpText2) - Len(tmpText3)) ' tmpText4 is now "slide_title" ' replace original hyperlink with one w/o commas in title oHl.SubAddress = tmpText1 & tmpText3 & Replace(tmpText4, ",", Chr$(130)) End If End If Next oHl Next ' slide End Sub Function SlideTitle(oSl As Slide) As Shape ' returns the title of a slide Dim oSh As Shape For Each oSh In oSl.Shapes If oSh.Type = msoPlaceholder Then If oSh.HasTextFrame Then If oSh.TextFrame.HasText Then If oSh.PlaceholderFormat.Type = ppPlaceholderCenterTitle Or _ oSh.PlaceholderFormat.Type = ppPlaceholderTitle Then ' found it Set SlideTitle = oSh End If End If End If End If Next End Function