unitwebcam.pas

不错的远程控制程序

unit UnitWebcam;

interface

uses
  Windows,
  Messages,
  SysUtils,
  Variants,
  Classes,
  Graphics,
  jpeg,
  Controls,
  Forms,
  Dialogs,
  ExtCtrls,
  Sockets,
  CompressionStreamUnitForms,
  ComCtrls,
  StdCtrls,
  GR32_Image;


type
  TWebcam = class(TForm)
    Timer1: TTimer;
    Panel1: TPanel;
    Panel2: TPanel;
    CheckBox1: TCheckBox;
    Edit1: TEdit;
    Label1: TLabel;
    Label2: TLabel;
    Edit2: TEdit;
    CheckBox2: TCheckBox;
    Image1: TImage32;
    CheckBox3: TCheckBox;
    Label3: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure CheckBox1Click(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormDeactivate(Sender: TObject);
  private
    { Private declarations }
    DataSocket: TCustomWinSocket;
    Connected: Boolean;
    Number: dword;
    ConnectNotifyInfo: TNotifyInfo;
    ReadNotifyInfo: TNotifyInfo;
    DisconnectNotifyInfo: TNotifyInfo;
    procedure Connect(var Socket: TCustomWinSocket; Data: Pointer);
    procedure Read(var Socket: TCustomWinSocket; CommandFrame: TCommandFrame; Stream: TMemoryStream; Data: Pointer);
    procedure Disconnect(var Socket: TCustomWinSocket; Data: Pointer);
    function SocketConnected: Boolean;
  public
    { Public declarations }
    RemoteAddress: string;
    WindowItem: TListItem;
  end;

implementation

uses UnitMain;

{$R *.dfm}

const
  W_TYPE = 4;
  W_SHOT = 1;
  W_ERROR = 2;
  W_SHOTB = 3;

function TWebcam.SocketConnected: Boolean;
begin
  if ((Connected) and (DataSocket <> nil)) then
  begin
    Connected := DataSocket.Connected;
    if not Connected then Label3.Caption:= '摄像头监控－ 连接断开';
  end;
  Result := Connected;
end;

function Bmp2Jpeg(BmpStream: Classes.TMemoryStream): TJPEGImage;
var
  Bmp: TBitmap;
begin
  Bmp := TBitmap.Create;
  Result := TJPEGImage.Create;
  try
    Bmp.LoadFromStream(BmpStream);
    Result.Assign(Bmp);
  finally
    Bmp.Free;
  end;
end;

function CreateBitmapDelta(LastBitmap: Pointer; LastBitmapSize: dword; Difference: TMemoryStream): Classes.TMemoryStream;
begin
  Result := Classes.TMemoryStream.Create;
  Result.SetSize(Difference.Size);
  Result.WriteBuffer(Difference.Memory^, Difference.Size);
  Result.Position := 0;
  Exit;
end;

procedure TWebcam.Connect(var Socket: TCustomWinSocket; Data: Pointer);
var
  Webcam: TWebcam;
  ConnectionInfo: TConnectionInfo;
begin
  Webcam := TWebcam(Data);
  if TStreamRecord(Socket.Data).LocalAddress <> Webcam.RemoteAddress then Exit;
  if Webcam.DataSocket = nil then Webcam.DataSocket := Socket else Exit;
  ConnectionInfo.ConnectionType := W_TYPE;
  Socket.SendBuf(ConnectionInfo, SizeOf(TConnectionInfo));
  Webcam.Connected := True;
  Webcam.Label3.Caption := ' 已连接: ' + Socket.RemoteAddress;
  Webcam.CheckBox1.Enabled := True;
  Socket := nil;
end;

procedure TWebcam.Read(var Socket: TCustomWinSocket; CommandFrame: TCommandFrame; Stream: TMemoryStream; Data: Pointer);
var
  Webcam: TWebcam;
  Delta: Classes.TMemoryStream;
  Jpg: TJPEGImage;
begin
  Webcam := TWebcam(Data);
  if Webcam.DataSocket = Socket then
  begin
    case CommandFrame.Command of
      W_SHOT:
        begin
          if Stream.Size = 0 then Exit;
          Label3.Caption := ' 接收图象';
          Delta := CreateBitmapDelta(nil, 0, Stream);
          if Webcam.CheckBox2.Checked then
          begin
            Inc(Webcam.Number);
            Delta.SaveToFile(PChar(Webcam.Edit2.Text + 'Webshot' + IntToHex(Webcam.Number, 4) + '.bmp'));
          end;
          Jpg := Bmp2Jpeg(Delta);
          Webcam.Image1.Bitmap.Assign(Jpg);
          Jpg.Free;
          Delta.Free;
          Label3.Caption := ' 播放图象';
          Webcam.Timer1.Enabled := Webcam.CheckBox1.Checked;
        end;
      W_ERROR:
        begin
          Webcam.Image1.Canvas.Brush.Color := $00000000;
          Webcam.Image1.Canvas.FillRect(Webcam.Image1.BoundsRect);
        end;
    end;
    Socket := nil;
  end;
end;

procedure TWebcam.Disconnect(var Socket: TCustomWinSocket; Data: Pointer);
var
  Webcam: TWebcam;
begin
  Webcam := TWebcam(Data);
  if Webcam.DataSocket = Socket then
  begin
    Webcam.Connected := False;
    Webcam.Label3.Caption := ' 断开连接';
    Webcam.CheckBox1.Checked := False;
    Webcam.CheckBox1.Enabled := False;
    Socket := nil;
    Webcam.DataSocket := nil;
  end;
end;

procedure TWebcam.FormCreate(Sender: TObject);
begin
  DataSocket := nil;
  ConnectNotifyInfo := TNotifyInfo.Create;
  ConnectNotifyInfo.Data := Self;
  ConnectNotifyInfo.Callback := @TWebcam.Connect;
  Main.NotifyConnectList.Add(ConnectNotifyInfo);
  ReadNotifyInfo := TNotifyInfo.Create;
  ReadNotifyInfo.Data := Self;
  ReadNotifyInfo.Callback := @TWebcam.Read;
  Main.NotifyReadList.Add(ReadNotifyInfo);
  DisconnectNotifyInfo := TNotifyInfo.Create;
  DisconnectNotifyInfo.Data := Self;
  DisconnectNotifyInfo.Callback := @TWebcam.Disconnect;
  Main.NotifyDisconnectList.Add(DisconnectNotifyInfo);
end;

procedure TWebcam.Timer1Timer(Sender: TObject);
var
  CommandFrame: TCommandFrame;
  ReplyStream: TMemoryStream;
begin
  if CheckBox3.Checked  then
  begin
  Timer1.Enabled := False;
  if not SocketConnected then Exit;
  Label3.Caption := ' 获取视频';
  Timer1.Interval := StrToInt(Edit1.Text);
  CommandFrame.len := 0;
  CommandFrame.Command := W_SHOT;
  CommandFrame.ID := FRAME_ID;
  ReplyStream := TMemoryStream.Create;
  ReplyStream.WriteBuffer(CommandFrame, SizeOf(TCommandFrame));
  Main.SendStream(DataSocket, ReplyStream);
  end else begin
    Timer1.Enabled := False;
  if not SocketConnected then Exit;
  Label3.Caption := ' 获取视频';
  Timer1.Interval := StrToInt(Edit1.Text);
  CommandFrame.len := 0;
  CommandFrame.Command := W_SHOTB;
  CommandFrame.ID := FRAME_ID;
  ReplyStream := TMemoryStream.Create;
  ReplyStream.WriteBuffer(CommandFrame, SizeOf(TCommandFrame));
  Main.SendStream(DataSocket, ReplyStream);
end;
end;

procedure TWebcam.CheckBox1Click(Sender: TObject);
begin
  Timer1.Interval := 1;
  Timer1.Enabled := CheckBox1.Checked;
end;

procedure TWebcam.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  CanClose := not CheckBox1.Checked;
end;

procedure TWebcam.FormClose(Sender: TObject; var Action: TCloseAction);
var
  Socket: TCustomWinSocket;
begin
  Main.NotifyConnectList.Delete(Main.NotifyConnectList.IndexOf(ConnectNotifyInfo));
  Main.NotifyReadList.Delete(Main.NotifyReadList.IndexOf(ReadNotifyInfo));
  Main.NotifyDisconnectList.Delete(Main.NotifyDisconnectList.IndexOf(DisconnectNotifyInfo));
  WindowItem.Delete;
  if DataSocket <> nil then
  begin
    if not SocketConnected then
    begin
      Socket := DataSocket;
      DataSocket := nil;
      Connected := False;
      Socket.Close;
    end;
  end;
end;

procedure TWebcam.FormDeactivate(Sender: TObject);
begin
  if WindowState = wsMinimized then Hide;
end;


end.