插入图片宏在64位Excel上不起作用

Question

我有一个Excel宏，可以在excel的注释(备注)中插入剪贴板中的图片。它在32位office上工作得很好，但在64位上不行--我看到消息说剪贴板是空的。我已经添加了PtsSafe和LongPtr，但它仍然不能工作。这个宏可以在64位的excel上使用吗？谢谢。

Option Explicit
Option Private Module
' Checks the clipboard for a bitmap
' If found, creates a standard Picture object from the
' clipboard contetnts and saves it to a file

' The code requires a reference to the "OLE Automation" type library

' The code in this module has been derived primarily from _
  ' the PatsePicture sample on Stephen Bullen's Excel Page _
  ' - http://www.bmsltd.ie/Excel/Default.htm

'Windows API Function Declarations
#If VBA7 Then
Public Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As LongPtr) As LongPtr
Public Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As LongPtr
Public Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Public Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As LongPtr
Public Declare PtrSafe Function CloseClipboard Lib "user32" () As LongPtr
Public Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As LongPtr, IPic As IPicture) As LongPtr
Public Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As LongPtr, ByVal un1 As LongPtr, ByVal n1 As LongPtr, ByVal n2 As LongPtr, ByVal un2 As LongPtr) As LongPtr
#Else
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Public Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Public Declare Function CloseClipboard Lib "user32" () As Long
Public Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Public 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
#End If

'The API format types we need
Const CF_BITMAP = 2, IMAGE_BITMAP = 0, LR_COPYRETURNORG = &H4
'Declare a UDT to store a GUID for the IPicture OLE Interface
Public Type GUID
        #If VBA7 Then
        Data1 As LongPtr
        #Else
        Data1 As Long
        #End If
        Data2 As Integer
        Data3 As Integer
        Data4(0 To 7) As Byte
End Type
'Declare a UDT to store the bitmap information
Public Type uPicDesc
        #If VBA7 Then
        Size As LongPtr
        Type As LongPtr
        hPic As LongPtr
        hPal As LongPtr
        #Else
        Size As Long
        Type As Long
        hPic As Long
        hPal As Long
        #End If
End Type

#If VBA7 Then
Public Declare PtrSafe Function EmptyClipboard Lib "user32" () As LongPtr
Public Declare PtrSafe Function CopyEnhMetaFileA Lib "gdi32" (ByVal hENHSrc As LongPtr, ByVal lpszFile As String) As LongPtr
Public Declare PtrSafe Function DeleteEnhMetaFile Lib "gdi32" (ByVal hEMF As LongPtr) As LongPtr
#Else
Public Declare Function EmptyClipboard Lib "user32" () As Long
Public Declare Function CopyEnhMetaFileA Lib "gdi32" (ByVal hENHSrc As Long, ByVal lpszFile As String) As Long
Public Declare Function DeleteEnhMetaFile Lib "gdi32" (ByVal hEMF As Long) As Long
#End If

#If VBA7 Then
Const CF_ENHMETAFILE As LongPtr = 14
#Else
Const CF_ENHMETAFILE As Long = 14
#End If

