delphi爬虫框架（自己动手丰衣足食）

最近在整理硬盘资料，前几年收集的不少chm格式的电子书合集，想复制到手机上阅读，发现格式又不支持，随即产生了以下作品，写个web服务器，用来解析电子书，然后就可以随时随地不受限制的读书了。

先看效果

delphi爬虫框架（自己动手丰衣足食）(1)

delphi爬虫框架（自己动手丰衣足食）(2)

delphi爬虫框架（自己动手丰衣足食）(3)

程序很简单，只有一个exe，一个配置文件。

双击运行后，把chm文件解压后的文件和服务端程序放一起即可。

delphi爬虫框架（自己动手丰衣足食）(4)

这里放首页文件。

下面上代码

form代码

object Form1: TForm1

Left = 271

Top = 114

Caption = 'MiniWeb By YSINFO'

ClientHeight = 361

ClientWidth = 795

Color = clBtnFace

Font.Charset = DEFAULT_CHARSET

Font.Color = clWindowText

Font.Height = -11

Font.Name = 'Tahoma'

Font.Style = []

OnClose = FormClose

OnCreate = FormCreate

OnShow = FormShow

TextHeight = 13

object Label1: TLabel

Left = 24

Top = 48

Width = 20

Height = 13

Caption = 'Port'

end

object Label2: TLabel

Left = 40

Top = 280

Width = 545

Height = 49

AutoSize = False

Caption = 'Label2'

Font.Charset = DEFAULT_CHARSET

Font.Color = clWindowText

Font.Height = -13

Font.Name = 'Tahoma'

Font.Style = []

ParentFont = False

end

object ButtonStart: TButton

Left = 24

Top = 8

Width = 75

Height = 25

Caption = 'Start'

TabOrder = 0

OnClick = ButtonStartClick

end

object ButtonStop: TButton

Left = 105

Top = 8

Width = 75

Height = 25

Caption = 'Stop'

TabOrder = 1

OnClick = ButtonStopClick

end

object EditPort: TEdit

Left = 24

Top = 67

Width = 121

Height = 21

TabOrder = 2

Text = '8080'

end

object ButtonOpenBrowser: TButton

Left = 24

Top = 112

Width = 107

Height = 25

Caption = 'Open Browser'

TabOrder = 3

OnClick = ButtonOpenBrowserClick

end

object btnDir: TBitBtn

Left = 224

Top = 112

Width = 107

Height = 25

Caption = #25171#24320#31243#24207#30446#24405

TabOrder = 4

OnClick = btnDirClick

end

object btn1: TBitBtn

Left = 264

Top = 8

Width = 107

Height = 25

Caption = #21047#26032

TabOrder = 5

OnClick = btn1Click

end

object mmo1: TMemo

Left = 504

Top = 8

Width = 185

Height = 169

Lines.Strings = (

'cover.htm'

'index0.htm'

'index1.htm')

TabOrder = 6

end

object btn2: TBitBtn

Left = 510

Top = 192

Width = 139

Height = 25

Caption = #33719#21462#25991#20214#21015#34920

TabOrder = 7

OnClick = btn2Click

end

object ApplicationEvents1: TApplicationEvents

OnIdle = ApplicationEvents1Idle

Left = 288

Top = 24

end

object trycn1: TTrayIcon

PopupMenu = pm1

Visible = True

OnDblClick = trycn1DblClick

Left = 184

Top = 288

end

object pm1: TPopupMenu

Left = 440

Top = 104

object N1: TMenuItem

Caption = #36864#20986

OnClick = N1Click

end

object tmr1: TTimer

OnTimer = btn1Click

Left = 424

Top = 264

end

PAS代码

unit FormUnit1;

interface

uses

Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,

System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,

Vcl.AppEvnts, Vcl.StdCtrls, IdHTTPWebBrokerBridge, Web.HTTPApp, Vcl.Buttons,

Vcl.ExtCtrls, Vcl.Menus;

type

TForm1 = class(TForm)

ButtonStart: TButton;

ButtonStop: TButton;

EditPort: TEdit;

Label1: TLabel;

ApplicationEvents1: TApplicationEvents;

ButtonOpenBrowser: TButton;

btnDir: TBitBtn;

btn1: TBitBtn;

trycn1: TTrayIcon;

Label2: TLabel;

pm1: TPopupMenu;

N1: TMenuItem;

tmr1: TTimer;

mmo1: TMemo;

btn2: TBitBtn;

procedure FormCreate(Sender: TObject);

