DownloadFile [Delphi]

[Khronos14]

Hace algún tiempo cree una función para descargar un archivo de una página web en Delphi. Hoy decidí mejorarla un poco y tiene algunas novedades:

- La función se ejecuta dentro de un Thread, por lo que no afecta al rendimiento de la aplicación ni hace que se congele.
- Para descargar el archivo me conecto al servidor trabajando directamente con sockets y consultas HTTP.
- Incluye 3 eventos: OnStartDownload, OnProgress y OnFinishDownload.

Código (delphi) [Seleccionar] Expandir

procedure DownloadFile(URL: AnsiString; FileName: String; StartDownload: TOnStartDownload;  
         Progress: TOnProgress; FinishDownload: TOnFinishDownload);

URL: Es la dirección del archivo web a descargar.
FileName: Es la ruta donde vas a guardar el archivo descargado.
StartDownload: Es un puntero a una función, este se ejecutará al comenzar la descarga. Devuelve como parámetro el tamaño del archivo, si se conoce.
Progress: Es un puntero a una función, este se ejecuta a medida que se va descargando el archivo. Este evento, puede ser útil si quieres mostrar el progreso de la descarga en un TProgressBar, por ejemplo.
FinishDownload: Es un puntero a una función, este se ejecuta si se produce algún error en la descarga o al terminar la descarga. Tiene como parámetro ErrorCode, de tipo byte, si ErrorCode es 0 significa que la descarga se completó con éxito.

A continuación el código de la unidad:

Código (delphi) [Seleccionar] Expandir


unit URLDown;

(*
* *****************************************************************************
* ***************************   Unidad URLDown  *******************************
*    Esta unidad contiene la función DownloadFile, una función que
* descarga un archivo desde una dirección URL. Esta función se ejecuta en
* otro thread, por lo que no "congela" la aplicación ni causa inastabilidad.
* Además, cuenta con 3 eventos: OnStartDownload, OnProgress y OnFinishDownload.
*
* Autor: Khronos
* Email: khronos14@hotmail.com
* Blog: khronos14.blogspot.com
*******************************************************************************
*)

interface

uses SysUtils, Classes, Windows, WinSock;

{$DEFINE OBJECT_FUNCTIONS}
(*
 Si borras la definición OBJECT_FUNCTIONS, los eventos
 de la función DownloadFile no serán de tipo objeto.
 Para emplear esta función en modo consola o sin clases,
 comenta esta definición.
*)

const
 SZBUFFER_SIZE   = 2048; //Este es el tamaño del buffer de descarga

 URLDOWN_OK                    = 0;
 URLDOWN_INVALID_HOST          = 1;
 URLDOWN_CONNECT_ERROR         = 2;
 URLDOWN_DOWNLOAD_ERROR        = 3;
 URLDOWN_UNKNOWN_ERROR         = $FD;

type
 TOnStartDownload = procedure(FileSize: int64) {$IFDEF OBJECT_FUNCTIONS}of object{$ENDIF};
 TOnProgress = procedure(Progress: int64) {$IFDEF OBJECT_FUNCTIONS}of object{$ENDIF};
 TOnFinishDownload = procedure(ErrorCode: byte) {$IFDEF OBJECT_FUNCTIONS}of object{$ENDIF};

 TDownloadVars = record
   URL: AnsiString;
   FileName: String;
   OnStartDownload: TOnStartDownload;
   OnProgress: TOnProgress;
   OnFinishDownload: TOnFinishDownload;
 end;
 PDownloadVars = ^TDownloadVars;

procedure DownloadFile(URL: AnsiString; FileName: String; StartDownload: TOnStartDownload;
         Progress: TOnProgress; FinishDownload: TOnFinishDownload); stdcall;

implementation


