PowerPoint宏 - 需要添加矩形和註釋到每個幻燈片

我有一個PowerPoint與每張幻燈片的筆記。對於每張幻燈片，我想複製筆記，創建一個帶黑色邊框的黃色矩形，並將筆記粘貼到矩形中。PowerPoint宏 - 需要添加矩形和註釋到每個幻燈片

我開始「拼接」一個宏。這是我到目前爲止。它的工作原理，但矩形是在頂部（需要在底部），不知道如何註釋複製並粘貼到矩形：

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

我需要更換「TEST」與那就是在音符區域中的文本的幻燈片（可能是幾句話）。

我感謝您的幫助！

來源

2015-06-09 user3264432

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

看看這是接近

來源

2015-06-09 13:35:59

這太棒了！還有一個問題---我想把盒子做成相同的大小，並穿過整個幻燈片。我用什麼命令來設置大小？（我知道我需要替換「oshp.TextFrame.AutoSize .....」聲明。非常感謝您的幫助!!! – user3264432

ActivePresentation.PageSetup.SlideHeight和.SlideWidth將返回當前演示文稿幻燈片的高度和寬度 –

我有幾個問題/調整： – user3264432

我想通了「微調」我需要左對齊文本，並指定一組高度。這裏是最終的代碼：

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

非常感謝您的幫助！

來源

2015-06-12 00:41:40 user3264432

PowerPoint宏 - 需要添加矩形和註釋到每個幻燈片

回答

相關問題