Question

我正在使用Lazarus，并且试图将图像从服务器循环发送到客户端。现在我有一个问题，它只是不发送，而只是冻结了我的计算机。我似乎不明白，也不知道为什么会这样，相反它只是挂在我的电脑上

发件人的代码如下：

发件人

unit ScreenCapClassEx;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, ssockets ,windows;

type

  { TForm1 }

  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
     FAbort: Boolean;
  public

  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}

{ TForm1 }

procedure DrawCursor (ACanvas:TCanvas; Position:TPoint) ;
var
  HCursor : THandle;
begin
  HCursor := GetCursor;
  DrawIconEx(ACanvas.Handle, Position.X, Position.Y,
              HCursor, 32, 32, 0, 0, DI_NORMAL) ;
end;

function CaptureWindow(const WindowHandle: HWnd): Graphics.TBitmap;
var
  DC: HDC;
  wRect: TRect;
  CurPos: TPoint;
begin
  DC := GetWindowDC(WindowHandle);
  Result := Graphics.TBitmap.Create;
  Result.PixelFormat := pf32bit;
  try
    GetWindowRect(WindowHandle, wRect);
    Result.Width := wRect.Right - wRect.Left;
    Result.Height := wRect.Bottom - wRect.Top;
    BitBlt(Result.Canvas.Handle,
           0,
           0,
           Result.Width,
           Result.Height,
           DC,
           0,
           0,
           SRCCOPY);
    GetCursorPos(CurPos);
    DrawCursor(Result.Canvas, CurPos);
  finally
    ReleaseDC(WindowHandle, DC);
  end;
end;

procedure DoCapture;
var
  Socket: TInetSocket;
  Bmp: Graphics.TBitmap;
  FAbort: Boolean;
begin
  { Create the socket now and free it only when you're done with it}
  Socket:= TInetSocket.Create('loopback',4800);
  try
    { You need some "scape". Infinite loops are ... bad }
    while (not FAbort) and (not Application.Terminated) do begin
      Bmp := CaptureWindow(GetDesktopWindow);
      try
        Bmp.Canvas.Changed;
        Socket.Write(Bmp,1000553);
      finally
         {If you don't do this, you'll consume all the memory}
        Bmp.Free;
      end;
      Application.ProcessMessages;
    end;
  finally
    Socket.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
    if Assigned(Sender) and Sender.InheritsFrom(TControl) then begin
    { Use the button to start/stop capture,
      using the button's Tag as a flag to know in which mode we are. }
    if (Sender as TControl).Tag < 0 then begin
       FAbort := True;
       (Sender as TControl).Caption := '&Start capture';
       (Sender as TControl).Tag := 0;
    end else begin
       FAbort := False;
       (Sender as TControl).Caption := '&Stop capture';
       (Sender as TControl).Tag := -1;
    end;
    DoCapture;
  end;
end;

end.

现在，代码也可以在循环中接收图像，这使我的计算机挂起时看起来像这样：

unit screenShowClassEx;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, StdCtrls,
  windows, ssockets;

type

    { TMyServer }

  TMyServer=class(TInetServer)
  public
  end;

{ TMyServer }

  { TForm1 }

  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private

  public

  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}

procedure receiveImage();
var
 Server: TInetServer;
 Bmp: Graphics.TBitmap;
 JpegImage: TJpegImage;

begin
            Server := TMyServer.Create('loopback', 4800);
            showmessage('ok i am receiving now');
            while true do
            begin
            Server.StartAccepting;
            // show image on imagebox where Image1 :Timage
            JpegImage.Assign(Bmp);
            Form1.Image1.Canvas.Draw(0,0,JpegImage);
end;
end;

{ TForm1 }

procedure TForm1.Button1Click(Sender: TObject);
begin
  receiveImage();
end;

procedure TForm1.FormCreate(Sender: TObject);
begin

end;
end.

为什么会这样？请在这里我需要帮助

使用Pascal在Loop中发送图像

0 个答案: