VB6结合GDI+实现内存(Stream)压缩/解压缩JPG(JPEG)图像

CSDN论坛vb版中有一个讨论内存压缩JPEG的帖子，在此我贴出解决代码。

代码原理原本就简单，所以注释也很简单。

希望能帮助到苦苦思索的朋友们。(魏滔序原创，转帖请注明出处。)

首先要下载一个IStream库，用该库可以减少代码量，如果直接全部用API也未尝不可。

IStream下载地址：IStream.zip

下面是代码，可以贴在一个模块中：

Option Explicit '常量声明 Private Const ClsidJPEG As String = "{557CF401-1A04-11D3-9A73-0000F81EF32E}" Private Const EncoderP<a href="https://www.jb51.cc/tag/ara/" target="_blank" class="keywords">ara</a>meterValueTypeLong As Long = 4& Private Const EncoderQuality As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}" Private Const GdiPlu<a href="https://www.jb51.cc/tag/sve/" target="_blank" class="keywords">sve</a>rsion As Long = 1& '结构声明 Private Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(0 To 7) As Byte End Type Private Type IID Data1 As Long Data2 As Integer Data3 As Integer Data4(0 To 7) As Byte End Type Private Type PICTDESC cbSizeOfStruct As Long picType As Long hg<a href="https://www.jb51.cc/tag/dio/" target="_blank" class="keywords">dio</a>bj As Long hPalOrXYExt As Long End Type Private Type EncoderP<a href="https://www.jb51.cc/tag/ara/" target="_blank" class="keywords">ara</a>meter GUID As GUID NumberOfValues As Long Type As Long Value As Long End Type Private Type EncoderP<a href="https://www.jb51.cc/tag/ara/" target="_blank" class="keywords">ara</a>meters Count As Long P<a href="https://www.jb51.cc/tag/ara/" target="_blank" class="keywords">ara</a>meter(15) As EncoderP<a href="https://www.jb51.cc/tag/ara/" target="_blank" class="keywords">ara</a>meter End Type Private Type GDIPlu<a href="https://www.jb51.cc/tag/sst/" target="_blank" class="keywords">sst</a>artupInput GdiPlu<a href="https://www.jb51.cc/tag/sve/" target="_blank" class="keywords">sve</a>rsion As Long DebugEventCallback As Long SuppressBackgroundThread As Long SuppressExternalCodecs As Long End Type Private Type Gdiplu<a href="https://www.jb51.cc/tag/sst/" target="_blank" class="keywords">sst</a>artupOutput NotificationHook As Long NotificationUnhook As Long End Type '枚举声明 Private Enum Status OK = 0 GenericError = 1 InvalidP<a href="https://www.jb51.cc/tag/ara/" target="_blank" class="keywords">ara</a>meter = 2 OutOfMemory = 3 ObjectBusy = 4 InsufficientBuffer = 5 NotImplemented = 6 Win32Error = 7 WrongState = 8 Aborted = 9 FileNotFound = 10 ValueOverflow = 11 AccessDenied = 12 Unk<a href="https://www.jb51.cc/tag/Now/" target="_blank" class="keywords">Now</a>nImageFormat = 13 FontFamilyNotFound = 14 FontStyleNotFound = 15 N<a href="https://www.jb51.cc/tag/ott/" target="_blank" class="keywords">ott</a>rueTypeFont = 16 UnsupportedGdiplu<a href="https://www.jb51.cc/tag/sve/" target="_blank" class="keywords">sve</a>rsion = 17 Gdiplus<a href="https://www.jb51.cc/tag/notin/" target="_blank" class="keywords">notin</a>itialized = 18 PropertyNotFound = 19 PropertyNotSupported = 20 ProfileNotFound = 21 End Enum 'API声明 Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long,ByVal hpal As Long,ByRef bitmap As Long) As Status Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" (ByVal bitmap As Long,ByRef hbmReturn As Long,ByVal Background As Long) As Status Private Declare Function Gdip<a href="https://www.jb51.cc/tag/dis/" target="_blank" class="keywords">dis</a>poseImage Lib "gdiplus" (ByVal image As Long) As Status Private Declare Function GdipLoadImageFromStream Lib "gdiplus" (ByVal Stream As IUnk<a href="https://www.jb51.cc/tag/Now/" target="_blank" class="keywords">Now</a>n,ByRef image As Long) As Status Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Status Private Declare Function Gdiplu<a href="https://www.jb51.cc/tag/sst/" target="_blank" class="keywords">sst</a>artup Lib "gdiplus" (ByRef token As Long,ByRef lpInput As GDIPlu<a href="https://www.jb51.cc/tag/sst/" target="_blank" class="keywords">sst</a>artupInput,ByRef lpOutput As Gdiplu<a href="https://www.jb51.cc/tag/sst/" target="_blank" class="keywords">sst</a>artupOutput) As Status Private Declare Function GdipSaveImag<a href="https://www.jb51.cc/tag/eto/" target="_blank" class="keywords">eto</a>Stream Lib "gdiplus" (ByVal image As Long,ByVal Stream As IStream,ByRef clsidEncoder As GUID,ByRef encoderP<a href="https://www.jb51.cc/tag/ara/" target="_blank" class="keywords">ara</a>ms As Any) As Status Private Declare Function CLSIDFromString Lib "ole32" (ByVal Str As Long,ByRef id As GUID) As Long Private Declare Function CreateStreamOnHGlobal Lib "ole32.dll" (ByRef hGlobal As Any,ByVal fDeleteOnRelease As Long,ByRef ppstm As Any) As Long Private Declare Sub OleCreatePictureIndirect Lib "oleaut32.dll" (ByRef lpPictDesc As PICTDESC,ByRef riid As IID,ByVal fOwn As Boolean,ByRef lplpvObj As Object) '根据版本初始化GDI+ Private Function StartUpGDIPlus(ByVal GdipVersion As Long) As Long Dim GdipToken As Long Dim GdipStartupInput As GDIPlu<a href="https://www.jb51.cc/tag/sst/" target="_blank" class="keywords">sst</a>artupInput Dim GdipStartupOutput As Gdiplu<a href="https://www.jb51.cc/tag/sst/" target="_blank" class="keywords">sst</a>artupOutput GdipStartupInput.GdiPlu<a href="https://www.jb51.cc/tag/sve/" target="_blank" class="keywords">sve</a>rsion = GdipVersion If Gdiplu<a href="https://www.jb51.cc/tag/sst/" target="_blank" class="keywords">sst</a>artup(GdipToken,GdipStartupInput,GdipStartupOutput) = OK Then StartUpGDIPlus = GdipToken End If End Function '从图像转换为流 Public Function Pictur<a href="https://www.jb51.cc/tag/eto/" target="_blank" class="keywords">eto</a>Stream(ByVal Picture As StdPicture,Optional ByVal JpegQuality As Long = 85) As IStream Dim picStream As IStream Dim lBitmap As Long Dim tGUID As GUID Dim bytBuff() As Byte Dim tP<a href="https://www.jb51.cc/tag/ara/" target="_blank" class="keywords">ara</a>ms As EncoderP<a href="https://www.jb51.cc/tag/ara/" target="_blank" class="keywords">ara</a>meters Dim lngGdipToken As Long lngGdipToken = StartUpGDIPlus(GdiPlu<a href="https://www.jb51.cc/tag/sve/" target="_blank" class="keywords">sve</a>rsion) '检查JPG压缩比率 If JpegQuality > 100 Then JpegQuality = 100 If JpegQuality < 0 Then JpegQuality = 0 '创建Bitmap If GdipCreateBitmapFromHBITMAP(Picture.Handle,lBitmap) = OK Then '创建Stream If CreateStreamOnHGlobal(ByVal 0,False,picStream) = 0 Then '转换GUID If CLSIDFromString(StrPtr(ClsidJPEG),tGUID) = 0 Then '设置JPG相关参数值 tP<a href="https://www.jb51.cc/tag/ara/" target="_blank" class="keywords">ara</a>ms.Count = 1 With tP<a href="https://www.jb51.cc/tag/ara/" target="_blank" class="keywords">ara</a>ms.P<a href="https://www.jb51.cc/tag/ara/" target="_blank" class="keywords">ara</a>meter(0) CLSIDFromString StrPtr(EncoderQuality),.GUID .NumberOfValues = 1 .Type = EncoderP<a href="https://www.jb51.cc/tag/ara/" target="_blank" class="keywords">ara</a>meterValueTypeLong .Value = VarPtr(JpegQuality) End With '将Bitmap数据保存到流(JPG格式) If GdipSaveImag<a href="https://www.jb51.cc/tag/eto/" target="_blank" class="keywords">eto</a>Stream(lBitmap,picStream,tGUID,tP<a href="https://www.jb51.cc/tag/ara/" target="_blank" class="keywords">ara</a>ms) = OK Then Set Pictur<a href="https://www.jb51.cc/tag/eto/" target="_blank" class="keywords">eto</a>Stream = picStream End If End If Set picStream = <a href="https://www.jb51.cc/tag/nothing/" target="_blank" class="keywords">nothing</a> End If End If Gdip<a href="https://www.jb51.cc/tag/dis/" target="_blank" class="keywords">dis</a>poseImage lBitmap '本行<a href="https://www.jb51.cc/tag/daima/" target="_blank" class="keywords">代码</a>乃后期修正 GdiplusShutdown lngGdipToken End Function '从流转换为图像 Public Function StreamToPicture(ByVal Stream As IStream) As StdPicture Dim picStream As IStream Dim lBitmap As Long Dim hBitmap As Long Dim lngGdipToken As Long Dim tPictDesc As PICTDESC Dim IID_IPicture As IID Dim oPicture As IPicture lngGdipToken = StartUpGDIPlus(GdiPlu<a href="https://www.jb51.cc/tag/sve/" target="_blank" class="keywords">sve</a>rsion) Set picStream = Stream '从Stream加载Bitmap If GdipLoadImageFromStream(picStream,lBitmap) = OK Then '根据Bitmap创建hBitbmp If GdipCreateHBITMAPFromBitmap(lBitmap,hBitmap,0) = OK Then With tPictDesc .cbSizeOfStruct = Len(tPictDesc) .picType = vbPicTypeBitmap .hg<a href="https://www.jb51.cc/tag/dio/" target="_blank" class="keywords">dio</a>bj = hBitmap .hPalOrXYExt = 0 End With ' 初始化IPicture With IID_IPicture .Data1 = &H7BF80981 .Data2 = &HBF32 .Data3 = &H101A .Data4(0) = &H8B .Data4(1) = &HBB .Data4(3) = &HAA .Data4(5) = &H30 .Data4(6) = &HC .Data4(7) = &HAB End With Call OleCreatePictureIndirect(tPictDesc,IID_IPicture,True,oPicture) Set StreamToPicture = oPicture End If End If Set picStream = <a href="https://www.jb51.cc/tag/nothing/" target="_blank" class="keywords">nothing</a> Gdip<a href="https://www.jb51.cc/tag/dis/" target="_blank" class="keywords">dis</a>poseImage lBitmap '本行<a href="https://www.jb51.cc/tag/daima/" target="_blank" class="keywords">代码</a>乃后期修正 GdiplusShutdown lngGdipToken End Function

示例：

'示例 Private Sub Command1_Click() Dim s As IStream Set s = Pictur<a href="https://www.jb51.cc/tag/eto/" target="_blank" class="keywords">eto</a>Stream(Me.Picture1.Picture) Set Me.Picture2.Picture = StreamToPicture(s) End Sub