Excel中利用VBA自定义图片批注
责任编辑：hylng 浏览：6809次 时间： 2012-12-31 23:13:56
免职声明：本网站为公益性网站，部分信息来自网络，如果涉及贵网站的知识产权，请及时反馈，我们承诺第一时间删除！
This website is a public welfare website, part of the information from the Internet, if it involves the intellectual property rights of your website, please timely feedback, we promise to delete the first time.
电话Tel: 19550540085: QQ号: 929496072 or 邮箱Email: Lng@vip.qq.com
摘要:功能：在当前单元格插入图片批注 '说明：1、如果选择的是单元格区域，则把单元格区域的内容做为批注的图片 ' 2、如果选择的是图片，则把此图片做为成批注的图片 '******************************************* Dim RngAddress As String, Files As String, Rng As Ra..
|
功能：在当前单元格插入图片批注 '说明：1、如果选择的是单元格区域，则把单元格区域的内容做为批注的图片 ' 2、如果选择的是图片，则把此图片做为成批注的图片 '******************************************* Dim RngAddress As String, Files As String, Rng As Range, Widths As Integer, heights As Integer RngAddress = ActiveCell.Address: Files = "C:\pz.BMP" '记录活动单元格地址和临时文件地址 If TypeName(Selection) = "Range" Then '如果选择单元格 On Error Resume Next star: Set Rng = Application.InputBox("请选择区域", "区域", RngAddress, Type:=8) '选择一个区域做批批注的引用源 If Err <> 0 Then Err.Clear: GoTo star '单击取消则重新提示选择区域 Application.ScreenUpdating = False Range(Rng.Address).CopyPicture '复制对象 ActiveSheet.Paste '粘贴 Set Shp = ActiveSheet.Shapes(ActiveSheet.Shapes.Count) Widths = Shp.Width: heights = Shp.Height '获取图片高度与宽度 Selection.Delete '删除临时图片 ElseIf TypeName(Selection) = "Picture" Then '如果选择了图片 Application.ScreenUpdating = False Selection.CopyPicture '复制为图片 Set Shp = ActiveSheet.Shapes(Selection.Name) Widths = Shp.Width: heights = Shp.Height '记录高度与宽度 Else Exit Sub End If OpenClipboard 0 '打开剪贴板 DeleteEnhMetaFile CopyEnhMetaFileA(GetClipboardData(14), Files) '导出剪贴板中的图片 CloseClipboard '关闭 Application.CutCopyMode = False Range(RngAddress).Select '激活单元格 Range(RngAddress).ClearComments '清除批注 With Range(RngAddress).AddComment.Shape '清加批注 .Width = Widths '指定宽度 .Height = heights '指定高度 .Fill.UserPicture Files '填充图片 End With Kill Files '清除临时文件 Application.ScreenUpdating = True Set Shp = Nothing End Sub |
分享到:
