很多年前就想做一个远程控制的软件,只是一直以来图片的压缩速度总是提升不上去,而我也参考过很多网上的关于图片压缩的例子,比如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
完整的模块代码太长了请到我空间看
如果要测试,可以把以上代码保存成一个模块,然后创建一个新的窗体,放置一个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
'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
完整的模块代码太长了请到我空间看
如果要测试,可以把以上代码保存成一个模块,然后创建一个新的窗体,放置一个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
解决方案 »
- datagrid绑定rst后,当rst增加记录(addnew)后,datagrid不能及时更新?
- 我用VB连SQL,调用存储过程时为什么返回值为-1
- 怎么判断任何一天的前一天的日期呢 ?谢谢!
- 急!!这么简单的SQL怎么会不对?
- 如何使用listview控件读入文件夹的文件并显示系统关联的图标?
- 如何判断一个位图文件中是否有圆?
- 关于工程之间相互调用,怎么激活被调工程?
- 请教一个关于VB ACTIVEX DLL的问题
- 救命啊。。。。如何在vb中查询SQL Server7.0中的日期时间字段。。。。。!!!!!
- VB6.0中命令按鈕實現修改access數據庫中所遇見的問題
- 像这样的xml文件是否可以实现??? 谢谢
- vb6中定义变量ACtr为Control,ACtr的tag属性是如何赋值的?急在线等。非常感谢!
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
' 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 FunctionPrivate 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]
' 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
好帖就要推荐之,感谢楼主的分享。
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
' 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
不我的代码和Modest的不同请注意我的代码有这句
picStream.Seek 0, STREAM_SEEK_CUR, dwSize '获取图像大小
这个必须要用tlb。。不然我不知道怎么获取生成的JPG流的长度。PS:呵呵上首页了。第一次上首页哈。
If GetHGlobalFromStream(ByVal hStream, o_hMem) = 0 Then
o_lngByteCount = GlobalSize(o_hMem)其实获取到的只是GlobalAlloc分配的空间。。而不是真正的JPG流的长度。这个用put #1,,arrayBytes写入文件再WinHex查看下就知道了,末尾都是00 00 00...
没错啊。全屏图像压缩始终是个治标不治本的方法如果可以的话最好能找出屏幕改变的地方,然后对这些改变的地方进行压缩再处理相当于在线将屏幕录像成视频数据流传输。只是目前还比较菜,这个方法也只能从YY中实现了适量YY有益健康哈。
Server side: 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
LoopClient Side:
还原即可
但只是怕有时光标闪动、右下角的网络图标闪动这些轻微变化也会整幅屏幕传输过去。
其实对于这个问题我自己也已经有了个想法,前段时间看了hd378高人的输入法全局注入方法,http://topic.csdn.net/u/20090505/20/7989d1b6-c8c5-4602-ae1e-f627b88c7c4c.html?7237
如果修改下的话应该可以全局拦截WM_NCPAINT消息,而参考MSDN,这个消息的wParam参数是
wParam
A handle to the update region of the window. The update region is clipped to the window frame
然后再用GetUpdateRect便可获得更新区域的矩形,最后将这些矩形发送便可。
当然以上说的所有东西都还没经过验证以上仅为本人的YY。
这个。学习API的话。只能靠经验了还有经常逛MSDN。
好了结贴了。
就是改成流(stream)了,就快了?
至于远程控件,则不用考虑上面的说法,而是侧重于性能,可以从两个方面入手,一是使用256色代替24位或32位真彩色,二是采取图像缩放,三是采取区域比较和更新。
具体而言,如果屏幕设置为1024*768和32位真彩色,那么其位图数据量为1024*768*4,等于3M多,如果压缩32位真彩取为256色,则数据量为1024*768,等于768K,如果再对256色位图进行缩小,假设缩小为300*400,则数据量为300*400,等于117K,这时基本上能满足局域网内即时传输了,如果机器性能可以,还可以对图像数据进行压缩(比如行程、ZIP、GIF等),此外,还可以视情况决定是否采取区域比较和更新(如果远程主机在看电影,则这种方式不可取),基本上,最终数据量可以为20-50K,那么,这个结果在广域网上传输也是可以的。
'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 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
ReDim Buff(Picture.Width * Picture.Height \ 256) '创建缓冲区
'创建Stream
If CreateStreamOnHGlobal(Buff(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
picStream.Seek 0, STREAM_SEEK_CUR, dwSize '获取图像大小
ReDim Preserve Buff(dwSize - 1)
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 hGlobal As Long, lpBuffer As Long
'创建Stream
If CreateStreamOnHGlobal(sBuf(0), False, picStream) = 0 Then
Set ByteArrayToPicture = StreamToPicture(picStream)
Set picStream = Nothing
End If
End Function
ReDim Buff(Picture.Width * Picture.Height \ 256) '创建缓冲区......ReDim Preserve Buff(dwSize - 1)我试了 不好用使用 GlobalAlloc 创建的缓冲区 好用