Question

我有一张PowerPoint，其中包含每张幻灯片的注释。对于每张幻灯片，我想复制笔记，创建一个带黑色边框的黄色矩形，然后将笔记粘贴到矩形中。

我开始＆＃34;拼接＆＃34;一起宏。这是我到目前为止所拥有的。它工作但矩形在顶部（需要在底部），不知道如何将笔记复制并粘贴到矩形：

Dim oPPT As Presentation
Dim oSlide As Slide
Dim r As Integer
Dim i As Integer
Dim shapectr As Integer
Dim maxshapes As Integer
Dim oShape As Shape

Set oPPT = ActivePresentation


For i = 1 To oPPT.Slides.Count
    For shapectr = 1 To oPPT.Slides(i).Shapes.Count

            ActiveWindow.View.GotoSlide i

            Set oShape = ActiveWindow.Selection.SlideRange.Shapes.AddShape(msoShapeRectangle, 575.5, 9.12, 124.75, 34.12)
                oShape.Fill.ForeColor.RGB = RGB(255, 255, 204)
                oShape.Fill.BackColor.RGB = RGB(137, 143, 75)

            With oShape

               With .TextFrame.TextRange
                    .Text = "TEST"
                 With .Font
                    .Name = "Arial"
                    .Size = 18
                    .Bold = msoFalse
                    .Italic = msoFalse
                    .Underline = msoFalse
                    .Shadow = msoFalse
                    .Emboss = msoFalse
                    .BaselineOffset = 0
                    .AutoRotateNumbers = msoFalse
                    .Color.SchemeColor = ppForeground
                End With
               End With
            End With


    Next shapectr


    Next i

我需要更换＆＃34; TEST＆＃34;与幻灯片的备注区域中的文本（可能是几个句子）。

感谢您的帮助！

Answer 1

Sub addShp()
Dim osld As Slide
Dim oshp As Shape
Dim oTR As TextRange
For Each osld In ActivePresentation.Slides
On Error Resume Next
osld.Shapes("NOTES").Delete
Set oshp = osld.Shapes.AddShape(msoShapeRectangle, 10, 400, 400, 100)
oshp.Name = "NOTES"
oshp.TextFrame.AutoSize = ppAutoSizeShapeToFitText
oshp.Fill.ForeColor.RGB = RGB(255, 255, 204)
oshp.Line.ForeColor.RGB = RGB(0, 0, 0)
With oshp.TextFrame.TextRange
If Not getNotes(osld) Is Nothing Then .Text = getNotes(osld).Text
.Font.Name = "Arial"
.Font.Size = 10
.Font.Color.RGB = vbBlack
 End With
 oshp.Top = ActivePresentation.PageSetup.SlideHeight - oshp.Height
 Next osld
 End Sub

Function getNotes(osld As Slide) As TextRange
' usually shapes(2) but not always
Dim oshp As Shape
For Each oshp In osld.NotesPage.Shapes
If oshp.Type = msoPlaceholder Then
If oshp.PlaceholderFormat.Type = ppPlaceholderBody Then
If oshp.TextFrame.HasText Then
Set getNotes = oshp.TextFrame.TextRange
End If
End If
End If
Next oshp
End Function

看看这是否更接近

Answer 2

我想出了＆＃34;调整＆＃34;我需要左对齐文本并指定一个设定的高度。这是最终的代码：

Dim osld As Slide
Dim oshp As Shape
Dim oTR As TextRange

For Each osld In ActivePresentation.Slides

On Error Resume Next

osld.Shapes("NOTES").Delete

Set oshp = osld.Shapes.AddShape(msoShapeRectangle, 20, 400, 400, 300)
    oshp.Name = "NOTES"
    oshp.TextFrame.AutoSize = ppAutoSizeShapeToFitText
    oshp.Fill.ForeColor.RGB = RGB(255, 255, 204)
    oshp.Line.ForeColor.RGB = RGB(0, 0, 0)
    oshp.Line.Weight = 1.5

With oshp.TextFrame.TextRange
    If Not getNotes(osld) Is Nothing Then .Text = getNotes(osld).Text
    .Font.Name = "Arial"
    .Font.Size = 14
    .Font.Color.RGB = vbBlack
    .ParagraphFormat.Alignment = msoAlignLeft

End With

oshp.Width = 717

If oshp.Height < 105 Then
    oshp.Height = 105
End If
oshp.Left = 1
oshp.Top = ActivePresentation.PageSetup.SlideHeight - oshp.Height


Next osld

End Sub

Function getNotes(osld As Slide) As TextRange
' usually shapes(2) but not always
Dim oshp As Shape

For Each oshp In osld.NotesPage.Shapes
    If oshp.Type = msoPlaceholder Then
        If oshp.PlaceholderFormat.Type = ppPlaceholderBody Then
            If oshp.TextFrame.HasText Then
                Set getNotes = oshp.TextFrame.TextRange
            End If
        End If
    End If
Next oshp
End Function

非常感谢你的帮助!!!

PowerPoint宏 - 需要为每张幻灯片添加带有注释的矩形

2 个答案: