图片网格化裁剪源码

发表于 更新于 分类于

今天又小伙伴在群里问及这个问题，就干脆直接放以前写好的源代码的吧！

新建一个模块，直接替换里面的全部代码，具体方法可以参考 个人常用的VBA代码块 中的方法

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
Option Explicit

Public Const APP_NAME  As String = "网格化裁剪图片"
Public Const DEVELOPER_NAME  As String = "ye4241"

Private Function InputInval(Promot As String, Title As String, DefultVal As String)
    '当用户给出不允许的值时，将跳出
    Dim X As Variant, Y As Integer
    X = InputBox(Promot, Title, DefultVal)
    If IsNumeric(X) Then
        InputInval = X
    Else
        MsgBox "未输入正确的值, 将退出!", vbOKOnly, APP_NAME
        End
    End If
End Function

Private Sub CropShape(oSh As Shape)
    Dim cropX As Integer, cropY As Integer
    Dim i As Integer, j As Integer
    Dim H As Single, W As Single
    Dim X As Single, Y As Single
    Dim Si As Single, Sj As Single
    Dim sum As Integer

    '方向 标志 个数 坐标 长度 单位 长度
    '横向  i  cropX  X  W Si
    '纵向  j  cropY  Y  H  Sj
    cropX = InputInval("请输入横向裁剪数量：", APP_NAME, "4")
    cropY = InputInval("请输入竖向裁剪数量：", APP_NAME, "3")

    '对插入的图形预处理
    Dim nSh As Shape
    '这边oSld的处理为Variant的话，将能支持各种父级对象
    Dim oSld As Variant
    Set oSld = oSh.Parent
    '获取当前图形所有参数
    With oSh
        H = .height
        W = .Width
        X = .Left
        Y = .Top
        Si = W / cropX
        Sj = H / cropY
        '修改当前图片名称
        .Name = .Name & ".bak"
    End With
    '横向遍历
    For i = 1 To cropX
        '纵向遍历
        For j = 1 To cropY
            sum = sum + 1
            '复制当前图形
            Set nSh = oSh.Duplicate(1)
            With nSh
                .Top = oSh.Top
                .Left = oSh.Left
                '智能化重命名
                .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
End Sub

Public Sub 剪裁当前所选图片()
    Dim oSh As Shape
    On Error GoTo CropSelectedPicture_Error
    '只会裁剪所选的第一个对象
    Set oSh = ActiveWindow.Selection.ShapeRange(1)
    If Not (oSh.PictureFormat Is Nothing) Then
        Call CropShape(oSh)
    End If
    On Error GoTo 0
    Exit Sub

CropSelectedPicture_Error:
    Debug.Print "Error " & Err.Number & " (" & Err.Description & ")"

End Sub

Public Sub 批量裁剪所有图层()
    Dim oShps As PowerPoint.ShapeRange, oSh As PowerPoint.Shape
    Set oShps = ActiveWindow.Selection.ShapeRange
    For Each oSh In oShps
        If Not (oSh.PictureFormat Is Nothing) Then
            Call CropShape(oSh)
        End If
    Next
End Sub

Public Sub 插入图片后裁剪()
    Dim vrtSelectedItem As Variant, fd As FileDialog, FilePath As String
    '文件选择对话框
    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 = vrtSelectedItem
            Next vrtSelectedItem
        Else
            MsgBox "未选择图片, 将退出!", vbOKOnly, APP_NAME
            End
        End If
    End With
    Set fd = Nothing

    Dim Sh As Shape
    Set Sh = ActiveWindow.Selection.SlideRange(1).Shapes.AddPicture(FilePath, msoFalse, msoTrue, 0, 0)

    Call CropShape(Sh)
End Sub