Question

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

vba 中Clipboard对象用不了，有什么办法在vba中把系统剪贴板中图片读取到image控件中？

或者有其他方式实现将网页上的图片保存到image控件中吗？

大神，帮帮忙啊，感谢

Answer 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)

Answer 2

前提是你已经复制了图片到剪切板，执行下列语句：
Selection.PasteAndFormat (wdPasteDefault)
即可粘贴到文档中

追问

Selection.PasteAndFormat (wdPasteDefault)，这一句加哪儿呢？

我加到CtrlRange.execCommand ("Copy") 后面

结果提示  对象不支持该属性或方法