Excel实例下载
  VBA  应用教程
    数据库SQL知识
设为首页
Excel中利用VBA自定义图片批注
作者:罗刚君 | 来源:网络转摘 | 时间:2010-11-02 | 阅读权限:游客 | 会员币:0 | 【
Private Declare Function OpenClipboard Lib "User32" (ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib "User32" () As Long
Private Declare Function GetClipboardData Lib "User32" (ByVal uFormat As Long) As Long
Private Declare Function CopyEnhMetaFileA Lib "Gdi32" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function DeleteEnhMetaFile Lib "Gdi32" (ByVal hdc As Long) As Long
Sub 图片批注()
'*******************************************
'时间:2010-11-02
'作者:罗刚君  整理:bengdeng
'功能:在当前单元格插入图片批注
'说明:1、如果选择的是单元格区域,则把单元格区域的内容做为批注的图片
'      2、如果选择的是图片,则把此图片做为成批注的图片
'发布:http://www.excelba.com
'*******************************************
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
文章录入:admin | 浏览次数:
相关评论(以下网友评论只代表其个人观点,不代表Excel吧的观点或立场)
相关信息

关于本站 | 留言本站 | 友情连接 | 后台管理
Copyright © 2005 - 2008 Excel吧 Inc. All Rights Reserved.
HxCms Ver9.0  闽ICP备06001689号
关闭此窗口