20170813pptVBA批量插入图片

Posted 2020-10-02 Excel VBA 小天地

Sub AddSldIn()
    Dim Pre As Presentation
    Dim NewSld As Slide

    Set Pre = Application.ActivePresentation
    Set NewSld = Pre.Slides.Add(Pre.Slides.Count + 1, ppLayoutBlank)

    Set Pre = Nothing
    Set NewSld = Nothing
End Sub
Sub AddTextBox()
    Dim Pre As Presentation
    Dim NewSld As Slide
    Dim Shp As Shape
    Dim Pos As Long
    Dim Tr As TextRange

    Set Pre = Application.ActivePresentation
    Set NewSld = Pre.Slides(1)
    With NewSld
        Set Shp = .Shapes.AddTextBox(msoTextOrientationHorizontal, Pre.PageSetup.SlideWidth / 2, 0, Pre.PageSetup.SlideWidth / 2, Pre.PageSetup.SlideHeight / 6)
        With Shp
            .TextFrame.WordWrap = msoTrue
            With .TextFrame.TextRange
                With .ParagraphFormat
                    .LineRuleWithin = msoTrue
                    .SpaceWithin = 1
                    .LineRuleBefore = msoTrue
                    .SpaceBefore = 0.5
                    .LineRuleAfter = msoTrue
                    .SpaceAfter = 0
                End With
                myText = "水平文本框" + Chr$(CharCode:=13) + "红色加粗"
                .Text = myText
                Pos = InStr(myText, Chr(13))
                Set Tr = .Characters(Pos + 1, Len(myText) - Pos)
                With Tr
                    .Font.Size = 36
                    .Font.Color.RGB = RGB(Red:=255, Green:=51, Blue:=0)
                End With
            End With
        End With

    End With
    Set Pre = Nothing
    Set NewSld = Nothing
End Sub
Sub InsertPicture()
    Dim Pre As Presentation
    Dim NewSld As Slide
    Dim Shp As Shape
    Dim FilePath As String
    Set Pre = Application.ActivePresentation
    Set NewSld = Pre.Slides(1)

    Set Shp = NewSld.Shapes.AddPicture(FilePath, msoFalse, msoTrue, 71, -21, 579, 584)

    Set Pre = Nothing
    Set NewSld = Nothing
    Set Shp = Nothing
End Sub
Function CustomLeft(ByVal Pre As Presentation, ByVal Pos As Long) As Double

End Function