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

最新推荐文章于 2024-04-24 09:04:15 发布

之之之之杰

最新推荐文章于 2024-04-24 09:04:15 发布

阅读量5k

点赞数 3

分类专栏： VBA 文章标签： microsoft

本文链接：https://blog.csdn.net/q14091355/article/details/125238698

版权

VBA 专栏收录该内容

19 篇文章 9 订阅

订阅专栏

记录一下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>

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方式循环导出;

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