PowerPoint vba宏 - 复制文本框文本以注意 - 还需要复制字体和字体颜色

Question

我有一个当前运行良好的宏。 它删除PPT幻灯片中的所有当前笔记 - 然后将每个包含文本的形状复制到幻灯片笔记中。

我还需要一个"调整"---当文本复制到笔记区域时，我还需要复制当前的字体、字体颜色、大小等。

有没有办法做到这一点？

非常感谢!!

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