Question

我可以通过将其复制到Windows剪贴板并将其保存到文件来从CommandBarButton.Picture获取Base64数据。

不幸的是，这个过程太慢了。处理4676个独特图像大约需要45秒。有没有办法直接从Windows剪贴板中的图像获取Base64数据？

或者，有没有办法进行多线程处理？我正在开发一个PowerShell脚本，它将处理剪贴板，但宁愿直接从VBA进行。

Option Explicit
'Referrence: Stephen Bullen: http://www.oaltd.co.uk
'Open the clipboard to read
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
'Get a pointer to the bitmap/metafile
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
'Close the clipboard
Private Declare Function CloseClipboard Lib "user32" () As Long
'Convert the handle into an OLE IPicture interface.
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
'Declare a UDT to store a GUID for the IPicture OLE Interface
Private 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
Private Type uPicDesc: Size As Long: Type As Long: hPic As Long: hPal As Long: End Type
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long

Private Type Bitmap
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type

Public Sub SavePictureFromClipBoard(ImagePath As String)

    Dim IPic As IPicture

    OpenClipboard 0&

    OleCreatePictureIndirect getuPicInfo, getIID_IDispatch, True, IPic

    SavePicture IPic, ImagePath

    CloseClipboard

    Set IPic = Nothing

End Sub

Private Function getIID_IDispatch() As GUID
    Dim IID_IDispatch As GUID
    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
    getIID_IDispatch = IID_IDispatch
End Function

Private Function getuPicInfo() As uPicDesc
    Const PICTYPE_BITMAP = 1
    Dim uPicInfo As uPicDesc

    ' Fill uPicInfo with necessary parts.
    With uPicInfo
        .Size = Len(uPicInfo)                         ' Length of structure.
        .Type = PICTYPE_BITMAP                        ' Type of Picture
        .hPic = GetClipboardData(xlBitmap)            ' Handle to image.
        .hPal = xlBitmap                              ' Handle to palette (if bitmap).
    End With
    getuPicInfo = uPicInfo
End Function

Public Function getADODBStream(ImagePath As String) As Byte()
    Const adTypeBinary = 1
    With CreateObject("ADODB.Stream")
        .Type = adTypeBinary
        .Open
        .LoadFromFile (ImagePath)
        getADODBStream = .Read()
    End With
End Function

Public Function getBase64FromImageFile(ImagePath As String) As String
    With CreateObject("MSXml2.DOMDocument")
        With .createElement("Base64Data")
            .DataType = "bin.base64"
            .nodeTypedValue = getADODBStream(ImagePath)
            getBase64FromImageFile = .Text
        End With
    End With
End Function

Public Function getBase64FromByteArray(Bytes() As Byte) As String
    With CreateObject("MSXml2.DOMDocument")
        With .createElement("Base64Data")
            .DataType = "bin.base64"
            .nodeTypedValue = Bytes
            getBase64FromByteArray = .Text
        End With
    End With
End Function

Public Function getBytes(Picture1 As IPictureDisp) As Byte()
    Dim PicBits() As Byte, PicInfo As Bitmap

    GetObject Picture1, Len(PicInfo), PicInfo

    ReDim PicBits((PicInfo.bmWidth * PicInfo.bmHeight * 3) - 1) As Byte

    GetBitmapBits Picture1, UBound(PicBits), PicBits(0)

    getBytes = PicBits()
End Function

附录

我能够从CommandBarButton和ClipBoard Image中读取Byte（）。我有的问题是Bitmap有一个Picture Byte（0到767）和一个Mask Byte（0到767）组合在一起形成一个完整的Image。注意：蒙版是一种背景图像，用于确定图片的像素强度。 SavePicture函数似乎合并了这两部分。 ADODB.Stream保存的文件返回一个字节（0到821）。

当复制到ClipBoard时，Byte（）数组的ClipBoard IPicture和CommandBarButton图片都是相同的。

上面的三个图像是CommandBarButton图片，CommandBarButton蒙版，以及保存到文件然后加载到图像控件中的剪贴板图像。

我对如何组合两个Byte（）以及如何从它们派生颜色感到困惑。

从剪贴板图像编码Base64数据

附录

0 个答案: