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

时间：2024-01-02 12:10:02

最近有学生问到，能不能快速的向PPT一个页面里插入成百张图片，并让它们按统一大小的矩形排布到页面上。我写了以下代码可以在第1页中按照指定横向和纵向矩形数目，填充指定路径下的图片。

 Sub LoadPicToShape()

     Dim mPageWidth As Double, mPageHeight As Double

     Dim X_Count As Integer, Y_Count As Integer

     Dim mShapeWidth As Double, mShapeHeight As Double

     Dim mShape As Shape

     Dim mPicPath As String, mPicName As String

     '清除所有第1页上的所有形状

     Do Until ActivePresentation.Slides().Shapes.Count =

         ActivePresentation.Slides().Shapes().Delete

     Loop

     mPageWidth = ActivePresentation.PageSetup.SlideWidth '获取页面宽度

     mPageHeight = ActivePresentation.PageSetup.SlideHeight '获取页面高度

     '这2个参数可以自己调整

     X_Count = : Y_Count =  'X方向图片数量，Y方向图片数量

     mShapeWidth = mPageWidth / X_Count: mShapeHeight = mPageHeight / Y_Count '图片形状的宽度和高度

     '指定图片所在文件夹路径，并开始获取第1张jpg图片名称

     mPicPath = "E:\Office培训\素材\图片"

     mPicName = Dir(mPicPath & "\*.jpg")

     If mPicName = "" Then Exit Sub

     '以下首先生成矩形形状，然后填充图片到形状

     For j =  To Y_Count

         For i =  To X_Count

             Set mShape = ActivePresentation.Slides().Shapes.AddShape(msoShapeRectangle, _

                 (i - ) * mShapeWidth, (j - ) * mShapeHeight, mShapeWidth, mShapeHeight)

             mShape.Fill.UserPicture mPicPath & "\" & mPicName

             mPicName = Dir

             If mPicName = "" Then mPicName = Dir(mPicPath & "\*.jpg") '图片总数不够数，从头开始重复加载

         Next

     Next

 End Sub

相关文章