ftpthread.pas

灰鸽子VIP1.2经典源代码

unit FTPThread;

interface

uses
  SysUtils, Classes;

type
   TFTPMode = (ftpSend, ftpGet);
   TStatusProc = procedure(Sender: TObject; const StatMsg: string) of object;

   TFTPThread = class(TThread)
   protected
      NumBytes    : integer;
      ModeStr     : string;
      TmpStat     : string;
      procedure   Execute; override;
      procedure   DoFTP;
      procedure   SendStat(const StatMsg: string);
      procedure   CallStatProc;
   public
      LocalFile   : string;
      RemoteFile  : string;
      Host        : string;
      FtpPorts    : integer;
      UserName    : string;
      Password    : string;
      FTPMode     : TFTPMode;
      StatProc    : TStatusProc;    // This is called inside of "Synchronize"
      ErrMsg      : string;
   end;


implementation

uses Windows, WinINet, INetUtil;

// ***************************************************************************
// TWorkThread

procedure TFTPThread.SendStat(const StatMsg: string);
begin
   TmpStat := StatMsg;
   Synchronize(CallStatProc);
end;

procedure TFTPThread.CallStatProc;
begin
   if Assigned(StatProc) then
      StatProc(Self, TmpStat);
end;

procedure FTP_Status(hi: HINTERNET; Context: integer; Status: integer;
   StatusInfo: pointer; StatusInfoLen: integer); stdcall;
var
   ft : TFTPThread;
begin
   ft := TFTPThread(Context);

   case Status of
      INTERNET_STATUS_REQUEST_SENT: begin
         ft.NumBytes := ft.NumBytes + PINT(StatusInfo)^;
         end;
   end;

   ft.SendStat(Format('%s = %1.0n', [ft.ModeStr, 0.0 + ft.NumBytes]));
end;

procedure TFTPThread.DoFTP;
var
   hi, fi   : HINTERNET;
begin
   SendStat('Initializing Internet Functions');
   hi := InternetOpen('VCS FTP', INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0);
   INetCheck(LongBool(hi));

   SendStat('正在连接FTP服务器...');     //INTERNET_DEFAULT_FTP_PORT
   fi := InternetConnect(hi, PChar(Host), FtpPorts ,
       PChar(UserName), PChar(Password), INTERNET_SERVICE_FTP, 0, 0);
   INetCheck(LongBool(fi));

   NumBytes := 0;
   if FTPMode = ftpSend then begin
      SendStat('正在更新IP文件...');
      ModeStr := 'Bytes Sent';
      InternetSetStatusCallback(fi, @FTP_Status);
      INetCheck(FtpPutFile(fi, PChar(LocalFile), PChar(RemoteFile), FTP_TRANSFER_TYPE_BINARY, integer(Self)));
      ModeStr := '发送完成.';
   end else begin
      SendStat('Receiving File');
      ModeStr := 'Bytes Received';
      InternetSetStatusCallback(fi, @FTP_Status);
      INetCheck(FtpGetFile(fi, PChar(RemoteFile), PChar(LocalFile), False, 0,
         FTP_TRANSFER_TYPE_BINARY, integer(Self)));
      ModeStr := 'Receive Complete';
   end;

   InternetCloseHandle(fi);
   InternetCloseHandle(hi);

   SendStat(Format('%s  %1.0n bytes', [ModeStr, 0.0 + NumBytes]));
end;

procedure TFTPThread.Execute;
begin
   try
      DoFTP;
   except
      on e: Exception do begin
         ErrMsg := e.Message;
         SendStat(ErrMsg);
      end;
   end;
end;


end.