记录一下VBA内对图片的常见处理,假投表格内有一个图片对象。我们先用一段代码测出图片的常用属性
Sub t2()
Dim k# '单义一个双精度变量
On Error Resume Next '如遇报错(未添加对象图片的表格)继续运行
Dim ms As Shape 'ms变量为shape图形对象,是sheets和chart的子对象
k = 1
For Each ms In Sheets(1).Shapes '本表格1里面寻找图形
k = k + 1 '行数
Cells(k, 1) = ms.Name '对象图片名子
Cells(k, 2) = ms.Type '类型
'图片1
Cells(k, 3) = ms.BottomRightCell '图片右上单元格位置(图片如果没固定位置则空白
Cells(k, 4) = ms.toleftcell '图片左下单元格位置(图片如果没固定位置则空白
Cells(k, 5) = ms.Hyperlink '图片超链接(见12.13
Cells(k, 6) = ms.Visible '-1可见/0不可见
Cells(k, 7) = ms.OnAction '图形运行的宏
Cells(k, 8) = ms.Top '顶距
Cells(k, 9) = ms.Width '宽度
Cells(k, 10) = ms.Height '高度
Cells(k, 11) = ms.Left '左边距
Cells(k, 12) = ms.Hyperlink.Address '图片超链接地址:网址或文档
Cells(k, 13) = ms.Hyperlink.SubAddress '文档引用的位置(第几页或者区域)
'例子将超链接设置桌面文档12345表格。返回A1:B10选中
ms.Hyperlink.Address = "C:\Users\Administrator\Desktop\12345.xlsx"
ms.Hyperlink.SubAddress = "A1:B10"
'在EXCEL选项卡显示为C:\Users\Administrator\Desktop\12345.xlsx#A1:B10
Next
End Sub表格内图片对象格式'对象.type 可查看返回格式
| Type名称 |
值 |
说明 |
| mso3DModel |
30 |
3D 模型 |
| msoAutoShape |
1 |
自Shape |
| msoCallout |
2 |
标注 |
| msoCanvas |
20 |
Canvas |
| msoChart |
3 |
图表 |
| msoComment |
4 |
批注 |
| msoContentApp |
27 |
外接程序Office内容 |
| msoDiagram |
21 |
图表 |
| msoEmbeddedOLEObject |
7 |
嵌入式 OLE 对象 |
| msoFormControl |
8 |
表单控件 |
| msoFreeform |
5 |
任意多边形 |
| msoGraphic |
28 |
图形 |
| msoGroup |
6 |
Group |
| msoIgxGraphic |
24 |
SmartArt 图形 |
| msoInk |
22 |
墨迹 |
| msoInkComment |
23 |
墨迹批注。 |
| msoLine |
9 |
线条。 |
| msoLinked3DModel |
31 |
链接的 3D 模型 |
| msoLinkedGraphic |
29 |
链接图形 |
| msoLinkedOLEObject |
10 |
链接 OLE 对象。 |
| msoLinkedPicture |
11 |
链接图片。 |
| msoMedia |
16 |
媒体 |
| msoOLEControlObject |
12 |
OLE 控件对象。 |
| msoPicture |
13 |
图片 |
| msoPlaceholder |
14 |
占位符 |
| msoScriptAnchor |
18 |
脚本定位标记。 |
| msoShapeTypeMixed |
-2 |
混和形状类型。 |
| msoSlicer |
25 |
切片器 |
| msoTable |
19 |
表格 |
| msoTextBox |
17 |
文本框。 |
| msoTextEffect |
15 |
文本效果。 |
| msoWebVideo |
26 |
Web 视频 |
往表格内添加图片
1.引用方式:
当图片位置被删除、移动时，excel文件中的图片找不到位置会显示错误。
'ActiveSheet.Pictures.Insert ("图片所在路径带文件名扩展名")
2.创建方式:
'Worksheets(1).Shapes.AddPicture "C:\Users\Administrator\Desktop\12345.png", False, True, 1, 1, 600, 600
Shapes.AddPicture 方法 (Excel)
从现有文件创建图片。 返回一个 Shape 对象，该对象表示新的图片。
语法:表达式。AddPicture (FileName、 LinkToFile、 SaveWithDocument、 Left、 Top、 Width、 Height)
expression：一个表示 Shapes 对象的变量。
| 名称 |
必需/可选 |
数据类型 |
说明 |
| FileName |
必需 |
String |
要创建图片的文件。 |
| LinkToFile |
必需 |
MsotriState |
要链接至的文件。 使用 msoFalse 使图片成为文件的独立副本。 使用 msoTrue 将图片链接到创建图片的文件。 |
| SaveWithDocument |
必需 |
MsoTriState |
将图片与文档一起保存。 使用 msoFalse 仅存储文档中的链接信息。 使用 msoTrue 将链接的图片与插入它的文档一起保存。 如果 LinkToFile 为 msoFalse，则此参数必须为 msoTrue。 |
| Left |
必需 |
Single |
图片 (左上角) 相对于文档左上角的位置，以点表示。 |
| Top |
必需 |
Single |
图片左上角相对于文档顶部的位置（以磅为单位）。 |
| Width |
必需 |
Single |
图片的宽度，以 (-1 以保留现有文件的宽度，以) 。 |
| Height |
必需 |
Single |
图片的高度（以 (-1 表示，以保留现有文件的高度) 。 |
官方原文说明 <Shapes.AddPicture 方法 (Excel) | Microsoft Docs> 文章来源：https://www.toymoban.com/news/detail-453275.html
Sub 图片导入方式1()
Dim s As Shape '定义一个图象变量
Dim rg As Range '定义一个单元格变量
For Each s In ActiveSheet.Shapes
If s.Type <> 8 Then 'msoShapeRectangle 类型为8
s.Delete '循环活动工作表的图表对象类型不为8的删除
End If
Next
For Each rg In Range("b2:b5") '循环B2:B5单元格
ActiveSheet.Shapes.AddShape(msoShapeRectangle, rg.Left, rg.Top, rg.Width, rg.Height).Select
'创建一个空白形状对象并选中
Selection.ShapeRange.Fill.UserPicture "C:\Users\Administrator\Desktop\新建文件夹\" & rg.Offset(0, -1) & ".jpg"
'选中的对象背景填充图片路径，文件名为RG偏移0行.-1列.文件类型JPG
Next
End Sub
sub 图片导入方式2()
dim str1 as string '定义一个文本做为路径带文件名
dim s as string '定义一个做为找不到图片时显示的文本
dim x as integer '循环数字
dim rng as range '图片要显示的单元格
with sheet1
for x = 2 to .range("a65536").end(xlup).row
str1 = "C:\Users\Administrator\Desktop" & "\" & .cells(x,1).text & ".jpg" '循环需要添加的图片名称带路径文件名格式
if dir(str1) <> "" then '使用dir函数返回文件名，如不使用循环当没有此图if会出错
.pictures.insert(str1).select '使用pictures.insert方法插入图片
set rng = .cells(x,3) '设置要放图片的单元格
with selection '选中单元格与刚放置的图片
.top = rng.top +1 '顶边距
.left = rng.left +1 '左边距
.width = rng.width -1 '宽度
.height = rng.height -1 '高度
end with '设置图片与单元格的尺才一致
else
s = s & chr(10) & .cells(x,1).text '如果没有图片则把没有名字的文本加到变理S里面,后面用MSGBOX显示
end if
next
.cells(3,1).select '选中
end with
if s <> "" then
msgbox s & chr(10) & "没有图片" '显示没有图片的名子
end if
end sub
Sub 批注的形式图片3()
Dim filePath As Object,fz As Object,dz$
Dim ss As Range, ss1 As Comment, h As Byte, w As Byte, dzzname As String
Selection.ClearComments '所选区域批注清除
Set filePath = CreateObject("scripting.filesystemobject")
'引用于操作磁盘、文件夹或文本文件FSO的对象
If Selection(1) = "" Then
MsgBox "未选择": Exit Sub
End If
Set fz = Application.FileDialog(msoFileDialogFolderPicker) '选择一个文件夹
'msoFileDialogFilePicker 可选文件夹
'msofiledialogopen 打开文件
'msofiledialogsaveas '保存一个文件
If fz.Show = -1 Then
dz = fz.SelectedItems(1) '图片文件夹路径记录
Else
Exit Sub
End If
For Each ss In Selection
dzzname = dz & "\" & ss.Value & ".jpg"
If filePath.fileexists(dzzname) Then 'FILEEXISTS查看目录是否存在
Set ss1 = ss.AddComment '创建批注
With ss1.Shape '设置新建的批注格式
.Fill.UserPicture dzzname '设置批注图片填充
.Width = ss.Width - 1
.Height = ss.Height - 1
End With
End If
Next
MsgBox "完成"
End Sub相反如果要导出表格内图片。则先For Each shp In 表格.Shapes方式循环导出;文章来源地址https://www.toymoban.com/news/detail-453275.html
Sub 图片导出()
Dim shp As Shape, picname$, n% '定义shp为图像对象,picname为文本,n,icount为数值
Application.ScreenUpdating = False '关闭宏进行中刷新，提高速度
For Each shp In Sheet2.Shapes '对表2中的图像对象循环
n = n + 1
'Debug.Print shp.Type '查看下图片类型，调试使用
'DoEvents ' 转让控制权，如果有加进度条窗体等可以使用
If shp.Type = 11 Then
picname = shp.BottomRightCell.Offset(-1, -1).Value & ".jpg"
'bottomrightcell图片所在位置右下单元格,OFFSET偏移到对应的名子赋值
shp.Copy
With Sheet2.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart
'.ChartObjects.Add创建新的嵌入式图表(左距、顶距、宽度、高度)
.ChartArea.Select '.ChartArea返回该图像对象
.Paste 'Chart.Paste方法将剪贴板中的图表数据粘贴到指定的图表中
.Export ThisWorkbook.Path & "\" & picname 'Chaet.Export 以图形格式导出图表。
.Parent.Delete '获取Chart控件的父对象,即chart.delete
End With
End If
Next
Application.ScreenUpdating = True '恢复刷新
MsgBox "完成"
End Sub到了这里，关于VBA(5)表格内常见导入图片方式的文章就介绍完了。如果您还想了解更多内容，请在右上角搜索TOY模板网以前的文章或继续浏览下面的相关文章，希望大家以后多多支持TOY模板网！
