Alphabetize text extracted from text boxes
Hello!
Back on VBAExpress post 54245 (won't let me link to it), I got some great help with this macro (Goes through PPT slides, and if text is red and bold, it creates an index page with that text and slide number.
It works fine, but it puts the capital text A-Z and then lowercase a-z. Can anyone help so it is truly alphabetical Aa-Zz?
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 + 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
Regards,
leaning
