PPT 批量插入图片代码

gareth

Yalishanda30 发表于 2020-10-18 18:27
附件供参考

图的次序乱了。不是从1.jpg~20.jpg

Yalishanda30

gareth 发表于 2020-10-18 19:56
图的次序乱了。不是从1.jpg~20.jpg

如果图片名都是数字，可以先排序再批量插入

gareth

Yalishanda30 发表于 2020-10-19 08:44
如果图片名都是数字，可以先排序再批量插入

再次感谢，帮了我大忙。

gareth

Yalishanda30 发表于 2020-10-18 19:47
附件供参考

ActivePresentation.ApplyTheme PowerPoint.ActivePresentation.Path & "\New.potx" '换新的母版

老师，更换新母版，只能是当前路径么，可否指定路径？如
"c:\New.potx"

Yalishanda30

gareth 发表于 2020-10-22 16:24
ActivePresentation.ApplyTheme PowerPoint.ActivePresentation.Path & "\New.potx" '换新的母版

老师 ...

当然可以，你自己测试

gareth

Yalishanda30 发表于 2020-10-22 17:31
当然可以，你自己测试

ActivePresentation.ApplyTheme & "c:\New.potx"
ActivePresentation.ApplyTheme PowerPoin & "c:\New.potx"
都不行呀

Yalishanda30

gareth 发表于 2020-10-22 19:39
ActivePresentation.ApplyTheme & "c:\New.potx"
ActivePresentation.ApplyTheme PowerPoin & "c:\New.p ...

你C盘根目录有模板文件吗？应该是这样 ActivePresentation.ApplyTheme  "c:\New.potx"

gareth

Yalishanda30 发表于 2020-10-23 16:04
你C盘根目录有模板文件吗？应该是这样 ActivePresentation.ApplyTheme  "c:\New.potx"

谢谢！的确如此。
有空帮我关注一下另外一个贴子呀，竟然0人看！
http://club.excelhome.net/thread-1560299-1-1.html

zzpsx

感谢高手，您的代码真的太厉害了，解决了我多年的困惑。毕竟ppt自带的插入相册来插入图片步骤太多。

弱弱地问下，想要得到附件中想要的效果，您的代码如何修改，主要是修改图片在ppt中的坐标？谢谢。


想要的效果.rar (1.41 MB, 下载次数: 12)

2023-2-12 19:21 上传

点击文件名下载附件

目前代码的效果.rar (1.1 MB, 下载次数: 11)

2023-2-12 18:54 上传

点击文件名下载附件

Sub InsertPicture()
Dim oPPT As Presentation
Dim oSlide As Slide
Dim oCL As CustomLayout
Dim Shp As Shape
Dim myFile
Dim filearr()
Set oPPT = PowerPoint.ActivePresentation
sPath = PowerPoint.ActivePresentation.Path & "\pic\"
myFile = Dir(sPath & "*.png")
Do While myFile <> ""
    ReDim Preserve filearr(i)
    filearr(i) = myFile
    i = i + 1
    myFile = Dir
Loop

With oPPT
    For i = 0 To UBound(filearr)
        Set oCL = .Slides(1).CustomLayout
        Set oSlide = .Slides.AddSlide(i + 2, oCL)
        Set Shp = oSlide.Shapes.AddPicture(sPath & filearr(i), msoFalse, msoTrue, 71, -21, 579, 584)
    Next
End With
MsgBox "完成"
End Sub

是不是修改红色的？

ning84

1. Private Sub del()
   
2.     Dim Rng As Range
   
3.     Dim Sht As Worksheet
   
4.     ''
   
5.     Dim Ppt As PowerPoint.Application
   
6.     Dim Pres As Presentation
   
7.     Dim Sld As Slide
   
8.    
   
9.         Set Rng = Selection
   
10.         ''
    
11.         Set Sht = Rng.Parent
    
12.         Set Rng = Sht.Cells(Rng.Row, 1).Resize(Rng.Rows.Count, 1)
    
13.         ''
    
14.         Set Ppt = New PowerPoint.Application
    
15.         Ppt.Visible = msoTrue
    
16.         If Ppt.Presentations.Count = 0 Then
    
17.              Set Pres = Ppt.Presentations.Add
    
18.              Set Sld = Pres.Slides.Add(1, ppLayoutBlank)
    
19.         Else
    
20.              Set Pres = Ppt.ActivePresentation
    
21.              Set Sld = Pres.Slides(1)
    
22.         End If
    
23.         'Debug.Print Pres.PageSetup.SlideHeight, Pres.PageSetup.SlideWidth
    
24.         For ii = Pres.Slides.Count To 1 Step -1
    
25.               Pres.Slides(ii).Delete
    
26.         Next ii
    
27.         For ii = 1 To Rng.Rows.Count
    
28.             Set Sld = Pres.Slides.Add(ii, ppLayoutBlank)
    
29.             ExcelInsertPicture Pres, Sld, Rng(ii, 1)
    
30.         Next ii
    
31. End Sub
    
32. Function ExcelInsertPicture(Pres As Presentation, Sld As Slide, Rng As Range)
    
33.    Debug.Print Sld.Name, Rng.Address, Rng(, 1), Rng(, 2), Rng(, 3)
    
34.    Dim Shp 'As Shape
    
35.            Set Shp = Sld.Shapes.AddPicture(Rng(, 1), msoFalse, msoTrue, 0, 0, Rng(, 2), Rng(, 3))
    
36.            'Debug.Print Shp.Width, Shp.Height
    
37.            With Shp
    
38.                .Width = .Width * 0.2
    
39.                .Height = .Height * 0.2
    
40.                .Top = (Pres.PageSetup.SlideHeight - .Height) / 2
    
41.                .Left = 20
    
42.            End With
    
43. End Function
    

复制代码