Microsoft Office Forums - View Single Post - Create document index looking for certain formatted text

leaning · 08-28-2017, 08:12 PM

For PowerPoint, you folks created a macro for me that goes through every text box on every slide, grabs the text that's red and bolded and the slide it's on, and then makes an alphabetized index with that. I use it for college notes and it's worked great. Now, for formatting and other reasons, I've transitioned all the data from 300+ slides to Word. But, if possible, I'd still like to be able to use that type of index. Can anyone assist in modifying this macro to work with Word (look for red bolded text and what pages it's on and create an index) )The index can be created in a separate Word document so it doesn't interfere with the page numbers of the subject document.)?

Regards,
leaning

Code:

Sub StartHere()
    Dim osld As Slide
    Dim oshp As Shape
    Dim rayTitles() As String
    Dim i As Integer
    ReDim rayTitles(1 To 1)
    For Each osld In ActivePresentation.Slides
        For Each oshp In osld.Shapes
            If oshp.HasTextFrame Then
                If oshp.TextFrame.HasText Then
                    For i = 1 To oshp.TextFrame.TextRange.Runs.Count
                        With oshp.TextFrame.TextRange.Runs(i).Font
                            If .Color.RGB = vbRed And .Bold = True Then
                                rayTitles(UBound(rayTitles)) = oshp.TextFrame.TextRange.Runs(i) & "\" & osld.SlideNumber
                                ReDim Preserve rayTitles(1 To UBound(rayTitles) + 1)
                            End If
                        End With
                    Next i
                End If
            End If
        Next oshp
    Next osld
    ReDim Preserve rayTitles(1 To UBound(rayTitles) - 1)
    Call mySort(rayTitles)
    Call make_sum(rayTitles)
End Sub
Function mySort(ArrayIn As Variant) As Variant
    Dim b_Cont As Boolean
    Dim lngCount As Long
    Dim strSwap As String
    Do
        b_Cont = False
        For lngCount = LBound(ArrayIn) To UBound(ArrayIn) - 1
            'If ArrayIn(lngCount) > ArrayIn(lngCount + 1) Then
            If LCase(ArrayIn(lngCount)) > LCase(ArrayIn(lngCount + 1)) Then
                strSwap = ArrayIn(lngCount)
                ArrayIn(lngCount) = ArrayIn(lngCount + 1)
                ArrayIn(lngCount + 1) = strSwap
                b_Cont = True
            End If
        Next lngCount
    Loop Until Not b_Cont
End Function
Sub make_sum(rayInstring As Variant)
    Dim osld As Slide
    Dim i As Integer
    For Each osld In ActivePresentation.Slides
        If osld.Tags("SUM") = "YES" Then
            osld.Delete
            Exit For
        End If
    Next osld
    Set osld = ActivePresentation.Slides.Add(1, ppLayoutText)
    osld.Tags.Add "SUM", "YES"
    osld.Shapes(2).TextFrame2.AutoSize = msoAutoSizeTextToFitShape
    osld.Shapes(2).TextFrame.Ruler.TabStops.Add ppTabStopLeft, 450
    With osld
        For i = 1 To UBound(rayInstring)
            .Shapes(2).TextFrame.TextRange = .Shapes(2).TextFrame.TextRange & Split(rayInstring(i), "\")(0) & " (" & Split(rayInstring(i), "\")(1) & ")" & vbCrLf & vbCrLf
        Next i
    End With
    MsgBox "Done", vbInformation, "Done!"
End Sub