'''''''''''''''
Type BitMapFileHeader
  bfType1 As Byte
  bfType2 As Byte
  #If VBA7 Then
  bfSize As LongPtr
  #Else
  bfSize As Long
  #End If
  bfReserved1 As Integer
  bfReserved2 As Integer
  #If VBA7 Then
  bfOffBits As LongPtr
  #Else
  bfOffBits As Long
  #End If
End Type
Type BitMapInfo
  #If VBA7 Then
  biSize As LongPtr
  biWidth As LongPtr
  biHeight As LongPtr
  #Else
  biSize As Long
  biWidth As Long
  biHeight As Long
  #End If
  iplanes As Integer
  biBitCount As Integer
  #If VBA7 Then
  biCompression As LongPtr
  biSizeImage As LongPtr
  biXPelsPerMeter As LongPtr
  biYPelsPerMeter As LongPtr
  biClrUsed As LongPtr
  biClrImportant As LongPtr
  #Else
  biCompression As Long
  biSizeImage As Long
  biXPelsPerMeter As Long
  biYPelsPerMeter As Long
  biClrUsed As Long
  biClrImportant As Long
  #End If
End Type
Type BMPFile
     bmfh As BitMapFileHeader
     bmih As BitMapInfo
End Type
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        
Sub MyComBars()
    Application.CommandBars("cell").Reset
    With Application.CommandBars("cell").Controls.Add(Type:=1, Before:=5)
        .OnAction = "AddImage"
        .Caption = "Paste Image"
    End With
End Sub

Sub AddImage()
    Dim ImaFile As String
    If Selection.Cells.Count > 1 Then Exit Sub
        SaveClipboardToBMP
    ImaFile = SaveClipboardToBMP
    On Error GoTo nexterr
    ActiveCell.ClearComments
    ActiveCell.AddComment.Shape.Fill.UserPicture (ImaFile)
    ActiveCell.Comment.Shape.Width = ReadShowSameBMPInfo(ImaFile, 1)
    ActiveCell.Comment.Shape.Height = ReadShowSameBMPInfo(ImaFile, 2)
    Exit Sub
nexterr:
    MsgBox "Clipboard is empty", vbCritical, "Error"
    ActiveCell.ClearComments
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Public Function SaveClipboardToBMP() As String
        Dim fn As String
    On Error Resume Next
        fn = Clip2FileEx
        SaveClipboardToBMP = fn
    If Dir(fn) = "" Then MsgBox "File  " & fn & "  not found", vbExclamation, "File not found"
        Exit Function
End Function

Public Function Clip2FileEx() As String
    Dim strOutputPath As String, oPic As IPictureDisp, PicPath As String
    On Error Resume Next
        MkDir Environ("TEMP") & "\Excel\"
    PicPath = Environ("TEMP") & "\Excel\": PicPath = PicPath & "Picture" & Format(Now, "DD-MMM-YYYY_HH-NN-SS") & ".bmp"
    Set oPic = GetClipPicture()
    If Not oPic Is Nothing Then
        SavePicture oPic, PicPath
        Clip2FileEx = PicPath
    Else
        Clip2FileEx = ""
        'MsgBox "Unable to retrieve bitmap from clipboard"
    End If
End Function

Function GetClipPicture() As IPicture
    #If VBA7 Then
        Dim H As LongPtr, hPicAvail As LongPtr, hPtr As LongPtr, hPal As LongPtr, hCopy As LongPtr
    #Else
        Dim H As Long, hPicAvail As Long, hPtr As Long, hPal As Long, hCopy As Long
    #End If
    'Check if the clipboard contains a bitmap
    hPicAvail = IsClipboardFormatAvailable(CF_BITMAP)
    If hPicAvail <> 0 Then
        'Get access to the clipboard
        H = OpenClipboard(0&)
        If H > 0 Then
            'Get a handle to the image data
            hPtr = GetClipboardData(CF_BITMAP)
            hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
            'Release the clipboard to other programs
            H = CloseClipboard
            'If we got a handle to the image, convert it into a Picture object and return it
            If hPtr <> 0 Then Set GetClipPicture = CreatePicture(hCopy, 0, CF_BITMAP)
        End If
    End If
End Function

#If VBA7 Then
Public Function CreatePicture(ByVal hPic As LongPtr, ByVal hPal As LongPtr, ByVal lPicType) As IPicture
#Else
Public Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, ByVal lPicType) As IPicture
#End If
    ' IPicture requires a reference to "OLE Automation"
#If VBA7 Then
    Dim r As LongPtr, uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture
#Else
    Dim r As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture
#End If
    'OLE Picture types
    Const PICTYPE_BITMAP = 1
    ' Create the Interface GUID (for the IPicture interface)
    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
    ' Fill uPicInfo with necessary parts.
    With uPicInfo
        .Size = Len(uPicInfo)    ' Length of structure.
        .Type = PICTYPE_BITMAP    ' Type of Picture
        .hPic = hPic    ' Handle to image.
        .hPal = 0    ' Handle to palette (if bitmap).
    End With
    ' Create the Picture object.
    r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)
    ' Return the new Picture object.
    Set CreatePicture = IPic
End Function

#If VBA7 Then
Public Function ReadShowSameBMPInfo(fn As String, par As Byte) As LongPtr
#Else
Public Function ReadShowSameBMPInfo(fn As String, par As Byte) As Long ' par=1 gives the image width , par=2 gives the image height,
#End If
  Dim bitmap1 As BMPFile
  Open fn For Binary As #1
  With bitmap1
    Get #1, , .bmfh
    Get #1, , .bmih
    Close #1
    Select Case par
        Case 1
            ReadShowSameBMPInfo = .bmih.biWidth
        Case 2
            ReadShowSameBMPInfo = .bmih.biHeight
    End Select
'    MsgBox "Type = " & Chr(.bmfh.bfType1) & Chr(.bmfh.bfType2) & Chr(10) & "Size = " & .bmih.biWidth & "x" & .bmih.biHeight, , fn
  End With
End Function

Answer 1

并非所有的Long变量都可以是LongPtr变量。在64位版本中，OleCreatePictureIndirect是在oleaut32中而不是在olepro32中。

Option Explicit
Option Private Module
' Checks the clipboard for a bitmap
' If found, creates a standard Picture object from the
' clipboard contetnts and saves it to a file

' The code requires a reference to the "OLE Automation" type library

' The code in this module has been derived primarily from _
  ' the PatsePicture sample on Stephen Bullen's Excel Page _
  ' - http://www.bmsltd.ie/Excel/Default.htm

'Windows API Function Declarations
#If VBA7 Then
Public Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr
Public Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) 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
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 Long, IPic As IPicture) As Long
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
#Else
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Public Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Public Declare Function CloseClipboard Lib "user32" () As Long
Public Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Public 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
#End If

'The API format types we need
Const CF_BITMAP = 2, IMAGE_BITMAP = 0, LR_COPYRETURNORG = &H4
'Declare a UDT to store a GUID for the IPicture OLE Interface
Public Type GUID
        Data1 As Long
        Data2 As Integer
        Data3 As Integer
        Data4(0 To 7) As Byte
End Type
'Declare a UDT to store the bitmap information
Public Type uPicDesc
        #If VBA7 Then
        Size As Long
        Type As Long
        hPic As LongPtr
        hPal As LongPtr
        #Else
        Size As Long
        Type As Long
        hPic As Long
        hPal As Long
        #End If
End Type

#If VBA7 Then
Public Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Public Declare PtrSafe Function CopyEnhMetaFileA Lib "gdi32" (ByVal hENHSrc As LongPtr, ByVal lpszFile As String) As LongPtr
Public Declare PtrSafe Function DeleteEnhMetaFile Lib "gdi32" (ByVal hEMF As LongPtr) As Long
#Else
Public Declare Function EmptyClipboard Lib "user32" () As Long
Public Declare Function CopyEnhMetaFileA Lib "gdi32" (ByVal hENHSrc As Long, ByVal lpszFile As String) As Long
Public Declare Function DeleteEnhMetaFile Lib "gdi32" (ByVal hEMF As Long) As Long
#End If

Const CF_ENHMETAFILE As Long = 14

'''''''''''''''
Type BitMapFileHeader
  bfType1 As Byte
  bfType2 As Byte
  bfSize As Long
  bfReserved1 As Integer
  bfReserved2 As Integer
  bfOffBits As Long
