Удалённый просмотр рабочего стола

unit uMain;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, IdBaseComponent, IdComponent, IdTCPConnection,
  IdTCPClient, StdCtrls;
 
type
  TForm1 = class(TForm)
    imgScreen: TImage;
    GroupBox1: TGroupBox;
    txtServer: TEdit;
    cmbConnect: TButton;
    GroupBox2: TGroupBox;
    Label1: TLabel;
    Label2: TLabel;
    lblResolution: TLabel;
    lblColors: TLabel;
    IdTCPClient1: TIdTCPClient;
    Timer1: TTimer;
    procedure cmbConnectClick(Sender: TObject);
    procedure IdTCPClient1Connected(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure IdTCPClient1Disconnected(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
procedure TForm1.cmbConnectClick(Sender: TObject);
begin
  if cmbConnect.Caption = 'Подключиться' then
  begin
    if txtServer.Text = '' then
      //не введено имя сервера
      MessageDlg('Введите имя машины-сервера в текстовом поле', mtInformation, [mbOK], 0)
    else
    begin
      //подключаемся к серверу
      IdTCPClient1.Host := txtServer.Text;
      try
        IdTCPClient1.Connect;
      except
        MessageDlg('Не удается соединиться с указанным сервером', mtError, [mbOK], 0);
        Exit;
      end;
    end
  end
  else
    //отключаемся от сервера
    IdTCPClient1.Disconnect;
end;
 
procedure TForm1.IdTCPClient1Connected(Sender: TObject);
begin
  txtServer.Enabled := False;
  cmbConnect.Caption := 'Отключиться';
  //начинаем периодически запрашивать данные с сервера
  Timer1.Enabled := True;
  //выполним первый запрос, не дожидаясь срабатыввания таймера
  Timer1Timer(nil);
end;
 
procedure TForm1.Timer1Timer(Sender: TObject);
var
  stream: TMemoryStream;
begin
  //запрашаваем у сервера данные о наблюдаемом компьютере
  with (IdTCPClient1) do
  begin
    //...разрешение
    WriteLn('get_screen_width');
    WriteLn('get_screen_height');
    lblResolution.Caption := IntToStr(ReadInteger) + 'x' + IntToStr(ReadInteger);
 
    //...глубина цвета
    WriteLn('get_screen_colors');
    lblColors.Caption := IntToStr(ReadInteger);
 
    //...копия экрана
    //.....1-й вариант - копирование экрана без сжатия
    //WriteLn('get_screen');
    //.....2-й вариант - сжатие на стороне сервера
    WriteLn('get_screen:' + IntToStr(imgScreen.Width) + ',' +
            IntToStr(imgScreen.Height));
    //....получаем данные
    stream := TMemoryStream.Create;
    ReadStream(stream);
    stream.Position := 0;
    //....формируем изображение
    imgScreen.Picture.Bitmap.LoadFromStream(stream);
    stream.Clear;
    stream.Free;
  end;
end;
 
procedure TForm1.IdTCPClient1Disconnected(Sender: TObject);
begin
  txtServer.Enabled := True;
  cmbConnect.Caption := 'Подключиться';
  Timer1.Enabled := False;
end;
 
end.

unit uMain;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, IdBaseComponent, IdComponent, IdTCPServer, ExtCtrls;
 
type
  TForm1 = class(TForm)
    IdTCPServer1: TIdTCPServer;
    procedure IdTCPServer1Execute(AThread: TIdPeerThread);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
//процедура снимает копию экрана, приводит полученное
//изображение к заданному размеру и отправляет
//преобразованное изображение клиентской программе
procedure SendScreen(width1: Integer; height1: Integer; Connection: TIdTCPServerConnection);
var
  ScreenCopy: TCanvas;
  gr: TBitmap;
  stream: TMemoryStream;
  rcDest, rcSource: TRect;
begin
  rcDest := Rect(0,0,width1,height1); //конечный размер изображения
  rcSource := Screen.DesktopRect; //исходный размер изображения
  //создаем канву и присоединяем ее к контексту Рабочего стола
  ScreenCopy := TCanvas.Create;
  ScreenCopy.Handle := GetDC(0);
  //создаем объект для хранения копии экрана и копируем изображение
  gr := TBitmap.Create;
  gr.Height := height1;
  gr.Width := width1;
  gr.Canvas.CopyRect(rcDest, ScreenCopy, rcSource);
  ReleaseDC(0, ScreenCopy.Handle);
  //сохраняем изображение в поток данных
  stream := TMemoryStream.Create;
  gr.SaveToStream(stream);
  //отправляем изображение клиенту
  Connection.WriteStream(stream, true, true);
  stream.Clear;
  stream.Free;
  gr.Free;
end;
 
 
procedure TForm1.IdTCPServer1Execute(AThread: TIdPeerThread);
var
  strText: String;
  width, height, i: Integer;
  dc: HDC;
begin
  //принмаем от клиента стркоу
  strText := AThread.Connection.ReadLn;
  //определяем, что нужно выполнить
  if strText = 'get_screen_height' then
    //возвратим высоту экрана
    AThread.Connection.WriteInteger(Screen.Height)
  else if strText = 'get_screen_width' then
    //возвратим ширину экрана
    AThread.Connection.WriteInteger(Screen.Width)
  else if strText = 'get_screen_colors' then
  begin
    //возвратим количество бит на точку
    dc := GetDC(0);
    AThread.Connection.WriteInteger(GetDeviceCaps(dc, BITSPIXEL));
    ReleaseDC(0, dc)
  end
  else if strText = 'get_screen' then
    //возвратим полноразмерную копию экрана
    SendScreen(Screen.Width, Screen.Height, AThread.Connection)
  else
  begin
    //строка вида 'get_screen:x, y'
    //Определим значени высоты и ширины переданные пользователем
    strText := Copy(strText, 12, Length(strText) - 11);
    i := Pos(',', strText); //положение запятой
    width := StrToInt(Copy(strText, 1, i - 1));
    height := StrToInt(Copy(strText, i+1, Length(strText) - i));
    //возвратим копию экрана
    SendScreen(width, height, AThread.Connection);
  end;
end;
 
end.