procedure ApplicationEvents1Idle(Sender: TObject; var Done: Boolean);

procedure ButtonStartClick(Sender: TObject);

procedure ButtonStopClick(Sender: TObject);

procedure ButtonOpenBrowserClick(Sender: TObject);

procedure btnDirClick(Sender: TObject);

procedure btn1Click(Sender: TObject);

procedure FormClose(Sender: TObject; var Action: TCloseAction);

procedure FormShow(Sender: TObject);

procedure N1Click(Sender: TObject);

procedure trycn1DblClick(Sender: TObject);

procedure btn2Click(Sender: TObject);

private

FServer: TIdHTTPWebBrokerBridge;

procedure StartServer;

procedure GetData(Sender: TObject);

{ Private declarations }

public { Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

uses

Winapi.ShellApi, Datasnap.DSSession, UnitPublic;

procedure TForm1.ApplicationEvents1Idle(Sender: TObject; var Done: Boolean);

begin

ButtonStart.Enabled := not FServer.Active;

ButtonStop.Enabled := FServer.Active;

EditPort.Enabled := not FServer.Active;

end;

procedure TForm1.GetData(Sender: TObject);

begin

Label2.Caption := Format('调用次数 %s 字节数:%.2f KB 流量:%s 运行时间:%s ', [ncount.ToString, (nsize / 1024), ConvertBytes(nsize), GetSubDateTime(now, dstart)])

end;

procedure TForm1.btn1Click(Sender: TObject);

begin

GetData(Sender);

//Label2.Caption:= Format('调用次数 %s 流量:%s 运行时间:%s ',[ncount.ToString,ConvertBytes(nsize) ,GetSubDateTime(now,dstart) ]) ;

end;

procedure TForm1.btn2Click(Sender: TObject);

var

sl:tstringlist;

begin

sl:=GetAllFile('d:\','*.*');

sl.SaveToFile(AppPath 'd.txt');

sl.Free;

end;

procedure TForm1.btnDirClick(Sender: TObject);

begin

openDir(AppPath);

end;

procedure TForm1.ButtonOpenBrowserClick(Sender: TObject);

var

LURL: string;

begin

StartServer;

LURL := Format('http://192.168.1.13:%s', [EditPort.Text]);

ShellExecute(0, nil, PChar(LURL), nil, nil, SW_SHOWNOACTIVATE);

end;

procedure TForm1.ButtonStartClick(Sender: TObject);

begin

StartServer;

end;

procedure TerminateThreads;

begin

if TDSSessionManager.Instance <> nil then

TDSSessionManager.Instance.TerminateAllSessions;

end;

procedure TForm1.ButtonStopClick(Sender: TObject);

begin

TerminateThreads;

FServer.Active := False;

FServer.Bindings.Clear;

end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);

begin

Self.Hide;

Action := caNone;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

EditPort.Text := SetIniNoEn(sconfig, False, 'set', 'port', '8080');

mmo1.Text := SetIniNoEn(sconfig, False, 'set', 'INDEX', 'index.htm');

FServer := TIdHTTPWebBrokerBridge.Create(Self);

StartServer;

end;

procedure TForm1.FormShow(Sender: TObject);

begin

getdata(Sender);

end;

procedure TForm1.N1Click(Sender: TObject);

begin

if MessageDlg('确定退出？', mtConfirmation, mbOKCancel, 0) = mrOk then

Application.Terminate;

end;

procedure TForm1.StartServer;

var

I: Integer;

begin

if not FServer.Active then

begin

FServer.Bindings.Clear;

FServer.DefaultPort := StrToInt(EditPort.Text);

FServer.Active := True;

SetIniNoEn(sconfig, True, 'set', 'port', EditPort.Text);

SetIniNoEn(sconfig, True, 'set', 'INDEX', MMO1.Text);

SetLength(sIndex, mmo1.Lines.Count);

for I := 0 to mmo1.Lines.Count - 1 do

sIndex[I] := mmo1.Lines[I];

end;

procedure TForm1.trycn1DblClick(Sender: TObject);

begin

Self.Show;

end;

end.

unit WebModuleUnit1;

interface

uses

System.SysUtils, System.Classes, Web.HTTPApp, Datasnap.DSHTTPCommon,

Datasnap.DSHTTPWebBroker, Datasnap.DSServer, Datasnap.DSProxyDispatcher,

Datasnap.DSProxyJavaAndroid, Datasnap.DSProxyJavaBlackBerry,

Datasnap.DSProxyObjectiveCiOS, Datasnap.DSProxyCsharpSilverlight,

Datasnap.DSProxyFreePascal_iOS, Datasnap.DSAuth, IPPeerServer,

Datasnap.DSMetadata, Datasnap.DSServerMetadata, Winapi.Windows, uQQWry,

Datasnap.DSClientMetadata, Datasnap.DSCommonServer, Datasnap.DSHTTP, qlog,

UnitPublic;

type

TWebModule1 = class(TWebModule)

DSHTTPWebDispatcher1: TDSHTTPWebDispatcher;

DSProxyGenerator1: TDSProxyGenerator;

DSServerMetaDataProvider1: TDSServerMetaDataProvider;

DSProxyDispatcher1: TDSProxyDispatcher;

procedure WebModule1DefaultHandlerAction(Sender: TObject; Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);

procedure WebModuleCreate(Sender: TObject);

private

procedure HandleFileRequest(const FileName: string; Request: TWebRequest; Response: TWebResponse);

{ Private declarations }

public { Public declarations }

end;

var

WebModuleClass: TComponentClass = TWebModule1;

implementation

uses

ServerMethodsUnit1, ServerContainerUnit1, Web.WebReq, MATH;

{$R *.dfm}

function StripHTMLTags(const strHTML: string): string;

var

P: PChar;

InTag: Boolean;

i, intResultLength: Integer;

begin

P := PChar(strHTML);

Result := '';

InTag := False;

repeat

case P^ of

'<':

InTag := True;

'>':

InTag := False;

#13, #10:

; { do nothing }

else

if not InTag then

begin

if (P^ in [#9, #32]) and ((P 1)^ in [#10, #13, #32, #9, '<']) then

else

Result := Result P^;

end;

Inc(P);

until (P^ = #0);

{ convert system characters }

Result := StringReplace(Result, '"', '"', [rfReplaceAll]);

Result := StringReplace(Result, ''', '''', [rfReplaceAll]);

Result := StringReplace(Result, '>', '>', [rfReplaceAll]);

Result := StringReplace(Result, '<', '<', [rfReplaceAll]);

Result := StringReplace(Result, '&', '&', [rfReplaceAll]);

{ here you may add another symbols from RFC if you need }

end;

function getFileType(inputFile: string): string;

const

JPEG_FLAG_BEGIN = $D8FF;

JPEG_FLAG_END = $D9FF;

JPEG_FRAME = $C0FF;

GIF_FLAG_BEGIN = $4947;

GIF_FLAG_END = $3B00;

PNG_FLAG_BEGIN = $5089;

PNG_FLAG_END = $8260;

BMP_FLAG_BEGIN = $4D42;

EXE_FLAG_BEGIN = $5A4D;

ZIP_7Z_FLAG_BEGIN = $7A37;

ZIP_FLAG_BEGIN = $4B50;

var

FileStream: TFileStream;

BeginFlag, EndFlag: WORD;

begin

Result := 'Unkown';

FileStream := nil;

try

FileStream := TFileStream.Create(inputFile, fmOpenRead);

FileStream.Position := 0;

FileStream.Read(BeginFlag, SizeOf(BeginFlag));

FileStream.Position := FileStream.Size - 2;

FileStream.Read(EndFlag, SizeOf(EndFlag));

if (BeginFlag = JPEG_FLAG_BEGIN) and (EndFlag = JPEG_FLAG_END) then

Result := 'JPG';

if (BeginFlag = GIF_FLAG_BEGIN) and (EndFlag = GIF_FLAG_END) then

Result := 'GIF';

if (BeginFlag = PNG_FLAG_BEGIN) and (EndFlag = PNG_FLAG_END) then

Result := 'PNG';

if (BeginFlag = BMP_FLAG_BEGIN) then

Result := 'BMP';

if (BeginFlag = EXE_FLAG_BEGIN) then

Result := 'EXE';

if BeginFlag = ZIP_7Z_FLAG_BEGIN then

Result := '7Z';

if BeginFlag = ZIP_FLAG_BEGIN then

Result := 'Zip';

finally

freeandnil(FileStream);

end;

function getContect(ext: string): string;

begin

if ext[1] = '.' then

ext := Copy(ext, 2);

if ext = 'ez' then

result := 'application/andrew-inset'

else if ext = 'hqx' then

result := 'application/mac-binhex40'

else if ext = 'cpt' then

result := 'application/mac-compactpro'

else if ext = 'doc' then

result := 'application/msword'

else if ext = 'bin' then