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

Posted 2023-02-16

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) 参考技术A image控件加载图片格式如下：
,image.picture
=
loadpicture(strimgfilename)
剪贴板没有路径可取，所以必须先保存到磁盘再加载。
保存代码参阅：
http://www.accessoft.com/article-show.asp?id=5915 参考技术B 前提是你已经复制了图片到剪切板，执行下列语句：
Selection.PasteAndFormat
(wdPasteDefault)
即可粘贴到文档中