netgiftran.ctl

远端荧幕传输程序,远端荧幕传输程序.rar

VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.UserControl NetGIFTran 
   CanGetFocus     =   0   'False
   ClientHeight    =   3600
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   ClipBehavior    =   0  '无
   HasDC           =   0   'False
   HitBehavior     =   0  '无
   InvisibleAtRuntime=   -1  'True
   PaletteMode     =   4  'None
   ScaleHeight     =   240
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   320
   ToolboxBitmap   =   "NetGIFTran.ctx":0000
   Begin MSWinsockLib.Winsock WskItem 
      Index           =   0
      Left            =   3840
      Top             =   1560
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
   End
   Begin MSWinsockLib.Winsock wskMain 
      Left            =   1920
      Top             =   1440
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
   End
   Begin VB.Image ImgView 
      Height          =   480
      Left            =   840
      Picture         =   "NetGIFTran.ctx":0312
      Top             =   600
      Visible         =   0   'False
      Width           =   480
   End
End
Attribute VB_Name = "NetGIFTran"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'////////////////////////////////////////////////
'## API #########################################
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

'Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
'Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (dest As Any, ByVal numBytes As Long)

Private Type BITMAPINFOHEADER '40 bytes
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type
Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type
Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors(0 To &HFF) As RGBQUAD
End Type

Private Const BI_RGB As Long = 0&


Private Declare Function GetObject Lib "gdi32.dll" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type


Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long


Private Declare Function GetDIBits Lib "gdi32.dll" (ByVal hDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As Any, ByVal wUsage As Long) As Long
Private Const DIB_RGB_COLORS As Long = 0
Private Const DIB_PAL_COLORS As Long = 1


Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long


