TPE

http://bayanbox.ir/view/263405954590585756/2mobile.png

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