这是HTTPGET的源代码：
unit HTTPGet;
interface
uses
Windows, Messages, SysUtils, Classes, WinInet;
type
TOnProgressEvent = procedure(Sender: TObject; TotalSize, Readed: Integer) of object;
TOnDoneFileEvent = procedure(Sender: TObject; FileName: String; FileSize: Integer) of object;
TOnDoneStringEvent = procedure(Sender: TObject; Result: String) of object;
THTTPGetThread = class(TThread)
private
FTAcceptTypes,
FTAgent,
FTURL,
FTFileName,
FTStringResult,
FTUserName,
FTPassword,
FTPostQuery,
FTReferer: String;
FTBinaryData,
FTUseCache: Boolean;
FTResult: Boolean;
FTFileSize: Integer;
FTToFile: Boolean;
BytesToRead, BytesReaded: DWord;
FTProgress: TOnProgressEvent;
procedure UpdateProgress;
protected
procedure Execute; override;
public
constructor Create(aAcceptTypes, aAgent, aURL, aFileName, aUserName, aPassword, aPostQuery, aReferer: String;
aBinaryData, aUseCache: Boolean; aProgress: TOnProgressEvent; aToFile: Boolean);
end;
THTTPGet = class(TComponent)
private
FAcceptTypes: String;
FAgent: String;
FBinaryData: Boolean;
FURL: String;
FUseCache: Boolean;
FFileName: String;
FUserName: String;
FPassword: String;
FPostQuery: String;
FReferer: String;
FWaitThread: Boolean;
FThread: THTTPGetThread;
FError: TNotifyEvent;
FResult: Boolean;
FProgress: TOnProgressEvent;
FDoneFile: TOnDoneFileEvent;
FDoneString: TOnDoneStringEvent;
procedure ThreadDone(Sender: TObject);
public
constructor Create(aOwner: TComponent); override;
destructor Destroy; override;
procedure GetFile;
procedure GetString;
procedure Abort;
published
property AcceptTypes: String read FAcceptTypes write FAcceptTypes;
property Agent: String read FAgent write FAgent;
property BinaryData: Boolean read FBinaryData write FBinaryData;
property URL: String read FURL write FURL;
property UseCache: Boolean read FUseCache write FUseCache;
property FileName: String read FFileName write FFileName;
property UserName: String read FUserName write FUserName;
property Password: String read FPassword write FPassword;
property PostQuery: String read FPostQuery write FPostQuery;
property Referer: String read FReferer write FReferer;
property WaitThread: Boolean read FWaitThread write FWaitThread;
property OnProgress: TOnProgressEvent read FProgress write FProgress;
property OnDoneFile: TOnDoneFileEvent read FDoneFile write FDoneFile;
property OnDoneString: TOnDoneStringEvent read FDoneString write FDoneString;
property OnError: TNotifyEvent read FError write FError;
end;
procedure Register;
implementation
// THTTPGetThread
constructor THTTPGetThread.Create(aAcceptTypes, aAgent, aURL, aFileName, aUserName, aPassword, aPostQuery, aReferer: String;
aBinaryData, aUseCache: Boolean; aProgress: TOnProgressEvent; aToFile: Boolean);
begin
FreeOnTerminate := True;
inherited Create(True);
FTAcceptTypes := aAcceptTypes;
FTAgent := aAgent;
FTURL := aURL;
FTFileName := aFileName;
FTUserName := aUserName;
FTPassword := aPassword;
FTPostQuery := aPostQuery;
FTReferer := aReferer;
FTProgress := aProgress;
FTBinaryData := aBinaryData;
FTUseCache := aUseCache;
FTToFile := aToFile;
Resume;
end;
procedure THTTPGetThread.UpdateProgress;
begin
FTProgress(Self, FTFileSize, BytesReaded);
end;
procedure THTTPGetThread.Execute;
var
hSession, hConnect, hRequest: hInternet;
HostName, FileName: String;
f: File;
Buf: Pointer;
dwBufLen, dwIndex: DWord;
Data: Array[0..$400] of Char;
TempStr: String;
RequestMethod: PChar;
InternetFlag: DWord;
AcceptType: LPStr;
procedure ParseURL(URL: String; var HostName, FileName: String);
procedure ReplaceChar(c1, c2: Char; var St: String);
var
p: Integer;
begin
while True do
begin
p := Pos(c1, St);
if p = 0 then Break
else St[p] := c2;
end;
end;
var
i: Integer;
begin
if Pos('http://', LowerCase(URL)) <> 0 then
System.Delete(URL, 1, 7);
i := Pos('/', URL);
HostName := Copy(URL, 1, i);
FileName := Copy(URL, i, Length(URL) - i + 1);
if (Length(HostName) > 0) and (HostName[Length(HostName)] = '/') then
SetLength(HostName, Length(HostName) - 1);
end;
procedure CloseHandles;
begin
InternetCloseHandle(hRequest);
InternetCloseHandle(hConnect);
InternetCloseHandle(hSession);
end;
begin
try
ParseURL(FTURL, HostName, FileName);
if Terminated then
begin
FTResult := False;
Exit;
end;
if FTAgent <> '' then
hSession := InternetOpen(PChar(FTAgent),
INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0)
else
hSession := InternetOpen(nil,
INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
hConnect := InternetConnect(hSession, PChar(HostName),
INTERNET_DEFAULT_HTTP_PORT, PChar(FTUserName), PChar(FTPassword), INTERNET_SERVICE_HTTP, 0, 0);
if FTPostQuery = '' then RequestMethod := 'GET'
else RequestMethod := 'POST';
if FTUseCache then InternetFlag := 0
else InternetFlag := INTERNET_FLAG_RELOAD;
AcceptType := PChar('Accept: ' + FTAcceptTypes);
hRequest := HttpOpenRequest(hConnect, RequestMethod, PChar(FileName), 'HTTP/1.0',
PChar(FTReferer), @AcceptType, InternetFlag, 0);
if FTPostQuery = '' then
HttpSendRequest(hRequest, nil, 0, nil, 0)
else
HttpSendRequest(hRequest, 'Content-Type: application/x-www-form-urlencoded', 47,
PChar(FTPostQuery), Length(FTPostQuery));
if Terminated then
begin
CloseHandles;
FTResult := False;
Exit;
end;
dwIndex := 0;
dwBufLen := 1024;
GetMem(Buf, dwBufLen);
FTResult := HttpQueryInfo(hRequest, HTTP_QUERY_CONTENT_LENGTH,
Buf, dwBufLen, dwIndex);
if Terminated then
begin
FreeMem(Buf);
CloseHandles;
FTResult := False;
Exit;
end;
if FTResult or not FTBinaryData then
begin
if FTResult then
FTFileSize := StrToInt(StrPas(Buf));
BytesReaded := 0;
if FTToFile then
begin
AssignFile(f, FTFileName);
Rewrite(f, 1);
end
else FTStringResult := '';
while True do
begin
if Terminated then
begin
if FTToFile then CloseFile(f);
FreeMem(Buf);
CloseHandles;
FTResult := False;
Exit;
end;
if not InternetReadFile(hRequest, @Data, SizeOf(Data), BytesToRead) then Break
else
if BytesToRead = 0 then Break
else
begin
if FTToFile then
BlockWrite(f, Data, BytesToRead)
else
begin
TempStr := Data;
SetLength(TempStr, BytesToRead);
FTStringResult := FTStringResult + TempStr;
end;
inc(BytesReaded, BytesToRead);
if Assigned(FTProgress) then
Synchronize(UpdateProgress);
end;
end;
if FTToFile then
FTResult := FTFileSize = Integer(BytesReaded)
else
begin
SetLength(FTStringResult, BytesReaded);
FTResult := BytesReaded <> 0;
end;
if FTToFile then CloseFile(f);
end;
FreeMem(Buf);
CloseHandles;
except
end;
end;
// HTTPGet
constructor THTTPGet.Create(aOwner: TComponent);
begin
inherited Create(aOwner);
FAcceptTypes := '*/*';
FAgent := 'UtilMind HTTPGet';
end;
destructor THTTPGet.Destroy;
begin
Abort;
inherited Destroy;
end;
procedure THTTPGet.GetFile;
var
Msg: TMsg;
begin
if not Assigned(FThread) then
begin
FThread := THTTPGetThread.Create(FAcceptTypes, FAgent, FURL, FFileName, FUserName, FPassword, FPostQuery, FReferer,
FBinaryData, FUseCache, FProgress, True);
FThread.OnTerminate := ThreadDone;
if FWaitThread then
while Assigned(FThread) do
while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end
end;
procedure THTTPGet.GetString;
var
Msg: TMsg;
begin
if not Assigned(FThread) then
begin
FThread := THTTPGetThread.Create(FAcceptTypes, FAgent, FURL, FFileName, FUserName, FPassword, FPostQuery, FReferer,
FBinaryData, FUseCache, FProgress, False);
FThread.OnTerminate := ThreadDone;
if FWaitThread then
while Assigned(FThread) do
while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end
end;
procedure THTTPGet.Abort;
begin
if Assigned(FThread) then
begin
FThread.Terminate;
FThread.FTResult := False;
end;
end;
procedure THTTPGet.ThreadDone(Sender: TObject);
begin
FResult := FThread.FTResult;
if FResult then
if FThread.FTToFile then
if Assigned(FDoneFile) then FDoneFile(Self, FThread.FTFileName, FThread.FTFileSize) else
else
if Assigned(FDoneString) then FDoneString(Self, FThread.FTStringResult) else
else
if Assigned(FError) then FError(Self);
FThread := nil;
end;
procedure Register;
begin
RegisterComponents('yjchen', [THTTPGet]);
end;
end.
这是分析HTML文件的程序的原代码：
ParseURL.pas
unit parseURL;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls;
type
PURLData = ^TURLData;
TURLData = record
URL: string;
Title: string;
end;
TURL = class
private
FList: TList;
FStream: TMemoryStream;
FFileName: string;
function GetURL(const Index: Integer): TURLData;
function GetURLCount: Integer;
procedure SetFileName(const Value: string);
public
constructor Create;
destructor Destroy; override;
procedure ClearURL;
procedure ExtractURL;
property URL[const Index: Integer]: TURLData read GetURL;
property URLCount: Integer read GetURLCount;
property FileName: string read FFileName write SetFileName;
end;
TForm1 = class(TForm)
Button1: TButton;
ListView1: TListView;
procedure Button1Click(Sender: TObject);
procedure ListView1Data(Sender: TObject; Item: TListItem);
private
FURL: TURL;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{ TURL }
procedure TURL.ClearURL;
var
I: Integer;
begin
for I := 0 to FList.Count - 1 do
FreeMem(FList);
FList.Clear;
end;
constructor TURL.Create;
begin
FList := TList.Create;
FStream := TMemoryStream.Create;
end;
destructor TURL.Destroy;
begin
ClearURL;
FStream.Free;
inherited Destroy;
end;
procedure TURL.SetFileName(const Value: string);
var
C: Char;
begin
if Value = FFileName then Exit;
ClearURL;
FFileName := Value;
FStream.LoadFromFile(FFileName);
C := #0;
FStream.Position := FStream.Size;
FStream.Write(C, 1);
ExtractURL;
end;
procedure TURL.ExtractURL;
const
HREF: array [0..3] of Char = ('H', 'R', 'E', 'F');
var
P, S: PChar;
Data: TURLData;
function CompHREF: Boolean;
var
T: PChar;
I: Integer;
begin
T := P;
for I := 0 to SizeOf(HREF) - 1 do
begin
Result := UpCase(T^) = HREF;
if not Result then
break;
Inc(T);
end;
end;
procedure SkipBlanks;
begin
while P^ <> #0 do
begin
if P^ in [#33..#255, #10] then
break;
Inc(P);
end;
end;
procedure AddURL;
var
D: PURLData;
begin
New(D);
D^.URL := Data.URL;
D^.Title := Data.Title;
FList.Add(D);
end;
procedure GetURL;
var
Len: Integer;
begin
SkipBlanks;
if CompHREF then
begin
Inc(P, SizeOf(HREF));
SkipBlanks;
if P^ = '=' then Inc(P);
SkipBlanks;
case P^ of
'"', '''':
begin
{ URL }
Inc(P);
S := P;
while not (P^ in ['"', '''']) do Inc(P);
Len := P - S;
SetLength(Data.URL, Len);
Move(S^, Data.URL[1], Len);
{ GetTitle }
Inc(P);
SkipBlanks;
while P^ <> '>' do Inc(P);
Inc(P);
SkipBlanks;
S := P;
while True do
case P^ of
'<':
begin
if P = S then
begin
Inc(P);
Continue;
end else
begin
Inc(P);
case P^ of
'/':
begin
Len := P - S - 1;
SetLength(Data.Title, Len);
Move(S^, Data.Title[1], Len);
AddURL;
Exit;
end;
end;
end;
end;
'>':
begin
Inc(P);
S := P;
end;
else
Inc(P);
end;
end;
end;
end;
end;
begin
P := FStream.Memory;
SkipBlanks;
while True do
begin
case P^ of
'<':
begin
Inc(P);
SkipBlanks;
case P^ of
'a', 'A':
begin
Inc(P);
GetURL;
end;
end;
end;
#0: break;
end;
Inc(P);
end;
end;
function TURL.GetURL(const Index: Integer): TURLData;
begin
if Index in [0..(FList.Count - 1)] then
Result := PURLData(FList[Index])^
else
raise Exception.Create('Error');
end;
function TURL.GetURLCount: Integer;
begin
Result := FList.Count;
end;
constructor TForm1.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FURL := TURL.Create;
end;
destructor TForm1.Destroy;
begin
FURL.Free;
inherited Destroy;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
FURL.FileName := 'a.txt'; //将HTML文件给FileName，进行解析
ListView1.Items.Count := FURL.URLCount;
end;
procedure TForm1.ListView1Data(Sender: TObject; Item: TListItem);
var
Data: TURLData;
begin
Data := FURL.URL[Item.Index];
Item.Caption := Data.Title;
Item.SubItems.Add(Data.URL)
end;
end.
请大家一定要帮忙啊 急
]