[英]PowerPoint Macro - Need to add Rectangle with Notes to each Slide
I have a PowerPoint with notes for each slide.我有一个 PowerPoint,每张幻灯片都有注释。 For each slide, I want to copy the notes, create a yellow rectangle with black border, and paste the notes into the rectangle.对于每张幻灯片,我想复制笔记,创建一个带有黑色边框的黄色矩形,然后将笔记粘贴到矩形中。
I started "splicing" a macro together.我开始“拼接”一个宏。 Here is what I have so far.这是我到目前为止所拥有的。 It works but rectangle is at the top (need at bottom) and not sure how to copy and paste the notes into the rectangle:它有效,但矩形位于顶部(底部需要)并且不确定如何将注释复制并粘贴到矩形中:
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
I need to replace "TEST" with the text that is in the notes area of the slide (could be several sentences).我需要用幻灯片注释区域中的文本(可能是几个句子)替换“TEST”。
I appreciate your help!我感谢您的帮助!
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
See if this is closer看看这是否更近
I figured out the "tweaks" I needed to left justify the text and specify a set height.我想出了我需要左对齐文本并指定设置高度的“调整”。 Here is the final code:这是最终的代码:
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
Many thanks for your help!!!非常感谢您的帮助!!!
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.