Summary Page Based on Text Box text font color.

[leaning]

Hello!

I found a routine (InsertSummaryPage by Joel Jeffery) that creates a Summary Slide for PowerPoint. It goes through each slide that you have selected, and puts all the titles into a summary page/TOC along with the slide number.

I like it, but I was wondering if there was something similar out there that would:
1) Look in every slide's text boxes.
2) If the text is red and bolded, copy that text and slide number to a summary slide.


I appreciate any help.

Regards, Leaning

[John Wilson]

Probably not too difficult but we have a totally free AddIn that might do what you want
http://www.pptalchemy.co.uk/summary2007.html

Works in versions from 2007

[leaning]

John,

I appreciate your help. I looked at your AddIn, and it does almost exactly what Joel Jeffery's does with some exceptions (yours does slide # and then title and no hyperlinks; his does title then slide number with or without hyperlinks.)

I use PowerPoint slides for college study notes. So, I have text boxes (as much as 30 on a slide) that have different topics/ideas. When it comes time for a test, etc. I can use those notes, but there are 200+ slides and it takes forever to find one idea out of 30 on a slide of 200. So I was copying all the ideas into the title box and then running the macro to make the summary. It works OK, except I still have to pore over the summary page to find what I need.

So I need an index like you find at the back of books. One idea and then the slide it is on. The summary page will be longer, but then I can just jump right to that idea.

My idea was to go through each text box, find the critical word or phrase, bold it and make it red, then run the routine to look for bold red words in all text boxes. It would make the index in slide order, so I will have to move it to Excel or something, get it into alphabetical order, and then move it back.

Anyway, that's the full story. Please me know what other ideas you have.

Regards,
Leaning

[John Wilson]

I haven't looked at the AddIn for a while but I am pretty sure it can create hyperlinks and allows you to tag the slides you need to include.

Here's the basis of the code to make what you need (If I have understood). It will need some error trapping

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.SlideIndex
                        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
            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, 550
   With osld
      For i = 1 To UBound(rayInstring)
         .Shapes(2).TextFrame.TextRange = .Shapes(2).TextFrame.TextRange _
                                          & Split(rayInstring(i), "\")(0) _
                                          & vbTab & Split(rayInstring(i), "\")(1) & vbCrLf
      Next i
   End With
End Sub

[leaning]

John,

That is really sweet! I am still playing around with it, and I have 200 pages to bold/red, so that will take a while. The only tweaks I can see are in how it does the Index:

Jo
Blocks
2
Parallax error

2

So, for Jo Blocks, both words should be on the same line and then it is actually on page 1, not 2. The index is 1, and it pushed the Jo Blocks page to 2. So the whole index is off by 1.

And then for Parallax Error, it put a line feed and then the slide number so there is a gap there.

(I attached a screen capture to show it better.)

It's funny because when I copy that section to this forum, it looks great:

Inside micrometer 5
Jenny calipers 5
Jo blocks 2
Johansson gauges 2
MBNQA 220
Micrometers 5
Muda 220
Ohno 220
Outside micrometer 5
PDF: 231
Parallax error 2
Pneumatic gages 3

Any ideas?

Regards,

Leaning

[leaning]

John,

I removed the vbtab from this line and it seems to make it look better. I can't figure out the best place in the code to put the -1, so the slides numbers are right in the index.

Can you help with that?

For i = 1 To UBound(rayInstring)
            .Shapes(2).TextFrame.TextRange = .Shapes(2).TextFrame.TextRange & Split(rayInstring(i), "\")(0) & ": " & Split(rayInstring(i), "\")(1) & vbCrLf
        Next i

Regards,

Leaning

[John Wilson]

Rather than remove the vbTab make to value of the added tab smaller This line places it as 550 try 450

osld.Shapes(2).TextFrame.Ruler.TabStops.Add ppTabStopLeft, 550

I don't see how the index can be off are you sure you don't mean slide NUMBER and you have started from zero? If so in the code change osld.SlideIndex to osld.SlideNumber

[leaning]

All,

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 + 1
                                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
                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
        Next i
    End With
End Sub

John Wilson is the man for this. I just tweaked it to what works for me:
1) Put the colon in vice the vbtab. That way the slide numbers are right next to the words instead of having to trace a straight line from the words across the page to the associated slide number.
2) Switched the pptabStopLeft to 450 from 550. I have no idea what that does, but it didn't hurt, so I 'm good.
3) Added +1 to osld.SlideNumber. So when you run the macro and it adds the index as Slide 1, it pushes your data slides to Slide 2+. So now the index reflects the true slide number of where that index item is.

There is probably a better way to optimize this code. If anyone has any ideas, please let me know.

Again, John rules. Thanks!

Regards,

Leaning

[leaning]

Hello. Back again with this thread.
When this macro runs, it treats capitalized words different than words that start with lowercase. Can this be modified so that it alphabetizes regardless of what case the initial letter is?
I appreciate your help!
Regards,
Leaning