VBA(5)表格内常见导入图片方式

VBA(5)表格内常见导入图片方式

记录一下VBA内对图片的常见处理,假投表格内有一个图片对象。我们先用一段代码测出图片的常用属性

Sub t2()Dim k# 			'单义一个双精度变量On Error Resume Next		'如遇报错(未添加对象图片的表格)继续运行Dim ms As Shape			'ms变量为shape图形对象,是sheets和chart的子对象	k = 1For Each ms In Sheets(1).Shapes	'本表格1里面寻找图形k = k + 1			'行数Cells(k, 1) = ms.Name       '对象图片名子Cells(k, 2) = ms.Type       '类型'图片1Cells(k, 3) = ms.BottomRightCell    '图片右上单元格位置(图片如果没固定位置则空白Cells(k, 4) = ms.toleftcell     '图片左下单元格位置(图片如果没固定位置则空白Cells(k, 5) = ms.Hyperlink      '图片超链接(见12.13Cells(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:UsersAdministratorDesktop12345.xlsx"ms.Hyperlink.SubAddress = "A1:B10"'在EXCEL选项卡显示为C:UsersAdministratorDesktop12345.xlsx#A1:B10Next
End Sub

表格内图片对象格式'对象.type        可查看返回格式

往表格内添加图片
    1.引用方式:
    当图片位置被删除、移动时，excel文件中的图片找不到位置会显示错误。
    'ActiveSheet.Pictures.Insert ("图片所在路径带文件名扩展名")
    2.创建方式:
    'Worksheets(1).Shapes.AddPicture "C:UsersAdministratorDesktop12345.png", False, True, 1, 1, 600, 600
    Shapes.AddPicture 方法 (Excel)
    从现有文件创建图片。 返回一个 Shape 对象，该对象表示新的图片。
    语法:表达式。AddPicture (FileName、 LinkToFile、 SaveWithDocument、 Left、 Top、 Width、 Height)
    expression：一个表示 Shapes 对象的变量。

官方原文说明 <Shapes.AddPicture 方法 (Excel) | Microsoft Docs>

Sub 图片导入方式1()Dim s As Shape      '定义一个图象变量Dim rg As Range     '定义一个单元格变量For Each s In ActiveSheet.ShapesIf s.Type <> 8 Then	'msoShapeRectangle 类型为8s.Delete        '循环活动工作表的图表对象类型不为8的删除End IfNextFor 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:UsersAdministratorDesktop新建文件夹" & rg.Offset(0, -1) & ".jpg"'选中的对象背景填充图片路径，文件名为RG偏移0行.-1列.文件类型JPGNext
End Subsub 图片导入方式2()dim str1 as string	'定义一个文本做为路径带文件名dim s as string		'定义一个做为找不到图片时显示的文本dim x as integer	'循环数字dim rng as range	'图片要显示的单元格with sheet1for x = 2 to .range("a65536").end(xlup).row				str1 = "C:UsersAdministratorDesktop" & "" & .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 = p +1 				'顶边距.left = rng.left +1				'左边距.width = rng.width -1				'宽度.height = rng.height -1				'高度end with						'设置图片与单元格的尺才一致elses = s & chr(10) & .cells(x,1).text			'如果没有图片则把没有名字的文本加到变理S里面,后面用MSGBOX显示end lls(3,1).select							'选中end withif s <> "" thenmsgbox s & chr(10) & "没有图片"				'显示没有图片的名子end if
end subSub 批注的形式图片3()Dim filePath As Object,fz As Object,dz$Dim ss As Range, ss1 As Comment, h As Byte, w As Byte, dzzname As StringSelection.ClearComments             '所选区域批注清除Set filePath = CreateObject("scripting.filesystemobject")        '引用于操作磁盘、文件夹或文本文件FSO的对象If Selection(1) = "" ThenMsgBox "未选择": Exit SubEnd IfSet fz = Application.FileDialog(msoFileDialogFolderPicker)      '选择一个文件夹'msoFileDialogFilePicker 可选文件夹'msofiledialogopen  打开文件'msofiledialogsaveas    '保存一个文件If fz.Show = -1 Thendz = fz.SelectedItems(1)    '图片文件夹路径记录ElseExit SubEnd IfFor Each ss In Selectiondzzname = 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 - 1End WithEnd IfNextMsgBox "完成"
End Sub

相反如果要导出表格内图片。则先For Each shp In 表格.Shapes方式循环导出;

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 Thenpicname = shp.BottomRightCell.Offset(-1, -1).Value & ".jpg"                                 'bottomrightcell图片所在位置右下单元格,OFFSET偏移到对应的名子赋值shp.CopyWith 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.deleteEnd WithEnd IfNextApplication.ScreenUpdating = True         '恢复刷新MsgBox "完成"
End Sub