PPT自动载入图片并矩阵分布

 1 Sub LoadPicToShape()
 2     Dim mPageWidth As Double, mPageHeight As Double
 3     Dim X_Count As Integer, Y_Count As Integer
 4     Dim mShapeWidth As Double, mShapeHeight As Double
 5     Dim mShape As Shape
 6     Dim mPicPath As String, mPicName As String
 7 
 8     ‘清除所有第1页上的所有形状
 9 
10     Do Until ActivePresentation.Slides(1).Shapes.Count = 0
11         ActivePresentation.Slides(1).Shapes(1).Delete
12     Loop
13 
14     mPageWidth = ActivePresentation.PageSetup.SlideWidth ‘获取页面宽度
15     mPageHeight = ActivePresentation.PageSetup.SlideHeight ‘获取页面高度
16 
17     ‘这2个参数可以自己调整
18     X_Count = 10: Y_Count = 6 ‘X方向图片数量，Y方向图片数量
19     mShapeWidth = mPageWidth / X_Count: mShapeHeight = mPageHeight / Y_Count ‘图片形状的宽度和高度
20 
21     ‘指定图片所在文件夹路径，并开始获取第1张jpg图片名称
22     mPicPath = "E:\Office培训\素材\图片"
23     mPicName = Dir(mPicPath & "\*.jpg")
24     If mPicName = "" Then Exit Sub
25 
26     ‘以下首先生成矩形形状，然后填充图片到形状
27     For i = 1 To X_Count
28         For j = 1 To Y_Count
29             Set mShape = ActivePresentation.Slides(1).Shapes.AddShape(msoShapeRectangle, _
30                 (i - 1) * mShapeWidth, (j - 1) * mShapeHeight, mShapeWidth, mShapeHeight)
31             mShape.Fill.UserPicture mPicPath & "\" & mPicName
32             mPicName = Dir
33             If mPicName = "" Then mPicName = Dir(mPicPath & "\*.jpg") ‘图片总数不够数，从头开始重复加载
34         Next
35     Next
36 End Sub