Hej,
Så fik jeg endelig taget mig sammen
Her er en komponent til at bruge WinINet til download via HTTP og FTP protokollen.
Hvis du vil vide mere nøjagtigt hvordan de forskellige kald til WinINet bruges må du kigge på:
http://msdn.microsoft.comDet er et lidt for stort område at gennem gå her, men har du spørgsmål så siger du bare til.
Efter Komponenten ligger en test af hvordan du bruger den (henter delphi forum ned som html
)
unit InternetAccess;
interface
uses
Windows, Messages, SysUtils, Classes, WinInet, Forms, Dialogs;
const
coMethod: array [0..3] of PChar = ('GET', 'PUT', 'POST', 'HEAD');
errorInvalidURL = '150001 - Invalid URL format';
errorExecuteFailed = '150002 - Unable to execute download command';
errorReadingHTTP = '150003 - Error reading HTTP file';
errorReadingFTP = '150004 - Error reading FTP file';
type
TC1024 = array [0..1024] of Char;
BytesArr = array of Byte;
TMethodType = (mtGet, mtPut, mtPost, mtHead);
TServerType = (stUnknown, stHTTP, stFTP);
TReadResult = (resOk, resError, resAbort);
TReadProgress = procedure(Sender: TObject; const TotalSize, Read : Cardinal; const FileName: string) of object;
TReadFinish = procedure(Sender: TObject; const FileSize: Cardinal; const FileName: string) of object;
TCustomInternetAccess = class;
TInternetAccessThread = class(TThread)
private
FReader: TCustomInternetAccess;
protected
procedure Execute; override;
public
constructor Create(AOwner: TCustomInternetAccess);
end;
TCustomInternetAccess = class(TComponent)
private
FFileSize : Cardinal;
FURL : string;
FFile : string;
FAgent : String;
FReading : Boolean;
FOnProgress : TReadProgress;
FOnDone : TReadFinish;
FThread : TInternetAccessThread;
FOnError : TNotifyEvent;
FOnAbort : TNotifyEvent;
FResult : TReadResult;
FMethod : TMethodType;
FServerType : TServerType;
FUseThread : Boolean;
procedure SetAgent(const aAgent: string);
procedure SetFile(const aFile: string);
procedure SetURL(const aURL : string);
procedure OnTerminate(Sender: TObject);
procedure Process;
function GetServerName(const aURL: string): string;
procedure ReadFile(var aRequest: HInternet);
procedure ReadFTP;
procedure ReadHTTP;
public
OptionalData: BytesArr;
constructor Create(AOwner: TComponent); override;
function GetUrlFileName(const aURL: String; OnlyName : Boolean = False) : String;
function Execute: TReadResult;
procedure Abort;
property Agent : String read FAgent write SetAgent;
property ServerType: TServerType read FServerType;
property URL : String read FURL write SetURL;
property LocalFile : String read FFile write SetFile;
property Reading : Boolean read FReading;
property MethodType : TMethodType read FMethod write FMethod;
property UseThread : Boolean read FUseThread write FUseThread;
property OnProgress : TReadProgress read FOnProgress write FOnProgress;
property OnDone : TReadFinish read FOnDone write FOnDone;
property OnError : TNotifyEvent read FOnError write FOnError;
property OnAbort : TNotifyEvent read FOnAbort write FOnAbort;
end;
TInternetAccess = class(TCustomInternetAccess)
published
property URL;
property LocalFile;
property MethodType;
property UseThread;
property OnProgress;
property OnDone;
property OnError;
property OnAbort;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Samples', [TInternetAccess]);
end;
constructor TCustomInternetAccess.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FFileSize := 0;
FURL := '';
FFile := '';
FAgent := '';
FReading := False;
FOnProgress := nil;
FOnDone := nil;
FThread := nil;
FOnError := nil;
FOnAbort := nil;
FResult := resOk;
FMethod := mtGet;
FServerType := stUnknown;
FUseThread := True;
end;
procedure TCustomInternetAccess.SetFile(const aFile: String);
begin
if FFile <> aFile then
FFile := aFile;
end;
procedure TCustomInternetAccess.SetURL(const aURL: String);
begin
if FURL <> aURL then
begin
FURL := aURL;
if aURL = '' then
begin
FServerType := stUnknown;
end
else
begin
if (Pos('HTTP://' , UpperCase(aURL)) = 1) then
begin
FServerType := stHTTP;
Exit;
end;
if (Pos('FTP://' , UpperCase(aURL)) = 1) then
begin
FServerType := stFTP;
Exit;
end;
raise Exception.Create(errorInvalidURL);
end;
end;
end;
function TCustomInternetAccess.Execute: TReadResult;
var
ResStr : String;
Res : PChar;
begin
Result := resError;
try
if (FReading = False) then
begin
if (FFile = '') then
begin // Create temp filename (for download)
ResStr := StringOfChar(' ',2048);
GetTempFileName('c:\\','epk',0,PChar(ResStr));
Res := PChar(ResStr);
FFile := Res;
end;
try
FReading := True;
if not FUseThread then
Process
else
begin
FThread := TInternetAccessThread.Create(Self);
while Assigned(FThread) do
Application.ProcessMessages;
end;
Result := FResult;
case Result of
resOk:
if Assigned(FOnDone) then
FOnDone(Self, FFileSize, FFile);
resAbort:
if Assigned(FOnAbort) then
FOnAbort(Self);
resError:
if Assigned(FOnError) then
FOnError(Self);
end;
except
Result := resError;
end;
end;
FReading := False;
except
raise Exception.Create(errorExecuteFailed);
end;
end;
procedure TCustomInternetAccess.Abort;
begin
FResult := resAbort;
end;
procedure TCustomInternetAccess.SetAgent(const aAgent: String);
begin
if FAgent <> aAgent then
if aAgent = '' then
FAgent := 'InternetAccess'
else
FAgent := aAgent;
end;
procedure TCustomInternetAccess.OnTerminate(Sender: TObject);
begin
FThread := nil;
end;
function TCustomInternetAccess.GetServerName(const aURL: String): String;
Var
S: String ;
I: Integer;
P: String ;
begin
case FServerType of
stHTTP:
P := 'HTTP://';
stFTP:
P := 'FTP://';
else
raise Exception.Create(errorInvalidURL);
end;
try
S := aURL;
if Pos(P, UpperCase(S)) = 1 then
Delete(S, 1, Length(P));
I := Pos('/', S);
Result := Copy(S, 1, I -1);
except
raise Exception.Create(errorInvalidURL);
end;
end;
function TCustomInternetAccess.GetUrlFileName(const aURL: String; OnlyName : Boolean = False): String;
Var
S: String ;
I: Integer;
P: String ;
begin
case FServerType of
stHTTP:
P := 'HTTP://';
stFTP:
P := 'FTP://';
else
raise Exception.Create(errorInvalidURL);
end;
try
S := aURL;
if Pos(P, UpperCase(S)) = 1 then
Delete(S, 1, Length(P));
I := Pos('/', S);
if (I > 0) then
Delete(S, 1, I);
if OnlyName then
begin
for I := Length(S) downto 1 do
begin
if S[I] = '/' then
begin
S := Copy(S,I+1,Length(S));
Break;
end;
end;
end;
except
raise Exception.Create(errorInvalidURL);
end;
Result := S;
end;
procedure TCustomInternetAccess.ReadFile(var aRequest: HInternet);
var
_fFIle : TextFile;
lpData : TC1024;
dwBtRead : Cardinal;
I : Integer;
dwReaded : Cardinal;
begin
FResult := resError;
dwReaded := 0;
AssignFile(_fFIle, FFile);
try
Rewrite(_fFIle);
except
Exit;
end;
try
while True do
begin
if Not InternetReadFile(aRequest, @lpData, SizeOf(lpData), dwBtRead) then
Break;
if FResult = resAbort then
Break;
if dwBtRead = 0 then
Break;
try
for I := 0 to dwBtRead -1 do
Write(_fFIle, lpData[I]);
except
CloseFile(_fFIle);
Exit;
end;
dwReaded := dwReaded +dwBtRead;
if Assigned(FOnProgress) then
FOnProgress(Self, FFileSize, dwReaded, FFile);
Application.ProcessMessages;
end;
if FFileSize <= dwReaded then
FResult := resOK;
finally
CloseFile(_fFIle);
end;
end;
procedure TCustomInternetAccess.ReadFTP;
var
hSession : HInternet;
hRequest : HInternet;
hConnect : HInternet;
w32FD : TWin32FindData;
begin
hSession := nil;
hConnect := nil;
try
FResult := resOK;
hSession := InternetOpen(PChar(FAgent), INTERNET_OPEN_TYPE_PRECONFIG,
nil, nil, 0);
hConnect := InternetConnect(hSession, PChar(GetServerName(FURL)),
INTERNET_DEFAULT_FTP_PORT, nil, nil,
INTERNET_SERVICE_FTP, INTERNET_FLAG_PASSIVE, 0);
hRequest := FtpFindFirstFile(hConnect, PChar(GetUrlFileName(FURL)),
w32FD, 0, 0);
if Not Assigned(hRequest) then
FResult := resError
else
begin
InternetCloseHandle(hRequest);
FFileSize := (w32FD.nFileSizeHigh *MAXDWORD) + w32FD.nFileSizeLow;
hRequest := InternetOpenUrl(hSession, PChar(FURL), nil, 0,
INTERNET_FLAG_PASSIVE, 0);
end;
if FResult = resOk then
ReadFile(hRequest);
InternetCloseHandle(hRequest);
InternetCloseHandle(hConnect);
InternetCloseHandle(hSession);
except
InternetCloseHandle(hRequest);
InternetCloseHandle(hConnect);
InternetCloseHandle(hSession);
raise Exception.Create(errorReadingFTP);
end;
end;
procedure TCustomInternetAccess.ReadHTTP;
function GetOptionalData(const aURL: String): String;
Var
I: Integer;
begin
Result := '';
I := Pos('?', aURL);
if I > 0 then
begin
Result := aURL;
Delete(Result, 1, I);
end;
end;
var
hSession : HInternet;
hRequest : HInternet;
hConnect : HInternet;
dwIndex : Cardinal;
sServer : String;
sFile : String;
dwBufLen : Cardinal;
lpBuf : Pointer;
pMethod : PChar;
sOptional: String;
begin
hSession := nil;
hConnect := nil;
try
FResult := resOK;
pMethod := coMethod[Integer(FMethod)];
sServer := GetServerName(FURL);
sFile := GetUrlFileName(FURL);
hSession := InternetOpen(PChar(FAgent), INTERNET_OPEN_TYPE_PRECONFIG,
nil, nil, 0);
hConnect := InternetConnect(hSession, PChar(sServer),
INTERNET_DEFAULT_HTTP_PORT, nil, nil,
INTERNET_SERVICE_HTTP, 0, 0);
hRequest := HttpOpenRequest(hConnect, pMethod, PChar(sFile), 'HTTP/1.0',
nil, nil, INTERNET_FLAG_RELOAD, 0);
if Not ((FMethod = mtPost) or (FMethod = mtPut)) then
HttpSendRequest(hRequest, nil, 0, nil, 0)
else
begin
if Length(OptionalData) > 0 then
begin
HttpSendRequest(hRequest, nil, 0, Pointer(OptionalData), Length(OptionalData));
SetLength(OptionalData, 0);
end
else
begin
sOptional := GetOptionalData(sFile);
HttpSendRequest(hRequest, nil, 0, PChar(sOptional), Length(sOptional));
end;
end;
dwIndex := 0;
dwBufLen := 1024;
GetMem(lpBuf, dwBufLen);
if HttpQueryInfo(hRequest, HTTP_QUERY_CONTENT_LENGTH, lpBuf, dwBufLen, dwIndex) then
FFileSize := StrToInt(StrPas(lpBuf))
else
begin
if not InternetQueryDataAvailable(hRequest,FFileSize,0,0) then
FResult := resError;
end;
FreeMem(lpBuf);
if FResult = resOk then
ReadFile(hRequest);
HttpEndRequest(hRequest, nil, HSR_INITIATE,0);
InternetCloseHandle(hRequest);
InternetCloseHandle(hConnect);
InternetCloseHandle(hSession);
except
InternetCloseHandle(hRequest);
InternetCloseHandle(hConnect);
InternetCloseHandle(hSession);
raise Exception.Create(errorReadingHTTP);
end;
end;
procedure TCustomInternetAccess.Process;
begin
case FServerType of
stHTTP:
ReadHTTP;
stFTP:
ReadFTP;
else
FResult := resError;
end;
end;
constructor TInternetAccessThread.Create(AOwner: TCustomInternetAccess);
begin
FReader := AOwner;
FreeOnTerminate := True;
OnTerminate := FReader.OnTerminate;
inherited Create(False);
end;
procedure TInternetAccessThread.Execute;
begin
FReader.Process;
end;
end.
Test unit.
unit TestMain;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, InternetAccess, StdCtrls, ComCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
ProgressBar1: TProgressBar;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
FIA : TCustomInternetAccess;
procedure OnProgress(Sender: TObject; const TotalSize, Read : Cardinal; const FileName: string);
procedure OnDone(Sender: TObject; const FileSize: Cardinal; const FileName: string);
procedure OnError(Sender : TObject);
procedure OnAbort(Sender : TObject);
public
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.OnProgress(Sender: TObject; const TotalSize, Read : Cardinal; const FileName: string);
begin
if (ProgressBar1.Max = 0) then
ProgressBar1.Max := TotalSize;
ProgressBar1.Position := Read;
end;
procedure TForm1.OnDone(Sender: TObject; const FileSize: Cardinal; const FileName: string);
begin
ProgressBar1.Position := 0;
end;
procedure TForm1.OnError(Sender : TObject);
begin
ProgressBar1.Position := 0;
end;
procedure TForm1.OnAbort(Sender : TObject);
begin
ProgressBar1.Position := 0;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FIA := TCustomInternetAccess.Create(self);
FIA.Agent := '';
FIA.MethodType := mtGet;
FIA.URL := 'http://www.udvikleren.dk/eforum/forum.php?f=2';
FIA.LocalFile := 'd:\\udv_delphi_forum.html';
FIA.UseThread := True; // use threads
FIA.OnProgress := OnProgress;
FIA.OnDone := OnDone;
FIA.OnError := OnError;
FIA.OnAbort := OnAbort;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ProgressBar1.Min := 0;
ProgressBar1.Max := 0;
ProgressBar1.Position := 0;
FIA.Execute;
end;
end.
God fornøjelse
Michael.