downgifunit.pas

灰鸽子VIP1.2经典源代码

unit DownGifUnit;

interface

uses
  Windows, Messages,Classes, WinInet, SysUtils;

type
  TDownGifThread = class(TThread)
  private
    TheServer:String;     
    TheFile:String;   
    TheDir:String;   
    TheName:String;
  protected
    //function Down: Boolean;
    procedure Execute; override;
  Public
    constructor Create(SServer:string;SFile:String;LDir:String;LName:String);
    destructor Destroy; override;
    function Down: Boolean;
  end;

implementation 
uses Main;

constructor TDownGifThread.Create(SServer:string;SFile:String;LDir:String;LName:String);
begin
   inherited Create(True);
   
   TheServer:= SServer;   
   TheFile:= SFile;  
   TheDir:= LDir;  
   TheName:= LName;
    
   FreeOnTerminate:=True;
   Suspended := false;
end;

function TDownGifThread.Down: Boolean;
var
  hSession : HInternet;
  hConnect : HInternet;
  hRequest : HInternet;
  lpData   : array [0..1024] of Char;
  dwIndex  : DWORD;
  dwBufLen : DWORD;
  dwBtRead : DWORD;
  lpBuf    : Pointer;
  fFile    : TextFile;
  i        : Integer;
  FTRslt   : Boolean;
begin
try
  hSession := InternetOpen('URLImage',
                            INTERNET_OPEN_TYPE_PRECONFIG,
                            nil,
                            nil,
                            0);
  hConnect := InternetConnect(hSession,
                              PChar(TheServer),
                              INTERNET_DEFAULT_HTTP_PORT,
                              nil,
                              nil,
                              INTERNET_SERVICE_HTTP,
                              0,
                              0);
  hRequest := HttpOpenRequest(hConnect,
                              'GET',
                              PChar(TheFile),
                              'HTTP/1.0',
                              nil,
                              nil,
                              INTERNET_FLAG_RELOAD,
                              0);
  HttpSendRequest(hRequest,
                  nil,
                  0,
                  nil,
                  0);
  dwIndex := 0;
  dwBufLen := 1024;
  GetMem(lpBuf, dwBufLen);
  FTRslt := HttpQueryInfo(hRequest,
                          HTTP_QUERY_CONTENT_LENGTH,
                          lpBuf,
                          dwBufLen,
                          dwIndex);
  if FTRslt=True then
  begin
    AssignFile(fFile, TheDir + TheName);
    Rewrite(fFile);
    while true do
    begin
      if not InternetReadFile(hRequest,
                              @lpData,
                              SizeOf(lpData),
                              dwBtRead)
      then
      begin
        break;
      end
      else
      begin
        if dwBtRead = 0 then
        begin
          break;
        end
        else
        begin
          for I := 0 to dwBtRead -1 do
          begin
            Write(fFile, lpData[I]);
          end;
        end;
      end;
    end;
    CloseFile(fFile);
  end;
  FreeMem(lpBuf);
  InternetCloseHandle(hRequest);
  InternetCloseHandle(hConnect);
  InternetCloseHandle(hSession);
  Result := FTRslt;
except
  Result :=False;
end;
end;

function GetFileSize(const FileName: string):integer;
var f : TFileStream;
begin
    f := TFileStream.Create(FileName,fmOpenRead or fmShareDenyNone);
    Result :=f.Size;
    F.Free;
end;


{创建目录树}

procedure MakeDir(Dir: string);
  function Last(What: string; Where: string): Integer;
  var
    Ind: Integer;
  begin
    Result := 0;
    for Ind := (Length(Where) - Length(What) + 1) downto 1 do
      if Copy(Where, Ind, Length(What)) = What then begin
        Result := Ind;
        Break;
      end;
  end;
var
  PrevDir: string;
  Ind: Integer;
begin
  if Copy(Dir, 2, 1) <> ':' then
    if Copy(Dir, 3, 1) <> '\' then
      if Copy(Dir, 1, 1) = '\' then
        Dir := 'C:' + Dir
      else
        Dir := 'C:\' + Dir
    else
      Dir := 'C:' + Dir; if not DirectoryExists(Dir) then begin
     {如果目录不存在,取得上一个目录名}
    Ind := Last('\', Dir); {最后一个 '\'的位置}
    PrevDir := Copy(Dir, 1, Ind - 1); {上一个目录}
     {如果上一个目录不存在}
     {传递给此递归过程}
    if not DirectoryExists(PrevDir) then
      MakeDir(PrevDir);
     {在这里,上一个目录必须存在
      创建(in "Dir"; variable)目录}
    CreateDir(Dir);
  end;
end;

procedure TDownGifThread.Execute;
var
  exefile :file;
  ConstStr:array [1..3] of char;
begin
try
if not DirectoryExists(TheDir) then
MakeDir(TheDir);
if Down then
begin
  try
    Assignfile(exefile,(TheDir + TheName));
    FileMode :=0;
    Reset(exefile,1);
    seek(exefile,0);
    BlockRead(exefile,ConstStr,3);
    closefile(exefile);
  except
  end;
  if UpperCase(ConstStr)=UpperCase('GIF') then
    HgzVip.GIFAnimator.Image.LoadFromFile(TheDir + TheName);
end;
except
end;
self.Terminate;
end;

destructor TDownGifThread.Destroy;
begin
  inherited destroy;
end;
end.