图片网格化裁剪源码

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

新建一个模块,直接替换里面的全部代码,具体方法可以参考 个人常用的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