vba word 图片切割

banjinjiu

请版主能加个精华，盖个精华章，要求不高吧，呵呵。也请大侠看能否把程序简化。

在ppt、excel板块都实现了图片的切割，但是，那些方法大部分从vb来的dll文件，无法查看源文件或代码。无意中，我找到了方法，很高兴与大家一同分享。

曾经看过首柔的文章，求助帖《vba能否实现图片分割，比如4等分》，http://club.excelhome.net/thread-225067-1-1.html，好像没能实现图片切割功能，不知道后来怎样了。

PictureFormat.CropLeft=20

‘表示指定图片或 OLE 对象从左侧裁剪了20 磅，只剩下右侧。

PictureFormat.CropRight=30

‘表示指定图片或 OLE 对象从右侧裁剪了30 磅，只剩下左侧。

PictureFormat.CropTop=40

‘表示指定图片或 OLE 对象从顶侧裁剪了40 磅，只剩下底侧。

PictureFormat.CropTop =50

‘表示指定图片或 OLE 对象从底侧裁剪了50 磅，只剩下顶侧。

如果把这四个属性的数值改为图片的高度(height)或宽度(width)，那不就实现了图片的切割了吗？

比如：

PictureFormat.CropLeft= ActiveDocument.Shapes("picture 2").Width / 2

‘浮动式图片

PictureFormat.CropLeft= ActiveDocument.InlineShapes(i).Height / 2

‘嵌入式图片

但是图片切割一次后，原有的图片就消失了，只剩下切割后的图片。怎么办？我想到了继续添加图片，或复制粘贴原有的图片，这样，切割就能多次进行。

简单举个例子，比如要把一个图片切割成四等份，就是横一刀，竖一刀，分成左上、右上、左下、右下四部分。

1、怎么保留左上呢？切掉右侧CropRight，切掉底侧CropBottom。

2、怎么保留右上呢？切掉左侧CropLeft，切掉底侧CropBottom。

3、怎么保留左下呢？切掉右侧.CropRight，切掉上侧CropTop。

4、怎么保留右上呢？切掉左侧CropLeft，切掉上侧CropTop。

因为不断添加图片，图片的名称就变化了，所以我在引用新的图片名称时就重新定义了。而在嵌入式图片时使用了复制粘贴的方法。

如果在你的电脑运行错误，建议你在空白文档中运行，或修改括号（）中的数值。

1. Sub 嵌入式图片切割1()
   
2. ‘插入一个嵌入式图片，只有一个哦
   
3. '横一刀
   
4. Dim s As InlineShape
   
5. Dim i As Integer
   
6. Set FileName = ActiveDocument.InlineShapes(1)
   
7. i = ActiveDocument.InlineShapes.Count
   
8. Set s = ActiveDocument.InlineShapes(1)
   
9. s.PictureFormat.CropBottom = ActiveDocument.InlineShapes(i).Height / 2
   
10. End Sub

复制代码

1. Sub 嵌入式图片切割2()
   
2. ‘插入一个嵌入式图片，只有一个哦
   
3. '竖一刀
   
4. Dim s As InlineShape
   
5. Dim i As Integer
   
6. Set FileName = ActiveDocument.InlineShapes(1)
   
7. i = ActiveDocument.InlineShapes.Count
   
8. Set s = ActiveDocument.InlineShapes(1)
   
9. s.PictureFormat.CropRight = ActiveDocument.InlineShapes(i).Width / 2
   
10. End Sub

复制代码

1. Sub 嵌入式图片切割3()
   
2. ‘插入一个嵌入式图片，只有一个哦
   
3. '横一刀竖一刀
   
4. Dim s As InlineShape, t As InlineShape, m As InlineShape, n As InlineShape
   
5. Dim i As Integer
   
6. Set FileName = ActiveDocument.InlineShapes(1)
   
7. i = ActiveDocument.InlineShapes.Count
   
8. ActiveDocument.InlineShapes(1).Select
   