End Type
Type BitMapInfo
  biSize As Long
  biWidth As Long
  biHeight As Long
  iplanes As Integer
  biBitCount As Integer
  biCompression As Long
  biSizeImage As Long
  biXPelsPerMeter As Long
  biYPelsPerMeter As Long
  biClrUsed As Long
  biClrImportant As Long
End Type
Type BMPFile
     bmfh As BitMapFileHeader
     bmih As BitMapInfo
End Type
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        
Sub MyComBars()
    Application.CommandBars("cell").Reset
    With Application.CommandBars("cell").Controls.Add(Type:=1, Before:=5)
        .OnAction = "AddImage"
        .Caption = "Paste Image"
    End With
End Sub

Sub AddImage()
    Dim ImaFile As String
    If Selection.Cells.Count > 1 Then Exit Sub
        SaveClipboardToBMP
    ImaFile = SaveClipboardToBMP
    On Error GoTo nexterr
    ActiveCell.ClearComments
    ActiveCell.AddComment.Shape.Fill.UserPicture (ImaFile)
    ActiveCell.Comment.Shape.Width = ReadShowSameBMPInfo(ImaFile, 1)
    ActiveCell.Comment.Shape.Height = ReadShowSameBMPInfo(ImaFile, 2)
    Exit Sub
