图形分割-----仅仅红字部分在2003中不能通过，帮修改

Sub Crop_Pic()
'图形分割
'第一次试手的啊
'
Dim S_X As Integer, S_Y As Integer, vrtSelectedItem As Variant, fd As FileDialog, FilePath As String, _
    i As Integer, j As Integer, H As Single, W As Single, x As Single, y As Single, Si As Single, Sj As Single, sum As Integer
    '方向 标志  最终个数  坐标  长度 单位长度
    '横向   i        S_X         X       W      Si
    '纵向   j        S_Y         Y       H       Sj
    With ActivePresentation.Slides(1)
        '确认操作
        If MsgBox("将清空该页所有对象, 是否继续?", vbYesNo + vbInformation, "?") = vbYes Then
            '使幻灯片版式为"空白"
            .Layout = ppLayoutBlank
            '删除所有形状, 原因是, 后面方便的从shape(1)到shape(最大值)
            For i = 1 To .Shapes.Count
                .Shapes(1).Delete
            Next
            '输入框,自定义了一个function, 用来判断数据合法性
            S_X = InputInval("输入目标分割横值", "Split_X", "2")
            S_Y = InputInval("输入目标分割纵值", "Split_Y", 3)
            '这边就是打开 对话框
            Set fd = Application.FileDialog(msoFileDialogFilePicker)
            With fd
                '对话框的标题
                .Title = "请选择一个图片"
                '这是筛选的那部分
                .Filters.Clear
                .Filters.Add "All files", "*.*"
                .Filters.Add "Images", "*.gif; *.jpg; *.jpeg", 1
                '显示对话框
                If .Show = -1 Then
                    For Each vrtSelectedItem In .SelectedItems
                        '给FilePath返回路径
                        FilePath = vrtSelectedItem
                    Next vrtSelectedItem
                        '添加图片
                        ActivePresentation.Slides(1).Shapes.AddPicture FilePath, msoFalse, msoTrue, 0, 0
                Else
                    '未选择图片, 直接退出
                    MsgBox "未选择图片, 将退出!", vbOKOnly + vbInformation, "Error"
                    End
                End If
            End With
            '清空对话框
            Set fd = Nothing
            With .Shapes(1)
                H = .Height
                W = .Width
                x = .Left
                y = .Top
                Si = W / S_X
                Sj = H / S_Y
                .Name = .Name & ".bak"
                '这里直接复制粘贴了, 其实, 可以用AddPicture接着来
                .Copy
            End With
            sum = 1
            For i = 1 To S_X
                For j = 1 To S_Y
                    'sum就是图片的id啦...
                    sum = sum + 1
                    '粘贴下
                    .Shapes.Paste
                    '图片和第一个对齐
                    .Shapes(sum).Top = .Shapes(1).Top
                    .Shapes(sum).Left = .Shapes(1).Left
                    With .Shapes(sum)
                        '重命名图片, 方便识别
                        .Name = "pic" & Int(sum)
                        With .PictureFormat.Crop
                            .ShapeHeight = Sj
                            .ShapeWidth = Si
                            .ShapeLeft = (i - 1) * Si + x
                            .ShapeTop = (j - 1) * Sj + y
                        End With
                    End With
                Next j
            Next i
            '删除多出来的 ,类似与原始图片, 不用这行将保留原始图片
            .Shapes(1).Delete
            MsgBox "搞定啦, 快去看看吧~", vbInformation, "hahahahaha...^-^"
        Else
            End
        End If
    End With
End Sub
Function InputInval(Promot As String, Title As String, DefultVal As String)
'当用户给出不允许的值时, 我就有用了啊
    Dim x As Variant
    x = InputBox(Promot, Title, DefultVal)
    '判断整数
    If Int(x) = Val(x) Then
        '返回X的值啊
        InputInval = Int(x)
    Else
        '值错了, 就退出了
        MsgBox "未输入正确的值, 将退出!", vbInformation, "Error"
        End
    End If
End Function

网上找来的，原文地址http://www.rapidbbs.cn/forum.php?mod=viewthread&tid=35435&page=1&extra=#pid1090274

[ 本帖最后由 chuhaiou 于 2011-7-14 16:16 编辑 ]

Sub CropImage()

   ActivePresentation.Slides(1).Shapes.AddPicture "C:\Documents and Settings\user\桌面\1.jpg", msoFalse, msoTrue, 250, 150, 200, 200

   ActivePresentation.Slides(1).Shapes(1).PictureFormat.Crop.PictureHeight = 100

   ActivePresentation.Slides(1).Shapes(1).PictureFormat.Crop.PictureWidth = 100

   ActivePresentation.Slides(1).Shapes(1).PictureFormat.Crop.PictureOffsetX = 0

   ActivePresentation.Slides(1).Shapes(1).PictureFormat.Crop.PictureOffsetY = 0

   ActivePresentation.Slides(1).Shapes(1).PictureFormat.Crop.ShapeHeight = 100

   ActivePresentation.Slides(1).Shapes(1).PictureFormat.Crop.ShapeWidth = 100

   ActivePresentation.Slides(1).Shapes(1).PictureFormat.Crop.ShapeLeft = 330

   ActivePresentation.Slides(1).Shapes(1).PictureFormat.Crop.ShapeTop = 170

End Sub