netgiftran.ctl

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

                            'GoSub GetNextCode
                                Do While BitUsed < CurBits
                                    BitBuff = BitBuff Or (BufLZW(BufLZWPos) * BitPosMask(BitUsed)) 'TempCode |= BufLZW(BufLZWPos)<<BitBuff
                                    BufLZWPos = BufLZWPos + 1
                                    If BufLZWPos >= BufLZWSize Then GoTo DecodeEnd
                                    BitUsed = BitUsed + 8
                                Loop
                                CurCode = BitBuff And BitsMask(CurBits)
                                BitBuff = BitBuff \ BitPosMask(CurBits)
                                BitUsed = BitUsed - CurBits
                        Loop While CurCode = LZW_CLEAR
                        If CurCode >= LZW_EOI Then Debug.Print "过界," & Y: GoTo DecodeEnd
                        
                        '第一个编码
                        BufCode(0) = CurCode
                        cbBufCode = 1
                        
                    ElseIf CurCode = LZW_EOI Then
                        Exit Do
                        
                    Else
                        If OldCode = LZW_CLEAR Then
                            '不可能出现OldCode = LZW_CLEAR的情况，所以一定出错了
                            Debug.Assert False
                            GoTo DecodeEnd
                        End If
                        
                        If TableSize > TableMaxSize Then
                            '字符串表已达最大大小
                            '同时没有LZW_CLEAR
                            '无法解决字符串表问题
                            Debug.Print ">"
                            GoTo DecodeEnd
                        End If
                        
                        '解压数据
                        TempIdx = IIf(CurCode < TableSize, CurCode, OldCode)
                            'If CurCode < TableSize
                                '表示CurCode在字符串表中，所以使用CurCode
                            'Else
                                '表示CurCode不在字符串表中，只有使用OldCode
                        cbBufCode = Level(TempIdx)
                        For I = 0 To cbBufCode - 1
                            BufCode(cbBufCode - I) = StrAdd(TempIdx)
                            TempIdx = Parent(TempIdx)
                        Next I
                        If TempIdx > &HFF Then
                            GoSub DecodeEnd
                        End If
                        BufCode(0) = TempIdx '最后一个字节是节点索引本身（0~255的默认数据）
                        cbBufCode = cbBufCode + 1
                        If CurCode >= TableSize Then '不在字符串表中
                            '= +GetFirstChar(Code2Str(OldCode))
                            'GIF-LZW解码算法规定，还得加上OldCode的第一字节
                            BufCode(cbBufCode) = BufCode(0)
                            cbBufCode = cbBufCode + 1
                        End If
                        
                        '添加新节点
                        StrAdd(TableSize) = BufCode(0)
                        Parent(TableSize) = OldCode
                        Level(TableSize) = Level(OldCode) + 1
                        TableSize = TableSize + 1
                        If TableSize >= TableMaxSize Then
                            If CurBits < LZW_MaxCodeBits Then
                                CurBits = CurBits + 1
                                TableMaxSize = TableMaxSize * 2
                            End If
                        End If
                        
                    End If
                    OldCode = CurCode
                    
                    '取得下一节点
                    'GoSub GetNextCode
                        Do While BitUsed < CurBits
                            BitBuff = BitBuff Or (BufLZW(BufLZWPos) * BitPosMask(BitUsed)) 'TempCode |= BufLZW(BufLZWPos)<<BitBuff
                            BufLZWPos = BufLZWPos + 1
                            If BufLZWPos >= BufLZWSize Then GoTo DecodeEnd
                            BitUsed = BitUsed + 8
                        Loop
                        CurCode = BitBuff And BitsMask(CurBits)
                        BitBuff = BitBuff \ BitPosMask(CurBits)
                        BitUsed = BitUsed - CurBits
                    
                    '复制位图数据
                    I = 0
                    While I < cbBufCode
                        TempIdx = mBI.bmiHeader.biWidth - X
                        If cbBufCode - I >= TempIdx Then '数据不在一扫描行内
                            CopyMemory ByVal CurPtr, BufCode(I), TempIdx
                            I = I + TempIdx
                            
                            '非交错
                            Y = Y + 1
                            If Y >= mBI.bmiHeader.biHeight Then Exit Do '超过图像大小
                            ScanPtr = ScanPtr - mScanBytes
                            CurPtr = ScanPtr
                            
                            X = 0
                            
                        Else '数据在一扫描行内
                            TempIdx = cbBufCode - I
                            CopyMemory ByVal CurPtr, BufCode(I), TempIdx
                            I = I + TempIdx
                            X = X + TempIdx
                            CurPtr = CurPtr + TempIdx
                            
                            '退出“复制位图数据”循环
                            cbBufCode = 0
                            
                        End If
                    Wend
                    cbBufCode = 0
                    
                Loop
                