nexterr:
    MsgBox "Clipboard is empty", vbCritical, "Error"
    ActiveCell.ClearComments
End Sub

Public Function SaveClipboardToBMP() As String
        Dim fn As String
    On Error Resume Next
        fn = Clip2FileEx
        SaveClipboardToBMP = fn
    If Dir(fn) = "" Then MsgBox "File  " & fn & "  not found", vbExclamation, "File not found"
        Exit Function
End Function


Public Function Clip2FileEx() As String
    Dim strOutputPath As String, oPic As IPictureDisp, PicPath As String
    On Error Resume Next
        MkDir Environ("TEMP") & "\Excel\"
    PicPath = Environ("TEMP") & "\Excel\": PicPath = PicPath & "Picture" & Format(Now, "DD-MMM-YYYY_HH-NN-SS") & ".bmp"
    Set oPic = GetClipPicture()
    If Not oPic Is Nothing Then
        SavePicture oPic, PicPath
        Clip2FileEx = PicPath
    Else
        Clip2FileEx = ""
        'MsgBox "Unable to retrieve bitmap from clipboard"
    End If
End Function

Function GetClipPicture() As IPicture
    #If VBA7 Then
        Dim H As LongPtr, hPicAvail As LongPtr, hPtr As LongPtr, hPal As LongPtr, hCopy As LongPtr
    #Else
        Dim H As Long, hPicAvail As Long, hPtr As Long, hPal As Long, hCopy As Long
    #End If
    'Check if the clipboard contains a bitmap
    hPicAvail = IsClipboardFormatAvailable(CF_BITMAP)
    If hPicAvail <> 0 Then
        'Get access to the clipboard
        H = OpenClipboard(0&)
        If H > 0 Then
            'Get a handle to the image data
            hPtr = GetClipboardData(CF_BITMAP)
            hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
            'Release the clipboard to other programs
            H = CloseClipboard
            'If we got a handle to the image, convert it into a Picture object and return it
            If hPtr <> 0 Then Set GetClipPicture = CreatePicture(hCopy, 0, CF_BITMAP)
        End If
    End If
End Function

#If VBA7 Then
Public Function CreatePicture(ByVal hPic As LongPtr, ByVal hPal As LongPtr, ByVal lPicType) As IPicture
#Else
Public Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, ByVal lPicType) As IPicture
#End If
    ' IPicture requires a reference to "OLE Automation"
#If VBA7 Then
    Dim r As LongPtr, uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture
#Else
    Dim r As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture
#End If
    'OLE Picture types
    Const PICTYPE_BITMAP = 1
    ' Create the Interface GUID (for the IPicture interface)
    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
    ' Fill uPicInfo with necessary parts.
    With uPicInfo
        .Size = Len(uPicInfo)    ' Length of structure.
        .Type = PICTYPE_BITMAP    ' Type of Picture
        .hPic = hPic    ' Handle to image.
        .hPal = 0    ' Handle to palette (if bitmap).
    End With
    ' Create the Picture object.
    r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)
    ' Return the new Picture object.
    Set CreatePicture = IPic
End Function

#If VBA7 Then
Public Function ReadShowSameBMPInfo(fn As String, par As Byte) As LongPtr
#Else
Public Function ReadShowSameBMPInfo(fn As String, par As Byte) As Long ' par=1 gives the image width , par=2 gives the image height,
#End If
  Dim bitmap1 As BMPFile
  Open fn For Binary As #1
  With bitmap1
    Get #1, , .bmfh
    Get #1, , .bmih
    Close #1
    Select Case par
        Case 1
            ReadShowSameBMPInfo = .bmih.biWidth
        Case 2
            ReadShowSameBMPInfo = .bmih.biHeight
    End Select
'    MsgBox "Type = " & Chr(.bmfh.bfType1) & Chr(.bmfh.bfType2) & Chr(10) & "Size = " & .bmih.biWidth & "x" & .bmih.biHeight, , fn
  End With
End Function