文件夹内，能否用代码将图片插入到ppt中？

zzpsx

附件.rar (623.63 KB, 下载次数: 2)

2021-12-28 07:57 上传

点击文件名下载附件

想要的效果如下，页面背景和页码有或者没有关系不大。

andysky

https://m.toutiaoimg.cn/group/7009183854606942759/?app=news_article&timestamp=1640762295&group_id=7009183854606942759&tt_from=mobile_qq&utm_source=mobile_qq&utm_medium=toutiao_android&utm_campaign=client_share&share_token=c4c616eb-a860-422c-9996-dc59294a9b2b

请问是这种效果吗？

andysky

https://www.ixigua.com/6997121967472148996
这里还有一个更复杂的

zzpsx

谢谢大神给我们开眼界，真是神操作，求分享。

andysky

zzpsx 发表于 2021-12-29 16:02
谢谢大神给我们开眼界，真是神操作，求分享。

我的书中有源代码
ExcelVBA程序开发自学宝典第4版

zzpsx

andysky 发表于 2021-12-29 16:18
我的书中有源代码
ExcelVBA程序开发自学宝典第4版

请问代码是在书的光盘中吗？

zzpsx

找到了这个代码，好像不行
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

andysky

用PPT精灵也行