|
|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
Option Explicit
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Const CF_BITMAP = 2 '对应 Format:=xlBitmap xlBitmap 对应 Bitmap (.bmp, .jpg, .gif).
Private Const CF_ENHMETAFILE = 14 '对应 Format:=xlPicture xlPicture 对应 Drawn picture (.png, .wmf, .mix). '来源 https://msdn.microsoft.com/en-us/library/microsoft.office.interop.excel.xlcopypictureformat.aspx
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 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 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 GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hPal As Long, BITMAP As Long) As Long
Public Function ClipBitMaptoJPG(ByVal destfilename As String, Optional ByVal quality As Integer = 80) As Integer
'*****该函数用于取出剪贴板中图片转换为jpg文件另存到指定路径****
'参数说明：
' destfilename:要保存的jpg文件的完整路径，必要参数；
' quality: jpg文件的质量，0-100之间的数值，数值越大，图片质量越高
'返回值：
' 0-保存成功；1-保存失败；2-剪贴板中无位图数据；3-无法打开剪贴板
Dim tSI As GdiplusStartupInput
Dim lRes As Long
Dim lGDIP As Long
Dim lBitmap As Long
Dim hBmp As Long
'尝试打开剪贴板
If OpenClipboard(0) Then
'尝试取出剪贴板中位图的句柄
hBmp = GetClipboardData(CF_BITMAP)
'如果hBmp为0，说明剪贴板中没有存放图片
If hBmp = 0 Then
ClipBitMaptoJPG = 2
CloseClipboard
Exit Function
End If
CloseClipboard
Else '如果openclipboard返回0(False)，说明剪贴板被其他程序所占用
ClipBitMaptoJPG = 3
Exit Function
End If
'初始化 GDI+
tSI.GdiplusVersion = 1
lRes = GdiplusStartup(lGDIP, tSI, 0)
If lRes = 0 Then
'从句柄创建 GDI+ 图像
lRes = GdipCreateBitmapFromHBITMAP(hBmp, 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(CByte(quality)) '此处原始quality 参数为byte类型
End With
'保存图像
lRes = GdipSaveImageToFile(lBitmap, StrPtr(destfilename), tJpgEncoder, tParams)
If lRes = 0 Then
ClipBitMaptoJPG = 0 '转换成功
Else
ClipBitMaptoJPG = 1 '转换失败
End If
'销毁GDI+图像
GdipDisposeImage lBitmap
End If
'销毁 GDI+
GdiplusShutdown lGDIP
End If
End Function
Sub test_ClipBitMaptoJPG()
Range("A1:K100").CopyPicture Appearance:=xlScreen, Format:=xlBitmap
Select Case ClipBitMaptoJPG("C:\211.jpg")
Case 0:
MsgBox "剪贴板图片已保存"
Case 1:
MsgBox "剪贴板图片保存失败"
Case 2:
MsgBox "剪贴板中无图片"
Case 3:
MsgBox "剪贴板无法打开，可能被其他程序所占用"
End Select
End Sub
能将此代码用VB6.0封装在DLL不，50元酬谢 |
|
楼主: 灰袍法师
[复制链接]
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2018-5-18 21:24
