注册 登录  
 加关注
   显示下一条  |  关闭
温馨提示!由于新浪微博认证机制调整,您的新浪微博帐号绑定已过期,请重新绑定!立即重新绑定新浪微博》  |  关闭

Oh! I see you!

Hi! ppmm~~

 
 
 

日志

 
 

Excel单元格批量插入图片批注  

2012-02-18 17:26:03|  分类: Excel |  标签: |举报 |字号 订阅

  下载LOFTER 我的照片书  |

本文链接:http://oicu.cc.blog.163.com/blog/static/123039471201211852154486/

今下雨,没户外活动。

妹妹QQ求助说要写个宏,在Excel单元格里批量插入图片批注方便做产品介绍资料。

于是我噼里啪啦敲键盘写了一通。

原理:单元格里保存的是jpg格式的图片名称(不带扩展名),这些图片都在一个文件夹里,

选择多个单元格后,运行宏,图片就嵌入到单元格的批注里。

注:批注里只能嵌入图片,不能链接,所以最后Excel文件大小肯定变大的。


Option Explicit

Sub AddPictureComment()
    Dim T As Range
    Dim PicDir As String
    Dim tmpPic As Object
    Dim fs As Object
    Set fs = CreateObject("Scripting.FileSystemObject")
   
    PicDir = "F:\产品图\"

    For Each T In Selection
        If fs.FileExists(PicDir & T.Value & ".jpg") Then
            If T.Comment Is Nothing Then
                T.AddComment
            Else
                T.Comment.Delete
                T.AddComment
            End If

            With T.Comment.Shape
                Set tmpPic = ActiveSheet.Pictures.Insert(PicDir & T.Value & ".jpg")
                .Width = tmpPic.ShapeRange.Width
                .Height = tmpPic.ShapeRange.Height
                .Fill.Visible = msoTrue
                .Fill.UserPicture PicDir & T.Value & ".jpg"
                .LockAspectRatio = msoTrue '锁定纵横比
                If .Width > 640 Then .Width = 640
                If .Height > 480 Then .Width = 480
                .Locked = msoTrue '属性-锁定
                tmpPic.Delete
            End With
        End If
    Next T
End Sub

   


2012/04/26 更新

昨天又有朋友问到这个应用,因此做一次更新。在贴代码之前,先介绍一下国产永中Office
软件把图片嵌入到单元格的功能:先插入图片,然后右键点击图片,选择“嵌入单元格”,
再选择单元格区域,最后图片会嵌入到所选区域左上角的一个单元格里,双击该单元格可放
大查看原图。如果不用批注图片的方式,而是要直接显示图片,推荐用永中Office把图片嵌
入到单元格,这样调整单元格也能同时更改图片大小,最后再导出为Excel文件。永中也可以
直接在批注里插入图片。

以下是在Excel单元格批量插入图片批注的宏,增加了选择文件夹,便于使用。图片的扩展名
还是在代码里修改吧,懒得写界面,jpg/png/gif/bmp这几个图片格式都可以。

 

2012/05/05 更新

增加调用图片文件夹的方法,不想用固定路径或者选择的,可以设置调用Excel文件所在路径。

 

' Module1

Option Explicit

Sub AddPictureComment()
    Dim T As Range
    Dim PicDir As String
    Dim FileExt As String
    Dim FileFullPath As String
    Dim tmpPic As Object
    Dim fs As Object
    Dim fd As Object
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    ' 设置了以下4种调用图片文件夹的方法,根据需求任选其一
    ' PicDir = "E:\pic"   ' 直接设定文件夹,最后不要\符号
    ' PicDir = ActiveWorkbook.Path   ' 使用Excel文件所在文件夹
    ' PicDir = ActiveWorkbook.Path & "\pic"   ' 用Excel文件所在位置的子文件夹pic
    ' 注意不要使用ThisWorkbook.Path,返回的是宏所在的工作簿路径!

    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    If fd.Show = -1 Then
        PicDir = fd.SelectedItems(1)    ' 记录所选的文件夹名,只能选一个文件夹
    Else
        Exit Sub    ' 无选择或取消则退出
    End If

    FileExt = ""    ' 如果单元格内容是 001.jpg 这样的完整文件名,这里设置为空。
                    ' 如果单元格内容没写文件扩展名,需要在这里设置图片的格式,
                   
' 如jpg、png、gif、bmp等,使用统一格式。
                   
' 为了方便,在这里要加.符号,如 FileExt = ".jpg"
   
    For Each T In Selection
        FileFullPath = PicDir & "\" & T.Value & FileExt
        If fs.FileExists(FileFullPath) Then
            If T.Comment Is Nothing Then
                T.AddComment
            Else
                T.Comment.Delete
                T.AddComment
            End If

            With T.Comment.Shape
                Set tmpPic = ActiveSheet.Pictures.Insert(FileFullPath)
                .Width = tmpPic.ShapeRange.Width
                .Height = tmpPic.ShapeRange.Height
                .Fill.Visible = msoTrue
                .Fill.UserPicture FileFullPath
                .LockAspectRatio = msoTrue    ' 锁定纵横比
                If .Width > 640 Then .Width = 640
                If .Height > 480 Then .Width = 480
                .Locked = msoTrue    ' 属性-锁定
                tmpPic.Delete
            End With
        End If
    Next T

End Sub


 

  评论这张
 
阅读(5363)| 评论(6)
推荐 转载

历史上的今天

评论

<#--最新日志,群博日志--> <#--推荐日志--> <#--引用记录--> <#--博主推荐--> <#--随机阅读--> <#--首页推荐--> <#--历史上的今天--> <#--被推荐日志--> <#--上一篇,下一篇--> <#-- 热度 --> <#-- 网易新闻广告 --> <#--右边模块结构--> <#--评论模块结构--> <#--引用模块结构--> <#--博主发起的投票-->
 
 
 
 
 
 
 
 
 
 
 
 
 
 

页脚

网易公司版权所有 ©1997-2017