// Обработчики клавиатуры для полноэкранной формы
FFullScreenForm.OnKeyDown := @FormKeyDown;
FFullScreenForm.OnKeyUp := @FormKeyUp;
FFullScreenForm.Show;
FFullScreenMode := True;
Button3.Caption := 'Exit Fullscreen';
SafeLog('Полноэкранный режим включен. Используйте Ctrl+F или Escape для выхода.');
end
else
begin
// Закрываю полноэкранную форму
if Assigned(FFullScreenForm) then
begin
FFullScreenForm.Close;
FFullScreenForm := nil;
end;
FFullScreenMode := False;
Button3.Caption := 'Fullscreen';
SafeLog('Полноэкранный режим выключен');
end;
except
on E: Exception do
SafeLog('Ошибка в Button3Click: ' + E.Message);
end;
end;
procedure TForm1.PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
ButtonMask: Byte;
ActualX, ActualY: Integer;
begin
try
ButtonMask := 0;
if Button = mbLeft then ButtonMask := 1
else if Button = mbRight then ButtonMask := 2
else if Button = mbMiddle then ButtonMask := 4;
// Преобразую координаты с учетом масштабирования в полноэкранном режиме
if FFullScreenMode then
begin
ActualX := Round(X * FScreenWidth / PaintBox1.Width);
ActualY := Round(Y * FScreenHeight / PaintBox1.Height);
end
else
begin
ActualX := X;
ActualY := Y;
end;
SendMouseEvent(ActualX, ActualY, ButtonMask);
except
on E: Exception do
SafeLog('Ошибка в PaintBox1MouseDown: ' + E.Message);
end;
end;
procedure TForm1.PaintBox1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
ActualX, ActualY: Integer;
begin
try
// Преобразую координаты с учетом маштабирования в полноэкранном режиме
if FFullScreenMode then
begin
ActualX := Round(X * FScreenWidth / PaintBox1.Width);
ActualY := Round(Y * FScreenHeight / PaintBox1.Height);
end
else
begin
ActualX := X;
ActualY := Y;
end;
SendMouseEvent(ActualX, ActualY, 0);
except
on E: Exception do
SafeLog('Ошибка в PaintBox1MouseUp: ' + E.Message);
end;
end;
procedure TForm1.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
// ОТПРАВЛЯЕМ СРАЗУ, но с проверкой частоты внутри SendMouseCoords
if FConnected then
SendMouseCoords(X, Y, 0);
end;
procedure TForm1.SendMouseCoords(X, Y: Integer; ButtonMask: Byte);
var
Buffer: array[0..5] of Byte;
CurrentTime: DWORD;
TimeDiff: DWORD;
const
MIN_MOUSE_DELAY = 100;
begin
CurrentTime := GetTickCount;
if CurrentTime >= FLastUpdateTime then
TimeDiff := CurrentTime - FLastUpdateTime
else
TimeDiff := MAXDWORD - FLastUpdateTime + CurrentTime;
if TimeDiff < MIN_MOUSE_DELAY then
Exit;
FLastUpdateTime := CurrentTime;
if (X < 0) or (Y < 0) or (X >= FRemoteWidth) or (Y >= FRemoteHeight) then
Exit;
Buffer[0] := $02;
Buffer[1] := ButtonMask;
PWord(@Buffer[2])^ := Word(X);
PWord(@Buffer[4])^ := Word(Y);
send(FRelaySocket, Buffer, SizeOf(Buffer), 0);
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
try
if FConnected then
begin
SafeLog('Timer: запрашиваем обновление');
RequestUpdate;
end;
except
on E: Exception do
begin
SafeLog('Ошибка в Timer1Timer: ' + E.Message);
Timer1.Enabled := False;
end;
end;
end;
procedure TForm1.RadioGroup1Click(Sender: TObject);
begin
FConnectionMode := TConnectionMode(RadioGroup1.ItemIndex);
if FConnectionMode = cmDirect then
begin
Edit1.Enabled := True;
Edit2.Enabled := True;
Edit3.Enabled := False;
Label8.Caption := 'Connection: Direct';
end
else
begin
Edit1.Enabled := False;
Edit2.Enabled := False;
Edit3.Enabled := True;
Label8.Caption := 'Connection: Via Relay';
end;
SafeLog('Changed connection mode to: ' + IntToStr(Ord(FConnectionMode)));
end;
procedure TForm1.SafeLog(const Msg: string);
var
TimeStr: string;
FullMsg: string;
begin
try
TimeStr := FormatDateTime('hh:nn:ss', Now);
FullMsg := '[' + TimeStr + '] ' + Msg;
if Assigned(Memo1) then
begin
Memo1.Lines.Add(FullMsg);
while Memo1.Lines.Count > 50 do
Memo1.Lines.Delete(0);
Application.ProcessMessages;
end;
if FLogOpened then
begin
WriteLn(FLogFile, FullMsg);
Flush(FLogFile);
end;
except
end;
end;
procedure TForm1.ConnectToServer;
var
ServerAddr: TSockAddrIn;
ServerIP: string;
ServerPort: Integer;
SocketBufferSize: Integer;
OptLen: Integer;
begin
if FConnected then Exit;
try
ServerIP := Edit1.Text;
ServerPort := StrToIntDef(Edit2.Text, VNC_PORT);
SafeLog('Подключаемся напрямую к ' + ServerIP + ':' + IntToStr(ServerPort));
if ServerIP = '' then
begin
ShowMessage('Enter server IP address');
Exit;
end;
SetStatus('Connecting to server...');
FSocket := socket(AF_INET, SOCK_STREAM, IPPROTO_TCP);
if FSocket = INVALID_SOCKET then
begin
SafeLog('Ошибка создания сокета: ' + IntToStr(WSAGetLastError));
raise Exception.Create('Failed to create socket');
end;
SocketBufferSize := 1024 * 1024;
OptLen := SizeOf(SocketBufferSize);
if setsockopt(FSocket, SOL_SOCKET, SO_RCVBUF, @SocketBufferSize, OptLen) = SOCKET_ERROR then
begin
SafeLog('Предупреждение: не удалось установить размер буфера приема: ' + IntToStr(WSAGetLastError));
end
else
begin
SafeLog('Буфер приема сокета установлен в ' + IntToStr(SocketBufferSize) + ' байт');
end;
SafeLog('Сокет создан: ' + IntToStr(FSocket));
ZeroMemory(@ServerAddr, SizeOf(ServerAddr));
ServerAddr.sin_family := AF_INET;
ServerAddr.sin_addr.s_addr := inet_addr(PAnsiChar(AnsiString(ServerIP)));
ServerAddr.sin_port := htons(ServerPort);
SafeLog('Вызываем connect()');
if connect(FSocket, @ServerAddr, SizeOf(ServerAddr)) = SOCKET_ERROR then
begin
SafeLog('Ошибка connect: ' + IntToStr(WSAGetLastError));
closesocket(FSocket);
FSocket := INVALID_SOCKET;
raise Exception.Create('Failed to connect to server');
end;
SafeLog('TCP соединение установлено');
SetStatus('Connection established');
SafeLog('Настраиваем асинхронные уведомления');
if WSAAsyncSelect(FSocket, Handle, WM_SOCKET, FD_READ or FD_CLOSE) = SOCKET_ERROR then
begin
SafeLog('Ошибка WSAAsyncSelect: ' + IntToStr(WSAGetLastError));
closesocket(FSocket);
FSocket := INVALID_SOCKET;
raise Exception.Create('Failed to set up async notifications');
end
else
begin
SafeLog('Асинхронные уведомления настроены успешно');
end;
FConnected := True;
FThroughRelay := False;
UpdateConnectionUI;
// Сбрасываю состояние буфера
FReceiveBufferUsed := 0;
FExpectingHeader := True;
FImageDataReceived := 0;
Timer1.Interval := 200;
Timer1.Enabled := True;
SetStatus('Connected to ' + ServerIP + ':' + IntToStr(ServerPort));
SafeLog('Прямое подключение завершено, ждем данных от сервера');
except
on E: Exception do
begin
SafeLog('ОШИБКА подключения: ' + E.Message);
SetStatus('Connection error: ' + E.Message);
ShowMessage('Connection error: ' + E.Message);
if FSocket <> INVALID_SOCKET then
begin
closesocket(FSocket);
FSocket := INVALID_SOCKET;
SafeLog('Сокет закрыт после ошибки');
end;
UpdateConnectionUI;
end;
end;
end;
procedure TForm1.ConnectViaRelay;
begin
if FConnected then Exit;
FTargetID := Edit3.Text;
if FTargetID = '' then
begin
ShowMessage('Enter server ID');
Exit;
end;
SetStatus('Connecting via relay to ID: ' + FTargetID);
// Сначала подключаемся к relay серверу
ConnectToRelayServer;
end;
procedure TForm1.ConnectToRelayServer;
var
RelayAddr: TSockAddrIn;
begin
if FRelayState <> rsDisconnected then Exit;
try
ParseRelayAddress;
SafeLog('Connecting to relay server: ' + FRelayIP + ':' + IntToStr(FRelayPort));
FRelaySocket := socket(AF_INET, SOCK_STREAM, IPPROTO_TCP);
if FRelaySocket = INVALID_SOCKET then
begin
SafeLog('Ошибка создания relay сокета: ' + IntToStr(WSAGetLastError));
raise Exception.Create('Failed to create relay socket');
end;
ZeroMemory(@RelayAddr, SizeOf(RelayAddr));
RelayAddr.sin_family := AF_INET;
RelayAddr.sin_addr.s_addr := inet_addr(PAnsiChar(AnsiString(FRelayIP)));
RelayAddr.sin_port := htons(FRelayPort);
if connect(FRelaySocket, @RelayAddr, SizeOf(RelayAddr)) = SOCKET_ERROR then
begin
SafeLog('Ошибка подключения к relay: ' + IntToStr(WSAGetLastError));
closesocket(FRelaySocket);
FRelaySocket := INVALID_SOCKET;
raise Exception.Create('Failed to connect to relay server');
end;
WSAAsyncSelect(FRelaySocket, Handle, WM_SOCKET, FD_READ or FD_CLOSE);
FRelayState := rsConnected;
Label7.Caption := 'Connected to relay';
Label7.Font.Color := clGreen;
SafeLog('Connected to relay server');
// Отправляем запрос на подключение к целевому серверу
SendToRelay('CONNECT_CLIENT ' + FTargetID);
FRelayState := rsWaiting;
Label7.Caption := 'Waiting for server...';
Label7.Font.Color := clBlue;
SetStatus('Waiting for server connection via relay...');
except
on E: Exception do
begin
SafeLog('Relay connection error: ' + E.Message);
SetStatus('Relay connection error: ' + E.Message);
FRelayState := rsDisconnected;
Label7.Caption := 'Connection failed';
Label7.Font.Color := clRed;
end;
end;
end;
procedure TForm1.DisconnectFromServer;
begin
try
if not FConnected and (FRelayState = rsDisconnected) then Exit;
SafeLog('Начинаем отключение');
FConnected := False;
Timer1.Enabled := False;
if FSocket <> INVALID_SOCKET then
begin
WSAAsyncSelect(FSocket, Handle, 0, 0);
closesocket(FSocket);
FSocket := INVALID_SOCKET;
SafeLog('Основной сокет закрыт');
end;
DisconnectFromRelay;
// Сбрасываю состояние буфера
FReceiveBufferUsed := 0;
FExpectingHeader := True;
FImageDataReceived := 0;
if Assigned(FScreenBitmap) then
begin
FScreenBitmap.Canvas.Brush.Color := clBlack;
FScreenBitmap.Canvas.FillRect(Classes.Rect(0, 0, FScreenBitmap.Width, FScreenBitmap.Height));
PaintBox1.Invalidate;
end;
SetStatus('Disconnected');
UpdateConnectionUI;
SafeLog('Отключение завершено');
except
on E: Exception do
SafeLog('Ошибка в DisconnectFromServer: ' + E.Message);
end;
end;
procedure TForm1.DisconnectFromRelay;
begin
if FRelaySocket <> INVALID_SOCKET then
begin
WSAAsyncSelect(FRelaySocket, Handle, 0, 0);
closesocket(FRelaySocket);
FRelaySocket := INVALID_SOCKET;
SafeLog('Relay сокет закрыт');
end;
FRelayState := rsDisconnected;
Label7.Caption := 'Disconnected';
Label7.Font.Color := clRed;
FRelayBuffer.Clear;
end;
procedure TForm1.ProcessServerData;
var
BytesReceived: Integer;
BytesProcessed: Integer;
RemainingDataInSocket: LongWord;
ExpectedTotalData: Cardinal;
MaxBufferSize: Cardinal;
FramesProcessed: Integer;
RemainingImageData: Integer;
AvailableData: Integer;
RemainingBytes: Integer;
begin
try
if FSocket = INVALID_SOCKET then
begin
SafeLog('ProcessServerData: FSocket недействителен, выход.');
Exit;
end;
MaxBufferSize := 10 * 1024 * 1024;
if ioctlsocket(FSocket, FIONREAD, @RemainingDataInSocket) = SOCKET_ERROR then
begin
SafeLog('Ошибка ioctlsocket (FIONREAD): ' + IntToStr(WSAGetLastError));
DisconnectFromServer;
Exit;
end;
if RemainingDataInSocket = 0 then
begin
SafeLog('ProcessServerData: Нет данных для чтения из сокета.');
Exit;
end;
if FReceiveBufferUsed + RemainingDataInSocket > MaxBufferSize then
begin
SafeLog(Format('ПРЕДУПРЕЖДЕНИЕ: Буфер переполнен (%d + %d > %d), сбрасываем старые данные',
[FReceiveBufferUsed, RemainingDataInSocket, MaxBufferSize]));
FReceiveBufferUsed := 0;
FExpectingHeader := True;
FImageDataReceived := 0;
RemainingDataInSocket := Min(RemainingDataInSocket, MaxBufferSize div 2);
end;
SafeLog(Format('ProcessServerData: в сокете доступно %d байт, в буфере %d байт',
[RemainingDataInSocket, FReceiveBufferUsed]));
ExpectedTotalData := FReceiveBufferUsed + RemainingDataInSocket;
if FReceiveBufferSize < ExpectedTotalData then
begin
FReceiveBufferSize := ExpectedTotalData + (64 * 1024);
ReallocMem(FReceiveBuffer, FReceiveBufferSize);
SafeLog(Format('Буфер приема увеличен до %d байт', [FReceiveBufferSize]));
end;
BytesReceived := recv(FSocket, (FReceiveBuffer + FReceiveBufferUsed)^, RemainingDataInSocket, 0);
if BytesReceived = SOCKET_ERROR then
begin
SafeLog('Ошибка recv: ' + IntToStr(WSAGetLastError));
DisconnectFromServer;
Exit;
end;
if BytesReceived = 0 then
begin
SafeLog('Соединение закрыто сервером (recv вернул 0)');
DisconnectFromServer;
Exit;
end;
Inc(FReceiveBufferUsed, BytesReceived);
SafeLog(Format('Получено %d байт, в буфере теперь %d байт', [BytesReceived, FReceiveBufferUsed]));
BytesProcessed := 0;
FramesProcessed := 0;
while (FReceiveBufferUsed - BytesProcessed >= SizeOf(TScreenHeader)) and (FramesProcessed < 3) do
begin
if FExpectingHeader then
begin
Move((FReceiveBuffer + BytesProcessed)^, FCurrentHeader, SizeOf(TScreenHeader));
Inc(BytesProcessed, SizeOf(TScreenHeader));
SafeLog(Format('Заголовок: %dx%d, данных: %d байт, формат: %d',
[FCurrentHeader.Width, FCurrentHeader.Height, FCurrentHeader.DataSize, FCurrentHeader.ImageFormat]));
if (FCurrentHeader.Width < 1) or (FCurrentHeader.Width > 4096) or
(FCurrentHeader.Height < 1) or (FCurrentHeader.Height > 4096) or
(FCurrentHeader.DataSize < 1) or (FCurrentHeader.DataSize > 50 * 1024 * 1024) then
begin
SafeLog(Format('Некорректный заголовок (%dx%d, DataSize=%d), поиск следующего',
[FCurrentHeader.Width, FCurrentHeader.Height, FCurrentHeader.DataSize]));
while (BytesProcessed < FReceiveBufferUsed - SizeOf(TScreenHeader)) do
begin
Inc(BytesProcessed);
Move((FReceiveBuffer + BytesProcessed)^, FCurrentHeader, SizeOf(TScreenHeader));
if (FCurrentHeader.Width >= 1) and (FCurrentHeader.Width <= 4096) and
(FCurrentHeader.Height >= 1) and (FCurrentHeader.Height <= 4096) and
(FCurrentHeader.DataSize >= 1) and (FCurrentHeader.DataSize <= 50 * 1024 * 1024) then
begin
SafeLog(Format('Найден корректный заголовок на позиции %d', [BytesProcessed]));
Inc(BytesProcessed, SizeOf(TScreenHeader));
Break;
end;
end;
if BytesProcessed >= FReceiveBufferUsed - SizeOf(TScreenHeader) then
begin
SafeLog('Корректный заголовок не найден, очищаем буфер');
FReceiveBufferUsed := 0;
FExpectingHeader := True;
Exit;
end;
end;
if (FScreenWidth <> FCurrentHeader.Width) or (FScreenHeight <> FCurrentHeader.Height) then
begin
SafeLog(Format('Изменяем размер bitmap: %dx%d -> %dx%d',
[FScreenWidth, FScreenHeight, FCurrentHeader.Width, FCurrentHeader.Height]));
FScreenWidth := FCurrentHeader.Width;
FScreenHeight := FCurrentHeader.Height;
if not Assigned(FScreenBitmap) then
begin
FScreenBitmap := Graphics.TBitmap.Create;
FScreenBitmap.PixelFormat := pf24bit;
end;
FScreenBitmap.Width := FScreenWidth;
FScreenBitmap.Height := FScreenHeight;
FScreenBitmap.Canvas.Brush.Color := clBlack;
FScreenBitmap.Canvas.FillRect(Classes.Rect(0, 0, FScreenWidth, FScreenHeight));
PaintBox1.Width := FScreenWidth;
PaintBox1.Height := FScreenHeight;
end;
FExpectingHeader := False;
FImageDataReceived := 0;
end;
if not FExpectingHeader then
begin
RemainingImageData := Integer(FCurrentHeader.DataSize) - FImageDataReceived;
AvailableData := FReceiveBufferUsed - BytesProcessed;
if AvailableData >= RemainingImageData then
begin
if FCurrentHeader.ImageFormat = 1 then // JPEG
begin
// Обработка JPEG через GDI+
ProcessJPEGFrame(FReceiveBuffer + BytesProcessed, RemainingImageData);
end
else // RAW
begin
UpdateBitmapRegion(BytesProcessed, RemainingImageData);
end;
Inc(BytesProcessed, RemainingImageData);
Inc(FImageDataReceived, RemainingImageData);
SafeLog(Format('Кадр %d завершен (%d байт, Формат: %s)',
[FramesProcessed + 1, FCurrentHeader.DataSize,
IfThen(FCurrentHeader.ImageFormat = 1, 'JPEG', 'RAW')]));
FExpectingHeader := True;
FImageDataReceived := 0;
Inc(FramesProcessed);
if FramesProcessed = 1 then
UpdateDisplay;
end
else
begin
if AvailableData > 0 then
begin
UpdateBitmapRegion(BytesProcessed, AvailableData);
Inc(FImageDataReceived, AvailableData);
Inc(BytesProcessed, AvailableData);
SafeLog(Format('Частичные данные: %d/%d байт получено',
[FImageDataReceived, FCurrentHeader.DataSize]));
end;
Break;
end;
end;
end;
if FramesProcessed > 1 then
begin
SafeLog(Format('Обработано %d кадров за один вызов', [FramesProcessed]));
UpdateDisplay;
end;
if BytesProcessed > 0 then
begin
RemainingBytes := FReceiveBufferUsed - BytesProcessed;
if RemainingBytes > 0 then
begin
Move((FReceiveBuffer + BytesProcessed)^, FReceiveBuffer^, RemainingBytes);
FReceiveBufferUsed := RemainingBytes;
SafeLog(Format('Буфер сдвинут, осталось %d байт', [FReceiveBufferUsed]));
end
else
begin
FReceiveBufferUsed := 0;
SafeLog('Буфер полностью обработан');
end;
end;
if not Timer1.Enabled and FConnected then
begin
Timer1.Enabled := True;
SafeLog('Таймер обновлений запущен');
end;
except
on E: Exception do
begin
SafeLog('ОШИБКА в ProcessServerData: ' + E.Message);
FReceiveBufferUsed := 0;
FExpectingHeader := True;
FImageDataReceived := 0;
DisconnectFromServer;
end;
end;
end;
procedure TForm1.ProcessRelayData;
var
Buffer: array[0..65535] of Byte;
BytesReceived: Integer;
StrData: string;
NewlinePos: Integer;
RemainingData: string;
begin
if FRelaySocket = INVALID_SOCKET then Exit;
// 1. Читаем из сокета
BytesReceived := recv(FRelaySocket, Buffer, SizeOf(Buffer), 0);
if BytesReceived <= 0 then
begin
SafeLog('Relay server disconnected (recv 0)');
DisconnectFromServer;
Exit;
end;
// 2. ВАЖНО: Ставим позицию в конец для ЗАПИСИ
FRelayBuffer.Position := FRelayBuffer.Size;
FRelayBuffer.Write(Buffer, BytesReceived);
// 3. Обработка
if FRelayState = rsWaiting then
begin
// --- ТЕКСТОВЫЙ РЕЖИМ ---
FRelayBuffer.Position := 0; // Читаем с начала
SetLength(StrData, FRelayBuffer.Size);
if Length(StrData) > 0 then
FRelayBuffer.Read(StrData[1], Length(StrData));
NewlinePos := Pos(#13#10, StrData);
if NewlinePos > 0 then
begin
HandleRelayResponse(Copy(StrData, 1, NewlinePos - 1));
// Сохраняем "хвост" если он есть (начало JPEG)
if NewlinePos + 1 < Length(StrData) then
begin
RemainingData := Copy(StrData, NewlinePos + 2, Length(StrData));
FRelayBuffer.Clear;
if Length(RemainingData) > 0 then
FRelayBuffer.Write(RemainingData[1], Length(RemainingData));
end
else
FRelayBuffer.Clear;
end;
end
else if FRelayState = rsReady then
begin
// --- БИНАРНЫЙ РЕЖИМ ---
// ВАЖНО: Сбрасываем позицию в 0, чтобы функция обработки видела данные
FRelayBuffer.Position := 0;
ProcessRelayBinaryData;
end;
end;
procedure TForm1.HandleRelayResponse(const Response: string);
var
Lines: TStringList;
i: Integer;
Line: string;
begin
Lines := TStringList.Create;
try
Lines.Text := Response;
for i := 0 to Lines.Count - 1 do
begin
Line := Trim(Lines[i]);
if Line = '' then Continue;
SafeLog('<< Relay: ' + Line);
if Pos('CONNECTED', Line) = 1 then
begin
FConnected := True;
FThroughRelay := True;
FRelayState := rsReady;
Label7.Caption := 'Connected to server';
Label7.Font.Color := clGreen;
SetStatus('Connected via relay to server: ' + FTargetID);
UpdateConnectionUI;
FExpectingHeader := True;
FImageDataReceived := 0;
// Сбрасываем буфер релея
FRelayBuffer.Clear;
Timer1.Enabled := True;
SafeLog('Successfully connected via relay to server');
// Запросить первый кадр
RequestUpdate();
end
else if Pos('ERROR', Line) = 1 then
begin
SetStatus('Relay error: ' + Copy(Line, 7, MaxInt));
SafeLog('Relay error: ' + Line);
DisconnectFromServer;
end
else if Pos('SERVER_DISCONNECTED', Line) = 1 then
begin
SetStatus('Server disconnected via relay');
SafeLog('Server disconnected');
DisconnectFromServer;
end;
end;
finally
Lines.Free;
end;
end;
procedure TForm1.ProcessRelayBinaryData;
var
Header: TScreenHeader;
TotalFrameSize: Integer;
TempData: TBytes;
BytesRemained: Integer;
FrameProcessed: Boolean;
begin
while True do
begin
FrameProcessed := False;
if FRelayBuffer.Size < SizeOf(TScreenHeader) then
Break;
FRelayBuffer.Position := 0;
FRelayBuffer.Read(Header, SizeOf(TScreenHeader));
if (Header.DataSize = 0) or (Header.DataSize > 50 * 1024 * 1024) then
begin
SafeLog('Critical: Bad header size (' + IntToStr(Header.DataSize) + '). Resetting buffer.');
FRelayBuffer.Clear;
Break;
end;
TotalFrameSize := SizeOf(TScreenHeader) + Header.DataSize;
if FRelayBuffer.Size < TotalFrameSize then
Break;
try
if Header.DataSize > 0 then
begin
SetLength(TempData, Header.DataSize);
FRelayBuffer.Position := SizeOf(TScreenHeader);
FRelayBuffer.Read(TempData[0], Header.DataSize);
if Header.ImageFormat = 1 then
ProcessJPEGFrame(@TempData[0], Header.DataSize);
FrameProcessed := True;
end;
except
on E: Exception do
SafeLog('Error processing frame: ' + E.Message);
end;
BytesRemained := FRelayBuffer.Size - TotalFrameSize;
if BytesRemained > 0 then
begin
Move(PByte(FRelayBuffer.Memory)[TotalFrameSize],
PByte(FRelayBuffer.Memory)[0],
BytesRemained);
FRelayBuffer.SetSize(BytesRemained);
end
else
begin
FRelayBuffer.Clear;
end;
FRelayBuffer.Position := 0;
end;
FRelayBuffer.Position := FRelayBuffer.Size;
end;
procedure TForm1.UpdateBitmapRegion(DataOffset: Integer; DataSize: Integer);
var
i: Integer;
CurrentLineBytes: PByte;
SrcPtr: PByte;
BytesPerPixel: Integer;
PixelsToCopy: Integer;
begin
if not Assigned(FScreenBitmap) then Exit;
BytesPerPixel := 3;
if FCurrentHeader.DataSize > 0 then
BytesPerPixel := FCurrentHeader.DataSize div (FCurrentHeader.Width * FCurrentHeader.Height);
FScreenBitmap.BeginUpdate;
try
SrcPtr := FReceiveBuffer + DataOffset;
for i := 0 to FScreenHeight - 1 do
begin
CurrentLineBytes := FScreenBitmap.ScanLine[i];
PixelsToCopy := FScreenWidth * BytesPerPixel;
if DataSize >= PixelsToCopy then
begin
Move(SrcPtr^, CurrentLineBytes^, PixelsToCopy);
Inc(SrcPtr, PixelsToCopy);
Dec(DataSize, PixelsToCopy);
end
else if DataSize > 0 then
begin
Move(SrcPtr^, CurrentLineBytes^, DataSize);
FillChar((CurrentLineBytes + DataSize)^, PixelsToCopy - DataSize, 0);
SrcPtr := SrcPtr + DataSize;
DataSize := 0;
end
else
begin
Break;
end;
end;
finally
FScreenBitmap.EndUpdate;
end;
end;
procedure TForm1.RequestUpdate;
var
Msg: Byte;
CurrentTime: DWORD;
TimeDiff: DWORD;
const
MIN_FRAME_DELAY = 50; // Если к примеру изменить с 30 до 100 мс (клиент будет отображать 10 FPS вместо 33)
begin
try
if not FConnected then Exit;
CurrentTime := GetTickCount;
if CurrentTime >= FLastUpdateTime then
TimeDiff := CurrentTime - FLastUpdateTime
else
TimeDiff := MAXDWORD - FLastUpdateTime + CurrentTime;
if TimeDiff < MIN_FRAME_DELAY then
begin
// SafeLog('Frame request throttled'); // для отладки
Exit;
end;
FLastUpdateTime := CurrentTime;
Msg := 1;
if FThroughRelay then
begin
SendBinaryToRelay([Msg]);
end
else
begin
if send(FSocket, Msg, SizeOf(Msg), 0) = SOCKET_ERROR then
DisconnectFromServer;
end;
except
on E: Exception do
SafeLog('Error in RequestUpdate: ' + E.Message);
end;
end;
procedure TForm1.SendMouseEvent(X, Y: Integer; Buttons: Byte);
var
Msg: TMouseMsg;
Data: TBytes;
begin
try
if not FConnected then Exit;
if (X < 0) or (X >= FScreenWidth) or (Y < 0) or (Y >= FScreenHeight) then
begin
SafeLog(Format('Попытка отправить недействительные координаты мыши: X=%d, Y=%d', [X, Y]));
Exit;
end;
Msg.MsgType := 2;
Msg.X := X;
Msg.Y := Y;
Msg.Buttons := Buttons;
SetLength(Data, SizeOf(Msg));
Move(Msg, Data[0], SizeOf(Msg));
if FThroughRelay then
begin
SendBinaryToRelay(Data);
end
else
begin
if send(FSocket, Msg, SizeOf(Msg), 0) = SOCKET_ERROR then
begin
SafeLog('Ошибка отправки mouse event: ' + IntToStr(WSAGetLastError));
end
else
begin
SafeLog(Format('Mouse: X=%d, Y=%d, Buttons=%d', [X, Y, Buttons]));
end;
end;
except
on E: Exception do
SafeLog('Ошибка в SendMouseEvent: ' + E.Message);
end;
end;
procedure TForm1.SendKeyEvent(KeyCode: DWORD; IsDown: Boolean);
var
Msg: TKeyMsg;
Data: TBytes;
begin
try
if not FConnected then Exit;
Msg.MsgType := 3;
if IsDown then
Msg.IsDown := 1
else
Msg.IsDown := 0;
Msg.KeyCode := KeyCode;
SetLength(Data, SizeOf(Msg));
Move(Msg, Data[0], SizeOf(Msg));
if FThroughRelay then
begin
SendBinaryToRelay(Data);
end
else
begin
if send(FSocket, Msg, SizeOf(Msg), 0) = SOCKET_ERROR then
begin
SafeLog('Ошибка отправки key event: ' + IntToStr(WSAGetLastError));
end
else
begin
SafeLog(Format('Key: Code=%d, Down=%s', [KeyCode, BoolToStr(IsDown, True)]));
end;
end;
except
on E: Exception do
SafeLog('Ошибка в SendKeyEvent: ' + E.Message);
end;
end;
procedure TForm1.UpdateDisplay;
var
LastUpdateTime: Cardinal;
CurrentTime: Cardinal;
const
MIN_UPDATE_INTERVAL = 33;
begin
try
CurrentTime := GetTickCount;
LastUpdateTime := 0;
if CurrentTime - LastUpdateTime >= MIN_UPDATE_INTERVAL then
begin
PaintBox1.Invalidate;
LastUpdateTime := CurrentTime;
if FFullScreenMode and Assigned(FFullScreenForm) then
begin
FFullScreenForm.Invalidate;
end;
end;
except
on E: Exception do
SafeLog('Ошибка в UpdateDisplay: ' + E.Message);
end;
end;
procedure TForm1.SetStatus(const Msg: string);
begin
try
if Assigned(Label3) then
Label3.Caption := Msg;
Application.ProcessMessages;
except
on E: Exception do
SafeLog('Ошибка в SetStatus: ' + E.Message);
end;
end;
procedure TForm1.UpdateConnectionUI;
begin
Button1.Enabled := not FConnected;
Button2.Enabled := FConnected;
Button3.Enabled := FConnected;
if FConnectionMode = cmDirect then
begin
Edit1.Enabled := not FConnected;
Edit2.Enabled := not FConnected;
Edit3.Enabled := False;
end
else
begin
Edit1.Enabled := False;
Edit2.Enabled := False;
Edit3.Enabled := not FConnected;
end;
RadioGroup1.Enabled := not FConnected;
case FRelayState of
rsDisconnected:
begin
Label7.Caption := 'Disconnected';
Label7.Font.Color := clRed;
end;
rsConnected:
begin
Label7.Caption := 'Connected to relay';
Label7.Font.Color := clGreen;
end;
rsWaiting:
begin
Label7.Caption := 'Waiting for server...';
Label7.Font.Color := clBlue;
end;
rsReady:
begin
Label7.Caption := 'Connected to server';
Label7.Font.Color := clGreen;
end;
end;
end;
procedure TForm1.SendToRelay(const Data: string);
var
FullData: AnsiString;
begin
if FRelaySocket <> INVALID_SOCKET then
begin
FullData := AnsiString(Data) + #13#10;
send(FRelaySocket, FullData[1], Length(FullData), 0);
SafeLog('>> Relay: ' + Data);
end;
end;
procedure TForm1.SendBinaryToRelay(const Data: TBytes);
begin
if FRelaySocket <> INVALID_SOCKET then
begin
send(FRelaySocket, Data[0], Length(Data), 0);
SafeLog('Binary data sent to relay: ' + IntToStr(Length(Data)) + ' bytes');
end;
end;
procedure TForm1.ParseRelayAddress;
begin
// Дефолтный адрес релей сервера для подключения
FRelayIP := '10.30.28.28';
FRelayPort := RELAY_PORT;
end;
procedure TForm1.PaintBox1Paint(Sender: TObject);
var
PaintBox: TPaintBox;
DestRect: TRect;
ScaleX, ScaleY, Scale: Double;
begin
try
PaintBox := Sender as TPaintBox;
if Assigned(FScreenBitmap) and (FScreenWidth > 0) and (FScreenHeight > 0) then
begin
if FFullScreenMode then
begin
ScaleX := PaintBox.Width / FScreenWidth;
ScaleY := PaintBox.Height / FScreenHeight;
Scale := MinDouble(ScaleX, ScaleY);
DestRect.Left := (PaintBox.Width - Round(FScreenWidth * Scale)) div 2;
DestRect.Top := (PaintBox.Height - Round(FScreenHeight * Scale)) div 2;
DestRect.Right := DestRect.Left + Round(FScreenWidth * Scale);
DestRect.Bottom := DestRect.Top + Round(FScreenHeight * Scale);
PaintBox.Canvas.StretchDraw(DestRect, FScreenBitmap);
end
else
begin
PaintBox.Canvas.Draw(0, 0, FScreenBitmap);
end;
end
else
begin
// Рисуем черный фон, если битмап не готов или имеет нулевые размеры
PaintBox.Canvas.Brush.Color := clBlack;
PaintBox.Canvas.FillRect(PaintBox.ClientRect);
end;
except
on E: Exception do
SafeLog('Ошибка в PaintBox1Paint: ' + E.Message);
end;
end;
procedure TForm1.WMSocket(var Message: TLMessage);
var
Event: Word;
Error: Integer;
Socket: TSocket;
begin
Event := LOWORD(Message.LParam);
Error := HIWORD(Message.LParam);
Socket := Message.WParam;
try
SafeLog(Format('WMSocket вызван. Событие: %d, Ошибка: %d, Socket: %d',
[Event, Error, Socket]));
if Socket = FRelaySocket then
begin
case Event of
FD_READ:
if Error = 0 then
ProcessRelayData
else
DisconnectFromServer;
FD_CLOSE:
begin
SafeLog('Relay connection closed');
DisconnectFromServer;
end;
end;
end
else if Socket = FSocket then
begin
case Event of
FD_READ:
if Error = 0 then
ProcessServerData
else
DisconnectFromServer;
FD_CLOSE:
begin
SafeLog('Direct connection closed');
DisconnectFromServer;
end;
end;
end;
except
on E: Exception do
begin
SafeLog('КРИТИЧЕСКАЯ ОШИБКА в WMSocket: ' + E.Message);
DisconnectFromServer;
end;
end;
end;
end.
