WebWorld_u 单元
unit WebWorld_u;
interface
uses Windows, Classes, WiniNet;
type
TWWOpenWorkEvent = procedure(Sender: TObject; const dwFileSize: DWORD) of object;
TWWOverWorkEvent = procedure(Sender: TObject; const dwPosition: DWORD; var bTerminate: LongBool) of object;
TWWCloseWorkEvent = procedure(Sender: TObject; const bSucceed: LongBool) of object;
type
TWebWorld = class
private
m_Session: HINTERNET;
FOnOpenWork: TWWOpenWorkEvent;
FOnOverWork: TWWOverWorkEvent;
FOnCloseWork: TWWCloseWorkEvent;
FURL: string;
FServerName, FObjectName, FFielName: string;
protected
function InternetConnect: HINTERNET;
function HttpOpenRequest(hConnect: HINTERNET): HINTERNET;
function HttpSendRequest(hRequest: HINTERNET): LongBool;
function InternetErrorDlg(hConnect: HINTERNET): DWORD;
function HttpQueryInfo(hRequest: HINTERNET; var dwFileSize: DWORD): LongBool;
function InternetReadFile(hRequest: HINTERNET; var dwPosition: DWORD; var dwBytesRead: DWORD; var lpBuffer: Pointer): LongBool;
procedure SetUrl(const aUrl: string);
published
property OnOpenWork: TWWOpenWorkEvent read FOnOpenWork write FOnOpenWork;
property OnOverWork: TWWOverWorkEvent read FOnOverWork write FOnOverWork;
property OnCloseWork: TWWCloseWorkEvent read FOnCloseWork write FOnCloseWork;
property Url: string read FURL write SetUrl;
public
constructor Create;
destructor Destroy; override;
procedure Get;
end;
implementation
uses SysUtils;
constructor TWebWorld.Create;
var
dwError: DWORD;
begin
m_Session := InternetOpen(pChar('CV-BOM'), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
dwError := GetLastError();
if dwError <> 0 then ;
end;
destructor TWebWorld.Destroy;
begin
InternetCloseHandle(m_Session);
end;
function TWebWorld.InternetConnect: HINTERNET;
var
szServerName: string;
hConnect: HINTERNET;
begin
//szServerName := 'www.cosmoscape.com';
//szServerName := 'topic.csdn.net';
szServerName := FServerName;
hConnect := WiniNet.InternetConnect(m_Session, pChar(szServerName),
INTERNET_DEFAULT_HTTP_PORT, nil, nil, INTERNET_SERVICE_HTTP, 0, 1);
result := hConnect;
end;
function TWebWorld.HttpOpenRequest(hConnect: HINTERNET): HINTERNET;
var
szVerb: string;
szObjectName: string;
szAcceptType: array[0..1] of pChar;
hRequest: HINTERNET;
begin
szVerb := 'GET';
//szObjectName := 'content/download/solarsys.exe';
//szObjectName := 't/20021116/12/1181472.html';
szObjectName := FObjectName;
szAcceptType[0] := pChar('*/*');
szAcceptType[1] := nil;
hRequest := WiniNet.HttpOpenRequest(hConnect, pChar(szVerb), pChar(szObjectName), HTTP_VERSION,
nil, @szAcceptType, INTERNET_FLAG_DONT_CACHE or INTERNET_FLAG_PRAGMA_NOCACHE or INTERNET_FLAG_RELOAD or INTERNET_FLAG_EXISTING_CONNECT, 1);
result := hRequest;
end;
function TWebWorld.HttpSendRequest(hRequest: HINTERNET): LongBool;
var
szHeaders: string;
dwHeadersLength: DWORD;
bResponse: LongBool;
begin
szHeaders := 'Content-Type: image/jpeg';
dwHeadersLength := Length(szHeaders);
bResponse := WiniNet.HttpSendRequest(hRequest, pChar(szHeaders), dwHeadersLength, nil, 0);
result := bResponse;
end;
function TWebWorld.InternetErrorDlg(hConnect: HINTERNET): DWORD;
var
vData: Pointer;
begin
vData := nil;
result := WiniNet.InternetErrorDlg(
GetDesktopWindow, hConnect,
ERROR_INTERNET_CLIENT_AUTH_CERT_NEEDED,
FLAGS_ERROR_UI_FILTER_FOR_ERRORS or FLAGS_ERROR_UI_FLAGS_GENERATE_DATA or FLAGS_ERROR_UI_FLAGS_CHANGE_OPTIONS, //
vData);
end;
function TWebWorld.HttpQueryInfo(hRequest: HINTERNET; var dwFileSize: DWORD): LongBool;
var
dwBufferSize: DWORD;
dwIndex: DWORD;
InfoBuffer: array[1..32] of Byte;
Info: string;
bQuery: LongBool;
begin
dwBufferSize := 32;
dwIndex := 0;
bQuery := WiniNet.HttpQueryInfo(hRequest, HTTP_QUERY_CONTENT_LENGTH, @InfoBuffer, dwBufferSize, dwIndex);
if bQuery then
begin
Info := pChar(@InfoBuffer);
dwFileSize := SysUtils.StrToInt(Info);
end;
result := bQuery;
end;
function TWebWorld.InternetReadFile(hRequest: HINTERNET; var dwPosition: DWORD; var dwBytesRead: DWORD; var lpBuffer: Pointer): LongBool;
var
bRead: LongBool;
Buffer: array[1..4096] of Byte;
begin
result := false;
bRead := WiniNet.InternetReadFile(hRequest, @Buffer, 4096, dwBytesRead);
if not bRead then exit;
inc(dwPosition, dwBytesRead);
lpBuffer := @Buffer;
result := true;
end;
procedure TWebWorld.Get;
var
hConnect: HINTERNET;
hRequest: HINTERNET;
dwFileSize: DWORD;
dwError: DWORD;
dwPosition: DWORD;
dwBytesRead: DWORD;
bTerminate: LongBool;
bSucceed: LongBool;
lpBuffer: Pointer;
f: file;
begin
hConnect := InternetConnect;
hRequest := HttpOpenRequest(hConnect);
while not HttpSendRequest(hRequest) do
begin
dwError := GetLastError();
if (dwError = ERROR_INTERNET_CLIENT_AUTH_CERT_NEEDED) and
(InternetErrorDlg(hConnect) = ERROR_SUCCESS) then
Continue;
InternetCloseHandle(hRequest);
InternetCloseHandle(hConnect);
exit;
end;
if not HttpQueryInfo(hRequest, dwFileSize) then exit;
try
AssignFile(f, FFielName);
Rewrite(f, 1);
dwPosition := 0; //启始位置
if Assigned(FOnOpenWork) then FOnOpenWork(self, dwFileSize);
bSucceed := false;
bTerminate := false;
while true do
begin
if Assigned(FOnOverWork) then FOnOverWork(self, dwPosition, bTerminate);
if bTerminate then Break;
if not InternetReadFile(hRequest, dwPosition, dwBytesRead, lpBuffer) then Break;
if dwBytesRead = 0 then
begin
bSucceed := true;
Break;
end;
BlockWrite(f, lpBuffer^, dwBytesRead);
end;
if Assigned(FOnCloseWork) then FOnCloseWork(self, bSucceed);
CloseFile(f);
finally
InternetCloseHandle(hRequest);
InternetCloseHandle(hConnect);
end;
end;
procedure TWebWorld.SetUrl(const aUrl: string);
var
ls_Url: string;
begin
self.FURL := aUrl;
ls_Url := aUrl;
if pos('http://', ls_Url) = 1 then System.Delete(ls_Url, 1, 7);
self.FServerName := copy(ls_Url, 1, pos('/', ls_Url) - 1);
System.Delete(ls_Url, 1, pos('/', ls_Url));
self.FObjectName := ls_Url;
self.FFielName := ExtractFileName(StringReplace(ls_Url, '/', '\', [rfReplaceAll]));
end;
end.