Private Declare Function SetDIBitsToDevice Lib "gdi32.dll" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal dX As Long, ByVal dY As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As Any, ByVal wUsage As Long) As Long
Private Declare Function StretchDIBits Lib "gdi32" (ByVal hDC As Long, ByVal XDest As Long, ByVal YDest As Long, ByVal nDestWidth As Long, ByVal nDestHeight As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, lpBits As Any, lpBitsInfo As Any, ByVal wUsage As Long, ByVal dwRop As Long) As Long


Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, lpbmi As Any, ByVal iUsage As Long, ByRef ppvBits As Long, ByVal hSection As Long, ByVal dwOffset As Long) As Long



Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Declare Function DrawEdge Lib "user32" (ByVal hDC As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long

Private Const BDR_RAISEDOUTER As Long = &H1
Private Const BDR_SUNKENOUTER As Long = &H2
Private Const BDR_OUTER As Long = &H3
Private Const BDR_RAISEDINNER As Long = &H4
'private Const BDR_RAISED As Long = &H5
Private Const BDR_SUNKENINNER As Long = &H8
'private Const BDR_SUNKEN As Long = &HA
Private Const BDR_INNER As Long = &HC
Private Const EDGE_RAISED As Long = (BDR_RAISEDOUTER Or BDR_RAISEDINNER)
Private Const EDGE_ETCHED As Long = (BDR_SUNKENOUTER Or BDR_RAISEDINNER)
Private Const EDGE_BUMP As Long = (BDR_RAISEDOUTER Or BDR_SUNKENINNER)
Private Const EDGE_SUNKEN As Long = (BDR_SUNKENOUTER Or BDR_SUNKENINNER)

Private Const BF_LEFT As Long = &H1
Private Const BF_TOP As Long = &H2
Private Const BF_RIGHT As Long = &H4
Private Const BF_BOTTOM As Long = &H8
Private Const BF_DIAGONAL As Long = &H10
Private Const BF_MIDDLE As Long = &H800
Private Const BF_SOFT As Long = &H1000
Private Const BF_ADJUST As Long = &H2000
Private Const BF_FLAT As Long = &H4000
Private Const BF_MONO As Long = &H8000
Private Const BF_RECT As Long = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
Private Const BF_TOPLEFT As Long = (BF_TOP Or BF_LEFT)
Private Const BF_TOPRIGHT As Long = (BF_TOP Or BF_RIGHT)
Private Const BF_BOTTOMLEFT As Long = (BF_BOTTOM Or BF_LEFT)
Private Const BF_BOTTOMRIGHT As Long = (BF_BOTTOM Or BF_RIGHT)
Private Const BF_DIAGONAL_ENDBOTTOMLEFT As Long = (BF_DIAGONAL Or BF_BOTTOM Or BF_LEFT)
Private Const BF_DIAGONAL_ENDBOTTOMRIGHT As Long = (BF_DIAGONAL Or BF_BOTTOM Or BF_RIGHT)
Private Const BF_DIAGONAL_ENDTOPLEFT As Long = (BF_DIAGONAL Or BF_TOP Or BF_LEFT)
Private Const BF_DIAGONAL_ENDTOPRIGHT As Long = (BF_DIAGONAL Or BF_TOP Or BF_RIGHT)




'////////////////////////////////////////////////
'################################################
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

Private Const SizeofMyCommandHeader As Long = 4
Private Type MyCommandHeader
    Sign As Byte '识别标记（=MyCommandSign）
    Code As Byte '命令（eMyCommandID）
    SIZE As Integer '数据的长度（单位字节）。不可>=&H4000
End Type
Private Const MyCommandSign As Byte = &HFF

'[S/C]:服务器/客户机发送的（客户机/服务器处理指令）
'[S>C]:服务器发送的（客户机处理指令）
'[C>S]:客户机发送的（服务器处理指令）
Private Enum eMyCommandID
    MyCID_Null = 0  '[???]（保留）
    MyCID_Stop      '[S/C]结束传输                  （附加数据:0）
    MyCID_QVer      '[C>S]查询版本号                （附加数据:0）
    MyCID_Ver       '[S>C]得到版本号                （附加数据:2）
    MyCID_Next      '[C>S]提示服务器发送下一幅图片  （附加数据:0）
    MyCID_Info      '[S>C]图像数据信息              （附加数据:8）
    MyCID_QData     '[C>S]请求数据                  （附加数据:0）
    MyCID_Send      '[S>C]服务器发来图像数据        （附加数据:4+x）
End Enum

Private Const SoftVer As Integer = &H100
Private mCurVer As Integer


'MyCID_Info
Private Type MyImageInfo '8Byte
    SizeImage As Long
    Width As Integer
    Height As Integer
End Type



'~~ 处理流程 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'[C]Connect事件: 发送MyCID_QVer
'[S]发送MyCID_Ver
'[C]If 版本号正确 Then
'    [C]发送MyCID_Next
'    [S]触发OnQueryPicture事件
'    [S]压缩图像
'    [S]发送MyCID_Info
'    Do
'        [C]发送MyCID_QData
'        [S]发送MyCID_Send
'    While Until 图像压缩数据接收完毕
'    [C]发送MyCID_Next（这样可以实现并行处理）
'    [C]解压图像数据
'    [C]触发OnPictureArrival事件
'    ……
'~~ 另一种表示法 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'01.[C]>>MyCID_QVer>>[S]
'02.[C]<<MyCID_Ver<<[S]
'03.[C]判断版本号，若不能匹配则中断连结
'04.[C]>>MyCID_Next>>[S]
'06.                 [S]触发OnQueryPicture事件
'07.                 [S]压缩图像
'08.[C]<<MyCID_Info<<[S]
'09.[C]>>MyCID_QData>>[S]
'10.[C]<<MyCID_Send<<[S]
'11.[C]若数据没有接收完，则转到9
'12.[C]>>MyCID_Next>>[S]（这样可以实现并行处理）
'13.[C]解压图像数据
'14.[C]触发OnPictureArrival事件
'15.因12发送的指令，转到8


Private DitherTable(0 To &HFF) As Byte '抖动模板

Private palWeb216(0 To &HFF) As RGBQUAD

'Private Num8Bto6(0 To &HFF) As Long '\&H33
'Private Num6to8B(0 To 5) As Long    '*&H33
Private Diff8Bto6(0 To &HFF) As Long '8位数据转为6种后的误差（格式化到[0,256]区间）

Private mBI As BITMAPINFO  '位图信息
Private mScanBytes As Long '扫描行字节数
Private mMapData() As Byte '位图数据
Private mIsChangeBitmap As Boolean '图片是否改变（是否需要重新编码）

Private Const MaxFrameSize As Integer = &HF00 '最大封包大小

'Private LZWStream() As Byte 'LZW数据流
'Private LZWStreamSize As Long 'LZW数据流长度
'Private LZWStreamPos As Long '当前位置
Private mLZWS As New CByteStream
Private mImgInfo As MyImageInfo

Private Const PicColorBits As Byte = 8 '图片颜色位数
Private Const LZW_MinCodeLen As Byte = PicColorBits '最小编码单元
Private Const LZW_MaxCodeBits As Long = 12 'GIF-LZW最大编码长度


'################################################
'################################################
'################################################
Private mInited As Boolean

Private bClosing As Boolean '正在关闭
Private bDecode As Boolean '准备解码

Private mCurClients As Long

'Private DataStream() As Byte '数据流
'Private DataStreamSize As Long '数据流长度

Private mCmdS As New CByteStream '命令数据流

Private Type ServerData
    CmdS As CByteStream
    LZWS As CByteStream
End Type
Private mServers() As ServerData

Public Event CloseConnect() '关闭连结

Public Event OnQueryPicture()   '[S]请求新的图片
Public Event OnPictureArrival() '[C]图片已经接收

'缺省属性值:
Const m_def_MaxClient = 100
Const m_def_IsServer = False
'属性变量:
Dim m_MaxClient As Long
Private m_IsServer As Boolean

'## 内部函数 ##############################################

Private Sub pInit()
    If mInited Then Exit Sub
    mInited = True
    
    Debug.Print
    Debug.Print String(60, "=")
    
    Call mBit.Init
    
    mCurVer = SoftVer
    mCurClients = 0
    ReDim mServers(WskItem.LBound To WskItem.UBound)
    'Debug.Print "Init"
    
    Dim TempArr As Variant
    Dim I As Long, J As Long, K As Long
    Dim Idx As Long
    
    TempArr = Array(0, 235, 59, 219, 15, 231, 55, 215, 2, 232, 56, 217, 12, 229, 52, 213, _
            128, 64, 187, 123, 143, 79, 183, 119, 130, 66, 184, 120, 140, 76, 180, 116, _
            33, 192, 16, 251, 47, 207, 31, 247, 34, 194, 18, 248, 44, 204, 28, 244, _
            161, 97, 144, 80, 175, 111, 159, 95, 162, 98, 146, 82, 172, 108, 156, 92, _
            8, 225, 48, 208, 5, 239, 63, 223, 10, 226, 50, 210, 6, 236, 60, 220, _
            136, 72, 176, 112, 133, 69, 191, 127, 138, 74, 178, 114, 134, 70, 188, 124, _
            41, 200, 24, 240, 36, 197, 20, 255, 42, 202, 26, 242, 38, 198, 22, 252, _
            169, 105, 152, 88, 164, 100, 148, 84, 170, 106, 154, 90, 166, 102, 150, 86, _
            3, 233, 57, 216, 13, 228, 53, 212, 1, 234, 58, 218, 14, 230, 54, 214, _
            131, 67, 185, 121, 141, 77, 181, 117, 129, 65, 186, 122, 142, 78, 182, 118, _
            35, 195, 19, 249, 45, 205, 29, 245, 32, 193, 17, 250, 46, 206, 30, 246, _
            163, 99, 147, 83, 173, 109, 157, 93, 160, 96, 145, 81, 174, 110, 158, 94, _
            11, 227, 51, 211, 7, 237, 61, 221, 9, 224, 49, 209, 4, 238, 62, 222, _
            139, 75, 179, 115, 135, 71, 189, 125, 137, 73, 177, 113, 132, 68, 190, 126, _
            43, 203, 27, 243, 39, 199, 23, 253, 40, 201, 25, 241, 37, 196, 21, 254, _
            171, 107, 155, 91, 167, 103, 151, 87, 168, 104, 153, 89, 165, 101, 149, 85)
    For I = 0 To &HFF
        DitherTable(I) = TempArr(I)
    Next I
    
    For I = 0 To 5 'Blue
        For J = 0 To 5 'Green
            For K = 0 To 5 'Red
                Idx = (I * 6 + J) * 6 + K
                palWeb216(Idx).rgbRed = K * &H33
                palWeb216(Idx).rgbGreen = J * &H33
                palWeb216(Idx).rgbBlue = I * &H33
            Next K
        Next J
    Next I
    
    With mBI.bmiHeader
        .biSize = Len(mBI.bmiHeader)
        .biWidth = 0
        .biHeight = 0
        .biBitCount = PicColorBits
        .biPlanes = 1
        .biCompression = BI_RGB
        mScanBytes = 0
        .biSizeImage = mScanBytes * .biHeight
        .biXPelsPerMeter = 0
        .biYPelsPerMeter = 0
        .biClrUsed = 0
        .biClrImportant = 0
    End With
    CopyMemory mBI.bmiColors(0), palWeb216(0), &H100 * 4
    
    For I = 0 To &HFF
        Diff8Bto6(I) = ((I - (I \ &H33) * &H33) * &H100 + (&H33 \ 2)) \ &H33
    Next I
    
End Sub

'设置位图
Private Function pSetBitmap(ByVal hDC As Long, _
        ByVal X As Long, ByVal Y As Long, _
        ByVal Width As Long, ByVal Height As Long) As Boolean
    If Width <= 0 Or Height <= 0 Then Exit Function
    
    Dim Rc As Boolean
    
    Dim SrcBI As BITMAPINFOHEADER
    Dim ScanBytes As Long
    Dim pSrcDIB As Long
    Dim hSrcDIB As Long
    Dim hDCDIB As Long
    Dim hOldMap As Long
    
    hDCDIB = CreateCompatibleDC(hDC)
    If hDCDIB Then
        With SrcBI
            .biSize = Len(SrcBI)
            .biWidth = Width
            .biHeight = Height
            .biBitCount = 24
            .biPlanes = 1
            .biCompression = BI_RGB
            ScanBytes = (.biWidth * 3 + 3) And &H7FFFFFFC
            .biSizeImage = ScanBytes * .biHeight
            .biXPelsPerMeter = 0