function GetDomainName(const URL: AnsiString): AnsiString;
var
P1: integer;
begin
 P1:= Pos('http://', URL);
 if P1 > 0 then
  begin
    result:= Copy(URL, P1 + 7, Length(URL) - P1 - 6);
    P1:= Pos('/', result);
    if P1 > 0 then
      result:= Copy(result, 0, P1 - 1);
  end else
    begin
      P1:= Pos('/', URL);
      if P1 > 0 then
        result:= Copy(URL, 0, P1 - 1)
      else result:= URL;
    end;
end;

function GetFileWeb(const URL: AnsiString): AnsiString;
var
P1: integer;
begin
 P1:= Pos('http://', URL);
 if P1 > 0 then
  begin
    result:= Copy(URL, P1 + 7, Length(URL) - P1 - 6);
    P1:= Pos('/', result);
    if P1 > 0 then
      result:= Copy(result, P1, Length(result) - P1 + 1);
  end else
    begin
      P1:= Pos('/', URL);
      if P1 > 0 then
        result:= Copy(URL, P1, Length(URL) - P1 + 1)
      else result:= URL;
    end;
 if result = GetDomainName(URL) then
   result:= '/';
end;

procedure CleanHttp(var Mem: TMemoryStream);
var
i: integer;
Separator: array [0..3] of AnsiChar;
Mem2: TMemoryStream;
begin
if Assigned(Mem) then
  begin
    for i := 0 to Mem.Size - 1 do
      begin
        Mem.Seek(i, 0);
        Mem.Read(Separator, 4);
        if (Separator[0] = #13) and (Separator[1] = #10) and (Separator[2] = #13)
            and (Separator[3] = #10) then
              begin
                Mem2:= TMemoryStream.Create;
                Mem.Seek(i + 4, 0);
                Mem2.CopyFrom(Mem, Mem.Size - I - 4);
                Mem:= Mem2;
                break;
              end;
      end;
  end;
end;

function SendQuery(Socket: TSocket; RHost: sockaddr_in; Query: AnsiString): boolean;
begin
if Connect(Socket, PSockAddrIn(@RHost)^, Sizeof(RHost)) = 0 then
 begin
   send(Socket, Pointer(Query)^, Length(Query), 0);
   result:= true;
 end else
   result:= false;
end;

function CreateQuery(URL: AnsiString): AnsiString;
begin
 result:= 'GET ' + GetFileWeb(URL) + ' HTTP/1.0' + #13#10 +
   'Host: ' + GetDomainName(URL) +  #13#10 +
   'User-Agent: Khronos' + #13#10#13#10;
end;

function GetContentLength(szBuff: AnsiString; Size: Cardinal): int64;
var
dwStart, dwEnd: integer;
ContentLength: AnsiString;
begin
Result:= 0;
 dwStart:= Pos('Content-Length: ', szBuff);
 if dwStart <> 0 then
   begin
     dwStart:= dwStart + StrLen('Content-Length: ');
     dwEnd:= dwStart;
     repeat
       Inc(dwEnd);
     until (szBuff[dwEnd] = #0) or (szBuff[dwEnd] = #13) or (dwEnd = Size);
     ContentLength:= Copy(szBuff, dwStart, dwEnd - dwStart);
     if TryStrToInt64(ContentLength, Result) = false then
       result:= -1;
   end;
 dwStart:= Pos(#13#10#13#10, szBuff);
end;

function InitializeWinSock(Host: AnsiString; var Socket: TSocket; var RHost: sockaddr_in): boolean;
var
WSA: TWSAData;
Addr: u_long;
Hostent: PHostent;
Ip: ^Integer;
begin
If WSAStartup(MakeWord(2,2), WSA) = 0 then
 begin
    Socket:= WinSock.SOCKET(AF_INET, SOCK_STREAM, 0);
    if Socket <> INVALID_SOCKET then
       begin
         Hostent:= GetHostByName(PAnsiChar(GetDomainName(Host)));
         if Hostent <> nil then
           begin
             Ip:= @Hostent.h_addr_list^[0];
             RHost.sin_family:= AF_INET;
             RHost.sin_port:= htons(80);
             RHost.sin_addr.S_addr:= ip^;
             result:= true;
          end;
       end;
 end else
   result:= false;
end;

function ProcessDownload(Socket: TSocket; FileName: WideString; StartDownload: TOnStartDownload;
         Progress: TOnProgress; FinishDownload: TOnFinishDownload): boolean;
var
szBuffer: array [0..SZBUFFER_SIZE] of AnsiChar;
Stream: TMemoryStream;
ContentLength, ReturnCode: integer;
begin
result:= false;
   try
     Stream:= TMemoryStream.Create;
     ContentLength:= 0;
     repeat
       FillChar(szBuffer, SZBUFFER_SIZE, 0);
       ReturnCode:= recv(Socket, szBuffer, SZBUFFER_SIZE, 0);
       if (ContentLength = 0) and (ReturnCode > 0) then
         begin
           ContentLength:= GetContentLength(szBuffer, ReturnCode);
           if Assigned(StartDownload) then
             StartDownload(ContentLength);
         end;
       if ReturnCode > 0 then
         begin
           Stream.Write(szBuffer, ReturnCode);
           if Assigned(Progress) then
               Progress(Stream.Position);
         end;
     until ReturnCode <= 0;
     if Stream.Size > 0 then
       begin
         CleanHttp(Stream);
         Stream.SaveToFile(FileName);
         if Assigned(FinishDownload) then
           FinishDownload(URLDOWN_OK);
         result:= true;
       end;
   finally
     Stream.Free;
   end;
end;

procedure Download(P: Pointer);
var
Query: AnsiString;
Socket: TSocket;
RHost: sockaddr_in;
begin
 try
   if InitializeWinSock(TDownloadVars(P^).URL, Socket, RHost) then
     begin
       Query:= CreateQuery(TDownloadVars(P^).URL);
       if SendQuery(Socket, RHost, Query) then
         begin
           If ProcessDownload(Socket, TDownloadVars(P^).FileName, TDownloadVars(P^).OnStartDownload,
               TDownloadVars(P^).OnProgress, TDownloadVars(P^).OnFinishDownload) = false then
               if Assigned(TDownloadVars(P^).OnFinishDownload) then
                 TDownloadVars(P^).OnFinishDownload(URLDOWN_DOWNLOAD_ERROR);
           ShutDown(Socket, SD_BOTH);
           CloseSocket(Socket);
         end else
           if Assigned(TDownloadVars(P^).OnFinishDownload) then
             TDownloadVars(P^).OnFinishDownload(URLDOWN_CONNECT_ERROR);
     end else
       if Assigned(TDownloadVars(P^).OnFinishDownload) then
         TDownloadVars(P^).OnFinishDownload(URLDOWN_INVALID_HOST);

   WSACleanUp();
   Dispose(PDownloadVars(P));
 Except on Exception do
   begin
     if Assigned(TDownloadVars(P^).OnFinishDownload) then
         TDownloadVars(P^).OnFinishDownload(URLDOWN_UNKNOWN_ERROR);
   end;
 end;
end;

procedure DownloadFile(URL: AnsiString; FileName: String; StartDownload: TOnStartDownload;
         Progress: TOnProgress; FinishDownload: TOnFinishDownload);
var
DownloadVars: ^TDownloadVars;
begin
 New(DownloadVars);
 DownloadVars^.URL:= URL;
 DownloadVars^.FileName:= FileName;
 DownloadVars^.OnStartDownload:= StartDownload;
 DownloadVars^.OnProgress:= Progress;
 DownloadVars^.OnFinishDownload:= FinishDownload;

 BeginThread(nil, 0, @Download, DownloadVars, 0, PDWORD(0)^);
end;


end.


Subí a MegaUpload un programa de prueba que usa la función, además incluye todo el código fuente.

http://www.megaupload.com/?d=GU5P5QDW

Saludos.