将图片获取到用户窗体Excel VBA在64位窗口10中没有区别

如何解决将图片获取到用户窗体Excel VBA在64位窗口10中没有区别

我正在64位窗口10 PC中使用64位办公室。 我做了谷歌搜索，发现下面的示例代码可以将图片从当前剪贴板加载到用户窗体，但是没有任何变化。 （图片未显示在用户窗体的图片控件中）

首先，我对dll引用感到怀疑，因为我无法使用VBE中的工具>引用命令来手动添加引用。

所以我在管理员模式下使用了regsvr32 C:\windows\system32 oleaut32.dll，现在成功了，但仍然无法将剪贴板图像发送到用户窗体。

我更改了一些代码并将其简化，下面是最后一个。 如果有人可以给我一个简单的提示，我将不胜感激。

我做了一些修改

'***************************************************************************'*
'* AUTHOR & DATE:   STEPHEN BULLEN,Office Automation Ltd
'*                  15 November 1998


'*
'* DESCRIPTION:     Creates a standard Picture object from whatever is on the clipboard.
'*                  This object can then be assigned to (for example) and Image control
'*                  on a userform.  The PastePicture function takes an optional argument of
'*                  the picture type - xlBitmap or xlPicture.
'*
'*                  The code requires a reference to the "OLE Automation" type library
'*
'*                  The code in this module has been derived from a number of sources
'*                  discovered on MSDN.
'*
'*                  To use it:
'*                      Set Image1.Picture = PastePicture(xlPicture)
'*                  to paste a picture of whatever is on the clipboard into a standard image control.
'*
'* PROCEDURES:
'*   PastePicture   The entry point for the routine
'*   CreatePicture  Private function to convert a bitmap or metafile handle to an OLE reference
'*   fnOLEError     Get the error text for an OLE error code
'***************************************************************************

Option Explicit
Option Compare Text

Public Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type


Public Type uPicDesc
    Size As Long
    Type As Long
    hPic As LongPtr
    hPal As LongPtr
End Type

    Public Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
    Public Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Public Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr 'Correct wFormat type is integer or long???
    Public Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    
    Public Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc,RefIID As GUID,ByVal fPictureOwnsHandle As LongPtr,IPic As IPicture) As LongPtr
    ' In here,I tried manual referencing via tools > reference but can't,the error says
    '      "Can't add a reference to the specified file"
    ' Or can I use regsvr32 oleaut32.dll command in cmd window instead ??
    ' I already did regsvr32 registration and succeeeded but function still not working .
        
    Public Declare PtrSafe Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As LongPtr,ByVal lpszFile As String) As LongPtr
    Public Declare PtrSafe Function CopyImage Lib "user32" (ByVal Handle As LongPtr,ByVal un1 As Long,ByVal n1 As Long,ByVal n2 As Long,ByVal un2 As Long) As LongPtr
 

Const CF_BITMAP = 2
Const CF_PALETTE = 9
Const CF_ENHMETAFILE = 14
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4

Public Function PastePicture(Optional lXlPicType As Long = xlPicture) As IPicture
  PastePictureVBA7 (lXlPicType)
End Function

Public Function PastePictureVBA7(Optional lXlPicType As Long = xlPicture) As IPicture

    Dim H As Long,hPicAvail As Long,hPtr As LongPtr,hPal As LongPtr,lPicType As Long,hCopy As LongPtr  ''Correct lPicType type is integer or long???
    
    lPicType = IIf(lXlPicType = xlBitmap,CF_BITMAP,CF_ENHMETAFILE)
    hPicAvail = IsClipboardFormatAvailable(lPicType)
    
    If hPicAvail <> 0 Then
        H = OpenClipboard(0&)
    
        If H > 0 Then
            hPtr = GetClipboardData(lPicType)
            
            If lPicType = CF_BITMAP Then
                hCopy = CopyImage(hPtr,IMAGE_BITMAP,LR_COPYRETURNORG)
            Else
                hCopy = CopyEnhMetaFile(hPtr,vbNullString)
            End If
            
       
            H = CloseClipboard
            If hPtr <> 0^ Then Set PastePictureVBA7 = CreatePictureVBA7(hCopy,lPicType)
        End If
    End If
End Function

Public Function CreatePictureVBA7(ByVal hPic As LongPtr,ByVal hPal As LongPtr,ByVal lPicType) As IPicture

        Dim r As LongPtr,uPicInfo As uPicDesc,IID_IDispatch As GUID,IPic As IPicture
        Const PICTYPE_BITMAP = 1
        Const PICTYPE_ENHMETAFILE = 4
        
        With IID_IDispatch
            .Data1 = &H7BF80980
            .Data2 = &HBF32
            .Data3 = &H101A
            .Data4(0) = &H8B
            .Data4(1) = &HBB
            .Data4(2) = &H0
            .Data4(3) = &HAA
            .Data4(4) = &H0
            .Data4(5) = &H30
            .Data4(6) = &HC
            .Data4(7) = &HAB
        End With
        
        With uPicInfo
            .Size = Len(uPicInfo)
            .Type = IIf(lPicType = CF_BITMAP,PICTYPE_BITMAP,PICTYPE_ENHMETAFILE)
            .hPic = hPic
            .hPal = IIf(lPicType = CF_BITMAP,hPal,0)
        End With

        r = OleCreatePictureIndirect(uPicInfo,IID_IDispatch,1,IPic)
        'Is there somting wrong in here ???
        
        If r = 0 Then
           Set CreatePictureVBA7 = IPic
        End If
End Function

解决方法

将声明更改为：

Public Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc,RefIID As GUID,ByVal fPictureOwnsHandle As Long,IPic As IPicture) As LongPtr

正如Greg先前在评论中指出的那样，我错了，并且根据OleCreatePictureIndirect function (olectl.h) fPictureOwnsHandle的官方文档是布尔值，因此必须为Long。

请注意，此功能不会执行任何操作：

Public Function PastePicture(Optional lXlPicType As Long = xlPicture) As IPicture
    PastePictureVBA7 (lXlPicType)
End Function

因为它只运行PastePictureVBA7，但是它不返回图片作为函数PastePicture的返回值。这样图片就消失了，PastePicture总是返回Nothing。要使其从PastePictureVBA7返回图片，您需要将其更改为：

Public Function PastePicture(Optional lXlPicType As Long = xlPicture) As
    Set PastePicture = PastePictureVBA7(lXlPicType)
End Function

但是您实际上可以直接运行PastePictureVBA7，因为它的功能完全相同。

如果我在新的用户窗体中添加图像框Image1并运行

Image1.Picture = PastePictureVBA7

在VBA中复制范围后，它会在图像框中显示为图像。