[VB]GDI+ IStream、StdPicture、Byte() 互转

很多年前就想做一个远程控制的软件，只是一直以来图片的压缩速度总是提升不上去，而我也参考过很多网上的关于图片压缩的例子，比如zyl910的GIF_LZW压缩方法，Huffman压缩方法，以至到GDI+的直接生成JPG、PNG的方法（这种方法无论从压缩率和速度上都是最佳的，可惜这种方法网上一直没找到直接保存为Byte()的例子，见得最多的例子就是用GdipSaveImageToFile保存到磁盘，然后再读取发送了，但是我做的可是远程控制软件，每秒不知道要写多少M的数据进磁盘！），近来在偶然机会重新拾起了完成这个程序的念头，而且很巧的是搜索到了Modest的《VB6结合GDI+实现内存(Stream)压缩/解压缩JPG(JPEG)图像》，这篇文章给了我很大的启发，在此感谢Modest！！！

Modest的代码已经实现了StdPicture和IStream的互转，我另外使用了GlobalAlloc、GlobalLock、GlobalUnlock、GlobalFree等函数创建一个缓冲区（指针为hGlobal），将Modest代码中CreateStreamOnHGlobal(ByVal 0&, False, picStream)改成CreateStreamOnHGlobal(ByVal hGlobal, False, picStream)，这样我便可根据hGlobal来读写picStream的内容了，具体代码如下：

'By TZWSOHO '从图像转换为流再转为字节数组 Public Function PictureToByteArray(ByVal Picture As StdPicture, Optional ByVal JpegQuality As Long = 85) As Byte() Dim picStream As IStream Dim lBitmap As Long Dim tGUID As GUID Dim bytBuff() As Byte Dim tParams As EncoderParameters Dim lngGdipToken As Long Dim hGlobal As Long, lpBuffer As Long, dwSize As Long, Buff() As Byte lngGdipToken = StartUpGDIPlus(GdiPlusVersion) '检查JPG压缩比率 If JpegQuality > 100 Then JpegQuality = 100 If JpegQuality < 0 Then JpegQuality = 0 '创建Bitmap If GdipCreateBitmapFromHBITMAP(Picture.Handle, 0, lBitmap) = OK Then hGlobal = GlobalAlloc(GMEM_MOVEABLE, Picture.Width * Picture.Height / 256) '创建缓冲区 '创建Stream If CreateStreamOnHGlobal(ByVal hGlobal, False, picStream) = 0 Then '转换GUID If CLSIDFromString(StrPtr(ClsidJPEG), tGUID) = 0 Then '设置JPG相关参数值 tParams.Count = 1 With tParams.Parameter(0) CLSIDFromString StrPtr(EncoderQuality), .GUID .NumberOfValues = 1 .Type = EncoderParameterValueTypeLong .Value = VarPtr(JpegQuality) End With '将Bitmap数据保存到流(JPG格式) If GdipSaveImageToStream(lBitmap, picStream, tGUID, tParams) = OK Then 'GetHGlobalFromStream picStream, hGlobal picStream.Seek 0, STREAM_SEEK_CUR, dwSize '获取图像大小 lpBuffer = GlobalLock(hGlobal) '获取缓冲区读写指针 ReDim Buff(dwSize - 1): CopyMemory Buff(0), ByVal lpBuffer, dwSize '读取图像 GlobalUnlock hGlobal: GlobalFree hGlobal '释放分配的缓冲区空间 PictureToByteArray = Buff End If End If Set picStream = Nothing End If End If GdipDisposeImage lBitmap GdiplusShutdown lngGdipToken End Function

若要把Byte()转化为StdPicture，我的方法是先用CreateStreamOnHGlobal把Byte()转化为IStream，然后再调用Modest代码里面的StreamToPicture函数最终转化为StdPicture，具体代码如下：

'By TZWSOHO '从字节数组转换为流再转换为图像 Public Function ByteArrayToPicture(sBuf() As Byte) 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 Dim hGlobal As Long, lpBuffer As Long lngGdipToken = StartUpGDIPlus(GdiPlusVersion) hGlobal = GlobalAlloc(GMEM_MOVEABLE, UBound(sBuf) + 1) '创建缓冲区 lpBuffer = GlobalLock(hGlobal) '获取缓冲区读写指针 CopyMemory ByVal lpBuffer, sBuf(0), UBound(sBuf) + 1 '复制字节数组内容到缓冲区 '创建Stream If CreateStreamOnHGlobal(ByVal hGlobal, False, picStream) = 0 Then '从Stream加载Bitmap If GdipLoadImageFromStream(picStream, lBitmap) = OK Then '根据Bitmap创建hBitbmp If GdipCreateHBITMAPFromBitmap(lBitmap, hBitmap, 0) = OK Then With tPictDesc .cbSizeOfStruct = Len(tPictDesc) .picType = vbPicTypeBitmap .hgdiObj = 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 ByteArrayToPicture = StreamToPicture(picStream) End If End If GlobalUnlock hGlobal: GlobalFree hGlobal '释放分配的缓冲区空间 Set picStream = Nothing End If GdipDisposeImage lBitmap GdiplusShutdown lngGdipToken End Function  

完整的模块代码如下（包括Modest的代码）：

Option Explicit '********************************************************************************* 'StdPicture、IStream、Byte() 互转 '作者：TZWSOHO ' '参考了魏滔序的《VB6 结合 GDI+ 实现内存（Stream）压缩/解压缩 JPG 图像》 'http://blog.csdn.net/Modest/archive/2009/08/31/4505237.aspx '非常感谢魏滔序的代码！！！ ' '欢迎访问我的博客：http://blog.csdn.net/tzwsoho '********************************************************************************* Private Const GMEM_MOVEABLE As Long = &H2 '常量声明 Private Const ClsidJPEG As String = "{557CF401-1A04-11D3-9A73-0000F81EF32E}" Private Const EncoderParameterValueTypeLong As Long = 4& Private Const EncoderQuality As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}" Private Const GdiPlusVersion 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 hgdiObj As Long hPalOrXYExt 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(15) As EncoderParameter End Type Private Type GDIPlusStartupInput GdiPlusVersion As Long DebugEventCallback As Long SuppressBackgroundThread As Long SuppressExternalCodecs As Long End Type Private Type GdiplusStartupOutput NotificationHook As Long NotificationUnhook As Long End Type '枚举声明 Private Enum Status OK = 0 GenericError = 1 InvalidParameter = 2 OutOfMemory = 3 ObjectBusy = 4 InsufficientBuffer = 5 NotImplemented = 6 Win32Error = 7 WrongState = 8 Aborted = 9 FileNotFound = 10 ValueOverflow = 11 AccessDenied = 12 UnknownImageFormat = 13 FontFamilyNotFound = 14 FontStyleNotFound = 15 NotTrueTypeFont = 16 UnsupportedGdiplusVersion = 17 GdiplusNotInitialized = 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 GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As Status Private Declare Function GdipLoadImageFromStream Lib "gdiplus" (ByVal Stream As IStream, ByRef image As Long) As Status Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Status Private Declare Function GdiplusStartup Lib "gdiplus" (ByRef token As Long, ByRef lpInput As GDIPlusStartupInput, ByRef lpOutput As GdiplusStartupOutput) As Status Private Declare Function GdipSaveImageToStream Lib "gdiplus" (ByVal image As Long, ByVal Stream As IStream, ByRef clsidEncoder As GUID, ByRef encoderParams 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) Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long) Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long 'Private Declare Function GlobalSize Lib "kernel32.dll" (ByVal hMem As Long) As Long Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long Private Declare Function GlobalFree Lib "kernel32.dll" (ByVal hMem As Long) As Long 'Private Declare Function GetHGlobalFromStream Lib "ole32.dll" (ByVal pstm As IStream, ByRef phglobal As Long) As Long 'By Modest '根据版本初始化GDI+ Private Function StartUpGDIPlus(ByVal GdipVersion As Long) As Long Dim GdipToken As Long Dim GdipStartupInput As GDIPlusStartupInput Dim GdipStartupOutput As GdiplusStartupOutput GdipStartupInput.GdiPlusVersion = GdipVersion If GdiplusStartup(GdipToken, GdipStartupInput, GdipStartupOutput) = OK Then StartUpGDIPlus = GdipToken End If End Function 'By Modest '从图像转换为流 Public Function PictureToStream(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 tParams As EncoderParameters Dim lngGdipToken As Long lngGdipToken = StartUpGDIPlus(GdiPlusVersion) '检查JPG压缩比率 If JpegQuality > 100 Then JpegQuality = 100 If JpegQuality < 0 Then JpegQuality = 0 '创建Bitmap If GdipCreateBitmapFromHBITMAP(Picture.Handle, 0, lBitmap) = OK Then '创建Stream If CreateStreamOnHGlobal(ByVal 0&, False, picStream) = 0 Then '转换GUID If CLSIDFromString(StrPtr(ClsidJPEG), tGUID) = 0 Then '设置JPG相关参数值 tParams.Count = 1 With tParams.Parameter(0) CLSIDFromString StrPtr(EncoderQuality), .GUID .NumberOfValues = 1 .Type = EncoderParameterValueTypeLong .Value = VarPtr(JpegQuality) End With '将Bitmap数据保存到流(JPG格式) If GdipSaveImageToStream(lBitmap, picStream, tGUID, tParams) = OK Then Set PictureToStream = picStream End If End If Set picStream = Nothing End If End If GdipDisposeImage lBitmap GdiplusShutdown lngGdipToken End Function 'By Modest '从流转换为图像 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(GdiPlusVersion) 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 .hgdiObj = 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 = Nothing GdipDisposeImage lBitmap GdiplusShutdown lngGdipToken End Function 'By TZWSOHO '从图像转换为流再转为字节数组 Public Function PictureToByteArray(ByVal Picture As StdPicture, Optional ByVal JpegQuality As Long = 85) As Byte() Dim picStream As IStream Dim lBitmap As Long Dim tGUID As GUID Dim bytBuff() As Byte Dim tParams As EncoderParameters Dim lngGdipToken As Long Dim hGlobal As Long, lpBuffer As Long, dwSize As Long, Buff() As Byte lngGdipToken = StartUpGDIPlus(GdiPlusVersion) '检查JPG压缩比率 If JpegQuality > 100 Then JpegQuality = 100 If JpegQuality < 0 Then JpegQuality = 0 '创建Bitmap If GdipCreateBitmapFromHBITMAP(Picture.Handle, 0, lBitmap) = OK Then hGlobal = GlobalAlloc(GMEM_MOVEABLE, Picture.Width * Picture.Height / 256) '创建缓冲区 '创建Stream If CreateStreamOnHGlobal(ByVal hGlobal, False, picStream) = 0 Then '转换GUID If CLSIDFromString(StrPtr(ClsidJPEG), tGUID) = 0 Then '设置JPG相关参数值 tParams.Count = 1 With tParams.Parameter(0) CLSIDFromString StrPtr(EncoderQuality), .GUID .NumberOfValues = 1 .Type = EncoderParameterValueTypeLong .Value = VarPtr(JpegQuality) End With '将Bitmap数据保存到流(JPG格式) If GdipSaveImageToStream(lBitmap, picStream, tGUID, tParams) = OK Then 'GetHGlobalFromStream picStream, hGlobal picStream.Seek 0, STREAM_SEEK_CUR, dwSize '获取图像大小 lpBuffer = GlobalLock(hGlobal) '获取缓冲区读写指针 ReDim Buff(dwSize - 1): CopyMemory Buff(0), ByVal lpBuffer, dwSize '读取图像 GlobalUnlock hGlobal: GlobalFree hGlobal '释放分配的缓冲区空间 PictureToByteArray = Buff End If End If Set picStream = Nothing End If End If GdipDisposeImage lBitmap GdiplusShutdown lngGdipToken End Function 'By TZWSOHO '从字节数组转换为流再转换为图像 Public Function ByteArrayToPicture(sBuf() As Byte) 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 Dim hGlobal As Long, lpBuffer As Long lngGdipToken = StartUpGDIPlus(GdiPlusVersion) hGlobal = GlobalAlloc(GMEM_MOVEABLE, UBound(sBuf) + 1) '创建缓冲区 lpBuffer = GlobalLock(hGlobal) '获取缓冲区读写指针 CopyMemory ByVal lpBuffer, sBuf(0), UBound(sBuf) + 1 '复制字节数组内容到缓冲区 '创建Stream If CreateStreamOnHGlobal(ByVal hGlobal, False, picStream) = 0 Then '从Stream加载Bitmap If GdipLoadImageFromStream(picStream, lBitmap) = OK Then '根据Bitmap创建hBitbmp If GdipCreateHBITMAPFromBitmap(lBitmap, hBitmap, 0) = OK Then With tPictDesc .cbSizeOfStruct = Len(tPictDesc) .picType = vbPicTypeBitmap .hgdiObj = 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 ByteArrayToPicture = StreamToPicture(picStream) End If End If GlobalUnlock hGlobal: GlobalFree hGlobal '释放分配的缓冲区空间 Set picStream = Nothing End If GdipDisposeImage lBitmap GdiplusShutdown lngGdipToken End Function

如果要测试，可以把以上代码保存成一个模块，然后创建一个新的窗体，放置一个Picture1（加载一张图片）、一个Picture2（留空白）、一个Command1，粘贴以下代码：

 Option Explicit '********************************************************************************* 'StdPicture、IStream、Byte() 互转 '作者：TZWSOHO ' '参考了魏滔序的《VB6 结合 GDI+ 实现内存（Stream）压缩/解压缩 JPG 图像》 'http://blog.csdn.net/Modest/archive/2009/08/31/4505237.aspx '非常感谢魏滔序的代码！！！ ' '欢迎访问我的博客：http://blog.csdn.net/tzwsoho '********************************************************************************* '示例 Private Sub Command1_Click() 'By Modest 'Dim s As IStream 'Set s = PictureToStream(Picture1.Picture, 5) 'Set Picture2.Picture = StreamToPicture(s) 'By TZWSOHO Dim Buf() As Byte Buf = PictureToByteArray(Picture1.Picture, 5) Set Picture2.Picture = ByteArrayToPicture(Buf) End Sub

使用代码前请先引用IStream.tlb，下载地址：http://mitglied.lycos.de/real51/directdl.php?file=IStream.zip