9. Selection.Copy
   
10. Set s = ActiveDocument.InlineShapes(1)
    
11. s.PictureFormat.CropRight = ActiveDocument.InlineShapes(1).Width / 2 '左上
    
12. s.PictureFormat.CropBottom = ActiveDocument.InlineShapes(1).Height / 2
    
13. Selection.MoveRight Unit:=wdCharacter, Count:=1
    
14. Selection.Paste
    
15. ActiveDocument.InlineShapes(2).Select
    
16. Set t = ActiveDocument.InlineShapes(2)
    
17. t.PictureFormat.CropLeft = ActiveDocument.InlineShapes(2).Width / 2 '右上
    
18. t.PictureFormat.CropBottom = ActiveDocument.InlineShapes(2).Height / 2
    
19. Selection.MoveRight Unit:=wdCharacter, Count:=1
    
20. Selection.Paste
    
21. ActiveDocument.InlineShapes(3).Select
    
22. Set m = ActiveDocument.InlineShapes(3)
    
23. m.PictureFormat.CropRight = ActiveDocument.InlineShapes(3).Width / 2 '左下
    
24. m.PictureFormat.CropTop = ActiveDocument.InlineShapes(3).Height / 2
    
25. Selection.MoveRight Unit:=wdCharacter, Count:=1
    
26. Selection.Paste
    
27. ActiveDocument.InlineShapes(4).Select
    
28. Set n = ActiveDocument.InlineShapes(4)
    
29. n.PictureFormat.CropLeft = ActiveDocument.InlineShapes(4).Width / 2 '右下
    
30. n.PictureFormat.CropTop = ActiveDocument.InlineShapes(4).Height / 2
    
31. End Sub

复制代码

浮动式图片切割原理和嵌入式图片切割原理相似。

1. Sub 浮动式图片切割1()
   
2. ‘插入嵌入式图片，改为浮动式图片后。
   
3. '横一刀竖一刀
   
4. Dim s As Shape, t As Shape, m As Shape, n As Shape
   
5. Dim i As Integer
   
6. Selection.ShapeRange.Name = "picture 2"
   
7. 'i = ActiveDocument.Shapes.Count
   
8. Set s = ActiveDocument.Shapes("picture 2")
   
9. ActiveDocument.Shapes("picture 2").Select
   
10. Selection.Copy
    
11. s.PictureFormat.CropRight = ActiveDocument.Shapes("picture 2").Width / 2’左上
    
12. s.PictureFormat.CropBottom = ActiveDocument.Shapes("picture 2").Height / 2
    
13. Selection.MoveRight Unit:=wdCharacter, Count:=1
    
14. Selection.Paste
    
15. Selection.ShapeRange.Name = "picture 3"
    
16. Set t = ActiveDocument.Shapes("picture 3")
    
17. t.PictureFormat.CropLeft = ActiveDocument.Shapes("picture 3").Width / 2’右上
    
18. t.PictureFormat.CropBottom = ActiveDocument.Shapes("picture 3").Height / 2
    
19. Selection.MoveRight Unit:=wdCharacter, Count:=1
    
20. Selection.Paste
    
21. Selection.ShapeRange.Name = "picture 4"
    
22. Set m = ActiveDocument.Shapes("picture 4")
    
23. m.PictureFormat.CropRight = ActiveDocument.Shapes("picture 4").Width / 2’左下
    
24. m.PictureFormat.CropTop = ActiveDocument.Shapes("picture 4").Height / 2
    
25. Selection.MoveRight Unit:=wdCharacter, Count:=1
    
26. Selection.Paste
    
27. Selection.ShapeRange.Name = "picture 5"
    
28. Set n = ActiveDocument.Shapes("picture 5")
    
29. n.PictureFormat.CropLeft = ActiveDocument.Shapes("picture 5").Width / 2’右下
    
30. n.PictureFormat.CropTop = ActiveDocument.Shapes("picture 5").Height / 2
    
