DownloadFile [Delphi]

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

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

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.