缩小图片到指定大小。解决思路
缩小图片到指定大小。
我这里指的大小不只是宽、高的大小。而是指图片的实际大小即文件大小。
如：有一张1024X768 大小为800K的图片，我现在要把它变为1024X768 大小为300K的图片，如何实现啊？
------解决方案--------------------
以下函数使用GDI+ API来保存图象，可以指定JPEG的质量。默认为80，如果改小该值，文件大小也会变小。
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, Optional ByVal outputbuf As Long = 0) 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 CopyMemory Lib "kernel32 " Alias "RtlMoveMemory " (Dest As Any, Src As Any, ByVal cb As Long) As Long
'*************************************************************************
'** 作 者 ： laviewpbt
'** 函 数 名 ： SavePic
'** 输 入 ： pic(StdPicture) - 图象句柄
'** ： FileName(String) - 保存路径
'** ： Quality(Byte) - JPG图象质量
'** ： TIFF_ColorDepth(Long) - TTF格式的颜色深度
'** ： TIFF_Compression(Long) - TTF格式的压缩比
'** 输 出 ： 无
'** 功能描述 ： 把图象保存为JPG、TIFF、PNG、GIF、BMP格式
'** 日 期 ：
'** 修 改 人 ： laviewpbt
'** 日 期 ： 2005-10-23 14.43.52
'** 版 本 ： Version 1.2.1
'*************************************************************************
Sub SavePic(ByVal pict As StdPicture, ByVal FileName As String, PicType As String, _
Optional ByVal Quality As Byte = 80, _
Optional ByVal TIFF_ColorDepth As Long = 24, _
Optional ByVal TIFF_Compression As Long = 6)
Screen.MousePointer = vbHourglass
Dim tSI As GdiplusStartupInput
Dim lRes As Long
Dim lGDIP As Long
Dim lBitmap As Long
Dim aEncParams() As Byte
On Error GoTo ErrHandle:
tSI.GdiplusVersion = 1 ' 初始化 GDI+
lRes = GdiplusStartup(lGDIP, tSI)
If lRes = 0 Then ' 从句柄创建 GDI+ 图像
lRes = GdipCreateBitmapFromHBITMAP(pict.Handle, 0, lBitmap)
If lRes = 0 Then
Dim tJpgEncoder As GUID
Dim tParams As EncoderParameters '初始化解码器的GUID标识
Select Case PicType
Case ".jpg "
CLSIDFromString StrPtr( "{557CF401-1A04-11D3-9A73-0000F81EF32E} "), tJpgEncoder
tParams.count = 1 ' 设置解码器参数
With tParams.Parameter ' Quality
CLSIDFromString StrPtr( "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB} "), .GUID ' 得到Quality参数的GUID标识
我这里指的大小不只是宽、高的大小。而是指图片的实际大小即文件大小。
如：有一张1024X768 大小为800K的图片，我现在要把它变为1024X768 大小为300K的图片，如何实现啊？
------解决方案--------------------
以下函数使用GDI+ API来保存图象，可以指定JPEG的质量。默认为80，如果改小该值，文件大小也会变小。
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, Optional ByVal outputbuf As Long = 0) 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 CopyMemory Lib "kernel32 " Alias "RtlMoveMemory " (Dest As Any, Src As Any, ByVal cb As Long) As Long
'*************************************************************************
'** 作 者 ： laviewpbt
'** 函 数 名 ： SavePic
'** 输 入 ： pic(StdPicture) - 图象句柄
'** ： FileName(String) - 保存路径
'** ： Quality(Byte) - JPG图象质量
'** ： TIFF_ColorDepth(Long) - TTF格式的颜色深度
'** ： TIFF_Compression(Long) - TTF格式的压缩比
'** 输 出 ： 无
'** 功能描述 ： 把图象保存为JPG、TIFF、PNG、GIF、BMP格式
'** 日 期 ：
'** 修 改 人 ： laviewpbt
'** 日 期 ： 2005-10-23 14.43.52
'** 版 本 ： Version 1.2.1
'*************************************************************************
Sub SavePic(ByVal pict As StdPicture, ByVal FileName As String, PicType As String, _
Optional ByVal Quality As Byte = 80, _
Optional ByVal TIFF_ColorDepth As Long = 24, _
Optional ByVal TIFF_Compression As Long = 6)
Screen.MousePointer = vbHourglass
Dim tSI As GdiplusStartupInput
Dim lRes As Long
Dim lGDIP As Long
Dim lBitmap As Long
Dim aEncParams() As Byte
On Error GoTo ErrHandle:
tSI.GdiplusVersion = 1 ' 初始化 GDI+
lRes = GdiplusStartup(lGDIP, tSI)
If lRes = 0 Then ' 从句柄创建 GDI+ 图像
lRes = GdipCreateBitmapFromHBITMAP(pict.Handle, 0, lBitmap)
If lRes = 0 Then
Dim tJpgEncoder As GUID
Dim tParams As EncoderParameters '初始化解码器的GUID标识
Select Case PicType
Case ".jpg "
CLSIDFromString StrPtr( "{557CF401-1A04-11D3-9A73-0000F81EF32E} "), tJpgEncoder
tParams.count = 1 ' 设置解码器参数
With tParams.Parameter ' Quality
CLSIDFromString StrPtr( "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB} "), .GUID ' 得到Quality参数的GUID标识