31. End Sub

复制代码

下面几个程序，文件名自己可以修改，其余的不动。文档中是空白的，利用导入文件的方法。每次切割后，原有图片消失，只剩下切割后的图片，所以我的程序里不断添加这个文件，不断切割，达到效果。

1. Sub 图片切割四等份()
   
2. '横一刀竖一刀
   
3. Dim s As Shape
   
4. Dim i As Integer
   
5. filename = "C:\Documents and Settings\Administrator\桌面\111.jpg"
   
6. i = ActiveDocument.Shapes.Count
   
7. Set s = ActiveDocument.Shapes.AddPicture(filename)
   
8. s.PictureFormat.CropRight = ActiveDocument.Shapes(i + 1).Width / 2
   
9. s.PictureFormat.CropBottom = ActiveDocument.Shapes(i + 1).Height / 2
   
10. Set s = ActiveDocument.Shapes.AddPicture(filename)
    
11. s.PictureFormat.CropLeft = ActiveDocument.Shapes(i + 2).Width / 2
    
12. s.PictureFormat.CropBottom = ActiveDocument.Shapes(i + 2).Height / 2
    
13. Set s = ActiveDocument.Shapes.AddPicture(filename)
    
14. s.PictureFormat.CropRight = ActiveDocument.Shapes(i + 3).Width / 2
    
15. s.PictureFormat.CropTop = ActiveDocument.Shapes(i + 3).Height / 2
    
16. Set s = ActiveDocument.Shapes.AddPicture(filename)
    
17. s.PictureFormat.CropLeft = ActiveDocument.Shapes(i + 4).Width / 2
    
18. s.PictureFormat.CropTop = ActiveDocument.Shapes(i + 4).Height / 2
    
19. End Sub

复制代码

1. Sub 图片切割六等份()
   
2. '横一刀竖两刀
   
3. Dim s As Shape
   
4. Dim i As Integer
   
5. filename = "C:\Documents and Settings\Administrator\桌面\111.jpg"
   
6. i = ActiveDocument.Shapes.Count
   
7. Set s = ActiveDocument.Shapes.AddPicture(filename)
   
8. s.PictureFormat.CropRight = ActiveDocument.Shapes(i + 1).Width * 2 / 3 '左上块
   
9. s.PictureFormat.CropBottom = ActiveDocument.Shapes(i + 1).Height / 2
   
10. Set s = ActiveDocument.Shapes.AddPicture(filename)
    
11. s.PictureFormat.CropLeft = ActiveDocument.Shapes(i + 2).Width / 3 '中上块
    
12. s.PictureFormat.CropRight = ActiveDocument.Shapes(i + 2).Width / 2
    
13. s.PictureFormat.CropBottom = ActiveDocument.Shapes(i + 2).Height / 2
    
14. Set s = ActiveDocument.Shapes.AddPicture(filename)
    
15. s.PictureFormat.CropLeft = ActiveDocument.Shapes(i + 3).Width * 2 / 3 '右上块
    
16. s.PictureFormat.CropBottom = ActiveDocument.Shapes(i + 3).Height / 2
    
17. Set s = ActiveDocument.Shapes.AddPicture(filename)
    
18. s.PictureFormat.CropRight = ActiveDocument.Shapes(i + 4).Width * 2 / 3 '左下块
    
19. s.PictureFormat.CropTop = ActiveDocument.Shapes(i + 4).Height / 2
    
20. Set s = ActiveDocument.Shapes.AddPicture(filename)
    
21. s.PictureFormat.CropLeft = ActiveDocument.Shapes(i + 5).Width / 3 '中下块
    
22. s.PictureFormat.CropRight = ActiveDocument.Shapes(i + 5).Width / 2
    
23. s.PictureFormat.CropTop = ActiveDocument.Shapes(i + 5).Height / 2
    
24. Set s = ActiveDocument.Shapes.AddPicture(filename)
    
