vba Crop 图片等份切割 （非常接近无间隙）

perfect131

             vba Crop 图片等份切割，根据图片缩放高宽 ，每份高宽会有微小的差异，可以忽略

              代码参考：

1. Sub 图片切割()  '''无间隙图片切割
   
2.     ActiveSheet.Pictures.Delete '''删图
   
3.     myFname = Application.GetOpenFilename(FileFilter:="全部图片(*.jpg;*.png;*.jpeg),*.jpg;*.png;*.jpeg")
   
4.     If myFname = "False" Then Exit Sub
   
5.     n1 = Val(InputBox("横切几块?", "分图", 5))                       '横n1-1刀
   
6.     n2 = Val(InputBox("竖切几块?", "分图", 5))                       '竖n2-1刀
   
7.     Set 原图 = ActiveSheet.Pictures.Insert(myFname)
   
8.     With 原图
   
9.         .Top = 20: .Left = 20
   
10.         w = .Width: h = .Height: .Copy: .Delete                '读取原图 W/H 尺寸 ，复制后删除
    
11.     End With
    
12.     '''判断 宽高会不会整除
    
13.     If w / n1 <> w \ n1 Then w = (w \ n1) * n1 + n1: aa = aa + 1
    
14.     If h / n2 <> h \ n2 Then h = (h \ n2) * n2 + n2: aa = aa + 1
    
15.     If aa > 0 Then
    
16.         ''不整除，调整宽高
    
17.         With ActiveSheet.Shapes.AddPicture(Filename:=myFname, _
    
18.                 LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=20, Top:=20, Width:=w, Height:=h)
    
19.             .Copy: .Delete                                     '复制后删除
    
20.         End With
    
21.     End If
    
22.     num = 1
    
23.     For i = 1 To n1
    
24.         For j = 1 To n2
    
25.             ActiveSheet.Paste
    
26.             Selection.Name = "pic" & num
    
27.             With ActiveSheet.Shapes("pic" & num)
    
28.                 .Top = 20: .Left = 20
    
29.                 measurements = GetOriginalMeasurements(ActiveSheet.Shapes("pic" & num))
    
30.                 ScaleWidth = (w / (measurements(0) / 100)) / 100
    
31.                 ScaleHeight = (h / (measurements(1) / 100)) / 100
    
32.                 .PictureFormat.CropLeft = w * (j - 1) / n2 / ScaleWidth
    
33.                 .PictureFormat.CropRight = w * (n2 - j) / n2 / ScaleWidth
    
34.                 .PictureFormat.CropTop = h * (i - 1) / n1 / ScaleHeight
    
35.                 .PictureFormat.CropBottom = h * (n1 - i) / n1 / ScaleHeight
    
36.             End With
    
37.             num = num + 1
    
38.         Next
    
39.     Next
    
40. End Sub
    
41. Private Function GetOriginalMeasurements(ByRef myShape As Excel.Shape)
    
42.     Dim shpCopy As Excel.Shape
    
43.     Dim measurements(1) As Single
    
44.     Set shpCopy = myShape.Duplicate
    
45.     ' Reset original measurements
    
46.     shpCopy.ScaleWidth 1, msoTrue
    
47.     shpCopy.ScaleHeight 1, msoTrue
    
48.     measurements(0) = shpCopy.Width
    
49.     measurements(1) = shpCopy.Height
    
50.     shpCopy.Delete
    
51.     GetOriginalMeasurements = measurements
    
52. End Function

复制代码

实际案例 22 楼：https://club.excelhome.net/forum ... 68&pid=11136201

少如

请教：另存为图片如何处理呀？谢谢！

perfect131

少如 发表于 2022-11-28 07:30
请教：另存为图片如何处理呀？谢谢！

导出高质量图片 (Shapes到图片)
https://club.excelhome.net/forum ... amp;_dsign=7154d8b6

opiona

图片分隔  支持一下