DecodeEnd: '编码结束
                
            End If
            
        End If
        
    End If
    
End Sub

'## 控件事件 ##############################################

Private Sub UserControl_InitProperties()
    Call pInit
    
    m_IsServer = m_def_IsServer
    m_MaxClient = m_def_MaxClient
End Sub

Private Sub UserControl_Paint()
    Dim rct As RECT
    
    With UserControl
        '-- 绘制边框
        rct.Left = 0
        rct.Top = 0
        rct.Right = .ScaleX(.ScaleWidth, .ScaleMode, vbPixels)
        rct.Bottom = .ScaleY(.ScaleHeight, .ScaleMode, vbPixels)
        Call DrawEdge(.hDC, rct, EDGE_BUMP, BF_RECT)
        
        '--绘制图标
        .PaintPicture ImgView.Picture, ImgView.Left, ImgView.Top
        
    End With
    
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    Call pInit
    
    wskMain.LocalPort = PropBag.ReadProperty("LocalPort", 0)
    wskMain.RemoteHost = PropBag.ReadProperty("RemoteHost", "")
    wskMain.RemotePort = PropBag.ReadProperty("RemotePort", 0)
    m_IsServer = PropBag.ReadProperty("IsServer", m_def_IsServer)
    m_MaxClient = PropBag.ReadProperty("MaxClient", m_def_MaxClient)
End Sub

Private Sub UserControl_Resize()
    On Error Resume Next
    
    Const SelfEdge = 4
    With UserControl
        .SIZE .ScaleX(ImgView.Width + SelfEdge * 2, .ScaleMode, vbTwips), .ScaleY(ImgView.Height + SelfEdge * 2, .ScaleMode, vbTwips)
        ImgView.Move (.ScaleWidth - ImgView.Width) / 2, (.ScaleHeight - ImgView.Height) / 2
    End With
    
End Sub

Private Sub UserControl_Terminate()
    Me.CloseConnect
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    '
    Call PropBag.WriteProperty("LocalPort", wskMain.LocalPort, 0)
    Call PropBag.WriteProperty("RemoteHost", wskMain.RemoteHost, "")
    Call PropBag.WriteProperty("RemotePort", wskMain.RemotePort, 0)
    Call PropBag.WriteProperty("IsServer", m_IsServer, m_def_IsServer)
    Call PropBag.WriteProperty("MaxClient", m_MaxClient, m_def_MaxClient)
End Sub

Private Sub WskItem_Close(Index As Integer)
    'Debug.Print "WskItem_Close["; Index; "]:"
    
    mCurClients = mCurClients - 1
    
    '清空命令流
    Call mServers(Index).CmdS.Clear
    
    '释放LZW位流对象
    Set mServers(Index).LZWS = Nothing
    
End Sub

Private Sub WskItem_Connect(Index As Integer)
    'Debug.Print "WskItem_Connect["; Index; "]:"
    'mCurClients = mCurClients + 1
End Sub

Private Sub WskItem_ConnectionRequest(Index As Integer, ByVal requestID As Long)
    'Debug.Print "WskItem_ConnectionRequest["; Index; "]:"
    
End Sub

