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

零售创新,创新那些事儿,SPSS,VBA

零售创新

 
 
 

日志

 
 
关于我

新浪微博,零售创新 研究经理,数据分析师 希望和市场研究和零售业的同事共同进步! 本博客发表的都是免费或试用的资料,如果有版权问题请发邮件wangli12a@163.com联系删除。 spss excel vba blog

网易考拉推荐

在窗体图形控件中显示Excel表格的Range、Chart和Shape  

2009-02-17 16:18:02|  分类: VB和VBA知识 |  标签: |举报 |字号 订阅

  下载LOFTER 我的照片书  |

Option Explicit
   
Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ppstm As Any) As Long
Private Declare Function OleLoadPicture Lib "olepro32" (pStream As Any, ByVal lSize As Long, ByVal fRunmode As Long, riid As Any, ppvObj As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Any, pclsid As Any) As Long

Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long

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 wFormat As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long

Private Sub UserForm_Initialize()
    Image1.Picture = LoadShapePicture(Sheet1.ChartObjects(1))
    Image2.Picture = LoadShapePicture(Sheet1.Shapes(2))
    Me.Picture = LoadShapePicture(Sheet1.Range("B1:C15"))
End Sub

Public Function LoadShapePicture(shp As Object) As IPictureDisp
    Dim nClipsize As Long
    Dim hMem As Long
    Dim lpData As Long
    Dim sdata() As Byte
    Dim fmt As Long
    Dim fmtName As String
    Dim iClipBoardFormatNumber As Long
    Dim IID_IPicture(15)
    Dim istm As stdole.IUnknown
   
    If TypeName(shp) = "ChartObject" Or TypeName(shp) = "Range" Then
        shp.CopyPicture xlPrinter
        Sheet1.Paste
        Selection.Cut
    Else
        shp.Copy
    End If
   
    OpenClipboard 0&
    If iClipBoardFormatNumber = 0 Then
        fmt = EnumClipboardFormats(0)
        Do While fmt <> 0
            fmtName = Space(255)
            GetClipboardFormatName fmt, fmtName, 255
            fmtName = Trim(fmtName)
            If fmtName <> "" Then
                fmtName = Left(fmtName, Len(fmtName) - 1)
                If fmtName = "GIF" Then
                    iClipBoardFormatNumber = fmt
                    Exit Do
                End If
            End If
            fmt = EnumClipboardFormats(fmt)
         Loop
    End If

    hMem = GetClipboardData(iClipBoardFormatNumber)
    If CBool(hMem) Then
        nClipsize = GlobalSize(hMem)
        lpData = GlobalLock(hMem)
        GlobalUnlock hMem
        If CreateStreamOnHGlobal(hMem, 1, istm) = 0 Then
                If CLSIDFromString(StrPtr("{7BF80980-BF32-101A-8BBB-00AA00300CAB}"), IID_IPicture(0)) = 0 Then
                   Call OleLoadPicture(ByVal ObjPtr(istm), nClipsize, 0, IID_IPicture(0), LoadShapePicture)
                End If
        End If
    End If

    EmptyClipboard
    CloseClipboard

  End Function




  评论这张
 
阅读(819)| 评论(0)
推荐 转载

历史上的今天

在LOFTER的更多文章

评论

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

页脚

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