作者学习VBA以来搜集的操作图片的代码都在这里了。这就是我说的用到时候修修改改的源代码。
▶▶▶单元格（合并单元格）插入图片
Pictures.insert通用性不如shapes.addpicture。Excel2016用pictures.insert插入图片，
得到的是图片链接，而非嵌入图片。(虽然录制宏得到的的确是这个insert方法)
Sub 插入图片()
Set Rng = Range("a1")
i = ThisWorkbook.Path & "\" & "图片" & "\1.jpg"
Sheet1.Shapes.AddPicture i, True, True, Rng.Left, Rng.Top, Rng.Width, Rng.Height
End Sub
'rng是你需要插入图片的单元格。前面需要给rng指定一下是哪个单元格Sub 合并单元格插入图片()
Range("d4").Select
Set r = Selection
i = ThisWorkbook.Path & "\" & "图片" & "\1.jpg"
Sheet1.Shapes.AddPicture i, True, True, r.Left, r.Top, r.Width, r.Height
End Sub▶▶▶批注插入图片
Sub test()
Dim rng As Range, com As Comment
[a:a].ClearComments
For Each rng In Range("a2", [a2].End(xlDown))
Set com = rng.AddComment
com.Shape.Fill.UserPicture ThisWorkbook.Path & "\素材图片\" & rng.Value
com.Shape.Width = 100
com.Shape.Height = 60
Next
End Sub
▶▶▶导出插入的图片
Sub 保存文件中的图片()
Dim ad$, m&, mc$, shp As Shape
Dim nm$, n&, myFolder$
Sheet1.Activate
n = 0
myFolder = ThisWorkbook.Path & "\图片\" '指定文件夹名称
For Each shp In ActiveSheet.Shapes
If shp.Type = 13 Then
If Len(Dir(myFolder, vbDirectory)) = 0 Then
MkDir myFolder
End If
n = n + 1
'ad = shp.TopLeftCell.Address
m = shp.TopLeftCell.Row
mc = Replace(Cells(m, 1).Address, "$", "")
nm = Format(n, "00") & "-" & mc & ".jpg" '图形对象的名字
shp.CopyPicture '将图形对象复制到剪切板
With ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart '在工作表中添加一个图表对象
.Parent.Select
.Paste '代码将剪切板中的图形对象以图片的格式粘贴到新添加的图表中
.Export myFolder & nm, "JPG"
.Parent.Delete '删除工作表中添加的图表对象
End With
'Range(ad) = nm
End If
Next
MsgBox "完成"
End Sub
▶▶▶导出选定区域为图片
导出为png格式、按位图复制（Rng.CopyPicture xlScreen, xlBitmap）不会失真
Sub 导出选定区域为图片()
Call RangeToPic(Range("A1:D5")) '直接输入要输出的区域……必须有Range()
Call RangeToPic(Selection) '按当前选中的区域
Call RangeToPic(Application.InputBox("Select Range", Type:=8)) '出现对话框选择区域
End SubSub RangeToPic(Rng As Range, Optional Pnm = "", Optional Pth = "")
If Pth = "" Then Pth = ActiveWorkbook.Path '默认使用当前文件所在路径作为输出路径
If Pnm = "" Then Pnm = Left(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".") - 1) & "_" & Replace(Rng.Address(0, 0), ":", "_")
'默认使用当前【文件名_区域地址】作为输出文件名
If ActiveWindow.DisplayGridlines = True Then ActiveWindow.DisplayGridlines = False: flg = True '去掉默认格子线
Rng.CopyPicture Appearance:=xlScreen, Format:=xlBitmap '把选择范围内容转化为截屏图片信息
With ActiveSheet.ChartObjects.Add(0, 0, Rng.Width + 1, Rng.Height + 1).Chart '在A1处按图片尺寸稍大建立1个空白图表对象
.ChartArea.Border.LineStyle = 0 '去除边框
.Paste '把刚才截屏的图片信息粘贴上去
.Export Pth & "\" & Pnm & ".jpg", "JPG" '按指定图片路径及名称导出jgp格式图片……如果区域内有图片应该用这个
.Export Pth & "\" & Pnm & ".png", "PNG" '按指定图片路径及名称导出png格式图片……这个对于纯数据工作表来说更好
.Parent.Delete '删去该临时增加的图表对象
End With
If flg Then ActiveWindow.DisplayGridlines = True '恢复默认格子线
End Sub
▶▶▶导出图表为图片
Sub 导出图表为图片()
Dim myChart As Chart
Dim myFileName As String
Set myChart = Sheet1.ChartObjects(1).Chart
myFileName = "myChart.jpg"
myChart.Export Filename:=ThisWorkbook.Path & "/" & myFileName, Filtername:="JPG"
End Sub
▶▶▶删除图片
Sub DeletePic()
Dim p As Shape
For Each p In ActiveSheet.Shapes
If p.Type = 13 Then
p.Delete
End If
Next
End Sub
'MsoShapeType 枚举
'指定形状的类型或形状范围?
'名称 值 描述
'msoAutoShape 1 自选图形。
'msoCallout 2 标注。
'msoCanvas 20 画布。
'msoChart 3 图。
'msoComment 4 批注。
'msoDiagram 21 图表。
'msoEmbeddedOLEObject 7 嵌入的 OLE 对象。
'msoFormControl 8 窗体控件。
'msoFreeform 5 任意多边形。
'msoGroup 6 组合。
'msoIgxGraphic 24 IGX 图形
'msoInk 22 墨迹
'msoInkComment 23 墨迹批注
'msoLine 9 线条
'msoLinkedOLEObject 10 链接 OLE 对象
'msoLinkedPicture 11 链接图片
'msoMedia 16 媒体
'msoOLEControlObject 12 OLE 控件对象
'msoPicture 13 图片
'msoPlaceholder 14 占位符
'msoScriptAnchor 18 脚本定位标记
'msoShapeTypeMixed -2 混和形状类型
'msoTable 19 表
'msoTextBox 17 文本框
'msoTextEffect 15 文本效果
▶▶▶求单元格中图片个数
Sub 求单元格中图片个数()
For r = 2 To [a65536].End(xlUp).Row
t = Range("b" & r).Top
h = Range("b" & r).Height
c = 0
For Each s In ActiveSheet.Shapes
If s.Top >= t And s.Top <= t + h Then
c = c + 1
End If
Next
Range("c" & r) = c
Next r
End Sub
看都看到最后了，如果觉得不错，希望大家分享一下，或者点一下右下角的"在看" 按钮。
联系客服
