vba 怎么读取系统剪贴板中的图片到image控件?

Python017

vba 怎么读取系统剪贴板中的图片到image控件?,第1张

VBA不能直接读取剪切板的内容,需要分两步,先将剪切板内容保存到JPG,再从JPG中读取图片到IMAGE控件。

代码如下:

Option Explicit

Private Type GUID

    Data1 As Long

    Data2 As Integer

    Data3 As Integer

    Data4(0 To 7) As Byte

End Type

Private Type GdiplusStartupInput

    GdiplusVersion As Long

    DebugEventCallback As Long

    SuppressBackgroundThread As Long

    SuppressExternalCodecs As Long

End Type

Private Type EncoderParameter

    GUID As GUID

    NumberOfValues As Long

    type As Long

    Value As Long

End Type

Private Type EncoderParameters

    Count As Long

    Parameter As EncoderParameter

End Type

Private Declare Sub keybd_event Lib "user32" _

(ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, ByVal outputbuf As Long) As Long

Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long

Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hpal As Long, Bitmap As Long) As Long

Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long

Private Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal filename As Long, clsidEncoder As GUID, encoderParams As Any) As Long

Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long

'Private Declare Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal filename As Long, Bitmap As Long) As Long

Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long

Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long

Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long '剪贴板

Private Declare Function CloseClipboard Lib "user32" () As Long

Const CF_BITMAP = 2

Private Sub My_Screen_1()

    Call keybd_event(vbKeySnapshot, 0, 0, 0)

    DoEvents

End Sub

  

Private Sub My_Screen_2()

    Call keybd_event(vbKeySnapshot, 1, 1, 1)

    DoEvents

End Sub

Public Function Screen2JPG(ByVal filename As String, Optional ByVal quality As Byte = 80) As Boolean

    

    Dim tSI As GdiplusStartupInput

    Dim lRes As Long

    Dim lGDIP As Long

    Dim lBitmap As Long

    Dim hBitmap As Long

    '复制单元格区域图像

    ''''''Range.CopyPicture xlScreen, xlBitmap

    My_Screen_2

    

    '打开剪贴板

    OpenClipboard 0&

    '获取剪贴板中bitmap数据的句柄

    hBitmap = GetClipboardData(CF_BITMAP)

    '关闭剪贴板

    CloseClipboard

    '初始化 GDI+

    tSI.GdiplusVersion = 1

    lRes = GdiplusStartup(lGDIP, tSI, 0)

     

    If lRes = 0 Then

        '从句柄创建 GDI+ 图像

         lRes = GdipCreateBitmapFromHBITMAP(hBitmap, 0, lBitmap)

        If lRes = 0 Then

            Dim tJpgEncoder As GUID

            Dim tParams As EncoderParameters

             

            '初始化解码器的GUID标识

            CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder

            '设置解码器参数

            tParams.Count = 1

                With tParams.Parameter ' Quality

                '得到Quality参数的GUID标识

                CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID

                .NumberOfValues = 1

                .type = 4

                .Value = VarPtr(quality)

            End With

             

            '保存图像

            lRes = GdipSaveImageToFile(lBitmap, StrPtr(filename), tJpgEncoder, tParams)

             

            '销毁GDI+图像

            GdipDisposeImage lBitmap

        End If

         

        '销毁 GDI+

        GdiplusShutdown lGDIP

    End If

    

        Screen2JPG = Not lRes

End Function

'最后,只要用载入图片即可。

Image.Picture = LoadPicture(filename)

如果你是想鼠标选中后点击复制到文本框内,其实不用剪贴板,可以获取选中的内容,然后在复制给文本框就可以了

http://www.phptogether.com/codecontent/351