Private Sub WskItem_DataArrival(Index As Integer, ByVal bytesTotal As Long)
    'Debug.Print "WskItem_DataArrival["; Index; "]: bytesTotal="; bytesTotal
    
    Dim tCmdR As MyCommandHeader, tCmdS As MyCommandHeader
    Dim TempBytes() As Byte
    
    '得到数据
    Call WskItem(Index).GetData(TempBytes, vbByte Or vbArray, bytesTotal)
    With mServers(Index)
        '联接位流
        Call .CmdS.AddData(TempBytes)
        
        Do While .CmdS.Count >= SizeofMyCommandHeader
            '查探数据流是否足够长度
            Call .CmdS.PeekData4Ptr(VarPtr(tCmdR), , SizeofMyCommandHeader)
            If .CmdS.Count < (SizeofMyCommandHeader + tCmdR.SIZE) Then Exit Do
            Call .CmdS.DeleteData(, SizeofMyCommandHeader)
            
            '处理数据
            '因客户机端都在wskMain处理，所以这里都是服务器端处理
            'Debug.Print "wskItem[" & Index & "]: " & "Command=" & tCmdR.Code & "," & vbTab & "Size=" & tCmdR.SIZE & "(&H" & Hex(tCmdR.SIZE) & ")"
            Select Case tCmdR.Code
            Case MyCID_Stop
                If sckClosed <> WskItem(Index).State Then WskItem(Index).Close
                
            Case MyCID_QVer
                With tCmdS
                    .Sign = MyCommandSign
                    .Code = MyCID_Ver
                    .SIZE = 2
                    ReDim TempBytes(0 To SizeofMyCommandHeader + .SIZE - 1)
                End With
                CopyMemory TempBytes(0), tCmdS, SizeofMyCommandHeader
                
                mCurVer = SoftVer
                CopyMemory TempBytes(SizeofMyCommandHeader), mCurVer, tCmdS.SIZE
                
                Call WskItem(Index).SendData(TempBytes)
                
            Case MyCID_Ver
                '（无）
                
            Case MyCID_Next
                Dim tInfo As MyImageInfo
                
                '请求图像
                RaiseEvent OnQueryPicture
                
                '压缩图像
                Call pEncode
                
                '提交压缩数据
                'Call .LZWS.Clear
                'Call .LZWS.AddData(mLZWS.Data)
                Call .LZWS.CloneFrom(mLZWS)
                
                '发送MyCID_Info
                With tCmdS
                    .Sign = MyCommandSign
                    .Code = MyCID_Info
                    .SIZE = Len(tInfo)
                    ReDim TempBytes(0 To SizeofMyCommandHeader + .SIZE - 1)
                End With
                CopyMemory TempBytes(0), tCmdS, SizeofMyCommandHeader
                
                With tInfo
                    .SizeImage = mServers(Index).LZWS.Count
                    .Width = mBI.bmiHeader.biWidth
                    .Height = mBI.bmiHeader.biHeight
                End With
                CopyMemory TempBytes(SizeofMyCommandHeader), tInfo, tCmdS.SIZE
                
                Call WskItem(Index).SendData(TempBytes)
                
            Case MyCID_Info
                '（无）
                
            Case MyCID_QData
                With tCmdS
                    .Sign = MyCommandSign
                    .Code = MyCID_Send
                    .SIZE = IIf(mServers(Index).LZWS.Count > MaxFrameSize, MaxFrameSize, mServers(Index).LZWS.Count)
                    'Debug.Print .SIZE
                    ReDim TempBytes(0 To SizeofMyCommandHeader + .SIZE - 1)
                End With
                CopyMemory TempBytes(0), tCmdS, SizeofMyCommandHeader
                
                If tCmdS.SIZE > 0 Then
                    Call .LZWS.GetData4Ptr(VarPtr(TempBytes(SizeofMyCommandHeader)), tCmdS.SIZE)
                    'Debug.Print TempBytes(SizeofMyCommandHeader)
                End If
                
                Call WskItem(Index).SendData(TempBytes)
                
            Case MyCID_Send
                '（无）
                
            End Select
            
            '删除多余数据
            Call .CmdS.DeleteData(, tCmdR.SIZE)
            
        Loop
        
    End With
    
End Sub

Private Sub WskItem_Error(Index As Integer, ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
    'Debug.Print "WskItem_Error["; Index; "]:"
    
    If sckClosed <> WskItem(Index).State Then WskItem(Index).Close
    
    MsgBox Number & vbCrLf & Description, vbCritical, "wskItem[" & Index & "]"
    
End Sub

Private Sub WskItem_SendComplete(Index As Integer)
    'Debug.Print "WskItem_SendComplete["; Index; "]:"
    
End Sub

Private Sub WskItem_SendProgress(Index As Integer, ByVal bytesSent As Long, ByVal bytesRemaining As Long)
    'Debug.Print "WskItem_SendProgress["; Index; "]:"
    
End Sub

Private Sub wskMain_Close()
    'Debug.Print "wskMain_Close:"
    
    '清空命令流
    mCmdS.Clear
    
    RaiseEvent CloseConnect
    
End Sub

Private Sub wskMain_Connect()
    'Debug.Print "wskMain_Connect:"
    
    Dim tCmdS As MyCommandHeader
    Dim TempBytes() As Byte
    
    If Me.IsServer Then
    Else
        '发送MyCID_QVer
        With tCmdS
            .Sign = MyCommandSign
            .Code = MyCID_QVer
            .SIZE = 0
            ReDim TempBytes(0 To SizeofMyCommandHeader + .SIZE - 1)
        End With
        CopyMemory TempBytes(0), tCmdS, SizeofMyCommandHeader
        Call wskMain.SendData(TempBytes)
        
    End If
    
End Sub

Private Sub wskMain_ConnectionRequest(ByVal requestID As Long)
    'Debug.Print "wskMain_ConnectionRequest:" & Hex(requestID)
    
    If Me.IsServer Then
        '## 单连结
        'If wskMain.State <> 0 Then wskMain.Close
        'wskMain.Accept requestID '允许连接请求
        
        '## 多连结
        Dim I As Long
        Dim Idx As Long
        Dim fFree As Boolean
        Dim fErr As Boolean
        
        If mCurClients >= Me.MaxClient Then Exit Sub
        
        Idx = -1
        For I = WskItem.LBound To WskItem.UBound
            On Error Resume Next
            If sckClosing = WskItem(I).State Then WskItem(I).Close
            fErr = Err.Number
            On Error GoTo 0