25. s.PictureFormat.CropLeft = ActiveDocument.Shapes(i + 6).Width * 2 / 3 '右下块
    
26. s.PictureFormat.CropTop = ActiveDocument.Shapes(i + 6).Height / 2 '
    
27. End Sub

复制代码

1. Sub 图片切割六等份2()
   
2. '横两刀竖一刀
   
3. Dim s As Shape
   
4. Dim i As Integer
   
5. filename = "C:\Documents and Settings\Administrator\桌面\111.jpg"
   
6. i = ActiveDocument.Shapes.Count
   
7. Set s = ActiveDocument.Shapes.AddPicture(filename)
   
8. s.PictureFormat.CropRight = ActiveDocument.Shapes(i + 1).Width / 2 '左上块
   
9. s.PictureFormat.CropBottom = ActiveDocument.Shapes(i + 1).Height * 2 / 3
   
10. Set s = ActiveDocument.Shapes.AddPicture(filename)
    
11. s.PictureFormat.CropLeft = ActiveDocument.Shapes(i + 2).Width / 2 '右上块
    
12. s.PictureFormat.CropBottom = ActiveDocument.Shapes(i + 2).Height * 2 / 3
    
13. Set s = ActiveDocument.Shapes.AddPicture(filename)
    
14. s.PictureFormat.CropTop = ActiveDocument.Shapes(i + 3).Height / 3 '左中块
    
15. s.PictureFormat.CropBottom = ActiveDocument.Shapes(i + 3).Height / 2
    
16. s.PictureFormat.CropRight = ActiveDocument.Shapes(i + 3).Width / 2
    
17. Set s = ActiveDocument.Shapes.AddPicture(filename)
    
18. s.PictureFormat.CropTop = ActiveDocument.Shapes(i + 4).Height / 3 '右中块
    
19. s.PictureFormat.CropBottom = ActiveDocument.Shapes(i + 4).Height / 2
    
20. s.PictureFormat.CropLeft = ActiveDocument.Shapes(i + 4).Width / 2
    
21. Set s = ActiveDocument.Shapes.AddPicture(filename)
    
22. s.PictureFormat.CropRight = ActiveDocument.Shapes(i + 5).Width / 2 '左下块
    
23. s.PictureFormat.CropTop = ActiveDocument.Shapes(i + 5).Height * 2 / 3
    
24. Set s = ActiveDocument.Shapes.AddPicture(filename)
    
25. s.PictureFormat.CropLeft = ActiveDocument.Shapes(i + 6).Width / 2 '右下块
    
26. s.PictureFormat.CropTop = ActiveDocument.Shapes(i + 6).Height * 2 / 3 '
    
27. End Sub

复制代码

如果程序有错误，请告知，谢谢。

zhanglei1371

有一定创意。不过精华帖貌似不可能的。守柔为word第一人，看看也就22个精华。惊才绝艳的七叶一枝梅屡屡发出高深的东西，7个精华。sylun和tangqingfu混了几年，也就是1个精华。可想而知，在EH的word板块搞一个精华帖多费劲。如今版主基本都不露脸了，更没人去加精华贴了。好像两年都没见有精华贴了。。。。。。

xyz74sc

呵呵，楼上是看了n多年前的帖子，那时对api的研究还不深入，用裁剪的方法本质上是没有实现图片切割的，如果要切成30以上数量级的话，文件体积会巨增。用gdi+才是正解，这个在VB的代码中已经很常见了。

banjinjiu

xyz74sc 发表于 2014-8-28 20:26
呵呵，楼上是看了n多年前的帖子，那时对api的研究还不深入，用裁剪的方法本质上是没有实现图片切割的，如果 ...

谢谢提醒，能否给个gdi的实例，以及对旋转倾斜的图片操作。

agoodfish

学习了啊啊啊啊

feilang5000

谢谢！批量修改裁剪WORD图片，很有用。

weiyingde

有创意，很好，但不知在实用性上有否指向？