delphi Tcp + Stream 兩台電腦互相傳遞畫面 @ 抓狂小白的程式筆記

idTcpClient/idTcpServer 傳送圖檔(stream) 範例

使用版本 delphi XE10.2.3

共用unit - 取得螢幕畫面(Server及Client都要用)

unit XBGetDC;

interface

uses Jpeg, Windows, Vcl.Graphics, Forms, System.Types;

function GetJepg(X1, Y1, X2, Y2: integer): TJpegimage;

implementation

//輸入螢幕左上、右下座標回傳一個Jpeg
function GetJepg(X1, Y1, X2, Y2: integer): TJpegimage;
var
DC: HDC;
Canvas: TCanvas;
MyBitmap: TBitmap;
begin
if X2 - X1 <=0 then
X2 := X1 + 500;
if Y2 - Y1 <=0 then
Y2 := Y1 + 500;

Canvas := TCanvas.Create;
MyBitmap := TBitmap.Create;
DC := GetDC(0);
Result := TJpegImage.Create;
try
Canvas.Handle := DC;
with Screen do
begin
MyBitmap.Width := X2 - X1;
MyBitmap.Height := Y2 - Y1;

MyBitmap.Canvas.CopyRect(
Rect(0, 0, X2 - X1, Y2 - Y1), Canvas,
Rect(X1, Y1, X2, Y2));
Result.Assign(MyBitmap);
end;
finally
{ free memory }
ReleaseDC(0, DC);
MyBitmap.Free;
Canvas.Free;
end;
end;

end.

Client端

unit WIClient_Main;

interface

uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, System.Win.ScktComp, Vcl.StdCtrls,
Vcl.ExtCtrls, Jpeg, IdBaseComponent, IdComponent, IdUDPBase, IdUDPClient,
IdTCPConnection, IdTCPClient;

type
{
TCustomThread = Class(TThread)
private
protected
procedure Execute; override;
public
constructor Create;
Destructor Destroy;
end;
}

