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 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

Answer 2

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

PowerPoint vba宏 - 复制文本框文本以注意 - 也需要复制字体＆amp;字体颜色

2 个答案: