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
'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
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
Private Function CreateStreamFromArray(ArrayPtr As Long, Length As Long) As stdole.IUnknown
' Purpose: Create an IStream-compatible IUnknown interface containing the
' passed byte aray. This IUnknown interface can be passed to GDI+ functions
' that expect an IStream interface -- neat hack
On Error GoTo HandleError
Dim o_hMem As Long
Dim o_lpMem As Long
If ArrayPtr = 0& Then
CreateStreamOnHGlobal 0&, 1&, pvCreateStreamFromArray
ElseIf Length <> 0& Then
o_hMem = GlobalAlloc(&H2&, Length)
If o_hMem <> 0 Then
o_lpMem = GlobalLock(o_hMem)
If o_lpMem <> 0 Then
CopyMemory ByVal o_lpMem, ByVal ArrayPtr, Length
Call GlobalUnlock(o_hMem)
Call CreateStreamOnHGlobal(o_hMem, 1&, pvCreateStreamFromArray)
End If
End If
End If
HandleError:
End Function
o_lngByteCount = GlobalSize(o_hMem)
If o_lngByteCount > 0 Then
o_lpMem = GlobalLock(o_hMem)
If o_lpMem <> 0 Then
ReDim arrayBytes(0 To o_lngByteCount - 1)
CopyMemory arrayBytes(0), ByVal o_lpMem, o_lngByteCount
GlobalUnlock o_hMem
ArrayFromStream = True
End If
End If
End If
End If
End Function
Private Function StreamToStdPicture(hStream As Long) As IPicture
' function creates a stdPicture from the passed array
' Note: The array was already validated as not empty before this was called
Dim aGUID(0 To 3) As Long
aGUID(0) = &H7BF80980 ' GUID for stdPicture
aGUID(1) = &H101ABF32
aGUID(2) = &HAA00BB8B
aGUID(3) = &HAB0C3000
Call OleLoadPicture(ByVal hStream, 0&, 0&, aGUID(0), StreamToStdPicture)
End Function
[/Code]
[解决办法]
根本不需要引用那个tlb，直接定义As stdole.IUnknown
Private Function StreamToStdPicture(hStream As Long) As IPicture
' function creates a stdPicture from the passed array
' Note: The array was already validated as not empty before this was called
Dim aGUID(0 To 3) As Long
aGUID(0) = &H7BF80980 ' GUID for stdPicture
aGUID(1) = &H101ABF32
aGUID(2) = &HAA00BB8B
aGUID(3) = &HAB0C3000
Call OleLoadPicture(ByVal hStream, 0&, 0&, aGUID(0), StreamToStdPicture)
End Function
Private Function CreateStreamFromArray(ArrayPtr As Long, Length As Long) As stdole.IUnknown
' Purpose: Create an IStream-compatible IUnknown interface containing the
' passed byte aray. This IUnknown interface can be passed to GDI+ functions
' that expect an IStream interface -- neat hack
On Error GoTo HandleError
Dim o_hMem As Long
Dim o_lpMem As Long
If ArrayPtr = 0& Then
CreateStreamOnHGlobal 0&, 1&, CreateStreamFromArray
ElseIf Length <> 0& Then
o_hMem = GlobalAlloc(&H2&, Length)
If o_hMem <> 0 Then
o_lpMem = GlobalLock(o_hMem)
If o_lpMem <> 0 Then
CopyMemory ByVal o_lpMem, ByVal ArrayPtr, Length
Call GlobalUnlock(o_hMem)
Call CreateStreamOnHGlobal(o_hMem, 1&, pvCreateStreamFromArray)
End If
End If
End If
HandleError:
End Function
Private Function ArrayFromStream(hStream As Long, arrayBytes() As Byte) As Boolean
' Return the array contained in an IUnknown interface (stream)
Dim o_hMem As Long, o_lpMem As Long
Dim o_lngByteCount As Long
If hStream Then
If GetHGlobalFromStream(ByVal hStream, o_hMem) = 0 Then
o_lngByteCount = GlobalSize(o_hMem)
If o_lngByteCount > 0 Then
o_lpMem = GlobalLock(o_hMem)
If o_lpMem <> 0 Then
ReDim arrayBytes(0 To o_lngByteCount - 1)
CopyMemory arrayBytes(0), ByVal o_lpMem, o_lngByteCount
GlobalUnlock o_hMem
ArrayFromStream = True
End If
End If
End If
End If
End Function
