diff --git a/src/cVncServer.cls b/src/cVncServer.cls index a35ad17..6774e26 100644 --- a/src/cVncServer.cls +++ b/src/cVncServer.cls @@ -31,6 +31,8 @@ Private Const MODULE_NAME As String = "cVncServer" #Const ImplUseDebugLog = (USE_DEBUG_LOG <> 0) #Const ImplUseShared = (VNC_USESHARED <> 0) +Public Event OnTextChatMsg(ByVal ConnID As Long, ByVal MsgType As Long, ByVal MsgText As String) + '========================================================================= ' API '========================================================================= @@ -250,6 +252,7 @@ Private Enum RfbMessageEnum rfbMsgServerCutText = 3 '--- bidirectional rfbMsgFileTransfer = 7 + rfbMsgTextChat = 11 rfbMsgSetDesktopSize = 251 rfbMsgTightFileTransfer = 252 ' &HFC '--- tight file transfer @@ -502,6 +505,15 @@ Private Type RfbTightCapability End Type Private Const sizeof_RfbTightCapability As Long = 16 +Private Type RfbTextChatMsg + MessageType As Byte + Pad1 As Byte + Pad2 As Integer + Length As Long + Text As String +End Type +Private Const sizeof_RfbTextChatMsg As Long = 8 + '========================================================================= ' Constants and member variables '========================================================================= @@ -519,7 +531,9 @@ End Enum Private Enum UcsSendChannelEnum ucsChaFrame ucsChaFtp - [_ucsChaMax] + ucsChaChat + [_] + ucsChaMax = [_] - 1 End Enum Private Const STR_APP_NAME As String = "VbVncServer" @@ -546,7 +560,7 @@ Private m_eState As UcsProtocolStateEnum Private WithEvents m_oSocket As cAsyncSocket Attribute m_oSocket.VB_VarHelpID = -1 Private m_uRecvBuffer As UcsBuffer -Private m_uSendBuffer(0 To [_ucsChaMax] - 1) As UcsBuffer +Private m_uSendBuffer(0 To ucsChaMax) As UcsBuffer Private m_eSecurityType As RfbSecurityTypeEnum Private m_baSecurityChallenge() As Byte Private m_uClientPixelFormat As RfbClientSetPixelFormat @@ -698,7 +712,7 @@ Private Property Get pvFirstPendingChannel() As UcsSendChannelEnum Dim eChannel As UcsSendChannelEnum pvFirstPendingChannel = -1 - For eChannel = 0 To [_ucsChaMax] - 1 + For eChannel = 0 To ucsChaMax If m_uSendBuffer(eChannel).Size > m_uSendBuffer(eChannel).Pos Then pvFirstPendingChannel = eChannel Exit For @@ -737,6 +751,27 @@ Public Function Init(Optional ListenAddress As String, Optional ByVal ListenPort QH: End Function +Public Function TextChatMsg(ByVal ConnID As Long, MsgText As String) As Boolean + Dim oConn As cVncServer + + If m_cConnections Is Nothing Then + If Not pvSendTextChatMsg(m_uSendBuffer(ucsChaChat), MsgText) Then + GoTo QH + End If + Else + For Each oConn In m_cConnections + If ObjPtr(oConn) = ConnID Then + If Not oConn.TextChatMsg(0, MsgText) Then + GoTo QH + End If + End If + Next + End If + '--- success + TextChatMsg = True +QH: +End Function + Friend Function frNewConnection(oSocket As cAsyncSocket, oParent As cVncServer) As Boolean Const WINCODEC_SDK_VERSION1 As Long = &H236& Const WINCODEC_SDK_VERSION2 As Long = &H237& @@ -976,6 +1011,14 @@ Private Function pvSendPointerPosition(uOutput As UcsBuffer, ByVal lLeft As Long pvSendPointerPosition = pvBufferSendAsync(uOutput) End Function +Private Function pvSendTextChatMsg(uOutput As UcsBuffer, MsgText As String) As Boolean + pvBufferWriteLong uOutput, rfbMsgTextChat + pvBufferWriteLong uOutput, 0, Size:=3 + pvBufferWriteUtf8 uOutput, MsgText + '--- success (or failure) + pvSendTextChatMsg = pvBufferSendAsync(uOutput) +End Function + Private Sub pvHandleReceive(uOutput As UcsBuffer) Const FUNC_NAME As String = "pvHandleReceive" Const SecurityResultOk As Long = 0 @@ -1129,6 +1172,7 @@ Private Function pvHandleClientMessage(uInput As UcsBuffer) As Boolean Dim baData() As Byte Dim uTightTransfer As UcsTightTransfer Dim lSize As Long + Dim uTextChatMsg As RfbTextChatMsg On Error GoTo EH With uInput @@ -1244,13 +1288,34 @@ Private Function pvHandleClientMessage(uInput As UcsBuffer) As Boolean If .Size - .Pos < sizeof_RfbClientCutText + m_uClientCutText.Length Then GoTo QH End If - pvArrayAllocate m_uClientCutText.Text, m_uClientCutText.Length, FUNC_NAME + pvArrayAllocate m_uClientCutText.Text, m_uClientCutText.Length, FUNC_NAME & ".m_uClientCutText.Text" Call CopyMemory(m_uClientCutText.Text(0), .Data(.Pos + sizeof_RfbClientCutText), m_uClientCutText.Length) End If .Pos = .Pos + sizeof_RfbClientCutText + m_uClientCutText.Length If Not pvHandleCutEvent(m_uClientCutText) Then GoTo QH End If + Case rfbMsgTextChat + If .Size - .Pos < sizeof_RfbTextChatMsg Then + GoTo QH + End If + Call CopyMemory(uTextChatMsg, .Data(.Pos), sizeof_RfbClientCutText) + With uTextChatMsg + .Length = pvNetworkLong(.Length) + End With + If uTextChatMsg.Length > 0 Then + If .Size - .Pos < sizeof_RfbTextChatMsg + uTextChatMsg.Length Then + GoTo QH + End If + .Pos = .Pos + sizeof_RfbTextChatMsg - 4 + pvBufferReadUtf8 uInput, uTextChatMsg.Text + Else + .Pos = .Pos + sizeof_RfbTextChatMsg + uTextChatMsg.Text = vbNullString + End If + If Not pvHandleTextChatMsg(uTextChatMsg) Then + GoTo QH + End If Case rfbMsgFileTransfer If .Size - .Pos < sizeof_RfbFileTransfer Then GoTo QH @@ -1576,6 +1641,27 @@ EH: PrintError FUNC_NAME End Function +Private Function pvHandleTextChatMsg(uEvent As RfbTextChatMsg) As Boolean + Const FUNC_NAME As String = "pvHandleTextChatMsg" + + On Error GoTo EH + If uEvent.Length < 0 Then + pvParent.frFireOnTextChatMsg Me, -uEvent.Length + Else + pvParent.frFireOnTextChatMsg Me, 0, uEvent.Text + End If + '--- success + pvHandleTextChatMsg = True + Exit Function +EH: + PrintError FUNC_NAME + Resume Next +End Function + +Friend Sub frFireOnTextChatMsg(oConn As cVncServer, ByVal MsgType As Long, Optional MsgText As String) + RaiseEvent OnTextChatMsg(ObjPtr(oConn), MsgType, MsgText) +End Sub + '= file transfer ========================================================= Private Function pvSendFileTransfer( _ @@ -2609,15 +2695,17 @@ Private Function pvCaptureSend(uFrame As UcsCaptureFrame, uOutput As UcsBuffer) End Select End If '--- send desktop + lBufferSize = m_oSocket.SockOpt(ucsSsoSendBuffer) If pvHasSupport(rfbEncCopyRect) Then lSize = uFrame.NumMoveRects End If - lBufferSize = m_oSocket.SockOpt(ucsSsoSendBuffer) - With uUpdate - .MessageType = rfbMsgFramebufferUpdate - .NumberOfRectangles = pvNetworkShort(lSize + uFrame.NumTiles) - End With - pvBufferWriteBlob uOutput, VarPtr(uUpdate), sizeof_RfbServerFramebufferUpdate + If lSize + uFrame.NumTiles <> 0 Then + With uUpdate + .MessageType = rfbMsgFramebufferUpdate + .NumberOfRectangles = pvNetworkShort(lSize + uFrame.NumTiles) + End With + pvBufferWriteBlob uOutput, VarPtr(uUpdate), sizeof_RfbServerFramebufferUpdate + End If For lIdx = 0 To lSize - 1 With .MoveRects(lIdx).DestinationRect uRectangle.XPosition = pvNetworkShort(.Left) @@ -2765,8 +2853,10 @@ Private Function pvCaptureSend(uFrame As UcsCaptureFrame, uOutput As UcsBuffer) #End If End If #If ImplUseDebugLog Then - If lIdx <= Form1.labDebug.UBound Then - Form1.labDebug(lIdx).Caption = sDebugInfo + If Not DebugForm Is Nothing Then + If lIdx <= DebugForm.labDebug.UBound Then + DebugForm.labDebug(lIdx).Caption = sDebugInfo + End If End If #End If If uOutput.Size > uOutput.Pos + lBufferSize Then @@ -2789,9 +2879,11 @@ Private Function pvCaptureSend(uFrame As UcsCaptureFrame, uOutput As UcsBuffer) End If Next #If ImplUseDebugLog Then - For lIdx = .NumTiles To Form1.labDebug.UBound - Form1.labDebug(lIdx).Caption = vbNullString - Next + If Not DebugForm Is Nothing Then + For lIdx = .NumTiles To DebugForm.labDebug.UBound + DebugForm.labDebug(lIdx).Caption = vbNullString + Next + End If #End If End With If Not m_oSocket.HasPendingEvent Then @@ -3195,7 +3287,7 @@ Private Function pvBufferSendAsync(uOutput As UcsBuffer) As Boolean Dim lBufferSize As Long On Error GoTo EH - For eChannel = 0 To [_ucsChaMax] - 1 + For eChannel = 0 To ucsChaMax If VarPtr(m_uSendBuffer(eChannel)) = VarPtr(uOutput) Then Exit For End If @@ -3504,7 +3596,7 @@ Private Function PathCombine(sPath As String, sFile As String) As String PathCombine = sPath & IIf(LenB(sPath) <> 0 And Right$(sPath, 1) <> "\" And LenB(sFile) <> 0, "\", vbNullString) & sFile End Function -Public Property Get At(vData As Variant, ByVal lIdx As Long, Optional sDefault As String) As String +Private Property Get At(vData As Variant, ByVal lIdx As Long, Optional sDefault As String) As String On Error GoTo QH At = sDefault If IsArray(vData) Then @@ -3611,7 +3703,7 @@ End Sub '========================================================================= #If Not ImplUseShared Then -Public Function InitAddressOfMethod(pObj As Object, ByVal MethodParamCount As Long) As Object +Private Function InitAddressOfMethod(pObj As Object, ByVal MethodParamCount As Long) As Object Dim STR_THUNK As String: STR_THUNK = "6AAAAABag+oFV4v6ge9QEMEAgcekEcEAuP9EJAS5+QcAAPOri8LB4AgFuQAAAKuLwsHoGAUAjYEAq7gIAAArq7hEJASLq7hJCIsEq7iBi1Qkq4tEJAzB4AIFCIkCM6uLRCQMweASBcDCCACriTrHQgQBAAAAi0QkCIsAiUIIi0QkEIlCDIHqUBDBAIvCBTwRwQCri8IFUBHBAKuLwgVgEcEAq4vCBYQRwQCri8IFjBHBAKuLwgWUEcEAq4vCBZwRwQCri8IFpBHBALn5BwAAq4PABOL6i8dfgcJQEMEAi0wkEIkRK8LCEAAPHwCLVCQE/0IEi0QkDIkQM8DCDABmkItUJAT/QgSLQgTCBAAPHwCLVCQE/0oEi0IEg/gAfgPCBABZWotCDGgAgAAAagBSUf/gZpC4AUAAgMIIALgBQACAwhAAuAFAAIDCGAC4AUAAgMIkAA==" ' 25.3.2019 14:01:08 Const THUNK_SIZE As Long = 16728 Dim hThunk As Long @@ -3625,7 +3717,7 @@ Public Function InitAddressOfMethod(pObj As Object, ByVal MethodParamCount As Lo Debug.Assert lSize = THUNK_SIZE End Function -Public Function InitFireOnceTimerThunk(pObj As Object, ByVal pfnCallback As Long, Optional Delay As Long) As IUnknown +Private Function InitFireOnceTimerThunk(pObj As Object, ByVal pfnCallback As Long, Optional Delay As Long) As IUnknown Dim STR_THUNK As String: STR_THUNK = "6AAAAABag+oFgeogEQUAV1aLdCQUg8YIgz4AdCqL+oHHDBMFAIvCBSgSBQCri8IFZBIFAKuLwgV0EgUAqzPAq7kIAAAA86WBwgwTBQBSahj/UhBai/iLwqu4AQAAAKszwKuri3QkFKWlg+8Yi0IMSCX/AAAAUItKDDsMJHULWIsPV/9RFDP/62P/QgyBYgz/AAAAjQTKjQTIjUyIMIB5EwB101jHAf80JLiJeQTHQQiJRCQEi8ItDBMFAAWgEgUAUMHgCAW4AAAAiUEMWMHoGAUA/+CQiUEQiU8MUf90JBRqAGoAiw//URiJRwiLRCQYiTheX7g8EwUALSARBQAFABQAAMIQAGaQi0QkCIM4AHUqg3gEAHUkgXgIwAAAAHUbgXgMAAAARnUSi1QkBP9CBItEJAyJEDPAwgwAuAJAAIDCDACQi1QkBP9CBItCBMIEAA8fAItUJAT/SgSLQgR1HYtCDMZAEwCLCv9yCGoA/1Eci1QkBIsKUv9RFDPAwgQAi1QkBItCEIXAdFuLCotBKIXAdCdS/9Bag/gBd0mLClL/USxahcB1PosKUmrw/3Eg/1EkWqkAAAAIdSuLClL/cghqAP9RHFr/QgQzwFBU/3IQ/1IUi1QkCMdCCAAAAABS6G////9YwhQADx8AjURAAQ==" ' 13.5.2020 18:59:12 Const THUNK_SIZE As Long = 5660 Static hThunk As Long diff --git a/test/Form1.frm b/test/Form1.frm index fb8df08..baede35 100644 --- a/test/Form1.frm +++ b/test/Form1.frm @@ -48,7 +48,8 @@ Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit -Private m_oServer As cVncServer +Private WithEvents m_oServer As cVncServer +Attribute m_oServer.VB_VarHelpID = -1 Private Sub Form_Load() Const DEF_PASSWORD As String = "0000" @@ -71,4 +72,17 @@ Private Sub Form_Load() Label1.Caption = "Waiting for connection on " & sAddress & ":" & lPort & _ IIf(LenB(m_oServer.Password) <> 0, " (password: " & m_oServer.Password & ")", vbNullString) End If + Set DebugForm = Me +End Sub + +Private Sub Form_Unload(Cancel As Integer) + Set DebugForm = Nothing +End Sub + +Private Sub m_oServer_OnTextChatMsg(ByVal ConnID As Long, ByVal MsgType As Long, ByVal MsgText As String) + If MsgType = 1 Then + With New Form2 + .Init m_oServer, ConnID + End With + End If End Sub diff --git a/test/Form2.frm b/test/Form2.frm new file mode 100644 index 0000000..667183a --- /dev/null +++ b/test/Form2.frm @@ -0,0 +1,103 @@ +VERSION 5.00 +Begin VB.Form Form2 + Caption = "Text Chat" + ClientHeight = 4428 + ClientLeft = 108 + ClientTop = 456 + ClientWidth = 6828 + LinkTopic = "Form2" + ScaleHeight = 4428 + ScaleWidth = 6828 + StartUpPosition = 3 'Windows Default + Begin VB.TextBox Text2 + BeginProperty Font + Name = "Segoe UI" + Size = 9 + Charset = 204 + Weight = 400 + Underline = 0 'False + Italic = 0 'False + Strikethrough = 0 'False + EndProperty + Height = 432 + Left = 504 + TabIndex = 0 + Top = 3864 + Width = 5220 + End + Begin VB.TextBox Text1 + BeginProperty Font + Name = "Segoe UI" + Size = 9 + Charset = 204 + Weight = 400 + Underline = 0 'False + Italic = 0 'False + Strikethrough = 0 'False + EndProperty + Height = 2952 + Left = 168 + MultiLine = -1 'True + ScrollBars = 2 'Vertical + TabIndex = 1 + TabStop = 0 'False + Top = 168 + Width = 5472 + End +End +Attribute VB_Name = "Form2" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +Option Explicit + +Private WithEvents m_oServer As cVncServer +Attribute m_oServer.VB_VarHelpID = -1 +Private m_lConnID As Long + +Public Function Init(oServer As cVncServer, ByVal ConnID As Long) + Set m_oServer = oServer + m_lConnID = ConnID + Show +End Function + +Private Sub pvAppendText(ByVal sText As String) + With Text1 + .SelStart = &H7FFF + If .SelStart + Len(sText) > &H7FFF& Then + sText = .Text & sText + .Text = Mid$(sText, InStr(Len(sText) - &H8001&, sText, vbCrLf) + 2) + Else + .SelText = sText + End If + .SelStart = &H7FFF + End With +End Sub + +Private Sub m_oServer_OnTextChatMsg(ByVal ConnID As Long, ByVal MsgType As Long, ByVal MsgText As String) + If ConnID = m_lConnID Then + If MsgType = 0 Then + pvAppendText m_lConnID & ": " & MsgText + ElseIf MsgType = 2 Then + Unload Me + End If + End If +End Sub + +Private Sub Text2_KeyPress(KeyAscii As Integer) + If KeyAscii = 13 Then + If m_oServer.TextChatMsg(m_lConnID, Text2.Text & vbCrLf) Then + pvAppendText "Me: " & Text2.Text & vbCrLf + Text2.Text = vbNullString + End If + KeyAscii = 0 + End If +End Sub + +Private Sub Form_Resize() + If WindowState <> vbMinimized Then + Text2.Move 30, ScaleHeight - Text2.Height - 30, ScaleWidth - 60 + Text1.Move 0, 0, ScaleWidth, Text2.Top - 60 + End If +End Sub diff --git a/test/VbVncServer.vbp b/test/VbVncServer.vbp index 22d6e09..177ea93 100644 --- a/test/VbVncServer.vbp +++ b/test/VbVncServer.vbp @@ -1,11 +1,12 @@ Type=Exe Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#..\..\..\..\Windows\SysWOW64\stdole2.tlb#OLE Automation -Reference=*\G{79C9E228-0732-4C1A-925D-9EF1A6CDE1FF}#1.0#0#..\..\VBD3D11\typelib\VBD3D11.tlb#DirectX 11 for VB6 1.0 (wqweto@gmail.com) +Reference=*\G{79C9E228-0732-4C1A-925D-9EF1A6CDE1FF}#1.0#0#..\..\..\Dreem\1.5\Bin\VBD3D11.tlb#DirectX 11 for VB6 1.0 (wqweto@gmail.com) Form=Form1.frm Class=cVncServer; ..\src\cVncServer.cls Class=cAsyncSocket; ..\lib\VbAsyncSocket\src\cAsyncSocket.cls Module=mdGlobals; mdGlobals.bas Class=cZipArchive; ..\lib\ZipArchive\src\cZipArchive.cls +Form=Form2.frm IconForm="Form1" Startup="Form1" HelpFile="" @@ -17,7 +18,7 @@ HelpContextID="0" CompatibleMode="0" MajorVer=0 MinorVer=0 -RevisionVer=6 +RevisionVer=8 AutoIncrementVer=0 ServerSupportFiles=0 VersionCompanyName="Unicontsoft" diff --git a/test/mdGlobals.bas b/test/mdGlobals.bas index d771d53..284a296 100644 --- a/test/mdGlobals.bas +++ b/test/mdGlobals.bas @@ -6,6 +6,8 @@ Private Declare Function IsBadReadPtr Lib "kernel32" (ByVal lp As Long, ByVal uc Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long +Public DebugForm As Form1 + Public Function DesignDumpArray(baData() As Byte, Optional ByVal Pos As Long, Optional ByVal Size As Long = -1) As String If Size < 0 Then Size = UBound(baData) + 1 - Pos