PowerPoint vba macro - Copy Text Box text to note -need to also copy font & font color

Question

I have a current macro that works well. It deletes all of the current notes in the PPT slide - then copies every shape that has text to the slide notes.

I need one more "tweak"--- when the text is copied to the note area, I need to also copy the current font, font color, size, etc.

Is there a way to do this?

Many thanks!!!

Sub Copy_SlideShapeText_ToNotes()

  Dim curSlide As Slide
  Dim curShape As Shape
  Dim curNotes As Shape
  Dim oSh As Shape

'delete all notes in receiving slides
  For Each curSlide In ActivePresentation.Slides
    curSlide.NotesPage.Shapes(2) _
          .TextFrame.TextRange = ""
  Next curSlide

  For Each curSlide In ActivePresentation.Slides
    For Each oSh In curSlide.NotesPage.Shapes
      If oSh.PlaceholderFormat.Type = ppPlaceholderBody Then
        Set curNotes = oSh
        Exit For
      End If

    Next oSh
    For Each curShape In curSlide.Shapes
      If curShape.TextFrame.HasText Then
        curNotes.TextFrame.TextRange.InsertAfter curShape.TextFrame.TextRange.Text & vbCr
      End If
    Next curShape
  Next curSlide

End Sub

Answer 1

Sub Example()
' Assume you have two rectangles on slide 1 and no other shapes
' And that the first rectangle has text with various formatting
' This will pick up the text from the first rectangle, run by run,
'    and apply the text AND its formatting to the second rectangle

    Dim oSrc As Shape
    Dim oTgt As Shape
    Dim x As Long
    Dim oRng As TextRange

    Set oSrc = ActivePresentation.Slides(1).Shapes(1)
    Set oTgt = ActivePresentation.Slides(1).Shapes(2)

    With oSrc.TextFrame.TextRange
        For x = 1 To .Runs.Count
            With .Runs(x)
                ' Add the text from the current run to the second rectangle
                ' and get a reference to its range in oRng
                Set oRng = oTgt.TextFrame.TextRange.InsertAfter(.Text)

                ' now format the text in oRng to match the same range
                ' from the original
                oRng.Font.Name = .Font.Name
                oRng.Font.Bold = .Font.Bold
                oRng.Font.Color = .Font.Color
                ' add other properties as required, stir well

            End With
        Next
    End With

End Sub

Answer 2

Sub Copy_SlideShapeText_ToNotes()

  Dim curSlide As Slide
  Dim curShape As Shape
  Dim curNotes As Shape
  Dim oSh As Shape
  ' New variable:
  Dim oRng As TextRange

'delete all notes in receiving slides
  For Each curSlide In ActivePresentation.Slides
    curSlide.NotesPage.Shapes(2) _
          .TextFrame.TextRange = ""
  Next curSlide

  For Each curSlide In ActivePresentation.Slides
    For Each oSh In curSlide.NotesPage.Shapes
      If oSh.PlaceholderFormat.Type = ppPlaceholderBody Then
        Set curNotes = oSh
        Exit For
      End If
    Next oSh

    For Each curShape In curSlide.Shapes
      If curShape.TextFrame.HasText Then
        Set oRng = curNotes.TextFrame.TextRange.InsertAfter(curShape.TextFrame.TextRange.Text)
        With oRng
            .Font.Name = curShape.TextFrame.TextRange.Font.Name
            .Font.Bold = curShape.TextFrame.TextRange.Font.Bold
            .Font.Color.RGB = curShape.TextFrame.TextRange.Font.Color.RGB
            ' other properties as required
        End With
      End If
    Next curShape
  Next curSlide

End Sub