TPE

Tavvafi@gmail.com

≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡

Sub TitlesToText()
' Converts titles to text shapes then changes titles to something short
' in order to help solve hyperlink problems due to over-long/too-many titles

    Dim oSlide As Slide
    Dim oSlides As Slides
    Dim oShapes As Shapes
    Dim oSh As Shape
    Dim oHyperlinks As Hyperlinks
    Dim oHl As Hyperlink
    Dim tmpText1 As String
    Dim tmpText2 As String

    Set oSlides = ActivePresentation.Slides

    For Each oSlide In oSlides
        ' Deal with the titles:
        Set oShapes = oSlide.Shapes
        For Each oSh In oShapes
            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
                            ' make a copy of the title and move it to match title's position
                            With oSh.Duplicate
                                .Top = oSh.Top
                                .Left = oSh.Left
                                .Tags.Add "OriginalTitleText", oSh.TextFrame.TextRange.Text
                            End With

                            ' change the title text to something innocuous (and SHORT)
                            ' or leave it as is, but remove the commas
                            ' remove the ' from one or the other of the following lines 
                            ' to choose which:
                            'oSh.TextFrame.TextRange.Text = "S-" & CStr(oSlide.SlideIndex)
                            oSh.TextFrame.TextRange.Text = _
                                Replace(oSh.TextFrame.TextRange.Text, ",", " ")

                            ' and hide it
                            oSh.Visible = msoFalse
                        End If
                    End If
                End If
            End If
        Next oSh

        ' fix up hyperlinks
        Set oHyperlinks = oSlide.Hyperlinks
        For Each oHl In oHyperlinks
            If oHl.Address = "" And oHl.SubAddress <> "" Then
                If InStr(oHl.SubAddress, ",") > 0 Then
                    tmpText1 = oHl.SubAddress    ' xx,yy,This is the old title
                    ' get the text up to and including the first comma
                    tmpText2 = Mid$(tmpText1, 1, InStr(tmpText1, ",")) ' xx,
                    ' strip off the text we just grabbed
                    tmpText1 = Right$(tmpText1, Len(tmpText1) - Len(tmpText2)) ' yy,This is the old title
                    ' Get the text up to and including the first comma, append it
                    tmpText2 = tmpText2 & Mid$(tmpText1, 1, InStr(tmpText1, ","))
                    ' append a null
                    tmpText2 = tmpText2 & " "
                    oHl.SubAddress = tmpText2
                End If
            End If
        Next oHl

    Next oSlide

    Set oSlide = Nothing
    Set oSlides = Nothing

End Sub

Sub GatherTitles()
' This is a modified version of the GatherTitles macro
' that collects the original title text stored in tags
' by our TitlesToText macro

    Dim oSlide As Slide
    Dim strTitles As String
    Dim strFilename As String
    Dim intFileNum As Integer
    Dim PathSep As String

    If ActivePresentation.Path = "" Then
        MsgBox "Please save the presentation then try again"
        Exit Sub
    End If

    #If Mac Then
        PathSep = ":"
    #Else
        PathSep = "\"
    #End If

    For Each oSlide In ActiveWindow.Presentation.Slides
        On Error Resume Next    ' in case the title shape's gone missing
        strTitles = strTitles _
            & "Slide: " _
            & CStr(oSlide.SlideIndex) & vbCrLf _
            & oSlide.Shapes("PseudoTitle").Tags("OriginalTitleText") _
            & vbCrLf & vbCrLf
    Next oSlide

    intFileNum = FreeFile

    ' PC-Centricity Alert!
    ' This assumes that the file has a .PPT extension and strips it off to make the text file name.
    strFilename = ActivePresentation.Path _
        & PathSep _
        & Mid$(ActivePresentation.Name, 1, Len(ActivePresentation.Name) - 4) _
        & "_Titles.TXT"

    Open strFilename For Output As intFileNum
    Print #intFileNum, strTitles
    Close intFileNum
    Call Shell("Notepad " & strFilename, vbNormalFocus)
End Sub