将工作表中选择的对象加载到窗体或者图形控件

andysky

特点： 1.不需要保存为图片再加载，从而提升执行效率 2.清晰度高

andysky

Private Type GUID
    one As Long
    two As Integer
    three As Integer
    four(0 To 7) As Byte
End Type
Private Type uPicDesc
    Size As Long
Type As Long
    hPic As Long
    hPal As Long
End Type
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Function Pictures(ByVal hPic As Long, ByVal hPal As Long, ByVal xlBitmap) As IPicture
    Dim S As Long, Info As uPicDesc, Guids As GUID, IPic As IPicture
    With Guids
        .one = &H7BF80980
        .two = &HBF32
        .three = &H101A
        .four(0) = &H8B
        .four(1) = &HBB
        .four(2) = &H0
        .four(3) = &HAA
        .four(4) = &H0
        .four(5) = &H30
        .four(6) = &HC
        .four(7) = &HAB
    End With
    With Info
        .Size = Len(Info)
        .Type = IIf(xlBitmap = 2, 1, 4)
        .hPic = hPic
        .hPal = IIf(xlBitmap = 2, hPal, 0)
    End With
    S = OleCreatePictureIndirect(Info, Guids, True, IPic)
    Set Pictures = IPic
End Function
Sub 加载到窗体()
    Selection.CopyPicture , 2
    UserForm1.Show 0
        If IsClipboardFormatAvailable(xlBitmap) <> 0 Then
        If OpenClipboard(0&) > 0 Then
            Datas = GetClipboardData(xlBitmap)
            If xlBitmap = 2 Then hCopy = CopyImage(Datas, 0, 0, 0, &H4) Else hCopy = CopyEnhMetaFile(Datas, vbNullString)
            temp = CloseClipboard
            If Datas <> 0 Then Set UserForm1.Picture = Pictures(hCopy, 0, xlBitmap)
        End If
    End If
End Sub
Sub 加到到图片控件()
    Selection.CopyPicture , 2
          If IsClipboardFormatAvailable(xlBitmap) <> 0 Then
        If OpenClipboard(0&) > 0 Then
            Datas = GetClipboardData(xlBitmap)
            If xlBitmap = 2 Then hCopy = CopyImage(Datas, 0, 0, 0, &H4) Else hCopy = CopyEnhMetaFile(Datas, vbNullString)
            temp = CloseClipboard
            If Datas <> 0 Then Set ActiveSheet.Image1.Picture = Pictures(hCopy, 0, xlBitmap)
        End If
    End If
End Sub

menboy

谢谢分享。。

xtanuihazfh

谢谢分享,下载学习

brdsz

学习，谢谢分享

shun2233

好资料，谢谢分享

fosterhjza

EXCEL VBA如何将工作表中的图片直接插入到批注呢，不另存为文件直接导入

simpman

罗版主您好，能不能加载到窗体后主窗体能够最小化，子窗体不受影响呢？

ndyzx

andysky 发表于 2009-8-18 08:35
Private Type GUID
    one As Long
    two As Integer

很难懂记住慢慢看。

jhzghua

学习，谢谢分享