PPT图片剪裁

Sub CropPicture()
    Dim shp As Shape, picFile As String, n As Long
    Dim sld As Slide, pre As Presentation
    Dim RowCount As Long, ColCount As Long
    RowCount = 2 '上下裁剪为几部分
    ColCount = 2 '左右裁剪为几部分
    Set pre = Application.ActivePresentation
    With Application.FileDialog(msoFileDialogFilePicker)
        .InitialFileName = pre.Path
        .AllowMultiSelect = False
        .Title = "请选择图片文件！"
        .Filters.Add "图片文件", "*.jpg*"
        If .Show = -1 Then
            picFile = .SelectedItems(1)
        End If
    End With
    Set sld = pre.Slides(1)
    n = 0
    For c = 1 To ColCount
        For r = 1 To RowCount
            n = n + 1
            For Each shp In sld.Shapes
                shp.Delete
            Next
            Set shp = sld.Shapes.AddPicture(picFile, False, True, 0, 0)
            With shp
                .LockAspectRatio = msoFalse
                .Width = pre.PageSetup.SlideWidth
                .Height = pre.PageSetup.SlideHeight
                .Left = 0
                .Top = 0
            End With
            With shp.PictureFormat.Crop
                ' 图片大小
                .PictureHeight = pre.PageSetup.SlideHeight
                .PictureWidth = pre.PageSetup.SlideWidth
                .PictureOffsetX = 0
                .PictureOffsetY = 0
                ' 裁剪形状左上角位置 ' 裁剪形状大小
                .ShapeLeft = (r - 1) * (shp.Width / ColCount)
                .ShapeTop = (c - 1) * shp.Height / RowCount
                .ShapeHeight = shp.Height / RowCount
                .ShapeWidth = shp.Width / ColCount
            End With
            With shp
                .LockAspectRatio = msoFalse
                .Width = pre.PageSetup.SlideWidth
                .Height = pre.PageSetup.SlideHeight
                .Left = 0
                .Top = 0
            End With
            sld.Export Application.ActivePresentation.Path & "/" & n & ".jpg", _
             "JPG", pre.PageSetup.SlideWidth, pre.PageSetup.SlideHeight
        Next r
    Next c
End Sub