读书人
栏目▼

GDI+ IStream、StdPicture、Byte() 互

发布时间： 2012-02-06 15:52:44 作者： rapoo

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的内容了，具体代码如下：

VB code
'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，具体代码如下：
VB code
'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，粘贴以下代码：
VB code
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


[解决办法]
好，支持分享。
[解决办法]
VB code
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
[解决办法]
顶
[解决办法]
根本不需要引用那个tlb，直接定义As stdole.IUnknown


[解决办法]
根本不需要引用那个tlb，直接定义As stdole.IUnknown 
VB code
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 FunctionPrivate 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 FunctionPrivate 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 
 
[解决办法]
探讨
根本不需要引用那个tlb，直接定义As stdole.IUnknown



[解决办法]
'Revised

VB code
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 FunctionPrivate 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&, CreateStreamFromArray)            End If        End If    End If    HandleError:End FunctionPrivate 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
[解决办法]
'Revised

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&, CreateStreamFromArray)
           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

[解决办法]
gz
[解决办法]
正在找这个，谢谢啦！
[解决办法]
远程控制用JPG流在广域网上基本不太可能具有很大的实用性，除非双方的机器配置一流网络速度也一流。

是不管你用什么库也好，JPG压缩和解压终究是个耗时的工作。
[解决办法]
默默地走过，支持！
[解决办法]
SF
[解决办法]
直接传个工程 看看不就行了
[解决办法]
顶了慢慢看…………
[解决办法]
顶了慢慢看…………
[解决办法]
探讨
顶了慢慢看…………

[解决办法]
好样的程序！
顶一把！
[解决办法]
mark
[解决办法]
这类的程序其实要这样做：（Just idea)
Server side:
VB code
  DTHwnd = GetDesktopWindow()  DTHdc = GetDC(DeskHwnd)  Ret = GetWindowRect(DTHwnd , DTRect)    '### create 16 clolored DIB or 24 or 32bpp DIB取决于要求质量    DIB.Colors = 16    '将Screen分成若干份例如 5x5    Call DIB.Create(DTRect.Right / 5, DTRect.Bottom / 5)Do Until ENDE        For yPos = 0 To DTRect.Bottom Step (DTRect.Bottom / 5)            For xPos = 0 To DTRect.Right Step (DTRect.Right / 5)                    '### blit actual part of the desktop into DIB                    Ret = BitBlt(DIB.hdc, 0, 0, DTRect.Right / 5, DTRect.Bottom / 5, DTHdc, xPos, yPos, SRCCOPY)                    Call DIB.ToByte(ByteArray)                    '### 用Zlib或者其它compress the array                    Call ZLib.CompressByte(ByteArray)                    '### save the checksum 用CRC结果进行比较，如果相同就不送，这样就节省很多带宽！！！                    CS_Tmp = calcCRC32(ByteArray)                    '### if the part is different to the last-> send the data                    If CS_Tmp <> CS(K) Then                        CS(K) = CS_Tmp                        On Error GoTo NoConn                        '### first send the actual position                        frmCapture.TCP_Set.SendData CStr(xPos) & ";" & CStr(yPos)                        '### wait for response                        Do Until C_Set_Response                            DoEvents                        Loop                        C_Set_Response = False                        '### send data                        frmCapture.TCP.SendData ByteArray                        '### wait for response                        Do Until C_Response                            DoEvents                        Loop                        C_Response = False                        On Error GoTo 0                    End If                    '### next part of the desktop...                    K = K + 1                    DoEvents            Next xPos        Next yPos        '### begin at pos (0,0)        xPos = 0        yPos = 0                K = 0        '### one frame made        Q = Q + 1    Loop 
 
[解决办法]
哇！果然是高质量的帖子啊！高手云集！学习innnnnnnng
[解决办法]
211111111111111
[解决办法]
强力插入.................
[解决办法]
学习了

[解决办法]
ding 

[解决办法]
不懂图像处理的路过顶下...
[解决办法]
我记得以前有一份vb的远程桌面连接代码，可惜速度不太理想
如果是捕获全屏发送的话，速度和占用资源肯定是不行，还是
得直接发送修改了的地方这样才是比较好的一种方法。
[解决办法]
探讨
引用:
远程控制用JPG流在广域网上基本不太可能具有很大的实用性，除非双方的机器配置一流网络速度也一流。

是不管你用什么库也好，JPG压缩和解压终究是个耗时的工作。


没错啊。。。。全屏图像压缩始终是个治标不治本的方法。。。如果可以的话最好能找出屏幕改变的地方，然后对这些改变的地方进行压缩再处理。。。相当于在线将屏幕录像成视频数据流传输。。。。只是目前还比较菜，这个方法也只能从YY中实现了。。。适量YY有益健康哈。。。。

[解决办法]
学习了，不错。。。。
读书人网 >VB

热点推荐

触屏版 | 电脑版

读书人网 m.reader8.net