下面是关于上面的一个调用例子.很简单的一个例子,在局部网内同时对N台电脑进行监控.
//----------------------
unit MyRecvStream;
interface
uses
Classes,Forms,Windows,Graphics,Sysutils,MySocket, ComCtrls,ExtCtrls,MyPing;
type
TRecvStreamThread = class(TThread)
private
{ Private declarations }
protected
procedure Execute; override;
function LoadImage(Image1:TImage):Boolean;
public
RemoteAddress:String; // 远程主机IP
RemotePort:integer; // 远程主机Port
RemoteScreen:TImage; // 显示图象的对象指针
StatusBar: TStatusBar;
end;
implementation
{ Important: Methods and properties of objects in VCL can only be used in a
method called using Synchronize, for example,
Synchronize(UpdateCaption);
and UpdateCaption could look like,
procedure TRecvStreamThread.UpdateCaption;
begin
Form1.Caption := 'Updated in a thread';
end; }
{ TRecvStreamThread }
procedure TRecvStreamThread.Execute;
begin
{ Place thread code here }
if (LoadImage(RemoteScreen))
then
StatusBar.SimpleText := '数据接收完毕'
else
StatusBar.SimpleText := '接收数据失败';
end;
function TRecvStreamThread.LoadImage(Image1:TImage):Boolean;
var
bRtn:boolean;
RecvSocket:integer;
Stream:TMemoryStream;
RecvPort
integer;
begin
bRtn:= False; // 函数返回值初始为FALSE
StatusBar.SimpleText := '正在连接主机...';
bRtn:=Ping(RemoteAddress,4000);
if bRtn then
begin
bRtn:=False; //返回值再次初始为FALSE
new(RecvPort);
RecvPort^:=0;
RecvSocket := BindSocket(RecvPort); // 动态分配接收端口
if RecvSocket<>0 then
begin
if (SendMsg(RemoteAddress,RemotePort,inttostr(RecvPort^))) then// 向远程主机发送命令
begin
Stream:=TMemoryStream.Create;// 定义一个数据流并分配内存
try
// StatusBar.SimpleText := '正在接收数据...';
Application.ProcessMessages; // 处理系统消息
if (RecvStream(RecvSocket,Stream)) then // 开始接收图象到数据流中
begin
Image1.Picture.Bitmap.LoadFromStream(Stream);
MessageBeep(MB_OK); // 发出提示声音
bRtn := true; // 返回值为TRUE,表示成功
end
else
MessageBox(0,'接收数据流失败','',MB_ICONERROR);
finally
Stream.Free;
end; //try
end
else
MessageBox(0,'无法与主机建立连接', '',MB_ICONERROR);
end
else
MessageBox(0,'分配端口失败,无法继续接收数据','',MB_ICONERROR);
end
else
MessageBox(0,Pchar('主机'+RemoteAddress+'没有响应'),'',MB_ICONERROR);
Result:=bRtn;
end;
end.
//--------------------------------------------------
unit Main;
interface
uses Windows, SysUtils, Classes, Graphics, Forms, Controls, Menus,
StdCtrls, Dialogs, Buttons, Messages, ExtCtrls, ComCtrls, StdActns,
ActnList, ToolWin, ImgList, ScktComp, ExtDlgs;
type
TMainForm = class(TForm)
MainMenu1: TMainMenu;
File1: TMenuItem;
FileNewItem: TMenuItem;
FileCloseItem: TMenuItem;
Window1: TMenuItem;
Help1: TMenuItem;
N1: TMenuItem;
FileExitItem: TMenuItem;
WindowCascadeItem: TMenuItem;
WindowTileItem: TMenuItem;
WindowArrangeItem: TMenuItem;
HelpAboutItem: TMenuItem;
OpenDialog: TOpenDialog;
FileSaveItem: TMenuItem;
FileSaveAsItem: TMenuItem;
Edit1: TMenuItem;
CutItem: TMenuItem;
CopyItem: TMenuItem;
PasteItem: TMenuItem;
WindowMinimizeItem: TMenuItem;
StatusBar: TStatusBar;
ActionList1: TActionList;
EditCut1: TEditCut;
EditCopy1: TEditCopy;
EditPaste1: TEditPaste;
FileNew1: TAction;
FileSave1: TAction;
FileExit1: TAction;
FileOpen1: TAction;
FileSaveAs1: TAction;
WindowCascade1: TWindowCascade;
WindowTileHorizontal1: TWindowTileHorizontal;
WindowArrangeAll1: TWindowArrange;
WindowMinimizeAll1: TWindowMinimizeAll;
HelpAbout1: TAction;
FileClose1: TWindowClose;
WindowTileVertical1: TWindowTileVertical;
WindowTileItem2: TMenuItem;
ToolBar2: TToolBar;
ToolButton1: TToolButton;
ToolButton2: TToolButton;
ToolButton3: TToolButton;
ToolButton4: TToolButton;
ToolButton5: TToolButton;
ToolButton6: TToolButton;
ToolButton9: TToolButton;
ToolButton7: TToolButton;
ToolButton8: TToolButton;
ToolButton10: TToolButton;
ToolButton11: TToolButton;
ImageList1: TImageList;
ServerSocket1: TServerSocket;
PortCheck: TMenuItem;
SavePictureDialog1: TSavePictureDialog;
procedure FileNew1Execute(Sender: TObject);
procedure HelpAbout1Execute(Sender: TObject);
procedure FileExit1Execute(Sender: TObject);
procedure ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
procedure PortCheckClick(Sender: TObject);
procedure ServerSocket1ClientError(Sender: TObject;
Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer);
private
{ Private declarations }
procedure CreateMDIChild(const Name: string);
public
{ Public declarations }
end;
var
MainForm: TMainForm;
implementation
{$R *.DFM}
uses ChildWin, Myping,About, Unit1,MySocket,MyRecvStream,My_StreamManage;
procedure TMainForm.CreateMDIChild(const Name: string);
var
Child: TMDIChild;
begin
{ create a new MDI child window }
Child := TMDIChild.Create(Application);
Child.RemoteAddress:=Name;
Child.Caption := Name;
Child.Image1.OnDblClick(nil);
// if FileExists(Name) then Child.Memo1.Lines.LoadFromFile(Name);
end;
procedure TMainForm.FileNew1Execute(Sender: TObject);
begin
if ConfigForm.ShowModal=mrok then
CreateMDIChild(ConfigForm.ComboBox1.Text);// + IntToStr(MDIChildCount + 1));
end;
procedure TMainForm.HelpAbout1Execute(Sender: TObject);
begin
AboutBox.ShowModal;
end;
procedure TMainForm.FileExit1Execute(Sender: TObject);
begin
Close;
end;
procedure TMainForm.ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
var
sRecvString:string;
sRemoteAddress:string;
MyScreen:TMemoryStream;
begin
sRecvString:= Socket.ReceiveText; // 保存接收到的字符串
sRemoteAddress:= Socket.RemoteAddress; // 保存对方IP
MyScreen:=TMemoryStream.Create;
My_GetScreenToBmp(False,MyScreen);
SendStream(sRemoteAddress,strtoint(sRecvString),MyScreen);
{if SendStream(sRemoteAddress,strtoint(sRecvString),MyScreen)
then showmessage('ok')
else
Showmessage('no'); }
MyScreen.Free;
end;
procedure TMainForm.PortCheckClick(Sender: TObject);
begin
PortCheck.Checked:=NOT(PortCheck.Checked);
ServerSocket1.Active:=PortCheck.Checked;
end;
procedure TMainForm.ServerSocket1ClientError(Sender: TObject;
Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer);
begin
ErrorCode:=0;
MessageBox(0,'远程连接出错','',MB_ICONERROR); // 显示出错信息
end;
end.
//--------------------------------------------------------
至于屏幕发送,还是自己写了一个单元.800X600的情况下处理后只有560字节.
unit My_StreamManage;
interface
uses Windows,Classes,Graphics,Forms,Controls;
procedure My_GetScreenToBmp(DrawCur:Boolean;StreamName:TMemoryStream);
procedure My_CompareStream(MyFirstStream,MySecondStream,MyCompareStream:TMemorystream);
procedure My_ResumeStream(MyFirstStream,MySecondStream,MyCompareStream:TMemorystream);
implementation
procedure My_GetScreenToBmp(DrawCur:Boolean;StreamName:TMemoryStream);
var
Mybmp:Tbitmap;
Cursorx, Cursory: integer;
dc: hdc;
Mycan: Tcanvas;
R: TRect;
DrawPos: TPoint;
MyCursor: TIcon;
hld: hwnd;
Threadld: dword;
mp: tpoint;
pIconInfo: TIconInfo;
begin
Mybmp := Tbitmap.Create; {建立BMPMAP }
Mycan := TCanvas.Create; {屏幕截取}
dc := GetWindowDC(0);
try
Mycan.Handle := dc;
R := Rect(0, 0, Screen.Width,Screen.Height{GetSystemMetrics(SM_CXSCREEN), GetSystemMetrics(SM_CYSCREEN)});
Mybmp.Width := R.Right;
Mybmp.Height := R.Bottom;
Mybmp.Canvas.CopyRect(R, Mycan, R);
finally
releaseDC(0, DC);
end;
Mycan.Handle := 0;
Mycan.Free;
if DrawCur then {画上鼠标图象}
begin
GetCursorPos(DrawPos);
MyCursor := TIcon.Create;
getcursorpos(mp);
hld := WindowFromPoint(mp);
Threadld := GetWindowThreadProcessId(hld, nil);
AttachThreadInput(GetCurrentThreadId, Threadld, True);
MyCursor.Handle := Getcursor();
AttachThreadInput(GetCurrentThreadId, threadld, False);
GetIconInfo(Mycursor.Handle, pIconInfo);
cursorx := DrawPos.x - round(pIconInfo.xHotspot);
cursory := DrawPos.y - round(pIconInfo.yHotspot);
Mybmp.Canvas.Draw(cursorx, cursory, MyCursor); {画上鼠标}
DeleteObject(pIconInfo.hbmColor);{GetIconInfo 使用时创建了两个bitmap对象. 需要手工释放这两个对象}
DeleteObject(pIconInfo.hbmMask);{否则,调用他后,他会创建一个bitmap,多次调用会产生多个,直至资源耗尽}
Mycursor.ReleaseHandle; {释放数组内存}
MyCursor.Free; {释放鼠标指针}
end;
Mybmp.PixelFormat:=pf8bit; //256色
//Mybmp.SaveToFile(Filename);
Mybmp.SaveToStream(StreamName);
Mybmp.Free;
end;
procedure My_CompareStream(MyFirstStream,MySecondStream,MyCompareStream:TMemorystream);
begin
//MyFirstStream.Position:=0;MySecondStream.Position:=0;MyCompareStream.Position:=0; //必须
..............