N
norman520
Unregistered / Unconfirmed
GUEST, unregistred user!
求远程/局域网屏幕监控源码,能测试通过马上结贴
F
fc182
Unregistered / Unconfirmed
GUEST, unregistred user!
可以到2ccc上看看
我也在找
还没找到好的
--------------------
我也加300分,希望这方面的高手,帮帮忙
我也在找
还没找到好的
--------------------
我也加300分,希望这方面的高手,帮帮忙
J
jerry553
Unregistered / Unconfirmed
GUEST, unregistred user!
网上不是有很多资源下载的么? 谁说 2ccc没有. 上面不是有个huigezi的源码么.?
下面我帖上的是jingtao的代码...
<<INTENET屏幕极速传输开发文档>>目录
一:传统的屏幕传输方法与缺点
二:极速屏幕传输的方法与实现
三:程序流程图与细节
四:后记
附录:
一:压缩方法简介
二:传统的屏幕传输方法代码
三:服务端客户端公共代码列表
<<网络极速屏幕传输>>开发文档
一:传统的屏幕传输方法与缺点
传统的屏幕传输采用的是这样的方法: 抓取屏幕--à传输--à显示图像,此为完成传输一幅的过程.不断重复此过程即可实现屏幕监控.但是这种方法因为图像数据容量大,而网络实际信道容量是有限的,所以效果很不理想,具体表现就是每幅图像之间间隔时间长.后来发展到抓取屏幕-à压缩数据-à传输-à解压缩-à显示图像.这样做速度的确有所提高.但是在INTENET上面效果仍然不好.
二:极速屏幕传输的方法与实现
针对上面的情况,我们研究屏幕图像后发现,实际应用中屏幕变化的时候经常变的只是一小部分区域.有时侯(比如说浏览文本文件的时候)屏幕根本不作任何变化.而传统方法只是机械的重复传输整个屏幕的内容.如果我们每次只发送变化的区域部分,那么速度就会显著提高.
在INTENET上面的测试结果如下:客户端
湖北武汉)ISDN64KB上网局域网接入. 服务端:中山大学宽带接入的.服务端屏幕800X600X256色.屏幕变化不大的时候(比如说在用QQ在聊天),1~2秒钟可以看到一幅.如果变化大的话(比如说新开一个网页)要四秒钟甚至更长时间.
为了减少数据量,除了压缩图像外,可以先把图像转化为256色.我们使用了一个自定义函数来抓取屏幕然后转化为256色. My_GetScreenToBmp(DrawCur:Boolean;StreamName:TMemoryStream);注意函数里面的的Mybmp.PixelFormat:=pf8bit; 它的作用就是转化屏幕为256色图像.
关于如何比较:比如说我们第一副图像的数据为abcdefg,第二副图像数据为abcdefh,把数据相同的数据位标记为0,不同的记录下来.那么对比后可以得到第三副图像的数据为000000g.还原的时候,把第三副图像与第二幅图像比较,就可以得到第一幅图像数据abcdefg.
为什么比较后压缩数据会变小: .可以作个比较:一个文件全部为字符0,另外一个文件字符为不规则字符.压缩前两个文件一样大小,压缩后差别却很大.具体原理见附录.
下面是程序流程图:具体实现请参考代码.
四:后记
因为时间关系,很多地方没有做.还有需要改进的地方:
1:目前只是比较整个屏幕的变化.即使屏幕无变化的话也有几十个字节的数据量(全部为0).可以在发送前比较后作判断:如果无变化那么就发信息叫服务端重新输出原来的内容一次即可而不用重新传输一次.
2: 目前只是比较整个屏幕的变化.即使是屏幕某个小区域变化也把其它无变化的添加进去了.如果改为把屏幕切割称成为4X4块再比较的话速度更快.比如说现在屏幕只是第16块变化了一点,那么我们只要发送此块即可.
3:选择好的压缩算法.我们现在用的是LHARC压缩算法.我们知道:凡是压缩算法肯定是以牺牲CPU时间来达到目的的.LHARC算法不是最好的算法.
4:本算法只适应INTENET.因为,在局部网的话传输789KB的内容与传输536字节(不到1KB)速度是没有多大区别的.而且数据比较后还压缩.压缩就得占用时间.但是在INTENET上面,传输789KB跟传输536字节的区别是非常大的.
附录:
一:压缩方法简介
1、压缩（Encode）
??假设我们有一些数据：
a b a b a b a b c d d d a a b c d b a
怎么样才能使上面的数据变短呢？一般来说毫无规律的字符数据中经常回出现一些重复的串，象上面的“ab”“cd”，如果能将数据中重复出现的串用一个简短的代码表示出来不就做到了数据压缩了吗？但是我们并不知道到底哪些串会重复，难道要事先将所有数据扫描一遍吗？而且有这种情况，比如说当遇到“a b c d e”串时，到底是把它看成一个串还是将它分成“a b”+“c d e”或其它呢？
有时候想得太复杂不是件好事，可以把事情想得简单一些，我们完全可以在逐个读入数据的时候动态创建一个表来记录数据中重复的串，考虑到我们输出的是代表相应串的代码，假设压缩的是一字节为单位的字符串，所以在建立表时必须先把0 — 255代表的单个字符先放到表中，保证在压缩的时候一定能找到重复的串（至少跟自己本身重复嘛），然后再根据逐个读入的字符来添加我们的表项。当然记录重复串的表不能无限扩大，当大到了一定程度必须将其清空重新来过，所以要保留一个表项（256）为表清空标识，另外为了让我们在解压的时候知道什么时候解压结束，还要保留一个数据结束标识（257），下面就看看压缩的过程。首先初始化表，底49-53项的内容分别是“a”、“b”、“c”、“d”第256，257项留空，初始位置为第258项步骤：
1）每次将读入当前字符和前一次找到重复的字符串叠加生成新串（后称当前串）并在表中查找。
2）如果找到相同的串则跳到第一步继续查找以期待更长的重复串。
3）找不到重复串时将上一次匹配的重复串的相应代码输出，并将“当前串”做为新串添加到表中。
4）将“当前串”设为本次读入的字符，（不用找都知道肯定在表中），在表中找到重复串所以重复第一步。
读入的字符 上次的当前串 串叠加结果 查找重复项 输出代码 新添加表项 当前串重新赋值
a 无 a 97(a)
b a ab 无 97 258:ab 98(b)
a b ba 无 98 259:ba 97(a)
b a ab 258(ab)
a ab aba 无 258 260:aba 97(a)
b a ab 258(ab)
a ab aba 260(aba)
b aba abab 无 260 261:abab 98(b)
c b bc 无 98 262:bc 99(c)
d c cd 无 99 263:cd 100(d)
d d dd 无 100 264:dd 100(d)
d d dd 264(dd)
a dd dda 无 264 265:dda 97(a)
a a aa 无 97 266:aa 97(a)
b a ab 258(ab)
c ab abc 无 258 267:abc 99(c)
d c cd 263(cd)
b cd cdb 无 263 268cdb) 98(b)
a b ba 259(ba)
结束 259
流结束标志
表1
上面的压缩步骤应该是很容易理解吧？不过别以为这样就可以了，仔细观察一下就知道了，输出代码部分有超过255的数据，就是说不能用一个字节来表示，那怎么办呢？其实这样的话我们要摈弃传统的思想，不要把输出流看成是以字节为单位的字符串流，而要用位（bit）来做单位，在表项小于512时每次输出的代码占用9bit，大于等于512小于1024时占10bit依此类推动态增加每次输出代码所占用的位数，如果表过长其输出代码就要占用足够多的位数，现在该知道为什么当表到了一定程度就要清空了吧，通常表项数最大为4096项。
2、解压缩（Decode）
??解压缩和压缩的过程很相似，也是动态地生成一个串表然后根据读入的代码将压缩数据还原，虽然不太好理解但是解压缩的实现过程要比压缩过程简单得多，为什么这么说？首先观察一下压缩代码生成的特征，每输出一次代码则表中必定新建了一个表项，为了让解压缩时和压缩时创建的表一致，所以我们在读入一个代码时就要在表中新建立一个表项，看看下面的解压缩过程：
注意：在做字符串合并时只合并一个字符， 即如果当前读入的代码表示的字符串是“ab”的话我们只将“a”合并到原字符串末，如果当前读入的代码表示的字符串表项还未建立，则使用原来（即上一次读入的字符串）内容。
输出数据 读入的字符 combine new table
a a
a b ab 258:ab
b 258(ab) bab 259:ba
258(ab) 260(空，用原值ab) abab 260:aba
260(aba) b ab 261:abab
b c bc 262:bc
c d cd 263:cd
d 264(空，用原值d) dd 264:dd
264(dd) a da 265:da
a 258(ab) aab 266:aa
258(ab) 263(cd) abcd 267:abc
263(cd) 259(ba) cdba 268:cdb
259(ba) END
解压缩过程
??上面的实现步骤非常简单吧，只不过有些步骤（如只合并一个字符）不太容易理解为什么要这么做？但是只从程序编写的角度来说是件轻而易举的事情。
3、程序实现
编程上面最困难的就是讨厌的位处理了，因为编译器的限制对变量的处理是以8bit的倍数为单位的，就是说要想实现任意位数代码流必须经过很多的位移、位与操作，比如说：
|--01--||--02--||--03--||--04--||--05--||--06--|
123456781234567812345678123456781234567812345678
-------------^
假设当前代码流已经输出了13bit（即接下来的输出代码将从第02个字节的第6位开始）
|--01--||--02--||--03--||--04--||--05--||--06--|
123456781234567812345678123456781234567812345678
-------------*******010011101011^
现在获得下一个输出代码为010011101011共有12bit。由最大4096可只输出代码最长为12bit，最多跨度为三个字节，如果直接跟接下来的三个字节进行位与操作显然错位了。
|--01--||--02--||--03--||--04--||--05--||--06--|
123456781234567812345678123456781234567812345678
-------------010011101011^
必须先进行位移操作再位与操作，不难计算出需要位移的位数为：
24-代码位数-(输出流位置%8)=24-12-13%8=7
表2
??解压缩时就是以上步骤的逆运算：
|--01--||--02--||--03--||--04--||--05--||--06--|
123456781234567812345678123456781234567812345678
--------*****010011101011*******
^
设当前位置是第13bit，下一个代码长度为12bit，因为代码最多可能跨字节数为3，所以先把后3个字节的内容读出存到一个长整型变量中得到*****010011101011*******然后左移当前代码位置%8=13%8=5位再向右移24-代码位数=24-12=12位即可得到010011101011。
表3
二:传统的屏幕传输方法
利用流实现网络传输屏幕图像(作者:陈经韬.此文已经发表于<<电脑商情报>>)
大家应该见过很多网管程序，这类程序其中有一个功能就是监控远程电脑的屏幕。实际上，这也是利用流操作来实现的。下面我们给出一个例子，这个例子分两个程序，一个服务端，一个是客户端。程序编译后可以直接在单机、局部网或者互联网上使用。程序中已经给出相应注释。后面我们再来作具体分析。
新建一个工程，在Internet面版上拖一个ServerSocket控件到窗口，该控件主要用于监听客户端，用来与客户端建立连接和通讯。设置好监听端口后调用方法Open或者Active:=True即开始工作。注意：跟前面的NMUDP不同，当Socket开始监听后就不能再改变它的端口，要改变的话必须先调用Close或设置Active为False，否则将会产生异常。另外，如果该端口已经打开的话，就不能再用这个端口了。所以程序运行尚未退出就不能再运行这个程序，否则也会产生异常，即弹出出错窗口。实际应用中可以通过判断程序是否已经运行，如果已经运行就退出的方法来避免出错。
当客户端有数据传入，将触发ServerSocket1ClientRead事件，我们可以在这里对接收的数据进行处理。在本程序中，主要是接收客户端发送过来的字符信息并根据事先的约定来进行相应操作。
程序全部代码如下：
unit Unit1;{服务端程序}
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, JPEG,ExtCtrls, ScktComp;
type
TForm1 = class(TForm)
ServerSocket1: TServerSocket;
procedure ServerSocket1ClientRead(Sender: TObject;Socket: TCustomWinSocket);
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
procedure Cjt_GetScreen(var Mybmp: TBitmap; DrawCur: Boolean);
{自定义抓屏函数,DrawCur表示抓鼠标图像与否}
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
MyStream: TMemorystream;{内存流对象}
implementation
{$R *.DFM}
procedure TForm1.Cjt_GetScreen(var Mybmp: TBitmap; DrawCur: Boolean);
var
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);
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;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
ServerSocket1.Port := 3000; {端口}
ServerSocket1.Open; {Socket开始侦听}
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if ServerSocket1.Active then ServerSocket1.Close; {关闭Socket}
end;
procedure TForm1.ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
var
S, S1: string;
MyBmp: TBitmap;
Myjpg: TJpegimage;
begin
S := Socket.ReceiveText;
if S = 'cap' then {客户端发出抓屏幕指令}
begin
try
MyStream := TMemorystream.Create;{建立内存流}
MyBmp := TBitmap.Create;
Myjpg := TJpegimage.Create;
Cjt_GetScreen(MyBmp, True); {True表示抓鼠标图像}
Myjpg.Assign(MyBmp); {将BMP图象转成JPG格式,便于在互联网上传输}
Myjpg.CompressionQuality := 10; {JPG文件压缩百分比设置,数字越大图像越清晰,但数据也越大}
Myjpg.SaveToStream(MyStream); {将JPG图象写入流中}
Myjpg.free;
MyStream.Position := 0;{注意:必须添加此句}
s1 := inttostr(MyStream.size);{流的大小}
Socket.sendtext(s1); {发送流大小}
finally
MyBmp.free;
end;
end;
if s = 'ready' then {客户端已准备好接收图象}
begin
MyStream.Position := 0;
Socket.SendStream(MyStream); {将流发送出去}
end;
end;
end.
上面是服务端，下面我们来写客户端程序。新建一个工程，添加Socket控件ClientSocket、图像显示控件Image、一个 Panel 、一个Edit、两个 Button和一个状态栏控件StatusBar1。注意：把Edit1和两个 Button放在Panel1上面。ClientSocket的属性跟ServerSocket差不多，不过多了一个Address属性，表示要连接的服务端IP地址。填上IP地址后点“连接”将与服务端程序建立连接，如果成功就可以进行通讯了。点击“抓屏”将发送字符给服务端。因为程序用到了JPEG图像单元，所以要在Uses中添加Jpeg.
全部代码如下：
unit Unit2{客户端};
interface
uses
Windows,Messages,SysUtils,Classes,Graphics,Controls,Forms,Dialogs,StdCtrls,ScktComp,ExtCtrls,Jpeg, ComCtrls;
type
TForm1 = class(TForm)
ClientSocket1: TClientSocket;
Image1: TImage;
StatusBar1: TStatusBar;
Panel1: TPanel;
Edit1: TEdit;
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure ClientSocket1Connect(Sender: TObject;
Socket: TCustomWinSocket);
procedure Button2Click(Sender: TObject);
procedure ClientSocket1Error(Sender: TObject; Socket: TCustomWinSocket;
ErrorEvent: TErrorEvent; var ErrorCode: Integer);
procedure ClientSocket1Read(Sender: TObject; Socket: TCustomWinSocket);
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure ClientSocket1Disconnect(Sender: TObject;
Socket: TCustomWinSocket);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
MySize: Longint;
MyStream: TMemorystream;{内存流对象}
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
{-------- 下面为设置窗口控件的外观属性 ------------- }
{注意:把Button1、Button2和Edit1放在Panel1上面}
Edit1.Text := '127.0.0.1';
Button1.Caption := '连接主机';
Button2.Caption := '抓屏幕';
Button2.Enabled := false;
Panel1.Align := alTop;
Image1.Align := alClient;
Image1.Stretch := True;
StatusBar1.Align:=alBottom;
StatusBar1.SimplePanel := True;
{----------------------------------------------- }
MyStream := TMemorystream.Create; {建立内存流对象}
MySize := 0; {初始化}
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if not ClientSocket1.Active then
begin
ClientSocket1.Address := Edit1.Text; {远程IP地址}
ClientSocket1.Port := 3000; {Socket端口}
ClientSocket1.Open; {建立连接}
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
Clientsocket1.Socket.SendText('cap'); {发送指令通知服务端抓取屏幕图象}
Button2.Enabled := False;
end;
procedure TForm1.ClientSocket1Connect(Sender: TObject;
Socket: TCustomWinSocket);
begin
StatusBar1.SimpleText := '与主机' + ClientSocket1.Address + '成功建立连接!';
Button2.Enabled := True;
end;
procedure TForm1.ClientSocket1Error(Sender: TObject;
Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer);
begin
Errorcode := 0; {不弹出出错窗口}
StatusBar1.SimpleText := '无法与主机' + ClientSocket1.Address + '建立连接!';
end;
procedure TForm1.ClientSocket1Disconnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
StatusBar1.SimpleText := '与主机' + ClientSocket1.Address + '断开连接!';
Button2.Enabled := False;
end;
procedure TForm1.ClientSocket1Read(Sender: TObject;
Socket: TCustomWinSocket);
var
MyBuffer: array[0..10000] of byte; {设置接收缓冲区}
MyReceviceLength: integer;
S: string;
MyBmp: TBitmap;
MyJpg: TJpegimage;
begin
StatusBar1.SimpleText := '正在接收数据......';
if MySize = 0 then {MySize为服务端发送的字节数，如果为0表示为尚未开始图象接收}
begin
S := Socket.ReceiveText;
MySize := Strtoint(S); {设置需接收的字节数}
Clientsocket1.Socket.SendText('ready'); {发指令通知服务端开始发送图象}
end
else
begin {以下为图象数据接收部分}
MyReceviceLength := socket.ReceiveLength; {读出包长度}
StatusBar1.SimpleText := '正在接收数据,数据大小为:' + inttostr(MySize);
Socket.ReceiveBuf(MyBuffer, MyReceviceLength); {接收数据包并读入缓冲区内}
MyStream.Write(MyBuffer, MyReceviceLength); {将数据写入流中}
if MyStream.Size >= MySize then {如果流长度大于需接收的字节数，则接收完毕}
begin
MyStream.Position := 0;
MyBmp := tbitmap.Create;
MyJpg := tjpegimage.Create;
try
MyJpg.LoadFromStream(MyStream); {将流中的数据读至JPG图像对象中}
MyBmp.Assign(MyJpg); {将JPG转为BMP}
StatusBar1.SimpleText := '正在显示图像';
Image1.Picture.Bitmap.Assign(MyBmp); {分配给image1元件 }
finally {以下为清除工作 }
MyBmp.free;
MyJpg.free;
Button2.Enabled := true;
{ Socket.SendText('cap');添加此句即可连续抓屏 }
MyStream.Clear;
MySize := 0;
end;
end;
end;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
MyStream.Free; {释放内存流对象}
if ClientSocket1.Active then ClientSocket1.Close; {关闭Socket连接}
end;
end.
程序原理：运行服务端开始侦听，再运行客户端，输入服务端IP地址建立连接，然后发一个字符通知服务端抓屏幕。服务端调用自定义函数Cjt_GetScreen抓取屏幕存为BMP，把BMP转换成JPG，把JPG写入内存流中，然后把流发送给客户端。客户端接收到流后做相反操作，将流转换为JPG再转换为BMP然后显示出来。
注意：因为Socket的限制，不能一次发送过大的数据，只能分几次发。所以程序中服务端抓屏转换为流后先发送流的大小，通知客户端这个流共有多大，客户端根据这个数字大小来判断是否已经接收完流，如果接收完才转换并显示。
三:服务端客户端公共代码列表:
1: Lh5Unit.pas:LHArc压缩解压缩单元文件
2: My_StreamManage.pas:抓屏幕,比较流和还原流单元
(全文完)
下面我帖上的是jingtao的代码...
<<INTENET屏幕极速传输开发文档>>目录
一:传统的屏幕传输方法与缺点
二:极速屏幕传输的方法与实现
三:程序流程图与细节
四:后记
附录:
一:压缩方法简介
二:传统的屏幕传输方法代码
三:服务端客户端公共代码列表
<<网络极速屏幕传输>>开发文档
一:传统的屏幕传输方法与缺点
传统的屏幕传输采用的是这样的方法: 抓取屏幕--à传输--à显示图像,此为完成传输一幅的过程.不断重复此过程即可实现屏幕监控.但是这种方法因为图像数据容量大,而网络实际信道容量是有限的,所以效果很不理想,具体表现就是每幅图像之间间隔时间长.后来发展到抓取屏幕-à压缩数据-à传输-à解压缩-à显示图像.这样做速度的确有所提高.但是在INTENET上面效果仍然不好.
二:极速屏幕传输的方法与实现
针对上面的情况,我们研究屏幕图像后发现,实际应用中屏幕变化的时候经常变的只是一小部分区域.有时侯(比如说浏览文本文件的时候)屏幕根本不作任何变化.而传统方法只是机械的重复传输整个屏幕的内容.如果我们每次只发送变化的区域部分,那么速度就会显著提高.
在INTENET上面的测试结果如下:客户端
湖北武汉)ISDN64KB上网局域网接入. 服务端:中山大学宽带接入的.服务端屏幕800X600X256色.屏幕变化不大的时候(比如说在用QQ在聊天),1~2秒钟可以看到一幅.如果变化大的话(比如说新开一个网页)要四秒钟甚至更长时间.为了减少数据量,除了压缩图像外,可以先把图像转化为256色.我们使用了一个自定义函数来抓取屏幕然后转化为256色. My_GetScreenToBmp(DrawCur:Boolean;StreamName:TMemoryStream);注意函数里面的的Mybmp.PixelFormat:=pf8bit; 它的作用就是转化屏幕为256色图像.
关于如何比较:比如说我们第一副图像的数据为abcdefg,第二副图像数据为abcdefh,把数据相同的数据位标记为0,不同的记录下来.那么对比后可以得到第三副图像的数据为000000g.还原的时候,把第三副图像与第二幅图像比较,就可以得到第一幅图像数据abcdefg.
为什么比较后压缩数据会变小: .可以作个比较:一个文件全部为字符0,另外一个文件字符为不规则字符.压缩前两个文件一样大小,压缩后差别却很大.具体原理见附录.
下面是程序流程图:具体实现请参考代码.
四:后记
因为时间关系,很多地方没有做.还有需要改进的地方:
1:目前只是比较整个屏幕的变化.即使屏幕无变化的话也有几十个字节的数据量(全部为0).可以在发送前比较后作判断:如果无变化那么就发信息叫服务端重新输出原来的内容一次即可而不用重新传输一次.
2: 目前只是比较整个屏幕的变化.即使是屏幕某个小区域变化也把其它无变化的添加进去了.如果改为把屏幕切割称成为4X4块再比较的话速度更快.比如说现在屏幕只是第16块变化了一点,那么我们只要发送此块即可.
3:选择好的压缩算法.我们现在用的是LHARC压缩算法.我们知道:凡是压缩算法肯定是以牺牲CPU时间来达到目的的.LHARC算法不是最好的算法.
4:本算法只适应INTENET.因为,在局部网的话传输789KB的内容与传输536字节(不到1KB)速度是没有多大区别的.而且数据比较后还压缩.压缩就得占用时间.但是在INTENET上面,传输789KB跟传输536字节的区别是非常大的.
附录:
一:压缩方法简介
1、压缩（Encode）
??假设我们有一些数据：
a b a b a b a b c d d d a a b c d b a
怎么样才能使上面的数据变短呢？一般来说毫无规律的字符数据中经常回出现一些重复的串，象上面的“ab”“cd”，如果能将数据中重复出现的串用一个简短的代码表示出来不就做到了数据压缩了吗？但是我们并不知道到底哪些串会重复，难道要事先将所有数据扫描一遍吗？而且有这种情况，比如说当遇到“a b c d e”串时，到底是把它看成一个串还是将它分成“a b”+“c d e”或其它呢？
有时候想得太复杂不是件好事，可以把事情想得简单一些，我们完全可以在逐个读入数据的时候动态创建一个表来记录数据中重复的串，考虑到我们输出的是代表相应串的代码，假设压缩的是一字节为单位的字符串，所以在建立表时必须先把0 — 255代表的单个字符先放到表中，保证在压缩的时候一定能找到重复的串（至少跟自己本身重复嘛），然后再根据逐个读入的字符来添加我们的表项。当然记录重复串的表不能无限扩大，当大到了一定程度必须将其清空重新来过，所以要保留一个表项（256）为表清空标识，另外为了让我们在解压的时候知道什么时候解压结束，还要保留一个数据结束标识（257），下面就看看压缩的过程。首先初始化表，底49-53项的内容分别是“a”、“b”、“c”、“d”第256，257项留空，初始位置为第258项步骤：
1）每次将读入当前字符和前一次找到重复的字符串叠加生成新串（后称当前串）并在表中查找。
2）如果找到相同的串则跳到第一步继续查找以期待更长的重复串。
3）找不到重复串时将上一次匹配的重复串的相应代码输出，并将“当前串”做为新串添加到表中。
4）将“当前串”设为本次读入的字符，（不用找都知道肯定在表中），在表中找到重复串所以重复第一步。
读入的字符 上次的当前串 串叠加结果 查找重复项 输出代码 新添加表项 当前串重新赋值
a 无 a 97(a)
b a ab 无 97 258:ab 98(b)
a b ba 无 98 259:ba 97(a)
b a ab 258(ab)
a ab aba 无 258 260:aba 97(a)
b a ab 258(ab)
a ab aba 260(aba)
b aba abab 无 260 261:abab 98(b)
c b bc 无 98 262:bc 99(c)
d c cd 无 99 263:cd 100(d)
d d dd 无 100 264:dd 100(d)
d d dd 264(dd)
a dd dda 无 264 265:dda 97(a)
a a aa 无 97 266:aa 97(a)
b a ab 258(ab)
c ab abc 无 258 267:abc 99(c)
d c cd 263(cd)
b cd cdb 无 263 268
cdb) 98(b) a b ba 259(ba)
结束 259
流结束标志
表1
上面的压缩步骤应该是很容易理解吧？不过别以为这样就可以了，仔细观察一下就知道了，输出代码部分有超过255的数据，就是说不能用一个字节来表示，那怎么办呢？其实这样的话我们要摈弃传统的思想，不要把输出流看成是以字节为单位的字符串流，而要用位（bit）来做单位，在表项小于512时每次输出的代码占用9bit，大于等于512小于1024时占10bit依此类推动态增加每次输出代码所占用的位数，如果表过长其输出代码就要占用足够多的位数，现在该知道为什么当表到了一定程度就要清空了吧，通常表项数最大为4096项。
2、解压缩（Decode）
??解压缩和压缩的过程很相似，也是动态地生成一个串表然后根据读入的代码将压缩数据还原，虽然不太好理解但是解压缩的实现过程要比压缩过程简单得多，为什么这么说？首先观察一下压缩代码生成的特征，每输出一次代码则表中必定新建了一个表项，为了让解压缩时和压缩时创建的表一致，所以我们在读入一个代码时就要在表中新建立一个表项，看看下面的解压缩过程：
注意：在做字符串合并时只合并一个字符， 即如果当前读入的代码表示的字符串是“ab”的话我们只将“a”合并到原字符串末，如果当前读入的代码表示的字符串表项还未建立，则使用原来（即上一次读入的字符串）内容。
输出数据 读入的字符 combine new table
a a
a b ab 258:ab
b 258(ab) bab 259:ba
258(ab) 260(空，用原值ab) abab 260:aba
260(aba) b ab 261:abab
b c bc 262:bc
c d cd 263:cd
d 264(空，用原值d) dd 264:dd
264(dd) a da 265:da
a 258(ab) aab 266:aa
258(ab) 263(cd) abcd 267:abc
263(cd) 259(ba) cdba 268:cdb
259(ba) END
解压缩过程
??上面的实现步骤非常简单吧，只不过有些步骤（如只合并一个字符）不太容易理解为什么要这么做？但是只从程序编写的角度来说是件轻而易举的事情。
3、程序实现
编程上面最困难的就是讨厌的位处理了，因为编译器的限制对变量的处理是以8bit的倍数为单位的，就是说要想实现任意位数代码流必须经过很多的位移、位与操作，比如说：
|--01--||--02--||--03--||--04--||--05--||--06--|
123456781234567812345678123456781234567812345678
-------------^
假设当前代码流已经输出了13bit（即接下来的输出代码将从第02个字节的第6位开始）
|--01--||--02--||--03--||--04--||--05--||--06--|
123456781234567812345678123456781234567812345678
-------------*******010011101011^
现在获得下一个输出代码为010011101011共有12bit。由最大4096可只输出代码最长为12bit，最多跨度为三个字节，如果直接跟接下来的三个字节进行位与操作显然错位了。
|--01--||--02--||--03--||--04--||--05--||--06--|
123456781234567812345678123456781234567812345678
-------------010011101011^
必须先进行位移操作再位与操作，不难计算出需要位移的位数为：
24-代码位数-(输出流位置%8)=24-12-13%8=7
表2
??解压缩时就是以上步骤的逆运算：
|--01--||--02--||--03--||--04--||--05--||--06--|
123456781234567812345678123456781234567812345678
--------*****010011101011*******
^
设当前位置是第13bit，下一个代码长度为12bit，因为代码最多可能跨字节数为3，所以先把后3个字节的内容读出存到一个长整型变量中得到*****010011101011*******然后左移当前代码位置%8=13%8=5位再向右移24-代码位数=24-12=12位即可得到010011101011。
表3
二:传统的屏幕传输方法
利用流实现网络传输屏幕图像(作者:陈经韬.此文已经发表于<<电脑商情报>>)
大家应该见过很多网管程序，这类程序其中有一个功能就是监控远程电脑的屏幕。实际上，这也是利用流操作来实现的。下面我们给出一个例子，这个例子分两个程序，一个服务端，一个是客户端。程序编译后可以直接在单机、局部网或者互联网上使用。程序中已经给出相应注释。后面我们再来作具体分析。
新建一个工程，在Internet面版上拖一个ServerSocket控件到窗口，该控件主要用于监听客户端，用来与客户端建立连接和通讯。设置好监听端口后调用方法Open或者Active:=True即开始工作。注意：跟前面的NMUDP不同，当Socket开始监听后就不能再改变它的端口，要改变的话必须先调用Close或设置Active为False，否则将会产生异常。另外，如果该端口已经打开的话，就不能再用这个端口了。所以程序运行尚未退出就不能再运行这个程序，否则也会产生异常，即弹出出错窗口。实际应用中可以通过判断程序是否已经运行，如果已经运行就退出的方法来避免出错。
当客户端有数据传入，将触发ServerSocket1ClientRead事件，我们可以在这里对接收的数据进行处理。在本程序中，主要是接收客户端发送过来的字符信息并根据事先的约定来进行相应操作。
程序全部代码如下：
unit Unit1;{服务端程序}
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, JPEG,ExtCtrls, ScktComp;
type
TForm1 = class(TForm)
ServerSocket1: TServerSocket;
procedure ServerSocket1ClientRead(Sender: TObject;Socket: TCustomWinSocket);
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
procedure Cjt_GetScreen(var Mybmp: TBitmap; DrawCur: Boolean);
{自定义抓屏函数,DrawCur表示抓鼠标图像与否}
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
MyStream: TMemorystream;{内存流对象}
implementation
{$R *.DFM}
procedure TForm1.Cjt_GetScreen(var Mybmp: TBitmap; DrawCur: Boolean);
var
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);
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;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
ServerSocket1.Port := 3000; {端口}
ServerSocket1.Open; {Socket开始侦听}
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if ServerSocket1.Active then ServerSocket1.Close; {关闭Socket}
end;
procedure TForm1.ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
var
S, S1: string;
MyBmp: TBitmap;
Myjpg: TJpegimage;
begin
S := Socket.ReceiveText;
if S = 'cap' then {客户端发出抓屏幕指令}
begin
try
MyStream := TMemorystream.Create;{建立内存流}
MyBmp := TBitmap.Create;
Myjpg := TJpegimage.Create;
Cjt_GetScreen(MyBmp, True); {True表示抓鼠标图像}
Myjpg.Assign(MyBmp); {将BMP图象转成JPG格式,便于在互联网上传输}
Myjpg.CompressionQuality := 10; {JPG文件压缩百分比设置,数字越大图像越清晰,但数据也越大}
Myjpg.SaveToStream(MyStream); {将JPG图象写入流中}
Myjpg.free;
MyStream.Position := 0;{注意:必须添加此句}
s1 := inttostr(MyStream.size);{流的大小}
Socket.sendtext(s1); {发送流大小}
finally
MyBmp.free;
end;
end;
if s = 'ready' then {客户端已准备好接收图象}
begin
MyStream.Position := 0;
Socket.SendStream(MyStream); {将流发送出去}
end;
end;
end.
上面是服务端，下面我们来写客户端程序。新建一个工程，添加Socket控件ClientSocket、图像显示控件Image、一个 Panel 、一个Edit、两个 Button和一个状态栏控件StatusBar1。注意：把Edit1和两个 Button放在Panel1上面。ClientSocket的属性跟ServerSocket差不多，不过多了一个Address属性，表示要连接的服务端IP地址。填上IP地址后点“连接”将与服务端程序建立连接，如果成功就可以进行通讯了。点击“抓屏”将发送字符给服务端。因为程序用到了JPEG图像单元，所以要在Uses中添加Jpeg.
全部代码如下：
unit Unit2{客户端};
interface
uses
Windows,Messages,SysUtils,Classes,Graphics,Controls,Forms,Dialogs,StdCtrls,ScktComp,ExtCtrls,Jpeg, ComCtrls;
type
TForm1 = class(TForm)
ClientSocket1: TClientSocket;
Image1: TImage;
StatusBar1: TStatusBar;
Panel1: TPanel;
Edit1: TEdit;
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure ClientSocket1Connect(Sender: TObject;
Socket: TCustomWinSocket);
procedure Button2Click(Sender: TObject);
procedure ClientSocket1Error(Sender: TObject; Socket: TCustomWinSocket;
ErrorEvent: TErrorEvent; var ErrorCode: Integer);
procedure ClientSocket1Read(Sender: TObject; Socket: TCustomWinSocket);
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure ClientSocket1Disconnect(Sender: TObject;
Socket: TCustomWinSocket);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
MySize: Longint;
MyStream: TMemorystream;{内存流对象}
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
{-------- 下面为设置窗口控件的外观属性 ------------- }
{注意:把Button1、Button2和Edit1放在Panel1上面}
Edit1.Text := '127.0.0.1';
Button1.Caption := '连接主机';
Button2.Caption := '抓屏幕';
Button2.Enabled := false;
Panel1.Align := alTop;
Image1.Align := alClient;
Image1.Stretch := True;
StatusBar1.Align:=alBottom;
StatusBar1.SimplePanel := True;
{----------------------------------------------- }
MyStream := TMemorystream.Create; {建立内存流对象}
MySize := 0; {初始化}
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if not ClientSocket1.Active then
begin
ClientSocket1.Address := Edit1.Text; {远程IP地址}
ClientSocket1.Port := 3000; {Socket端口}
ClientSocket1.Open; {建立连接}
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
Clientsocket1.Socket.SendText('cap'); {发送指令通知服务端抓取屏幕图象}
Button2.Enabled := False;
end;
procedure TForm1.ClientSocket1Connect(Sender: TObject;
Socket: TCustomWinSocket);
begin
StatusBar1.SimpleText := '与主机' + ClientSocket1.Address + '成功建立连接!';
Button2.Enabled := True;
end;
procedure TForm1.ClientSocket1Error(Sender: TObject;
Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer);
begin
Errorcode := 0; {不弹出出错窗口}
StatusBar1.SimpleText := '无法与主机' + ClientSocket1.Address + '建立连接!';
end;
procedure TForm1.ClientSocket1Disconnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
StatusBar1.SimpleText := '与主机' + ClientSocket1.Address + '断开连接!';
Button2.Enabled := False;
end;
procedure TForm1.ClientSocket1Read(Sender: TObject;
Socket: TCustomWinSocket);
var
MyBuffer: array[0..10000] of byte; {设置接收缓冲区}
MyReceviceLength: integer;
S: string;
MyBmp: TBitmap;
MyJpg: TJpegimage;
begin
StatusBar1.SimpleText := '正在接收数据......';
if MySize = 0 then {MySize为服务端发送的字节数，如果为0表示为尚未开始图象接收}
begin
S := Socket.ReceiveText;
MySize := Strtoint(S); {设置需接收的字节数}
Clientsocket1.Socket.SendText('ready'); {发指令通知服务端开始发送图象}
end
else
begin {以下为图象数据接收部分}
MyReceviceLength := socket.ReceiveLength; {读出包长度}
StatusBar1.SimpleText := '正在接收数据,数据大小为:' + inttostr(MySize);
Socket.ReceiveBuf(MyBuffer, MyReceviceLength); {接收数据包并读入缓冲区内}
MyStream.Write(MyBuffer, MyReceviceLength); {将数据写入流中}
if MyStream.Size >= MySize then {如果流长度大于需接收的字节数，则接收完毕}
begin
MyStream.Position := 0;
MyBmp := tbitmap.Create;
MyJpg := tjpegimage.Create;
try
MyJpg.LoadFromStream(MyStream); {将流中的数据读至JPG图像对象中}
MyBmp.Assign(MyJpg); {将JPG转为BMP}
StatusBar1.SimpleText := '正在显示图像';
Image1.Picture.Bitmap.Assign(MyBmp); {分配给image1元件 }
finally {以下为清除工作 }
MyBmp.free;
MyJpg.free;
Button2.Enabled := true;
{ Socket.SendText('cap');添加此句即可连续抓屏 }
MyStream.Clear;
MySize := 0;
end;
end;
end;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
MyStream.Free; {释放内存流对象}
if ClientSocket1.Active then ClientSocket1.Close; {关闭Socket连接}
end;
end.
程序原理：运行服务端开始侦听，再运行客户端，输入服务端IP地址建立连接，然后发一个字符通知服务端抓屏幕。服务端调用自定义函数Cjt_GetScreen抓取屏幕存为BMP，把BMP转换成JPG，把JPG写入内存流中，然后把流发送给客户端。客户端接收到流后做相反操作，将流转换为JPG再转换为BMP然后显示出来。
注意：因为Socket的限制，不能一次发送过大的数据，只能分几次发。所以程序中服务端抓屏转换为流后先发送流的大小，通知客户端这个流共有多大，客户端根据这个数字大小来判断是否已经接收完流，如果接收完才转换并显示。
三:服务端客户端公共代码列表:
1: Lh5Unit.pas:LHArc压缩解压缩单元文件
2: My_StreamManage.pas:抓屏幕,比较流和还原流单元
(全文完)
F
fc182
Unregistered / Unconfirmed
GUEST, unregistred user!
我没说2ccc上没有
只是没有感觉效果好点的
只是没有感觉效果好点的
Q
QSmile
Unregistered / Unconfirmed
GUEST, unregistred user!
我没说2ccc上没有
只是没有感觉效果好点的
=============
那看 VNC 源码.
只是没有感觉效果好点的
=============
那看 VNC 源码.
网
网中戏
Unregistered / Unconfirmed
GUEST, unregistred user!
实时的不好做啊
D
dey-999
Unregistered / Unconfirmed
GUEST, unregistred user!
用delphi实现冰河的远程屏幕操作功能:
分为服务端和客户端两个部分，虽然不是一个完整的delphi工程，但是我们关心的其中有用的代码，对吧？
下面是服务端
unit ServerDlg;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls, WinSock, ScktComp, Menus, TrayIcon, FormSettings,
RemConMessages, ZLib, MsgSimulator, ComCtrls, ShellAPI;
type
TServerForm = class(TForm)
PageControl1: TPageControl;
TabSheet1: TTabSheet;
TabSheet2: TTabSheet;
LogList: TListBox;
ServerPanel: TPanel;
Label5: TLabel;
StartLab: TLabel;
Label9: TLabel;
ConLab: TLabel;
Label11: TLabel;
NumRecLab: TLabel;
Label13: TLabel;
NumSendLab: TLabel;
Label3: TLabel;
LastRecLab: TLabel;
Label4: TLabel;
NumErrLab: TLabel;
Panel1: TPanel;
Label1: TLabel;
NameLabel: TLabel;
Label2: TLabel;
PortEdit: TEdit;
Panel2: TPanel;
StartBut: TButton;
DisconBut: TButton;
MinimizeBut: TButton;
ClientBut: TButton;
ServerSocket1: TServerSocket;
TrayIcon1: TTrayIcon;
TrayMenu: TPopupMenu;
RemoteControl1: TMenuItem;
N1: TMenuItem;
Client1: TMenuItem;
N2: TMenuItem;
Shutdown1: TMenuItem;
FormSettings1: TFormSettings;
MsgSimulator1: TMsgSimulator;
Label6: TLabel;
PassEdit: TEdit;
procedure StartButClick(Sender: TObject);
procedure DisconButClick(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure MinimizeButClick(Sender: TObject);
procedure RemoteControl1Click(Sender: TObject);
procedure Shutdown1Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure ServerSocket1Listen(Sender: TObject;
Socket: TCustomWinSocket);
procedure ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
procedure ServerSocket1ClientConnect(Sender: TObject;
Socket: TCustomWinSocket);
procedure ServerSocket1ClientDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
procedure ServerSocket1ClientError(Sender: TObject;
Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Client1Click(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure ClientButClick(Sender: TObject);
protected
NumRec : double;
NumSend : double;
NumError : integer;
CurMsg : string;
LoggedOn : boolean;
CurBmp : TBitmap;
CurSocket : TCustomWinSocket;
CurHandle : THandle;
SleepTime : integer;
ViewMode : TViewMode;
CompMode : TCompressionLevel;
procedure UpdateStats;
procedure Log(const s: string);
procedure ProcessClick(const Data: string);
procedure ProcessDrag(const Data: string);
procedure Send_Screen_Update(Socket: TCustomWinSocket);
procedure SleepDone(Sender: TObject);
procedure ProcessKeys(const Data: string);
procedure CreateSleepThread;
procedure GetHostNameAddr;
procedure ParseComLine;
function Get_Process_List: string;
procedure CloseWindow(const Data: string);
procedure KillWindow(const Data: string);
function Get_Drive_List: string;
function GetDirectory(const PathName: string): string;
function GetFile(const PathName: string): string;
public
procedure EnableButs;
procedure ProcessMessage(const Msg: string; Socket: TCustomWinSocket);
procedure SendMsg(MsgNum: integer; const MsgData: string; Socket: TCustomWinSocket);
end;
var
ServerForm: TServerForm;
implementation
uses ClientFrm;
{$R *.DFM}
procedure TServerForm.StartButClick(Sender: TObject);
begin
with ServerSocket1 do begin
Port := StrToInt(PortEdit.Text);
Active := True;
end;
EnableButs;
end;
procedure TServerForm.DisconButClick(Sender: TObject);
begin
ServerSocket1.Active := False;
EnableButs;
end;
procedure TServerForm.EnableButs;
var
b : boolean;
begin
b := ServerSocket1.Active;
StartBut.Enabled := not b;
PortEdit.Enabled := not b;
DisconBut.Enabled := b;
// MinimizeBut.Enabled := b;
end;
procedure TServerForm.GetHostNameAddr;
var
buf : array[0..MAX_PATH] of char;
he : PHostEnt;
buf2 : PChar;
rc : integer;
begin
rc := GetHostName(buf, sizeof(buf));
if rc<>SOCKET_ERROR then begin
he := GetHostByName(buf);
if he = nil then begin
rc := WSAGetLastError;
NameLabel.Caption := Format('Socket Error %d = %s', [rc, SysErrorMessage(rc)]);
end else begin
buf2 := inet_ntoa(PInAddr(he.h_addr^)^);
NameLabel.Caption := Format('%s (%s)', [buf, buf2]);
end;
end else begin
NameLabel.Caption := 'Unknown Host';
end;
end;
procedure TServerForm.FormShow(Sender: TObject);
begin
EnableButs;
GetHostNameAddr;
end;
procedure TServerForm.MinimizeButClick(Sender: TObject);
begin
if ServerSocket1.Active then begin
TrayIcon1.ToolTip := Application.Title + ' - Port: ' + PortEdit.Text;
end else begin
TrayIcon1.ToolTip := Application.Title + ' - Inactive';
end;
TrayIcon1.Active := True;
ShowWindow(Application.Handle, SW_HIDE);
Hide;
end;
procedure TServerForm.RemoteControl1Click(Sender: TObject);
begin
TrayIcon1.Active := False;
ShowWindow(Application.Handle, SW_SHOW);
Application.Restore;
Show;
SetForegroundWindow(Handle);
end;
procedure TServerForm.Shutdown1Click(Sender: TObject);
begin
RemoteControl1Click(nil);
Close;
end;
procedure TServerForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
FormSettings1.SaveSettings;
end;
procedure TServerForm.ServerSocket1Listen(Sender: TObject;
Socket: TCustomWinSocket);
begin
StartLab.Caption := CurTime;
NumRec := 0;
NumSend := 0;
CurMsg := '';
LoggedOn := False;
UpdateStats;
Log('Startup at ' + CurTime);
end;
procedure TServerForm.UpdateStats;
begin
ConLab.Caption := IntToStr(ServerSocket1.Socket.ActiveConnections);
NumRecLab.Caption := Format('%1.0n', [NumRec]);
NumSendLab.Caption := Format('%1.0n', [NumSend]);
NumErrLab.Caption := IntToStr(NumError);
end;
procedure TServerForm.ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
var
s : string;
begin
Log(Format('%-20s %s', ['Recv Data', Socket.RemoteAddress]));
LastRecLab.Caption := CurTime;
s := Socket.ReceiveText;
NumRec := NumRec + Length(s);
UpdateStats;
CurMsg := CurMsg + s;
while IsValidMessage(CurMsg) do begin
s := TrimFirstMsg(CurMsg);
ProcessMessage(s, Socket);
end;
end;
procedure TServerForm.ServerSocket1ClientConnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
Log(Format('%-20s %s', ['Connect', Socket.RemoteAddress]));
ViewMode := vmColor4;
CompMode := clDefault;
SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_NORMAL);
UpdateStats;
end;
procedure TServerForm.ServerSocket1ClientDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
Log(Format('%-20s %s', ['Disconnect', Socket.RemoteAddress]));
UpdateStats;
end;
procedure TServerForm.ServerSocket1ClientError(Sender: TObject;
Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer);
begin
Log(Format('%-20s %d', ['Error', ErrorCode]));
ErrorCode := 0;
Inc(NumError);
UpdateStats;
end;
procedure TServerForm.Log(const s: string);
begin
LogList.ItemIndex := LogList.Items.Add(s);
end;
procedure TServerForm.ProcessMessage(const Msg: string; Socket: TCustomWinSocket);
var
MsgNum, x: integer;
rc : integer;
Data : string;
bmp : TBitmap;
tmp : string;
begin
CurSocket := Socket;
Move(Msg[1], MsgNum, sizeof(integer));
Data := Copy(Msg, 9, Length(Msg));
Log(Format('%-20s %d', ['Message', MsgNum]));
if MsgNum = MSG_LOGON then begin
LoggedOn := (AnsiCompareText(Data, PassEdit.Text) = 0);
if LoggedOn then begin
SendMsg(MSG_LOGON, '1', Socket)
end else begin
SendMsg(MSG_LOGON, '0', Socket);
end;
exit;
end;
if not LoggedOn then begin
Log('Denied Access!');
SendMsg(MSG_STAT_MSG, 'Invalid Password', Socket);
Socket.Close;
exit;
end;
if MsgNum = MSG_REFRESH then begin
Log('Screen Capture');
SendMsg(MSG_STAT_MSG, 'Screen Capture', Socket);
GetScreen(bmp, ViewMode);
Log('Compressing Bitmap');
SendMsg(MSG_STAT_MSG, 'Screen Compression', Socket);
CompressBitmap(bmp, tmp);
SaveString(tmp, 'Temp1.txt');
SendMsg(MSG_REFRESH, tmp, Socket);
CurBmp.Assign(bmp);
bmp.Free;
end;
if MsgNum = MSG_SCREEN_UPDATE then begin
Send_Screen_Update(Socket);
end;
if MsgNum = MSG_CLICK then begin
SendMsg(MSG_STAT_MSG, 'Simulating Input', Socket);
ProcessClick(Data);
// SleepDone will be called when it is finished
end;
if MsgNum = MSG_DRAG then begin
SendMsg(MSG_STAT_MSG, 'Simulating Input', Socket);
ProcessDrag(Data);
// SleepDone will be called when it is finished
end;
if MsgNum = MSG_KEYS then begin
SendMsg(MSG_STAT_MSG, 'Simulating Input', Socket);
ProcessKeys(Data);
// SleepDone will be called when it is finished
end;
if MsgNum = MSG_SEVER_DELAY then begin
Move(Data[1], SleepTime, sizeof(integer));
SendMsg(MSG_SEVER_DELAY, '', Socket);
end;
if MsgNum = MSG_VIEW_MODE then begin
Move(Data[1], x, sizeof(integer));
ViewMode := TViewMode(x);
SendMsg(MSG_VIEW_MODE, '', Socket);
end;
if MsgNum = MSG_FOCUS_SERVER then begin
if TrayIcon1.Active then RemoteControl1Click(nil);
SetFocus;
CreateSleepThread;
// SleepDone will be called when it is finished
end;
if MsgNum = MSG_COMP_MODE then begin
Move(Data[1], x, sizeof(integer));
CompMode := TCompressionLevel(x);
SendMsg(MSG_COMP_MODE, '', Socket);
end;
if MsgNum = MSG_PRIORITY_MODE then begin
Move(Data[1], x, sizeof(integer));
SetThreadPriority(GetCurrentThread, x);
SendMsg(MSG_PRIORITY_MODE, '', Socket);
end;
if MsgNum = MSG_PROCESS_LIST then begin
SendMsg(MSG_PROCESS_LIST, Get_Process_List, Socket);
end;
if MsgNum = MSG_CLOSE_WIN then begin
CloseWindow(Data);
end;
if MsgNum = MSG_KILL_WIN then begin
KillWindow(Data);
end;
if MsgNum = MSG_DRIVE_LIST then begin
SendMsg(MSG_DRIVE_LIST, Get_Drive_List, Socket);
end;
if MsgNum = MSG_DIRECTORY then begin
SendMsg(MSG_DIRECTORY, GetDirectory(Data), Socket);
end;
if MsgNum = MSG_FILE then begin
SendMsg(MSG_FILE, GetFile(Data), Socket);
end;
if MsgNum = MSG_REMOTE_LAUNCH then begin
SendMsg(MSG_STAT_MSG, 'Launching File: ' + Data, Socket);
rc := ShellExecute(Handle, 'open', PChar(Data), nil, nil, SW_SHOWNORMAL);
if rc <= 32 then begin
Data := Format('ShellExecute Error #%d Launching %s', [rc, Data]);
SendMsg(MSG_REMOTE_LAUNCH, Data, Socket);
end else begin
SendMsg(MSG_REMOTE_LAUNCH, Data, Socket);
end;
end;
end;
function EnumWinProc(hw: THandle; lp: LParam): boolean; stdcall;
var
sl : TStringList;
buf : array[0..MAX_PATH] of char;
s, iv : string;
begin
sl := TStringList(lp);
GetWindowText(hw, buf, sizeof(buf));
if buf<>'' then begin
if IsWindowVisible(hw) then iv := '' else iv := '(Invisible)';
s := Format('%8.8x - %-32s %s', [hw, buf, iv]);
sl.AddObject(s, TObject(hw));
end;
Result := True;
end;
function TServerForm.Get_Process_List: string;
var
sl : TStringList;
begin
sl := TStringList.Create;
EnumWindows(@EnumWinProc, integer(sl));
Result := sl.Text;
sl.Free;
end;
function TServerForm.Get_Drive_List: string;
var
DriveBits : integer;
i : integer;
begin
Result := '';
DriveBits := GetLogicalDrives;
for i := 0 to 25 do begin
if (DriveBits and (1 shl i)) <> 0 then
Result := Result + Chr(Ord('A') + i) + ':/' + #13#10;
end;
end;
function TServerForm.GetDirectory(const PathName: string): string;
var
DirList : TStringList;
CommaList : TStringList;
sr : TSearchRec;
s : string;
dt : TDateTime;
begin
DirList := TStringList.Create;
CommaList := TStringList.Create;
if FindFirst(PathName, faAnyFile, sr) = 0 then repeat
CommaList.Clear;
s := sr.Name;
if (s = '.') or (s = '..') then continue;
if (sr.Attr and faDirectory) <> 0 then s := s + '/';
CommaList.Add(s);
s := Format('%1.0n', [sr.Size+0.0]);
CommaList.Add(s);
dt := FileDateToDateTime(sr.Time);
s := FormatDateTime('yyyy-mm-dd hh:nn ampm', dt);
CommaList.Add(s);
DirList.Add(CommaList.CommaText);
until FindNext(sr) <> 0;
FindClose(sr);
Result := DirList.Text;
CommaList.Free;
DirList.Free;
end;
function TServerForm.GetFile(const PathName: string): string;
var
fs : TFileStream;
begin
fs := TFileStream.Create(PathName, fmOpenRead or fmShareDenyWrite);
SetLength(Result, fs.Size);
fs.Read(Result[1], fs.Size);
fs.Free;
end;
procedure TServerForm.CloseWindow(const Data: string);
var
sl : TStringList;
i : integer;
hw : THandle;
begin
sl := TStringList.Create;
EnumWindows(@EnumWinProc, integer(sl));
i := sl.IndexOf(Data);
if i<>-1 then begin
hw := THandle(sl.Objects);
SendMessage(hw, WM_CLOSE, 0, 0);
Sleep(SleepTime);
SendMsg(MSG_PROCESS_LIST, Get_Process_List, CurSocket);
end;
sl.Free;
end;
procedure TServerForm.KillWindow(const Data: string);
var
sl : TStringList;
i : integer;
hw : THandle;
ProcID : integer;
hProc : THandle;
begin
sl := TStringList.Create;
EnumWindows(@EnumWinProc, integer(sl));
i := sl.IndexOf(Data);
if i<>-1 then begin
hw := THandle(sl.Objects);
GetWindowThreadProcessId(hw, @ProcID);
hProc := OpenProcess(PROCESS_ALL_ACCESS, False, ProcID);
TerminateProcess(hProc, DWORD(-1));
CloseHandle(hProc);
Sleep(SleepTime);
SendMsg(MSG_PROCESS_LIST, Get_Process_List, CurSocket);
end;
sl.Free;
end;
procedure TServerForm.SleepDone(Sender: TObject);
begin
Send_Screen_Update(CurSocket);
end;
procedure TServerForm.Send_Screen_Update(Socket: TCustomWinSocket);
var
bmp, dif : TBitmap;
R : TRect;
tmp : string;
begin
Log('Screen Capture');
SendMsg(MSG_STAT_MSG, 'Screen Capture', Socket);
GetScreen(bmp, ViewMode);
Log('Creating Diff Image');
dif := TBitmap.Create;
dif.Assign(bmp);
R := Rect(0, 0, dif.Width, dif.Height);
SendMsg(MSG_STAT_MSG, 'Screen Difference', Socket);
dif.Canvas.CopyMode := cmSrcInvert;
dif.Canvas.CopyRect(R, CurBmp.Canvas, R);
Log('Compressing Bitmap');
SendMsg(MSG_STAT_MSG, 'Screen Compression', Socket);
CompressBitmap(dif, tmp);
SendMsg(MSG_SCREEN_UPDATE, tmp, Socket);
CurBmp.Assign(bmp);
dif.Free;
bmp.Free;
end;
function GetMB(but: integer): TMouseButton;
begin
case but of
1 : Result := mbLeft;
2 : Result := mbRight;
else Result := mbLeft;
end;
end;
procedure TServerForm.ProcessClick(const Data: string);
var
x, y, i : integer;
num, but : integer;
p : TPoint;
begin
Move(Data[1], x, sizeof(integer));
Move(Data[1+4], y, sizeof(integer));
Move(Data[1+8], num, sizeof(integer));
Move(Data[1+12], but, sizeof(integer));
// Find the Window Handle
p := Point(x, y);
CurHandle := WindowFromPoint(p);
Assert(CurHandle<>0);
SetCursorPos(x, y);
// Create the Messages to send in the Hook procedure
with MsgSimulator1 do begin
Messages.Clear;
for i := 1 to num do
Add_ClickEx(0, GetMB(but), [], x, y, 1);
Play;
end;
CreateSleepThread;
end;
procedure TServerForm.ProcessDrag(const Data: string);
var
x, y : integer;
time : integer;
num, but : integer;
p : TPoint;
StartPt : TPoint;
StopPt : TPoint;
begin
Move(Data[1], but, sizeof(integer));
Move(Data[1+4], num, sizeof(integer));
Assert(num > 2);
// Create the Messages to send in the Hook procedure
// Mouse Down
Move(Data[(1-1)*12 + 9], x, sizeof(integer));
Move(Data[(1-1)*12 + 13], y, sizeof(integer));
Move(Data[(1-1)*12 + 17], time, sizeof(integer));
SetCursorPos(x, y);
// Find the Window Handle
p := Point(x, y);
CurHandle := WindowFromPoint(p);
Assert(CurHandle<>0);
with MsgSimulator1 do begin
Messages.Clear;
StartPt.X := x;
StartPt.Y := y;
Windows.ScreenToClient(CurHandle, StartPt);
Move(Data[(num-1)*12 + 9], x, sizeof(integer));
Move(Data[(num-1)*12 + 13], y, sizeof(integer));
StopPt.X := x;
StopPt.Y := y;
Windows.ScreenToClient(CurHandle, StopPt);
Add_Window_Drag(CurHandle, StartPt.X, StartPt.Y, StopPt.X, StopPt.Y);
Play;
end;
CreateSleepThread;
end;
procedure TServerForm.ProcessKeys(const Data: string);
begin
with MsgSimulator1 do begin
Messages.Clear;
Add_ASCII_Keys(Data);
Play;
end;
CreateSleepThread;
end;
procedure TServerForm.SendMsg(MsgNum: integer; const MsgData: string; Socket: TCustomWinSocket);
var
s : string;
begin
s := IntToByteStr(MsgNum) + IntToByteStr(Length(MsgData)) + MsgData;
Log(Format('%-20s %-4d %1.0n', ['Send', MsgNum, Length(s)+0.0]));
Socket.SendText(s);
NumSend := NumSend + Length(s);
UpdateStats;
end;
procedure TServerForm.FormCreate(Sender: TObject);
begin
CurBmp := TBitmap.Create;
SleepTime := 50;
ParseComLine;
end;
procedure TServerForm.FormDestroy(Sender: TObject);
begin
CurBmp.Free;
end;
type
TSleepThread = class(TThread)
public
SleepTime : integer;
procedure Execute; override;
end;
procedure TSleepThread.Execute;
begin
Sleep(SleepTime);
end;
procedure TServerForm.CreateSleepThread;
var
st : TSleepThread;
begin
st := TSleepThread.Create(True);
st.SleepTime := SleepTime;
st.OnTerminate := SleepDone;
st.Resume;
end;
procedure TServerForm.Client1Click(Sender: TObject);
begin
ClientForm.Show;
end;
procedure TServerForm.FormCloseQuery(Sender: TObject;
var CanClose: Boolean);
var
rc : integer;
begin
if ServerSocket1.Socket.ActiveConnections > 0 then begin
rc := MessageDlg('Clients are still connected, do you want to close?',
mtWarning, mbYesNoCancel, 0);
CanClose := (rc = mrYes);
end;
end;
procedure TServerForm.ParseComLine;
var
i : integer;
s : string;
AutoStart : boolean;
begin
AutoStart := False;
for i := 1 to ParamCount do begin
s := UpperCase(ParamStr(i));
if Copy(s, 1, 6) = '/PORT:' then begin
PortEdit.Text := Copy(s, 7, Length(s));
AutoStart := True;
StartButClick(nil);
MinimizeButClick(nil);
end;
if s = '/CLIENT' then begin
MinimizeButClick(nil);
AutoStart := True;
end;
end;
if not AutoStart then
Visible := True;
end;
procedure TServerForm.ClientButClick(Sender: TObject);
begin
ClientForm.Show;
end;
end.
下面是客户端
unit ClientFrm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ScktComp, ExtCtrls, ComCtrls, FormSettings, Menus, StdCtrls, Buttons,
RemConMessages, ZLib;
const
DEFAULT_SERVER_DELAY = 500;
DEFAULT_VIEW_MODE = vmColor4;
DEFAULT_COMP_MODE = clDefault;
DEFAULT_SVR_PRIORITY = THREAD_PRIORITY_HIGHEST;
type
TMoveObj = class
X, Y : integer;
Time : integer;
end;
TClientForm = class(TForm)
StatPanel: TPanel;
StatusBar1: TStatusBar;
ScrollBox1: TScrollBox;
Image1: TImage;
ClientSocket1: TClientSocket;
Timer1: TTimer;
MainMenu1: TMainMenu;
File1: TMenuItem;
Connect1: TMenuItem;
N1: TMenuItem;
Exit1: TMenuItem;
Disconnect1: TMenuItem;
View1: TMenuItem;
RefreshComplete1: TMenuItem;
UpdateChanges1: TMenuItem;
ResponseTimer: TTimer;
ClickTimer: TTimer;
Options1: TMenuItem;
ServerPause1: TMenuItem;
N005sec1: TMenuItem;
N010sec1: TMenuItem;
N050sec1: TMenuItem;
N100sec1: TMenuItem;
N200sec1: TMenuItem;
N500sec1: TMenuItem;
LogList: TListBox;
Splitter1: TSplitter;
N2: TMenuItem;
Log1: TMenuItem;
CommStat1: TMenuItem;
N3: TMenuItem;
Shutdown1: TMenuItem;
Special1: TMenuItem;
FocusServerWindow1: TMenuItem;
BitmapFormat1: TMenuItem;
Color4: TMenuItem;
Gray4: TMenuItem;
Gray8: TMenuItem;
Color24: TMenuItem;
Default1: TMenuItem;
WaitImage: TImage;
CompressionLevel1: TMenuItem;
HighSlow1: TMenuItem;
Medium1: TMenuItem;
LowFast1: TMenuItem;
ServerPriority1: TMenuItem;
Critical1: TMenuItem;
Highest1: TMenuItem;
AboveNormal1: TMenuItem;
Normal1: TMenuItem;
BelowNormal1: TMenuItem;
Lowest1: TMenuItem;
Idle1: TMenuItem;
N4: TMenuItem;
ScaleImage1: TMenuItem;
ProcessList1: TMenuItem;
N5: TMenuItem;
FileList1: TMenuItem;
Panel1: TPanel;
SendCRBut: TSpeedButton;
SendBut: TSpeedButton;
SendPanel: TPanel;
SendEdit: TEdit;
Help1: TMenuItem;
About1: TMenuItem;
StatBarMenu: TMenuItem;
FullScreen1: TMenuItem;
procedure FormShow(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure ClientSocket1Lookup(Sender: TObject;
Socket: TCustomWinSocket);
procedure ClientSocket1Connecting(Sender: TObject;
Socket: TCustomWinSocket);
procedure ClientSocket1Connect(Sender: TObject;
Socket: TCustomWinSocket);
procedure ClientSocket1Error(Sender: TObject; Socket: TCustomWinSocket;
ErrorEvent: TErrorEvent; var ErrorCode: Integer);
procedure Exit1Click(Sender: TObject);
procedure Connect1Click(Sender: TObject);
procedure ClientSocket1Read(Sender: TObject; Socket: TCustomWinSocket);
procedure ClientSocket1Disconnect(Sender: TObject;
Socket: TCustomWinSocket);
procedure Disconnect1Click(Sender: TObject);
procedure RefreshComplete1Click(Sender: TObject);
procedure UpdateChanges1Click(Sender: TObject);
procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure ResponseTimerTimer(Sender: TObject);
procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Image1Click(Sender: TObject);
procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Image1DblClick(Sender: TObject);
procedure ClickTimerTimer(Sender: TObject);
procedure PauseChange(Sender: TObject);
procedure SendButClick(Sender: TObject);
procedure SendCRButClick(Sender: TObject);
procedure Log1Click(Sender: TObject);
procedure CommStat1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Shutdown1Click(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FocusServerWindow1Click(Sender: TObject);
procedure ColorClick(Sender: TObject);
procedure CompClick(Sender: TObject);
procedure PriorityClick(Sender: TObject);
procedure ScaleImage1Click(Sender: TObject);
procedure ProcessList1Click(Sender: TObject);
procedure FileList1Click(Sender: TObject);
procedure SendPanelResize(Sender: TObject);
procedure About1Click(Sender: TObject);
procedure StatBarMenuClick(Sender: TObject);
procedure FullScreen1Click(Sender: TObject);
procedure FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
protected
NumRec : double;
NumSend : double;
CurMsg : string;
NeedReply : integer;
LastX : integer;
LastY : integer;
t1 : DWORD;
but : integer;
NumClick : integer;
MoveList : TList;
Anim : integer;
LastRec : DWORD;
ServerDelay: integer;
ViewMode : TViewMode;
CompMode : TCompressionLevel;
SvrPriority: integer;
ProcForm : TForm;
FileForm : TForm;
LastCPS : string;
BeforeFull : TRect;
procedure SetStat(i: integer; s: string);
procedure UpdateStats;
procedure SendText(const Text: string);
procedure Log(const s: string);
procedure EnableButs;
procedure ClearMoveList;
procedure AddMove(x, y: integer);
procedure ParseComLine;
procedure StopAnim;
procedure StartAnim;
procedure EnableInput;
procedure WMSysCommand(var Message: TWMSysCommand); message WM_SYSCOMMAND;
function CanSendMenuMsg: boolean;
procedure Send_Current_Settings;
procedure ScaleXY(var X, Y: integer);
procedure UpdateLogVis;
public
procedure SendMsg(MsgNum: integer; const MsgData: string; Socket: TCustomWinSocket);
procedure ProcessMessage(const Msg: string; Socket: TCustomWinSocket);
property Stat[i: integer]: string write SetStat;
end;
var
ClientForm: TClientForm;
implementation
uses ConnectDlg, ProcListDlg, FilesDlg, About, FsTopDlg;
{$R *.DFM}
procedure TClientForm.FormShow(Sender: TObject);
begin
UpdateLogVis;
if not ClientSocket1.Active then
Timer1.Enabled := True;
end;
function IsDotAddress(const s: string): boolean;
var
i : integer;
begin
Result := True;
for i := 1 to Length(s) do
if not (s in ['0'..'9', '.']) then Result := False;
end;
procedure TClientForm.Timer1Timer(Sender: TObject);
var
f : TForm;
begin
Timer1.Enabled := False;
f := Self;
with ClientConnectForm do begin
Left := (f.Left + f.Width div 2) - Width div 2;
Top := (f.Top + f.Height div 2) - Height div 2;
if ShowModal = mrOK then with ClientSocket1 do begin
if IsDotAddress(ServerCombo.Text) then begin
Host := '';
Address := ServerCombo.Text;
end else begin
Address := '';
Host := ServerCombo.Text;
end;
Port := StrToInt(PortEdit.Text);
StartAnim;
Active := True;
end;
end;
end;
procedure TClientForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if BorderStyle<>bsNone then FormSettings1.SaveSettings;
Disconnect1Click(nil);
end;
procedure TClientForm.ClientSocket1Lookup(Sender: TObject;
Socket: TCustomWinSocket);
begin
Stat[0] := ('Looking up: ' + ClientSocket1.Host);
end;
procedure TClientForm.SetStat(i: integer; s: string);
begin
FSTopForm.StatLabel.Caption := s;
StatusBar1.Panels.Text := s;
Update;
end;
procedure TClientForm.ClientSocket1Connecting(Sender: TObject;
Socket: TCustomWinSocket);
begin
Stat[0] := ('Connecting: ' + ClientSocket1.Host);
end;
procedure TClientForm.ClientSocket1Connect(Sender: TObject;
Socket: TCustomWinSocket);
begin
Log(Format('%-7s %s', ['LogOn', DateTimeToStr(Now)]));
EnableButs;
Stat[0] := ('Connected: ' + Socket.RemoteHost);
Caption := 'Remote Control Client - ' + Socket.RemoteHost;
NumSend := 0;
NumRec := 0;
NeedReply := 0;
StopAnim;
EnableInput;
SendMsg(MSG_LOGON, ClientConnectForm.PassEdit.Text, ClientSocket1.Socket);
Send_Current_Settings;
end;
procedure TClientForm.ClientSocket1Error(Sender: TObject;
Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer);
begin
Stat[0] := ('Error: ' + IntToStr(ErrorCode));
ErrorCode := 0;
if not Socket.Connected then StopAnim;
end;
procedure TClientForm.Exit1Click(Sender: TObject);
begin
Close;
end;
procedure TClientForm.Connect1Click(Sender: TObject);
begin
Image1.Picture.Bitmap := nil;
Timer1Timer(nil);
end;
procedure TClientForm.SendMsg(MsgNum: integer; const MsgData: string; Socket: TCustomWinSocket);
var
s : string;
begin
Log(Format('%-7s #%2.2d', ['Send', MsgNum]));
Stat[0] := Format('Sending Message (Len = %1.0n)', [Length(MsgData)+0.0]);
s := IntToByteStr(MsgNum) + IntToByteStr(Length(MsgData)) + MsgData;
Socket.SendText(s);
NumSend := NumSend + Length(s);
UpdateStats;
Inc(NeedReply);
StartAnim;
end;
procedure TClientForm.UpdateStats;
begin
// Stat[0] := Format('Sent: %1.0n', [NumSend]);
// Stat[1] := Format('Recv: %1.0n', [NumRec]);
end;
procedure TClientForm.ClientSocket1Read(Sender: TObject;
Socket: TCustomWinSocket);
var
s : string;
msg : integer;
len : integer;
PerStr : string;
tdif : double;
cps : string;
begin
// WaitImage.Hint := 'Data Last Received:' + #13#10 + CurTime;
s := Socket.ReceiveText;
NumRec := NumRec + Length(s);
UpdateStats;
if CurMsg = '' then LastRec := GetTickCount;
CurMsg := CurMsg + s;
if Length(CurMsg) >= 8 then begin
Move(CurMsg[1], msg, sizeof(integer));
Move(CurMsg[5], len, sizeof(integer));
PerStr := Format('(%1.0n%%)', [Length(CurMsg) / (len + 8.0) * 100.0]);
tdif := (GetTickCount - LastRec) / 1000.0;
if tdif > 0.5 then cps := Format('%1.0n cps', [Length(CurMsg) / tdif])
else cps := '';
Stat[0] := Format('Received: %1.0n of %1.0n %s %s',
[Length(CurMsg) + 0.0, len + 8.0, PerStr, cps]);
LastCPS := cps;
end else begin
if Length(s) > 0 then
Stat[0] := 'Received: ' + IntToStr(Length(CurMsg));
end;
while IsValidMessage(CurMsg) do begin
s := TrimFirstMsg(CurMsg);
ProcessMessage(s, Socket);
end;
end;
procedure TClientForm.ProcessMessage(const Msg: string; Socket: TCustomWinSocket);
var
MsgNum : integer;
Data : string;
bmp : TBitmap;
R : TRect;
begin
Move(Msg[1], MsgNum, sizeof(integer));
if MsgNum <> MSG_STAT_MSG then
Log(Format('%-7s #%0.2d %6.0n bytes %s', ['Recv', MsgNum, Length(Msg)+0.0, LastCPS]));
Data := Copy(Msg, 9, Length(Msg));
if MsgNum = MSG_STAT_MSG then begin
Stat[0] := Data;
exit;
end;
Dec(NeedReply);
if NeedReply = 0 then begin
StopAnim;
end;
if MsgNum = MSG_LOGON then begin
if Data <> '0' then begin
Stat[0] := 'Log on Successful';
if ClientConnectForm.StartScreenBox.Checked then
SendMsg(MSG_REFRESH, '', ClientSocket1.Socket);
end else begin
Stat[0] := 'Invalid Password!';
MessageDlg('Invalid Password!', mtWarning, [mbOK], 0);
end;
end;
if MsgNum = MSG_REFRESH then begin
Stat[0] := 'Decompressing';
SaveString(Data, 'Temp2.txt');
UnCompressBitmap(Data, Image1.Picture.Bitmap);
Stat[0] := 'Ready';
end;
if MsgNum = MSG_SCREEN_UPDATE then begin
bmp := TBitmap.Create;
Stat[0] := 'Decompressing';
UnCompressBitmap(Data, bmp);
R := Rect(0, 0, bmp.Width, bmp.Height);
with Image1.Picture.Bitmap.Canvas do begin
CopyMode := cmSrcInvert;
CopyRect(R, bmp.Canvas, R);
end;
Stat[0] := 'Ready';
bmp.Free;
end;
if MsgNum = MSG_SEVER_DELAY then begin
Stat[0] := 'Server Delay Set';
end;
if MsgNum = MSG_VIEW_MODE then begin
Stat[0] := 'View Mode Set';
end;
if MsgNum = MSG_COMP_MODE then begin
Stat[0] := 'Compression Mode Set';
end;
if MsgNum = MSG_PRIORITY_MODE then begin
Stat[0] := 'Priority Mode Set';
end;
if MsgNum = MSG_PROCESS_LIST then begin
if ProcForm = nil then
ProcForm := TProcListForm.Create(Self);
(ProcForm as TProcListForm).SetList(Data);
ProcForm.Show;
Stat[0] := 'Received Process List';
end;
if MsgNum = MSG_DRIVE_LIST then begin
if FileForm = nil then
FileForm := TFilesForm.Create(Self);
(FileForm as TFilesForm).SetDriveList(Data);
FileForm.Show;
Stat[0] := 'Received Drive List';
end;
if MsgNum = MSG_DIRECTORY then begin
Assert(FileForm <> nil);
(FileForm as TFilesForm).SetDirData(Data);
FileForm.Show;
Stat[0] := 'Received Directory';
end;
if MsgNum = MSG_FILE then begin
Assert(FileForm <> nil);
Stat[0] := 'Received File';
(FileForm as TFilesForm).SetFileData(Data);
end;
if MsgNum = MSG_REMOTE_LAUNCH then begin
Stat[0] := 'Launched File: ' + Data;
end;
end;
procedure TClientForm.ClientSocket1Disconnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
Log(Format('%-7s %s', ['LogOff', DateTimeToStr(Now)]));
ClientSocket1.Active := False;
EnableButs;
Stat[0] := ('Disconnected: ' + Socket.RemoteHost);
Caption := 'Remote Control Client';
StopAnim;
end;
procedure TClientForm.Disconnect1Click(Sender: TObject);
begin
Stat[0] := 'Disconnecting...';
ClientSocket1.Active := False;
EnableButs;
StopAnim;
end;
procedure TClientForm.RefreshComplete1Click(Sender: TObject);
begin
SendMsg(MSG_REFRESH, '', ClientSocket1.Socket);
end;
procedure TClientForm.UpdateChanges1Click(Sender: TObject);
begin
SendMsg(MSG_SCREEN_UPDATE, '', ClientSocket1.Socket);
end;
procedure TClientForm.Image1MouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
begin
ScaleXY(X, Y);
LastX := X;
LastY := Y;
AddMove(X, Y);
end;
procedure TClientForm.AddMove(x, y: integer);
var
MoveObj : TMoveObj;
begin
MoveObj := TMoveObj.Create;
MoveObj.X := X;
MoveObj.Y := Y;
MoveObj.Time := GetTickCount;
MoveList.Add(MoveObj);
end;
procedure TClientForm.ResponseTimerTimer(Sender: TObject);
var
bm : TBitmap;
x, y : integer;
begin
WaitImage.Hint := Format('Wait: %3.1n seconds', [(GetTickCount-t1)/1000.0]);
bm := TBitmap.Create;
bm.Width := WaitImage.Width;
bm.Height := WaitImage.Height;
Anim := Anim + 1;
Anim := Anim and 31;
for x := -1 to 1 do
for y := -1 to 1 do
bm.Canvas.Draw(Anim + x*32, Anim + y*32, Application.Icon);
WaitImage.Picture.Assign(bm);
bm.Free;
end;
procedure TClientForm.Image1MouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
ScaleXY(X, Y);
but := 1;
if Button = mbRight then but := 2;
ClearMoveList;
AddMove(x, y);
end;
procedure TClientForm.Image1Click(Sender: TObject);
begin
NumClick := 1;
ClickTimer.Enabled := True;
end;
procedure TClientForm.Image1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
ScaleXY(X, Y);
if but = 2 then begin
// Only do this for Right Clicks
SendMsg(MSG_CLICK, IntToByteStr(LastX) + IntToByteStr(LastY) +
IntToByteStr(1 {Single}) + IntToByteStr(but), ClientSocket1.Socket);
end;
AddMove(x, y);
end;
procedure TClientForm.Image1DblClick(Sender: TObject);
begin
NumClick := 2;
ClickTimer.Enabled := True;
end;
procedure TClientForm.ClickTimerTimer(Sender: TObject);
var
s : string;
MoveObj : TMoveObj;
i : integer;
begin
ClickTimer.Enabled := False;
if (MoveList.Count < 5) or (NumClick = 2) then begin
// This is a Click or Double-click
SendMsg(MSG_CLICK, IntToByteStr(LastX) + IntToByteStr(LastY) +
IntToByteStr(NumClick) + IntToByteStr(but), ClientSocket1.Socket);
end else begin
// This is a "drag" operation
s := IntToByteStr(but) + IntToByteStr(MoveList.Count);
for i := 0 to MoveList.Count-1 do begin
MoveObj := MoveList;
s := s + IntToByteStr(MoveObj.X) + IntToByteStr(MoveObj.Y)
+ IntToByteStr(MoveObj.time);
end;
SendMsg(MSG_DRAG, s, ClientSocket1.Socket);
end;
end;
procedure TClientForm.SendButClick(Sender: TObject);
begin
SendText(SendEdit.Text);
end;
procedure TClientForm.SendCRButClick(Sender: TObject);
begin
SendText(SendEdit.Text + #13);
end;
procedure TClientForm.SendText(const Text: string);
begin
SendMsg(MSG_KEYS, Text, ClientSocket1.Socket);
end;
procedure TClientForm.Log1Click(Sender: TObject);
begin
Log1.Checked := not Log1.Checked;
UpdateLogVis;
end;
procedure TClientForm.UpdateLogVis;
begin
LogList.Visible := Log1.Checked;
Splitter1.Visible := Log1.Checked;
if Log1.Checked then
LogList.Left := Splitter1.Left - 1;
end;
procedure TClientForm.Log(const s: string);
begin
LogList.ItemIndex := LogList.Items.Add(s);
end;
procedure TClientForm.CommStat1Click(Sender: TObject);
begin
CommStat1.Checked := not CommStat1.Checked;
StatPanel.Visible := CommStat1.Checked;
end;
procedure TClientForm.EnableButs;
var
b : boolean;
begin
b := ClientSocket1.Active;
Connect1.Enabled := not b;
Disconnect1.Enabled := b;
end;
procedure TClientForm.FormCreate(Sender: TObject);
begin
EnableButs;
MoveList := TList.Create;
ParseComLine;
StopAnim;
EnableInput;
ServerDelay := DEFAULT_SERVER_DELAY;
ViewMode := DEFAULT_VIEW_MODE;
CompMode := DEFAULT_COMP_MODE;
SvrPriority := DEFAULT_SVR_PRIORITY;
end;
procedure TClientForm.Shutdown1Click(Sender: TObject);
begin
Close;
Application.MainForm.Close;
end;
procedure TClientForm.FormDestroy(Sender: TObject);
begin
ClearMoveList;
MoveList.Free;
end;
procedure TClientForm.ClearMoveList;
var
i : integer;
begin
for i := 0 to MoveList.Count-1 do
TObject(MoveList).Free;
MoveList.Clear;
end;
procedure TClientForm.FocusServerWindow1Click(Sender: TObject);
begin
SendMsg(MSG_FOCUS_SERVER, '', ClientSocket1.Socket);
end;
procedure TClientForm.ParseComLine;
var
i : integer;
s : string;
begin
for i := 1 to ParamCount do begin
s := UpperCase(ParamStr(i));
if s = '/CLIENT' then begin
Visible := True;
end;
end;
end;
procedure TClientForm.EnableInput;
var
b : boolean;
begin
b := (NeedReply = 0) and ClientSocket1.Active;
SendBut.Enabled := b;
SendCRBut.Enabled := b;
Image1.Enabled := b;
Special1.Enabled := b;
// Options1.Enabled := b;
end;
procedure TClientForm.StopAnim;
var
bmp : TBitmap;
begin
Screen.Cursor := crDefault;
ResponseTimer.Enabled := False;
// Stat[2] := 'Not Waiting';
bmp := TBitmap.Create;
bmp.Width := WaitImage.Width;
bmp.Height := WaitImage.Height;
bmp.Canvas.Draw(2, 2, Application.Icon);
WaitImage.Picture.Assign(bmp);
bmp.Free;
EnableInput;
end;
procedure TClientForm.StartAnim;
begin
Anim := 2;
ResponseTimer.Enabled := True;
// Stat[2] := 'Waiting';
t1 := GetTickCount;
Screen.Cursor := crAppStart;
EnableInput;
end;
procedure TClientForm.WMSysCommand(var Message: TWMSysCommand);
begin
if (Message.CmdType and $FFF0 = SC_MINIMIZE) then
Application.Minimize
else
inherited;
end;
function TClientForm.CanSendMenuMsg: boolean;
begin
Result := ClientSocket1.Active;
end;
procedure TClientForm.PauseChange(Sender: TObject);
var
d : integer;
begin
d := 0;
(Sender as TMenuItem).Checked := True;
if Sender = N005sec1 then d := 50;
if Sender = N010sec1 then d := 100;
if Sender = N050sec1 then d := 500;
if Sender = N100sec1 then d := 1000;
if Sender = N200sec1 then d := 2000;
if Sender = N500sec1 then d := 5000;
ServerDelay := d;
if CanSendMenuMsg then
SendMsg(MSG_SEVER_DELAY, IntToByteStr(d), ClientSocket1.Socket);
end;
procedure TClientForm.ColorClick(Sender: TObject);
var
vm : TViewMode;
x : integer;
begin
(Sender as TMenuItem).Checked := True;
vm := vmDefault;
if Sender = Color4 then vm := vmColor4;
if Sender = Gray4 then vm := vmGray4;
if Sender = Gray8 then vm := vmGray8;
if Sender = Color24 then vm := vmColor24;
if Sender = Default1 then vm := vmDefault;
ViewMode := vm;
if CanSendMenuMsg then begin
x := integer(vm);
SendMsg(MSG_VIEW_MODE, IntToByteStr(x), ClientSocket1.Socket);
SendMsg(MSG_REFRESH, '', ClientSocket1.Socket);
end;
end;
procedure TClientForm.CompClick(Sender: TObject);
var
cm : TCompressionLevel;
begin
(Sender as TMenuItem).Checked := True;
cm := clDefault;
if Sender = HighSlow1 then cm := clMax;
if Sender = Medium1 then cm := clDefault;
if Sender = LowFast1 then cm := clFastest;
CompMode := cm;
if CanSendMenuMsg then
SendMsg(MSG_COMP_MODE, IntToByteStr(integer(cm)), ClientSocket1.Socket);
end;
procedure TClientForm.PriorityClick(Sender: TObject);
var
x : integer;
begin
(Sender as TMenuItem).Checked := True;
x := THREAD_PRIORITY_NORMAL;
if Sender = Critical1 then x := THREAD_PRIORITY_TIME_CRITICAL;
if Sender = Highest1 then x := THREAD_PRIORITY_HIGHEST;
if Sender = AboveNormal1 then x := THREAD_PRIORITY_ABOVE_NORMAL;
if Sender = Normal1 then x := THREAD_PRIORITY_NORMAL;
if Sender = BelowNormal1 then x := THREAD_PRIORITY_BELOW_NORMAL;
if Sender = Lowest1 then x := THREAD_PRIORITY_LOWEST;
if Sender = Idle1 then x := THREAD_PRIORITY_IDLE;
SvrPriority := x;
if CanSendMenuMsg then
SendMsg(MSG_PRIORITY_MODE, IntToByteStr(x), ClientSocket1.Socket);
end;
procedure TClientForm.Send_Current_Settings;
begin
SendMsg(MSG_SEVER_DELAY, IntToByteStr(ServerDelay), ClientSocket1.Socket);
SendMsg(MSG_VIEW_MODE, IntToByteStr(integer(ViewMode)), ClientSocket1.Socket);
SendMsg(MSG_COMP_MODE, IntToByteStr(integer(CompMode)), ClientSocket1.Socket);
SendMsg(MSG_PRIORITY_MODE, IntToByteStr(SvrPriority), ClientSocket1.Socket);
end;
procedure TClientForm.ScaleImage1Click(Sender: TObject);
begin
ScaleImage1.Checked := not ScaleImage1.Checked;
if ScaleImage1.Checked then begin
Image1.AutoSize := False;
Image1.Stretch := True;
Image1.Align := alClient;
end else begin
Image1.AutoSize := True;
Image1.Stretch := False;
Image1.Align := alNone;
Image1.Picture.Assign(Image1.Picture.Graphic); // To trigger the Autosize property
end;
end;
procedure TClientForm.ScaleXY(var X, Y: integer);
begin
if not ScaleImage1.Checked then exit;
with Image1 do begin
X := X * Picture.Width div Width;
Y := Y * Picture.Height div Height;
end;
end;
procedure TClientForm.ProcessList1Click(Sender: TObject);
begin
SendMsg(MSG_PROCESS_LIST, '', ClientSocket1.Socket);
end;
procedure TClientForm.FileList1Click(Sender: TObject);
begin
SendMsg(MSG_DRIVE_LIST, '', ClientSocket1.Socket);
end;
procedure TClientForm.SendPanelResize(Sender: TObject);
begin
SendEdit.Width := SendPanel.ClientWidth - 8;
end;
procedure TClientForm.About1Click(Sender: TObject);
begin
AboutBox.ShowModal;
end;
procedure TClientForm.StatBarMenuClick(Sender: TObject);
begin
StatBarMenu.Checked := not StatBarMenu.Checked;
StatusBar1.Visible := StatBarMenu.Checked;
end;
procedure TClientForm.FullScreen1Click(Sender: TObject);
begin
if BorderStyle = bsSizeable then begin
BeforeFull := BoundsRect;
Menu := nil;
Left := 0;
Top := 0;
Width := Screen.Width;
Height := Screen.Height;
BorderStyle := bsNone;
StatPanel.Visible := False;
StatusBar1.Visible := False;
ScrollBox1.BorderStyle := bsNone;
FSTopForm.Show;
end else begin
BoundsRect := BeforeFull;
Menu := MainMenu1;
BorderStyle := bsSizeable;
StatPanel.Visible := True;
StatusBar1.Visible := True;
ScrollBox1.BorderStyle := bsSingle;
FSTopForm.Hide;
end;
end;
procedure TClientForm.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
// If in Full-Screen mode, do an extra check for Hot-Keys on the popup menu
if BorderStyle = bsNone then begin
FSTopForm.CheckShortCut(Key, Shift);
end;
end;
end.
分为服务端和客户端两个部分，虽然不是一个完整的delphi工程，但是我们关心的其中有用的代码，对吧？
下面是服务端
unit ServerDlg;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls, WinSock, ScktComp, Menus, TrayIcon, FormSettings,
RemConMessages, ZLib, MsgSimulator, ComCtrls, ShellAPI;
type
TServerForm = class(TForm)
PageControl1: TPageControl;
TabSheet1: TTabSheet;
TabSheet2: TTabSheet;
LogList: TListBox;
ServerPanel: TPanel;
Label5: TLabel;
StartLab: TLabel;
Label9: TLabel;
ConLab: TLabel;
Label11: TLabel;
NumRecLab: TLabel;
Label13: TLabel;
NumSendLab: TLabel;
Label3: TLabel;
LastRecLab: TLabel;
Label4: TLabel;
NumErrLab: TLabel;
Panel1: TPanel;
Label1: TLabel;
NameLabel: TLabel;
Label2: TLabel;
PortEdit: TEdit;
Panel2: TPanel;
StartBut: TButton;
DisconBut: TButton;
MinimizeBut: TButton;
ClientBut: TButton;
ServerSocket1: TServerSocket;
TrayIcon1: TTrayIcon;
TrayMenu: TPopupMenu;
RemoteControl1: TMenuItem;
N1: TMenuItem;
Client1: TMenuItem;
N2: TMenuItem;
Shutdown1: TMenuItem;
FormSettings1: TFormSettings;
MsgSimulator1: TMsgSimulator;
Label6: TLabel;
PassEdit: TEdit;
procedure StartButClick(Sender: TObject);
procedure DisconButClick(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure MinimizeButClick(Sender: TObject);
procedure RemoteControl1Click(Sender: TObject);
procedure Shutdown1Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure ServerSocket1Listen(Sender: TObject;
Socket: TCustomWinSocket);
procedure ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
procedure ServerSocket1ClientConnect(Sender: TObject;
Socket: TCustomWinSocket);
procedure ServerSocket1ClientDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
procedure ServerSocket1ClientError(Sender: TObject;
Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Client1Click(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure ClientButClick(Sender: TObject);
protected
NumRec : double;
NumSend : double;
NumError : integer;
CurMsg : string;
LoggedOn : boolean;
CurBmp : TBitmap;
CurSocket : TCustomWinSocket;
CurHandle : THandle;
SleepTime : integer;
ViewMode : TViewMode;
CompMode : TCompressionLevel;
procedure UpdateStats;
procedure Log(const s: string);
procedure ProcessClick(const Data: string);
procedure ProcessDrag(const Data: string);
procedure Send_Screen_Update(Socket: TCustomWinSocket);
procedure SleepDone(Sender: TObject);
procedure ProcessKeys(const Data: string);
procedure CreateSleepThread;
procedure GetHostNameAddr;
procedure ParseComLine;
function Get_Process_List: string;
procedure CloseWindow(const Data: string);
procedure KillWindow(const Data: string);
function Get_Drive_List: string;
function GetDirectory(const PathName: string): string;
function GetFile(const PathName: string): string;
public
procedure EnableButs;
procedure ProcessMessage(const Msg: string; Socket: TCustomWinSocket);
procedure SendMsg(MsgNum: integer; const MsgData: string; Socket: TCustomWinSocket);
end;
var
ServerForm: TServerForm;
implementation
uses ClientFrm;
{$R *.DFM}
procedure TServerForm.StartButClick(Sender: TObject);
begin
with ServerSocket1 do begin
Port := StrToInt(PortEdit.Text);
Active := True;
end;
EnableButs;
end;
procedure TServerForm.DisconButClick(Sender: TObject);
begin
ServerSocket1.Active := False;
EnableButs;
end;
procedure TServerForm.EnableButs;
var
b : boolean;
begin
b := ServerSocket1.Active;
StartBut.Enabled := not b;
PortEdit.Enabled := not b;
DisconBut.Enabled := b;
// MinimizeBut.Enabled := b;
end;
procedure TServerForm.GetHostNameAddr;
var
buf : array[0..MAX_PATH] of char;
he : PHostEnt;
buf2 : PChar;
rc : integer;
begin
rc := GetHostName(buf, sizeof(buf));
if rc<>SOCKET_ERROR then begin
he := GetHostByName(buf);
if he = nil then begin
rc := WSAGetLastError;
NameLabel.Caption := Format('Socket Error %d = %s', [rc, SysErrorMessage(rc)]);
end else begin
buf2 := inet_ntoa(PInAddr(he.h_addr^)^);
NameLabel.Caption := Format('%s (%s)', [buf, buf2]);
end;
end else begin
NameLabel.Caption := 'Unknown Host';
end;
end;
procedure TServerForm.FormShow(Sender: TObject);
begin
EnableButs;
GetHostNameAddr;
end;
procedure TServerForm.MinimizeButClick(Sender: TObject);
begin
if ServerSocket1.Active then begin
TrayIcon1.ToolTip := Application.Title + ' - Port: ' + PortEdit.Text;
end else begin
TrayIcon1.ToolTip := Application.Title + ' - Inactive';
end;
TrayIcon1.Active := True;
ShowWindow(Application.Handle, SW_HIDE);
Hide;
end;
procedure TServerForm.RemoteControl1Click(Sender: TObject);
begin
TrayIcon1.Active := False;
ShowWindow(Application.Handle, SW_SHOW);
Application.Restore;
Show;
SetForegroundWindow(Handle);
end;
procedure TServerForm.Shutdown1Click(Sender: TObject);
begin
RemoteControl1Click(nil);
Close;
end;
procedure TServerForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
FormSettings1.SaveSettings;
end;
procedure TServerForm.ServerSocket1Listen(Sender: TObject;
Socket: TCustomWinSocket);
begin
StartLab.Caption := CurTime;
NumRec := 0;
NumSend := 0;
CurMsg := '';
LoggedOn := False;
UpdateStats;
Log('Startup at ' + CurTime);
end;
procedure TServerForm.UpdateStats;
begin
ConLab.Caption := IntToStr(ServerSocket1.Socket.ActiveConnections);
NumRecLab.Caption := Format('%1.0n', [NumRec]);
NumSendLab.Caption := Format('%1.0n', [NumSend]);
NumErrLab.Caption := IntToStr(NumError);
end;
procedure TServerForm.ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
var
s : string;
begin
Log(Format('%-20s %s', ['Recv Data', Socket.RemoteAddress]));
LastRecLab.Caption := CurTime;
s := Socket.ReceiveText;
NumRec := NumRec + Length(s);
UpdateStats;
CurMsg := CurMsg + s;
while IsValidMessage(CurMsg) do begin
s := TrimFirstMsg(CurMsg);
ProcessMessage(s, Socket);
end;
end;
procedure TServerForm.ServerSocket1ClientConnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
Log(Format('%-20s %s', ['Connect', Socket.RemoteAddress]));
ViewMode := vmColor4;
CompMode := clDefault;
SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_NORMAL);
UpdateStats;
end;
procedure TServerForm.ServerSocket1ClientDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
Log(Format('%-20s %s', ['Disconnect', Socket.RemoteAddress]));
UpdateStats;
end;
procedure TServerForm.ServerSocket1ClientError(Sender: TObject;
Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer);
begin
Log(Format('%-20s %d', ['Error', ErrorCode]));
ErrorCode := 0;
Inc(NumError);
UpdateStats;
end;
procedure TServerForm.Log(const s: string);
begin
LogList.ItemIndex := LogList.Items.Add(s);
end;
procedure TServerForm.ProcessMessage(const Msg: string; Socket: TCustomWinSocket);
var
MsgNum, x: integer;
rc : integer;
Data : string;
bmp : TBitmap;
tmp : string;
begin
CurSocket := Socket;
Move(Msg[1], MsgNum, sizeof(integer));
Data := Copy(Msg, 9, Length(Msg));
Log(Format('%-20s %d', ['Message', MsgNum]));
if MsgNum = MSG_LOGON then begin
LoggedOn := (AnsiCompareText(Data, PassEdit.Text) = 0);
if LoggedOn then begin
SendMsg(MSG_LOGON, '1', Socket)
end else begin
SendMsg(MSG_LOGON, '0', Socket);
end;
exit;
end;
if not LoggedOn then begin
Log('Denied Access!');
SendMsg(MSG_STAT_MSG, 'Invalid Password', Socket);
Socket.Close;
exit;
end;
if MsgNum = MSG_REFRESH then begin
Log('Screen Capture');
SendMsg(MSG_STAT_MSG, 'Screen Capture', Socket);
GetScreen(bmp, ViewMode);
Log('Compressing Bitmap');
SendMsg(MSG_STAT_MSG, 'Screen Compression', Socket);
CompressBitmap(bmp, tmp);
SaveString(tmp, 'Temp1.txt');
SendMsg(MSG_REFRESH, tmp, Socket);
CurBmp.Assign(bmp);
bmp.Free;
end;
if MsgNum = MSG_SCREEN_UPDATE then begin
Send_Screen_Update(Socket);
end;
if MsgNum = MSG_CLICK then begin
SendMsg(MSG_STAT_MSG, 'Simulating Input', Socket);
ProcessClick(Data);
// SleepDone will be called when it is finished
end;
if MsgNum = MSG_DRAG then begin
SendMsg(MSG_STAT_MSG, 'Simulating Input', Socket);
ProcessDrag(Data);
// SleepDone will be called when it is finished
end;
if MsgNum = MSG_KEYS then begin
SendMsg(MSG_STAT_MSG, 'Simulating Input', Socket);
ProcessKeys(Data);
// SleepDone will be called when it is finished
end;
if MsgNum = MSG_SEVER_DELAY then begin
Move(Data[1], SleepTime, sizeof(integer));
SendMsg(MSG_SEVER_DELAY, '', Socket);
end;
if MsgNum = MSG_VIEW_MODE then begin
Move(Data[1], x, sizeof(integer));
ViewMode := TViewMode(x);
SendMsg(MSG_VIEW_MODE, '', Socket);
end;
if MsgNum = MSG_FOCUS_SERVER then begin
if TrayIcon1.Active then RemoteControl1Click(nil);
SetFocus;
CreateSleepThread;
// SleepDone will be called when it is finished
end;
if MsgNum = MSG_COMP_MODE then begin
Move(Data[1], x, sizeof(integer));
CompMode := TCompressionLevel(x);
SendMsg(MSG_COMP_MODE, '', Socket);
end;
if MsgNum = MSG_PRIORITY_MODE then begin
Move(Data[1], x, sizeof(integer));
SetThreadPriority(GetCurrentThread, x);
SendMsg(MSG_PRIORITY_MODE, '', Socket);
end;
if MsgNum = MSG_PROCESS_LIST then begin
SendMsg(MSG_PROCESS_LIST, Get_Process_List, Socket);
end;
if MsgNum = MSG_CLOSE_WIN then begin
CloseWindow(Data);
end;
if MsgNum = MSG_KILL_WIN then begin
KillWindow(Data);
end;
if MsgNum = MSG_DRIVE_LIST then begin
SendMsg(MSG_DRIVE_LIST, Get_Drive_List, Socket);
end;
if MsgNum = MSG_DIRECTORY then begin
SendMsg(MSG_DIRECTORY, GetDirectory(Data), Socket);
end;
if MsgNum = MSG_FILE then begin
SendMsg(MSG_FILE, GetFile(Data), Socket);
end;
if MsgNum = MSG_REMOTE_LAUNCH then begin
SendMsg(MSG_STAT_MSG, 'Launching File: ' + Data, Socket);
rc := ShellExecute(Handle, 'open', PChar(Data), nil, nil, SW_SHOWNORMAL);
if rc <= 32 then begin
Data := Format('ShellExecute Error #%d Launching %s', [rc, Data]);
SendMsg(MSG_REMOTE_LAUNCH, Data, Socket);
end else begin
SendMsg(MSG_REMOTE_LAUNCH, Data, Socket);
end;
end;
end;
function EnumWinProc(hw: THandle; lp: LParam): boolean; stdcall;
var
sl : TStringList;
buf : array[0..MAX_PATH] of char;
s, iv : string;
begin
sl := TStringList(lp);
GetWindowText(hw, buf, sizeof(buf));
if buf<>'' then begin
if IsWindowVisible(hw) then iv := '' else iv := '(Invisible)';
s := Format('%8.8x - %-32s %s', [hw, buf, iv]);
sl.AddObject(s, TObject(hw));
end;
Result := True;
end;
function TServerForm.Get_Process_List: string;
var
sl : TStringList;
begin
sl := TStringList.Create;
EnumWindows(@EnumWinProc, integer(sl));
Result := sl.Text;
sl.Free;
end;
function TServerForm.Get_Drive_List: string;
var
DriveBits : integer;
i : integer;
begin
Result := '';
DriveBits := GetLogicalDrives;
for i := 0 to 25 do begin
if (DriveBits and (1 shl i)) <> 0 then
Result := Result + Chr(Ord('A') + i) + ':/' + #13#10;
end;
end;
function TServerForm.GetDirectory(const PathName: string): string;
var
DirList : TStringList;
CommaList : TStringList;
sr : TSearchRec;
s : string;
dt : TDateTime;
begin
DirList := TStringList.Create;
CommaList := TStringList.Create;
if FindFirst(PathName, faAnyFile, sr) = 0 then repeat
CommaList.Clear;
s := sr.Name;
if (s = '.') or (s = '..') then continue;
if (sr.Attr and faDirectory) <> 0 then s := s + '/';
CommaList.Add(s);
s := Format('%1.0n', [sr.Size+0.0]);
CommaList.Add(s);
dt := FileDateToDateTime(sr.Time);
s := FormatDateTime('yyyy-mm-dd hh:nn ampm', dt);
CommaList.Add(s);
DirList.Add(CommaList.CommaText);
until FindNext(sr) <> 0;
FindClose(sr);
Result := DirList.Text;
CommaList.Free;
DirList.Free;
end;
function TServerForm.GetFile(const PathName: string): string;
var
fs : TFileStream;
begin
fs := TFileStream.Create(PathName, fmOpenRead or fmShareDenyWrite);
SetLength(Result, fs.Size);
fs.Read(Result[1], fs.Size);
fs.Free;
end;
procedure TServerForm.CloseWindow(const Data: string);
var
sl : TStringList;
i : integer;
hw : THandle;
begin
sl := TStringList.Create;
EnumWindows(@EnumWinProc, integer(sl));
i := sl.IndexOf(Data);
if i<>-1 then begin
hw := THandle(sl.Objects);
SendMessage(hw, WM_CLOSE, 0, 0);
Sleep(SleepTime);
SendMsg(MSG_PROCESS_LIST, Get_Process_List, CurSocket);
end;
sl.Free;
end;
procedure TServerForm.KillWindow(const Data: string);
var
sl : TStringList;
i : integer;
hw : THandle;
ProcID : integer;
hProc : THandle;
begin
sl := TStringList.Create;
EnumWindows(@EnumWinProc, integer(sl));
i := sl.IndexOf(Data);
if i<>-1 then begin
hw := THandle(sl.Objects);
GetWindowThreadProcessId(hw, @ProcID);
hProc := OpenProcess(PROCESS_ALL_ACCESS, False, ProcID);
TerminateProcess(hProc, DWORD(-1));
CloseHandle(hProc);
Sleep(SleepTime);
SendMsg(MSG_PROCESS_LIST, Get_Process_List, CurSocket);
end;
sl.Free;
end;
procedure TServerForm.SleepDone(Sender: TObject);
begin
Send_Screen_Update(CurSocket);
end;
procedure TServerForm.Send_Screen_Update(Socket: TCustomWinSocket);
var
bmp, dif : TBitmap;
R : TRect;
tmp : string;
begin
Log('Screen Capture');
SendMsg(MSG_STAT_MSG, 'Screen Capture', Socket);
GetScreen(bmp, ViewMode);
Log('Creating Diff Image');
dif := TBitmap.Create;
dif.Assign(bmp);
R := Rect(0, 0, dif.Width, dif.Height);
SendMsg(MSG_STAT_MSG, 'Screen Difference', Socket);
dif.Canvas.CopyMode := cmSrcInvert;
dif.Canvas.CopyRect(R, CurBmp.Canvas, R);
Log('Compressing Bitmap');
SendMsg(MSG_STAT_MSG, 'Screen Compression', Socket);
CompressBitmap(dif, tmp);
SendMsg(MSG_SCREEN_UPDATE, tmp, Socket);
CurBmp.Assign(bmp);
dif.Free;
bmp.Free;
end;
function GetMB(but: integer): TMouseButton;
begin
case but of
1 : Result := mbLeft;
2 : Result := mbRight;
else Result := mbLeft;
end;
end;
procedure TServerForm.ProcessClick(const Data: string);
var
x, y, i : integer;
num, but : integer;
p : TPoint;
begin
Move(Data[1], x, sizeof(integer));
Move(Data[1+4], y, sizeof(integer));
Move(Data[1+8], num, sizeof(integer));
Move(Data[1+12], but, sizeof(integer));
// Find the Window Handle
p := Point(x, y);
CurHandle := WindowFromPoint(p);
Assert(CurHandle<>0);
SetCursorPos(x, y);
// Create the Messages to send in the Hook procedure
with MsgSimulator1 do begin
Messages.Clear;
for i := 1 to num do
Add_ClickEx(0, GetMB(but), [], x, y, 1);
Play;
end;
CreateSleepThread;
end;
procedure TServerForm.ProcessDrag(const Data: string);
var
x, y : integer;
time : integer;
num, but : integer;
p : TPoint;
StartPt : TPoint;
StopPt : TPoint;
begin
Move(Data[1], but, sizeof(integer));
Move(Data[1+4], num, sizeof(integer));
Assert(num > 2);
// Create the Messages to send in the Hook procedure
// Mouse Down
Move(Data[(1-1)*12 + 9], x, sizeof(integer));
Move(Data[(1-1)*12 + 13], y, sizeof(integer));
Move(Data[(1-1)*12 + 17], time, sizeof(integer));
SetCursorPos(x, y);
// Find the Window Handle
p := Point(x, y);
CurHandle := WindowFromPoint(p);
Assert(CurHandle<>0);
with MsgSimulator1 do begin
Messages.Clear;
StartPt.X := x;
StartPt.Y := y;
Windows.ScreenToClient(CurHandle, StartPt);
Move(Data[(num-1)*12 + 9], x, sizeof(integer));
Move(Data[(num-1)*12 + 13], y, sizeof(integer));
StopPt.X := x;
StopPt.Y := y;
Windows.ScreenToClient(CurHandle, StopPt);
Add_Window_Drag(CurHandle, StartPt.X, StartPt.Y, StopPt.X, StopPt.Y);
Play;
end;
CreateSleepThread;
end;
procedure TServerForm.ProcessKeys(const Data: string);
begin
with MsgSimulator1 do begin
Messages.Clear;
Add_ASCII_Keys(Data);
Play;
end;
CreateSleepThread;
end;
procedure TServerForm.SendMsg(MsgNum: integer; const MsgData: string; Socket: TCustomWinSocket);
var
s : string;
begin
s := IntToByteStr(MsgNum) + IntToByteStr(Length(MsgData)) + MsgData;
Log(Format('%-20s %-4d %1.0n', ['Send', MsgNum, Length(s)+0.0]));
Socket.SendText(s);
NumSend := NumSend + Length(s);
UpdateStats;
end;
procedure TServerForm.FormCreate(Sender: TObject);
begin
CurBmp := TBitmap.Create;
SleepTime := 50;
ParseComLine;
end;
procedure TServerForm.FormDestroy(Sender: TObject);
begin
CurBmp.Free;
end;
type
TSleepThread = class(TThread)
public
SleepTime : integer;
procedure Execute; override;
end;
procedure TSleepThread.Execute;
begin
Sleep(SleepTime);
end;
procedure TServerForm.CreateSleepThread;
var
st : TSleepThread;
begin
st := TSleepThread.Create(True);
st.SleepTime := SleepTime;
st.OnTerminate := SleepDone;
st.Resume;
end;
procedure TServerForm.Client1Click(Sender: TObject);
begin
ClientForm.Show;
end;
procedure TServerForm.FormCloseQuery(Sender: TObject;
var CanClose: Boolean);
var
rc : integer;
begin
if ServerSocket1.Socket.ActiveConnections > 0 then begin
rc := MessageDlg('Clients are still connected, do you want to close?',
mtWarning, mbYesNoCancel, 0);
CanClose := (rc = mrYes);
end;
end;
procedure TServerForm.ParseComLine;
var
i : integer;
s : string;
AutoStart : boolean;
begin
AutoStart := False;
for i := 1 to ParamCount do begin
s := UpperCase(ParamStr(i));
if Copy(s, 1, 6) = '/PORT:' then begin
PortEdit.Text := Copy(s, 7, Length(s));
AutoStart := True;
StartButClick(nil);
MinimizeButClick(nil);
end;
if s = '/CLIENT' then begin
MinimizeButClick(nil);
AutoStart := True;
end;
end;
if not AutoStart then
Visible := True;
end;
procedure TServerForm.ClientButClick(Sender: TObject);
begin
ClientForm.Show;
end;
end.
下面是客户端
unit ClientFrm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ScktComp, ExtCtrls, ComCtrls, FormSettings, Menus, StdCtrls, Buttons,
RemConMessages, ZLib;
const
DEFAULT_SERVER_DELAY = 500;
DEFAULT_VIEW_MODE = vmColor4;
DEFAULT_COMP_MODE = clDefault;
DEFAULT_SVR_PRIORITY = THREAD_PRIORITY_HIGHEST;
type
TMoveObj = class
X, Y : integer;
Time : integer;
end;
TClientForm = class(TForm)
StatPanel: TPanel;
StatusBar1: TStatusBar;
ScrollBox1: TScrollBox;
Image1: TImage;
ClientSocket1: TClientSocket;
Timer1: TTimer;
MainMenu1: TMainMenu;
File1: TMenuItem;
Connect1: TMenuItem;
N1: TMenuItem;
Exit1: TMenuItem;
Disconnect1: TMenuItem;
View1: TMenuItem;
RefreshComplete1: TMenuItem;
UpdateChanges1: TMenuItem;
ResponseTimer: TTimer;
ClickTimer: TTimer;
Options1: TMenuItem;
ServerPause1: TMenuItem;
N005sec1: TMenuItem;
N010sec1: TMenuItem;
N050sec1: TMenuItem;
N100sec1: TMenuItem;
N200sec1: TMenuItem;
N500sec1: TMenuItem;
LogList: TListBox;
Splitter1: TSplitter;
N2: TMenuItem;
Log1: TMenuItem;
CommStat1: TMenuItem;
N3: TMenuItem;
Shutdown1: TMenuItem;
Special1: TMenuItem;
FocusServerWindow1: TMenuItem;
BitmapFormat1: TMenuItem;
Color4: TMenuItem;
Gray4: TMenuItem;
Gray8: TMenuItem;
Color24: TMenuItem;
Default1: TMenuItem;
WaitImage: TImage;
CompressionLevel1: TMenuItem;
HighSlow1: TMenuItem;
Medium1: TMenuItem;
LowFast1: TMenuItem;
ServerPriority1: TMenuItem;
Critical1: TMenuItem;
Highest1: TMenuItem;
AboveNormal1: TMenuItem;
Normal1: TMenuItem;
BelowNormal1: TMenuItem;
Lowest1: TMenuItem;
Idle1: TMenuItem;
N4: TMenuItem;
ScaleImage1: TMenuItem;
ProcessList1: TMenuItem;
N5: TMenuItem;
FileList1: TMenuItem;
Panel1: TPanel;
SendCRBut: TSpeedButton;
SendBut: TSpeedButton;
SendPanel: TPanel;
SendEdit: TEdit;
Help1: TMenuItem;
About1: TMenuItem;
StatBarMenu: TMenuItem;
FullScreen1: TMenuItem;
procedure FormShow(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure ClientSocket1Lookup(Sender: TObject;
Socket: TCustomWinSocket);
procedure ClientSocket1Connecting(Sender: TObject;
Socket: TCustomWinSocket);
procedure ClientSocket1Connect(Sender: TObject;
Socket: TCustomWinSocket);
procedure ClientSocket1Error(Sender: TObject; Socket: TCustomWinSocket;
ErrorEvent: TErrorEvent; var ErrorCode: Integer);
procedure Exit1Click(Sender: TObject);
procedure Connect1Click(Sender: TObject);
procedure ClientSocket1Read(Sender: TObject; Socket: TCustomWinSocket);
procedure ClientSocket1Disconnect(Sender: TObject;
Socket: TCustomWinSocket);
procedure Disconnect1Click(Sender: TObject);
procedure RefreshComplete1Click(Sender: TObject);
procedure UpdateChanges1Click(Sender: TObject);
procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure ResponseTimerTimer(Sender: TObject);
procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Image1Click(Sender: TObject);
procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Image1DblClick(Sender: TObject);
procedure ClickTimerTimer(Sender: TObject);
procedure PauseChange(Sender: TObject);
procedure SendButClick(Sender: TObject);
procedure SendCRButClick(Sender: TObject);
procedure Log1Click(Sender: TObject);
procedure CommStat1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Shutdown1Click(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FocusServerWindow1Click(Sender: TObject);
procedure ColorClick(Sender: TObject);
procedure CompClick(Sender: TObject);
procedure PriorityClick(Sender: TObject);
procedure ScaleImage1Click(Sender: TObject);
procedure ProcessList1Click(Sender: TObject);
procedure FileList1Click(Sender: TObject);
procedure SendPanelResize(Sender: TObject);
procedure About1Click(Sender: TObject);
procedure StatBarMenuClick(Sender: TObject);
procedure FullScreen1Click(Sender: TObject);
procedure FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
protected
NumRec : double;
NumSend : double;
CurMsg : string;
NeedReply : integer;
LastX : integer;
LastY : integer;
t1 : DWORD;
but : integer;
NumClick : integer;
MoveList : TList;
Anim : integer;
LastRec : DWORD;
ServerDelay: integer;
ViewMode : TViewMode;
CompMode : TCompressionLevel;
SvrPriority: integer;
ProcForm : TForm;
FileForm : TForm;
LastCPS : string;
BeforeFull : TRect;
procedure SetStat(i: integer; s: string);
procedure UpdateStats;
procedure SendText(const Text: string);
procedure Log(const s: string);
procedure EnableButs;
procedure ClearMoveList;
procedure AddMove(x, y: integer);
procedure ParseComLine;
procedure StopAnim;
procedure StartAnim;
procedure EnableInput;
procedure WMSysCommand(var Message: TWMSysCommand); message WM_SYSCOMMAND;
function CanSendMenuMsg: boolean;
procedure Send_Current_Settings;
procedure ScaleXY(var X, Y: integer);
procedure UpdateLogVis;
public
procedure SendMsg(MsgNum: integer; const MsgData: string; Socket: TCustomWinSocket);
procedure ProcessMessage(const Msg: string; Socket: TCustomWinSocket);
property Stat[i: integer]: string write SetStat;
end;
var
ClientForm: TClientForm;
implementation
uses ConnectDlg, ProcListDlg, FilesDlg, About, FsTopDlg;
{$R *.DFM}
procedure TClientForm.FormShow(Sender: TObject);
begin
UpdateLogVis;
if not ClientSocket1.Active then
Timer1.Enabled := True;
end;
function IsDotAddress(const s: string): boolean;
var
i : integer;
begin
Result := True;
for i := 1 to Length(s) do
if not (s in ['0'..'9', '.']) then Result := False;
end;
procedure TClientForm.Timer1Timer(Sender: TObject);
var
f : TForm;
begin
Timer1.Enabled := False;
f := Self;
with ClientConnectForm do begin
Left := (f.Left + f.Width div 2) - Width div 2;
Top := (f.Top + f.Height div 2) - Height div 2;
if ShowModal = mrOK then with ClientSocket1 do begin
if IsDotAddress(ServerCombo.Text) then begin
Host := '';
Address := ServerCombo.Text;
end else begin
Address := '';
Host := ServerCombo.Text;
end;
Port := StrToInt(PortEdit.Text);
StartAnim;
Active := True;
end;
end;
end;
procedure TClientForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if BorderStyle<>bsNone then FormSettings1.SaveSettings;
Disconnect1Click(nil);
end;
procedure TClientForm.ClientSocket1Lookup(Sender: TObject;
Socket: TCustomWinSocket);
begin
Stat[0] := ('Looking up: ' + ClientSocket1.Host);
end;
procedure TClientForm.SetStat(i: integer; s: string);
begin
FSTopForm.StatLabel.Caption := s;
StatusBar1.Panels.Text := s;
Update;
end;
procedure TClientForm.ClientSocket1Connecting(Sender: TObject;
Socket: TCustomWinSocket);
begin
Stat[0] := ('Connecting: ' + ClientSocket1.Host);
end;
procedure TClientForm.ClientSocket1Connect(Sender: TObject;
Socket: TCustomWinSocket);
begin
Log(Format('%-7s %s', ['LogOn', DateTimeToStr(Now)]));
EnableButs;
Stat[0] := ('Connected: ' + Socket.RemoteHost);
Caption := 'Remote Control Client - ' + Socket.RemoteHost;
NumSend := 0;
NumRec := 0;
NeedReply := 0;
StopAnim;
EnableInput;
SendMsg(MSG_LOGON, ClientConnectForm.PassEdit.Text, ClientSocket1.Socket);
Send_Current_Settings;
end;
procedure TClientForm.ClientSocket1Error(Sender: TObject;
Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer);
begin
Stat[0] := ('Error: ' + IntToStr(ErrorCode));
ErrorCode := 0;
if not Socket.Connected then StopAnim;
end;
procedure TClientForm.Exit1Click(Sender: TObject);
begin
Close;
end;
procedure TClientForm.Connect1Click(Sender: TObject);
begin
Image1.Picture.Bitmap := nil;
Timer1Timer(nil);
end;
procedure TClientForm.SendMsg(MsgNum: integer; const MsgData: string; Socket: TCustomWinSocket);
var
s : string;
begin
Log(Format('%-7s #%2.2d', ['Send', MsgNum]));
Stat[0] := Format('Sending Message (Len = %1.0n)', [Length(MsgData)+0.0]);
s := IntToByteStr(MsgNum) + IntToByteStr(Length(MsgData)) + MsgData;
Socket.SendText(s);
NumSend := NumSend + Length(s);
UpdateStats;
Inc(NeedReply);
StartAnim;
end;
procedure TClientForm.UpdateStats;
begin
// Stat[0] := Format('Sent: %1.0n', [NumSend]);
// Stat[1] := Format('Recv: %1.0n', [NumRec]);
end;
procedure TClientForm.ClientSocket1Read(Sender: TObject;
Socket: TCustomWinSocket);
var
s : string;
msg : integer;
len : integer;
PerStr : string;
tdif : double;
cps : string;
begin
// WaitImage.Hint := 'Data Last Received:' + #13#10 + CurTime;
s := Socket.ReceiveText;
NumRec := NumRec + Length(s);
UpdateStats;
if CurMsg = '' then LastRec := GetTickCount;
CurMsg := CurMsg + s;
if Length(CurMsg) >= 8 then begin
Move(CurMsg[1], msg, sizeof(integer));
Move(CurMsg[5], len, sizeof(integer));
PerStr := Format('(%1.0n%%)', [Length(CurMsg) / (len + 8.0) * 100.0]);
tdif := (GetTickCount - LastRec) / 1000.0;
if tdif > 0.5 then cps := Format('%1.0n cps', [Length(CurMsg) / tdif])
else cps := '';
Stat[0] := Format('Received: %1.0n of %1.0n %s %s',
[Length(CurMsg) + 0.0, len + 8.0, PerStr, cps]);
LastCPS := cps;
end else begin
if Length(s) > 0 then
Stat[0] := 'Received: ' + IntToStr(Length(CurMsg));
end;
while IsValidMessage(CurMsg) do begin
s := TrimFirstMsg(CurMsg);
ProcessMessage(s, Socket);
end;
end;
procedure TClientForm.ProcessMessage(const Msg: string; Socket: TCustomWinSocket);
var
MsgNum : integer;
Data : string;
bmp : TBitmap;
R : TRect;
begin
Move(Msg[1], MsgNum, sizeof(integer));
if MsgNum <> MSG_STAT_MSG then
Log(Format('%-7s #%0.2d %6.0n bytes %s', ['Recv', MsgNum, Length(Msg)+0.0, LastCPS]));
Data := Copy(Msg, 9, Length(Msg));
if MsgNum = MSG_STAT_MSG then begin
Stat[0] := Data;
exit;
end;
Dec(NeedReply);
if NeedReply = 0 then begin
StopAnim;
end;
if MsgNum = MSG_LOGON then begin
if Data <> '0' then begin
Stat[0] := 'Log on Successful';
if ClientConnectForm.StartScreenBox.Checked then
SendMsg(MSG_REFRESH, '', ClientSocket1.Socket);
end else begin
Stat[0] := 'Invalid Password!';
MessageDlg('Invalid Password!', mtWarning, [mbOK], 0);
end;
end;
if MsgNum = MSG_REFRESH then begin
Stat[0] := 'Decompressing';
SaveString(Data, 'Temp2.txt');
UnCompressBitmap(Data, Image1.Picture.Bitmap);
Stat[0] := 'Ready';
end;
if MsgNum = MSG_SCREEN_UPDATE then begin
bmp := TBitmap.Create;
Stat[0] := 'Decompressing';
UnCompressBitmap(Data, bmp);
R := Rect(0, 0, bmp.Width, bmp.Height);
with Image1.Picture.Bitmap.Canvas do begin
CopyMode := cmSrcInvert;
CopyRect(R, bmp.Canvas, R);
end;
Stat[0] := 'Ready';
bmp.Free;
end;
if MsgNum = MSG_SEVER_DELAY then begin
Stat[0] := 'Server Delay Set';
end;
if MsgNum = MSG_VIEW_MODE then begin
Stat[0] := 'View Mode Set';
end;
if MsgNum = MSG_COMP_MODE then begin
Stat[0] := 'Compression Mode Set';
end;
if MsgNum = MSG_PRIORITY_MODE then begin
Stat[0] := 'Priority Mode Set';
end;
if MsgNum = MSG_PROCESS_LIST then begin
if ProcForm = nil then
ProcForm := TProcListForm.Create(Self);
(ProcForm as TProcListForm).SetList(Data);
ProcForm.Show;
Stat[0] := 'Received Process List';
end;
if MsgNum = MSG_DRIVE_LIST then begin
if FileForm = nil then
FileForm := TFilesForm.Create(Self);
(FileForm as TFilesForm).SetDriveList(Data);
FileForm.Show;
Stat[0] := 'Received Drive List';
end;
if MsgNum = MSG_DIRECTORY then begin
Assert(FileForm <> nil);
(FileForm as TFilesForm).SetDirData(Data);
FileForm.Show;
Stat[0] := 'Received Directory';
end;
if MsgNum = MSG_FILE then begin
Assert(FileForm <> nil);
Stat[0] := 'Received File';
(FileForm as TFilesForm).SetFileData(Data);
end;
if MsgNum = MSG_REMOTE_LAUNCH then begin
Stat[0] := 'Launched File: ' + Data;
end;
end;
procedure TClientForm.ClientSocket1Disconnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
Log(Format('%-7s %s', ['LogOff', DateTimeToStr(Now)]));
ClientSocket1.Active := False;
EnableButs;
Stat[0] := ('Disconnected: ' + Socket.RemoteHost);
Caption := 'Remote Control Client';
StopAnim;
end;
procedure TClientForm.Disconnect1Click(Sender: TObject);
begin
Stat[0] := 'Disconnecting...';
ClientSocket1.Active := False;
EnableButs;
StopAnim;
end;
procedure TClientForm.RefreshComplete1Click(Sender: TObject);
begin
SendMsg(MSG_REFRESH, '', ClientSocket1.Socket);
end;
procedure TClientForm.UpdateChanges1Click(Sender: TObject);
begin
SendMsg(MSG_SCREEN_UPDATE, '', ClientSocket1.Socket);
end;
procedure TClientForm.Image1MouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
begin
ScaleXY(X, Y);
LastX := X;
LastY := Y;
AddMove(X, Y);
end;
procedure TClientForm.AddMove(x, y: integer);
var
MoveObj : TMoveObj;
begin
MoveObj := TMoveObj.Create;
MoveObj.X := X;
MoveObj.Y := Y;
MoveObj.Time := GetTickCount;
MoveList.Add(MoveObj);
end;
procedure TClientForm.ResponseTimerTimer(Sender: TObject);
var
bm : TBitmap;
x, y : integer;
begin
WaitImage.Hint := Format('Wait: %3.1n seconds', [(GetTickCount-t1)/1000.0]);
bm := TBitmap.Create;
bm.Width := WaitImage.Width;
bm.Height := WaitImage.Height;
Anim := Anim + 1;
Anim := Anim and 31;
for x := -1 to 1 do
for y := -1 to 1 do
bm.Canvas.Draw(Anim + x*32, Anim + y*32, Application.Icon);
WaitImage.Picture.Assign(bm);
bm.Free;
end;
procedure TClientForm.Image1MouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
ScaleXY(X, Y);
but := 1;
if Button = mbRight then but := 2;
ClearMoveList;
AddMove(x, y);
end;
procedure TClientForm.Image1Click(Sender: TObject);
begin
NumClick := 1;
ClickTimer.Enabled := True;
end;
procedure TClientForm.Image1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
ScaleXY(X, Y);
if but = 2 then begin
// Only do this for Right Clicks
SendMsg(MSG_CLICK, IntToByteStr(LastX) + IntToByteStr(LastY) +
IntToByteStr(1 {Single}) + IntToByteStr(but), ClientSocket1.Socket);
end;
AddMove(x, y);
end;
procedure TClientForm.Image1DblClick(Sender: TObject);
begin
NumClick := 2;
ClickTimer.Enabled := True;
end;
procedure TClientForm.ClickTimerTimer(Sender: TObject);
var
s : string;
MoveObj : TMoveObj;
i : integer;
begin
ClickTimer.Enabled := False;
if (MoveList.Count < 5) or (NumClick = 2) then begin
// This is a Click or Double-click
SendMsg(MSG_CLICK, IntToByteStr(LastX) + IntToByteStr(LastY) +
IntToByteStr(NumClick) + IntToByteStr(but), ClientSocket1.Socket);
end else begin
// This is a "drag" operation
s := IntToByteStr(but) + IntToByteStr(MoveList.Count);
for i := 0 to MoveList.Count-1 do begin
MoveObj := MoveList;
s := s + IntToByteStr(MoveObj.X) + IntToByteStr(MoveObj.Y)
+ IntToByteStr(MoveObj.time);
end;
SendMsg(MSG_DRAG, s, ClientSocket1.Socket);
end;
end;
procedure TClientForm.SendButClick(Sender: TObject);
begin
SendText(SendEdit.Text);
end;
procedure TClientForm.SendCRButClick(Sender: TObject);
begin
SendText(SendEdit.Text + #13);
end;
procedure TClientForm.SendText(const Text: string);
begin
SendMsg(MSG_KEYS, Text, ClientSocket1.Socket);
end;
procedure TClientForm.Log1Click(Sender: TObject);
begin
Log1.Checked := not Log1.Checked;
UpdateLogVis;
end;
procedure TClientForm.UpdateLogVis;
begin
LogList.Visible := Log1.Checked;
Splitter1.Visible := Log1.Checked;
if Log1.Checked then
LogList.Left := Splitter1.Left - 1;
end;
procedure TClientForm.Log(const s: string);
begin
LogList.ItemIndex := LogList.Items.Add(s);
end;
procedure TClientForm.CommStat1Click(Sender: TObject);
begin
CommStat1.Checked := not CommStat1.Checked;
StatPanel.Visible := CommStat1.Checked;
end;
procedure TClientForm.EnableButs;
var
b : boolean;
begin
b := ClientSocket1.Active;
Connect1.Enabled := not b;
Disconnect1.Enabled := b;
end;
procedure TClientForm.FormCreate(Sender: TObject);
begin
EnableButs;
MoveList := TList.Create;
ParseComLine;
StopAnim;
EnableInput;
ServerDelay := DEFAULT_SERVER_DELAY;
ViewMode := DEFAULT_VIEW_MODE;
CompMode := DEFAULT_COMP_MODE;
SvrPriority := DEFAULT_SVR_PRIORITY;
end;
procedure TClientForm.Shutdown1Click(Sender: TObject);
begin
Close;
Application.MainForm.Close;
end;
procedure TClientForm.FormDestroy(Sender: TObject);
begin
ClearMoveList;
MoveList.Free;
end;
procedure TClientForm.ClearMoveList;
var
i : integer;
begin
for i := 0 to MoveList.Count-1 do
TObject(MoveList).Free;
MoveList.Clear;
end;
procedure TClientForm.FocusServerWindow1Click(Sender: TObject);
begin
SendMsg(MSG_FOCUS_SERVER, '', ClientSocket1.Socket);
end;
procedure TClientForm.ParseComLine;
var
i : integer;
s : string;
begin
for i := 1 to ParamCount do begin
s := UpperCase(ParamStr(i));
if s = '/CLIENT' then begin
Visible := True;
end;
end;
end;
procedure TClientForm.EnableInput;
var
b : boolean;
begin
b := (NeedReply = 0) and ClientSocket1.Active;
SendBut.Enabled := b;
SendCRBut.Enabled := b;
Image1.Enabled := b;
Special1.Enabled := b;
// Options1.Enabled := b;
end;
procedure TClientForm.StopAnim;
var
bmp : TBitmap;
begin
Screen.Cursor := crDefault;
ResponseTimer.Enabled := False;
// Stat[2] := 'Not Waiting';
bmp := TBitmap.Create;
bmp.Width := WaitImage.Width;
bmp.Height := WaitImage.Height;
bmp.Canvas.Draw(2, 2, Application.Icon);
WaitImage.Picture.Assign(bmp);
bmp.Free;
EnableInput;
end;
procedure TClientForm.StartAnim;
begin
Anim := 2;
ResponseTimer.Enabled := True;
// Stat[2] := 'Waiting';
t1 := GetTickCount;
Screen.Cursor := crAppStart;
EnableInput;
end;
procedure TClientForm.WMSysCommand(var Message: TWMSysCommand);
begin
if (Message.CmdType and $FFF0 = SC_MINIMIZE) then
Application.Minimize
else
inherited;
end;
function TClientForm.CanSendMenuMsg: boolean;
begin
Result := ClientSocket1.Active;
end;
procedure TClientForm.PauseChange(Sender: TObject);
var
d : integer;
begin
d := 0;
(Sender as TMenuItem).Checked := True;
if Sender = N005sec1 then d := 50;
if Sender = N010sec1 then d := 100;
if Sender = N050sec1 then d := 500;
if Sender = N100sec1 then d := 1000;
if Sender = N200sec1 then d := 2000;
if Sender = N500sec1 then d := 5000;
ServerDelay := d;
if CanSendMenuMsg then
SendMsg(MSG_SEVER_DELAY, IntToByteStr(d), ClientSocket1.Socket);
end;
procedure TClientForm.ColorClick(Sender: TObject);
var
vm : TViewMode;
x : integer;
begin
(Sender as TMenuItem).Checked := True;
vm := vmDefault;
if Sender = Color4 then vm := vmColor4;
if Sender = Gray4 then vm := vmGray4;
if Sender = Gray8 then vm := vmGray8;
if Sender = Color24 then vm := vmColor24;
if Sender = Default1 then vm := vmDefault;
ViewMode := vm;
if CanSendMenuMsg then begin
x := integer(vm);
SendMsg(MSG_VIEW_MODE, IntToByteStr(x), ClientSocket1.Socket);
SendMsg(MSG_REFRESH, '', ClientSocket1.Socket);
end;
end;
procedure TClientForm.CompClick(Sender: TObject);
var
cm : TCompressionLevel;
begin
(Sender as TMenuItem).Checked := True;
cm := clDefault;
if Sender = HighSlow1 then cm := clMax;
if Sender = Medium1 then cm := clDefault;
if Sender = LowFast1 then cm := clFastest;
CompMode := cm;
if CanSendMenuMsg then
SendMsg(MSG_COMP_MODE, IntToByteStr(integer(cm)), ClientSocket1.Socket);
end;
procedure TClientForm.PriorityClick(Sender: TObject);
var
x : integer;
begin
(Sender as TMenuItem).Checked := True;
x := THREAD_PRIORITY_NORMAL;
if Sender = Critical1 then x := THREAD_PRIORITY_TIME_CRITICAL;
if Sender = Highest1 then x := THREAD_PRIORITY_HIGHEST;
if Sender = AboveNormal1 then x := THREAD_PRIORITY_ABOVE_NORMAL;
if Sender = Normal1 then x := THREAD_PRIORITY_NORMAL;
if Sender = BelowNormal1 then x := THREAD_PRIORITY_BELOW_NORMAL;
if Sender = Lowest1 then x := THREAD_PRIORITY_LOWEST;
if Sender = Idle1 then x := THREAD_PRIORITY_IDLE;
SvrPriority := x;
if CanSendMenuMsg then
SendMsg(MSG_PRIORITY_MODE, IntToByteStr(x), ClientSocket1.Socket);
end;
procedure TClientForm.Send_Current_Settings;
begin
SendMsg(MSG_SEVER_DELAY, IntToByteStr(ServerDelay), ClientSocket1.Socket);
SendMsg(MSG_VIEW_MODE, IntToByteStr(integer(ViewMode)), ClientSocket1.Socket);
SendMsg(MSG_COMP_MODE, IntToByteStr(integer(CompMode)), ClientSocket1.Socket);
SendMsg(MSG_PRIORITY_MODE, IntToByteStr(SvrPriority), ClientSocket1.Socket);
end;
procedure TClientForm.ScaleImage1Click(Sender: TObject);
begin
ScaleImage1.Checked := not ScaleImage1.Checked;
if ScaleImage1.Checked then begin
Image1.AutoSize := False;
Image1.Stretch := True;
Image1.Align := alClient;
end else begin
Image1.AutoSize := True;
Image1.Stretch := False;
Image1.Align := alNone;
Image1.Picture.Assign(Image1.Picture.Graphic); // To trigger the Autosize property
end;
end;
procedure TClientForm.ScaleXY(var X, Y: integer);
begin
if not ScaleImage1.Checked then exit;
with Image1 do begin
X := X * Picture.Width div Width;
Y := Y * Picture.Height div Height;
end;
end;
procedure TClientForm.ProcessList1Click(Sender: TObject);
begin
SendMsg(MSG_PROCESS_LIST, '', ClientSocket1.Socket);
end;
procedure TClientForm.FileList1Click(Sender: TObject);
begin
SendMsg(MSG_DRIVE_LIST, '', ClientSocket1.Socket);
end;
procedure TClientForm.SendPanelResize(Sender: TObject);
begin
SendEdit.Width := SendPanel.ClientWidth - 8;
end;
procedure TClientForm.About1Click(Sender: TObject);
begin
AboutBox.ShowModal;
end;
procedure TClientForm.StatBarMenuClick(Sender: TObject);
begin
StatBarMenu.Checked := not StatBarMenu.Checked;
StatusBar1.Visible := StatBarMenu.Checked;
end;
procedure TClientForm.FullScreen1Click(Sender: TObject);
begin
if BorderStyle = bsSizeable then begin
BeforeFull := BoundsRect;
Menu := nil;
Left := 0;
Top := 0;
Width := Screen.Width;
Height := Screen.Height;
BorderStyle := bsNone;
StatPanel.Visible := False;
StatusBar1.Visible := False;
ScrollBox1.BorderStyle := bsNone;
FSTopForm.Show;
end else begin
BoundsRect := BeforeFull;
Menu := MainMenu1;
BorderStyle := bsSizeable;
StatPanel.Visible := True;
StatusBar1.Visible := True;
ScrollBox1.BorderStyle := bsSingle;
FSTopForm.Hide;
end;
end;
procedure TClientForm.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
// If in Full-Screen mode, do an extra check for Hot-Keys on the popup menu
if BorderStyle = bsNone then begin
FSTopForm.CheckShortCut(Key, Shift);
end;
end;
end.