Tfrm_WIClient = class(TForm)
Image1: TImage;
mmo_Log: TMemo;
Timer1: TTimer;
Button1: TButton;
IdTCPClient1: TIdTCPClient;
Panel1: TPanel;
Label1: TLabel;
EX1: TEdit;
Label2: TLabel;
EY1: TEdit;
Label3: TLabel;
EX2: TEdit;
Label4: TLabel;
EY2: TEdit;
Label5: TLabel;
Label6: TLabel;
procedure Timer1Timer(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
FINI: TStringList;
function GetINIPath: string;
procedure GoOnce(aType: string = '');
procedure Status(aMsg: string);
{ Private declarations }
public
procedure log(aMsg: string);
{ Public declarations }
end;

var
frm_WIClient: Tfrm_WIClient;

implementation

{$R *.dfm}

uses XBGetDC, IdGlobal;

const BufferSize = 8192;

procedure Tfrm_WIClient.Button1Click(Sender: TObject);
begin
GoOnce;
end;

procedure Tfrm_WIClient.FormClose(Sender: TObject; var Action: TCloseAction);
begin
FINI.Values['X1'] := EX1.Text;
FINI.Values['Y1'] := EY1.Text;
FINI.Values['X2'] := EX2.Text;
FINI.Values['Y2'] := EY2.Text;
FINI.SaveToFile(GetINIPath);
FINI.Free;
end;

procedure Tfrm_WIClient.FormCreate(Sender: TObject);
begin
FINI := TStringList.Create;
if not fileexists(GetINIPath) then
FINI.SaveToFile(GetINIPath);
FINI.LoadFromFile(GetINIPath);

EX1.Text := FINI.Values['X1'];
EY1.Text := FINI.Values['Y1'];
EX2.Text := FINI.Values['X2'];
EY2.Text := FINI.Values['Y2'];
end;

procedure Tfrm_WIClient.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
var p: TPoint;
begin
case Key of
VK_F1: begin
GetCurSorPos(p);
EX1.Text := inttostr(p.X);
EY1.Text := inttostr(p.Y);
end;
VK_F2: begin
GetCurSorPos(p);
EX2.Text := inttostr(p.X);
EY2.Text := inttostr(p.Y);
end;
end;
end;

function Tfrm_WIClient.GetINIPath: string;
begin
Result := ExtractFileDir(Application.ExeName) + '\setup.ini';
end;

procedure Tfrm_WIClient.GoOnce(aType: string = '');
var
jpg: TJpegImage;
MStream: TMemoryStream;
b: TIdBytes;
size, i: integer;
s: String;
begin
if aType = '' then begin
GoOnce('A'); //先傳一個A 代表要傳送圖檔了
sleep(100);
GoOnce('B'); //傳完A之後傳B 代表要收Server的圖檔
Exit;
end;

try
MStream := TMemoryStream.Create;

MStream.Seek(0, soFromBeginning);
MStream.Size := 0;

IdTCPClient1.Connect;

IdTCPClient1.IOHandler.WriteLn(aType);
Log('Client Send ' + aType);

if aType = 'A' then begin
jpg := GetJepg(
strtointdef(EX1.Text, 0),
strtointdef(EY1.Text, 0),
strtointdef(EX2.Text, 500),
strtointdef(EY2.Text, 500)
);
//image1.Picture.Assign(jpg);

jpg.SaveToStream(MStream);

MStream.Seek(0, soFromBeginning);

log('Send Start!');

IdTCPClient1.IOHandler.Write(MStream);

log('Send End!');
jpg.Free;
end else begin
Log('B ReadLn!');

try
size := strtoint(IdTCPClient1.IOHandler.ReadLn());
except
on e: Exception do
Log('Recv Error e = ' + e.ClassName + ' ' + e.Message);
end;

Log('Recv Size = ' + inttostr(size));

log('Recv Start!');

IdTCPClient1.IOHandler.ReadStream(MStream, size, False);

log('Recv End!');
MStream.Seek(0, soFromBeginning);
frm_WIClient.Image1.Picture.LoadFromStream(MStream);
end;
finally
MStream.Free;
IdTCPClient1.Disconnect;
end;
end;

procedure Tfrm_WIClient.log(aMsg: string);
begin
mmo_Log.Lines.Append(FormatDateTime('HH:NN:SS.ZZZ', now) + ' ' + aMsg);
end;

procedure Tfrm_WIClient.Status(aMsg: string);
begin
Caption := FormatDateTime('HH:NN:SS.ZZZ', now) + ' ' + aMsg;
end;

procedure Tfrm_WIClient.Timer1Timer(Sender: TObject);
begin
try
Timer1.Enabled := False;
GoOnce;
finally
Timer1.Enabled := True;
end;
end;

end.

Server端

unit WIServer_Main;

interface

uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, System.Win.ScktComp, IdUDPServer,
IdGlobal, IdSocketHandle, IdBaseComponent, IdComponent, IdUDPBase,
Vcl.ExtCtrls, Vcl.StdCtrls, IdContext, IdCustomTCPServer, IdTCPServer;

type
TForm1 = class(TForm)
Image1: TImage;
mmo_Log: TMemo;
IdTCPServer1: TIdTCPServer;
Panel1: TPanel;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
Label5: TLabel;
Label6: TLabel;
EX1: TEdit;
EY1: TEdit;
EX2: TEdit;
EY2: TEdit;
procedure FormCreate(Sender: TObject);
procedure IdTCPServer1Execute(AContext: TIdContext);
procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
private
{ Private declarations }
public
procedure log(aMsg: string);
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

uses XBGetDC, jpeg;

procedure TForm1.FormCreate(Sender: TObject);
begin
IdTCPServer1.Active := True;
end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
var p: TPoint;
begin
case Key of
VK_F1: begin
GetCurSorPos(p);
EX1.Text := inttostr(p.X);
EY1.Text := inttostr(p.Y);
end;
VK_F2: begin
GetCurSorPos(p);
EX2.Text := inttostr(p.X);
EY2.Text := inttostr(p.Y);
end;
end;
end;

procedure TForm1.IdTCPServer1Execute(AContext: TIdContext);
var
MStream: TMemoryStream;
data: TIdBytes;
jpg: TJpegImage;
size: integer;
aType: string;
begin
try
MStream := TMemoryStream.Create;
MStream.Seek(0, soFromBeginning);
MStream.Size := 0;

aType := AContext.Connection.IOHandler.ReadLn();
Log('Server Recv ' + aType);
if aType = 'A' then begin //收到A 代表要接收圖檔

Log('Recv Start');
AContext.Connection.IOHandler.ReadStream(MStream, -1, True);
{
size := AContext.Connection.IOHandler.ReadLongInt;
AContext.Connection.IOHandler.ReadStream(MStream, size);
}
Log('Recv End');

MStream.Seek(0, soFromBeginning);
Image1.Picture.LoadFromStream(MStream);
end else begin //收到B代表要傳送圖檔

Log('B1');

jpg := GetJepg(
strtointdef(EX1.Text, 0),
strtointdef(EY1.Text, 0),
strtointdef(EX2.Text, 500),
strtointdef(EY2.Text, 500)
);

Log('B2');

try
jpg.SaveToStream(MStream);
except
on e:Exception do begin
Log('Send Size = ' + inttostr(size) + ' e = ' + e.ClassName + ' ' + e.Message);
AContext.Connection.IOHandler.WriteLn(inttostr(size));
Exit;
end;
end;

Log('B3');

MStream.Seek(0, soFromBeginning);

size := MStream.Size;

Log('Send Size = ' + inttostr(size));

AContext.Connection.IOHandler.WriteLn(inttostr(size));

Log('Send Start');

AContext.Connection.IOHandler.Write(MStream);

Log('Send End');

jpg.Free;
end;
finally
MStream.Free;
end;
end;

procedure TForm1.log(aMsg: string);
begin
mmo_Log.Lines.Append(FormatDateTime('HH:NN:SS.ZZZ', now) + ' ' + aMsg);
end;

end.

抓狂小白

抓狂小白的程式筆記

抓狂小白發表在痞客邦留言(0) 人氣()

E-mail轉寄

抓狂小白的程式筆記

之前無聊到跑去知識加回答一些程式問題然後驚覺之前學得很多種程式語言都退化了所以開了這個部落格做筆記主要精通Delphi 其他程式語言還在新手階段由於想試試自己的身手及能耐若有甚麼小程式需要幫忙的歡迎留言

delphi Tcp + Stream 兩台電腦互相傳遞畫面

留言列表

我的連結

熱門文章

文章分類

JSP (2)

Delphi (19)

JAVA (2)

Windows API (2)

VB (1)

PHP (3)

C (2)

DataBase (2)

Python (2)

最新文章

最新留言

文章搜尋

參觀人氣

QR Code

抓狂小白的程式筆記

之前無聊到跑去知識加回答一些程式問題 然後驚覺之前學得很多種程式語言都退化了 所以開了這個部落格做筆記 主要精通Delphi 其他程式語言還在新手階段 由於想試試自己的身手及能耐 若有甚麼小程式需要幫忙的歡迎留言

delphi Tcp + Stream 兩台電腦互相傳遞畫面

留言列表

我的連結

熱門文章

文章分類

JSP (2)

Delphi (19)

JAVA (2)

Windows API (2)

VB (1)

PHP (3)

C (2)

DataBase (2)

Python (2)

最新文章

最新留言

文章搜尋

參觀人氣

QR Code

之前無聊到跑去知識加回答一些程式問題然後驚覺之前學得很多種程式語言都退化了所以開了這個部落格做筆記主要精通Delphi 其他程式語言還在新手階段由於想試試自己的身手及能耐若有甚麼小程式需要幫忙的歡迎留言