delphi&internet2.txt

Delphi的Internet编程技术

  www.borland.com, or with some versions of
  Delphi 2.0. 
  
  You might Respond to OnNewDir events as follows:

  procedure TForm1.FTP1NewDir(Sender: TObject);
  begin
    ListBox1.Items := MyFtp1.FindFiles; // Get the directory list
  end;   
}

interface

uses
  Windows, Classes, WinINet,
  SysUtils;
  
type
  TMyFtp = class(TComponent)
  private
    FContext: Integer;
    FINet: HInternet;
    FFtpHandle: HInternet;
    FCurFiles: TStringList;
    FServer: string;
    FOnNewDir: TNotifyEvent;
    FCurDir: string;
    FUserID: string;
    FPassword: string;
    function GetCurrentDirectory: string;
    procedure SetUpNewDir;
  protected
    destructor Destroy; override;
  public
    constructor Create(AOwner: TComponent); override;
    function Connect: Boolean;
    function FindFiles: TStringList;
    function ChangeDirExact(S: string): Boolean;
    function ChangeDirCustom(S: string): Boolean;
    function BackOneDir: Boolean;
    function GetFile(FTPFile, NewFile: string): Boolean;
    function SendFile1(FTPFile, NewFile: string): Boolean;
    function SendFile2(FTPFile, NewFile: string): Boolean;
    function CustomToFileName(S: string): string;
  published
    property CurFiles: TStringList read FCurFiles;
    property CurDir: string read FCurDir;
    property UserID: string read FUserID write FUserID;
    property Password: string read FPassword write FPassword;
    property Server: string read FServer write FServer;
    property OnNewDir: TNotifyEvent read FOnNewDir 
                write FOnNewDir;
  end;

procedure Register;

implementation

uses
  Dialogs;

// A few utility functions

function GetFirstToken(S: string; Token: Char): string;
var
  Temp: string;
  Index: INteger;
begin
  Index := Pos(Token, S);
  if Index < 1 then begin
    GetFirstToken := '';
    Exit;
  end;
  Dec(Index);
  SetLength(Temp, Index);
  Move(S[1], Temp[1], Index);
  GetFirstToken := Temp;
end;

function StripFirstToken(S: string; Ch: Char): string;
var
  i, Size: Integer;
begin
  i := Pos(Ch, S);
  if i = 0 then begin
    StripFirstToken := S;
    Exit;
  end;
  Size := (Length(S) - i);
  Move(S[i + 1], S[1], Size);
  SetLength(S, Size);
  StripFirstToken := S;
end;

function ReverseStr(S: string): string;
var
  Len: Integer;
  Temp: String;
  i,j: Integer;
begin
  Len := Length(S);
  SetLength(Temp, Len);
  j := Len;
  for i := 1 to Len do begin
    Temp[i] := S[j];
    dec(j);
  end;
  ReverseStr := Temp;
end;

function StripLastToken(S: string; Token: Char): string;
var
  Temp: string;
  Index: INteger;
begin
  SetLength(Temp, Length(S));
  S := ReverseStr(S);
  Index := Pos(Token, S);
  Inc(Index);
  Move(S[Index], Temp[1], Length(S) - (Index - 1));
  SetLength(Temp, Length(S) - (Index - 1));
  StripLastToken := ReverseStr(Temp);
end;


procedure Register;
begin
  RegisterComponents('Unleash', [TMyFtp]);
end;

constructor TMyFtp.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCurFiles := TStringList.Create;
  FINet := InternetOpen('WinINet1', 0, nil, 0, 0);
end;

destructor TMyFtp.Destroy;
begin
  if FINet <> nil then
    InternetCloseHandle(FINet);
  if FFtpHandle <> nil then
    InternetCloseHandle(FFtpHandle);
  inherited Destroy;
end;

function TMyFtp.Connect: Boolean;
begin
  FContext := 255;
  FftpHandle := InternetConnect(FINet, PChar(FServer), 0,
   PChar(FUserID), PChar(FPassWord),
   Internet_Service_Ftp, 0, FContext);
  if FFtpHandle = nil then
    Result := False
  else begin
    SetUpNewDir;
    Result := True;
  end;
end;

function TMyFtp.GetCurrentDirectory: string;
var
  Len: Integer;
  S: string;
begin
  Len := 0;
  ftpGetCurrentDirectory(FFTPHandle, PChar(S), Len);
  SetLength(S, Len);
  ftpGetCurrentDirectory(FFTPHandle, PChar(S), Len);
  Result := S;
end;

procedure TMyFtp.SetUpNewDir;
begin
  FCurDir := GetCurrentDirectory;
  if Assigned(FOnNewDir) then
    FOnNewDir(Self);             
end;

function GetDots(NumDots: Integer): string;
var
  S: string;
  i: Integer;
begin
  S := '';
  for i := 1 to NumDots do
    S := S + ' ';
  Result := S;
end;

function GetFindDataStr(FindData: TWin32FindData): string;
var
  S: string;
  Temp: string;
begin
  case FindData.dwFileAttributes of
    FILE_ATTRIBUTE_ARCHIVE: S := 'A';
//    FILE_ATTRIBUTE_COMPRESSED: S := 'C';
    FILE_ATTRIBUTE_DIRECTORY: S := 'D';
    FILE_ATTRIBUTE_HIDDEN: S := 'H';
    FILE_ATTRIBUTE_NORMAL: S := 'N';
    FILE_ATTRIBUTE_READONLY: S := 'R';
    FILE_ATTRIBUTE_SYSTEM: S := 'S';
    FILE_ATTRIBUTE_TEMPORARY: S := 'T';
  else
    S := IntToStr(FindData.dwFileAttributes);
  end;
  S := S + GetDots(75);
  Move(FindData.CFilename[0], S[6], StrLen(FindData.CFileName));
  Temp := IntToStr(FindData.nFileSizeLow);
  Move(Temp[1], S[25], Length(Temp));
  Result := S;
end;

function TMyFtp.FindFiles: TStringList;
var
  FindData: TWin32FindData;
  FindHandle: HInternet;
begin
   FindHandle := FtpFindFirstFile(FFtphandle, '*.*',
     FindData, 0, 0);
   if FindHandle = nil then begin
     Result := nil;
     Exit;
   end;
   FCurFiles.Clear;
   FCurFiles.Add(GetFindDataStr(FindData));
   while InternetFindnextFile(FindHandle, @FindData) do
     FCurFiles.Add(GetFindDataStr(FindData));
   InternetCloseHandle(Findhandle);
   GetCurrentDirectory;
   Result := FCurFiles;
end;

function TMyFtp.CustomToFileName(S: string): string;
const
  PreSize = 6;
var
  Temp: string;
  TempSize: Integer;
begin
  Temp := '';
  TempSize := Length(S) - PreSize; 
  SetLength(Temp, TempSize);
  Move(S[PreSize], Temp[1], TempSize);
  Temp := GetFirstToken(Temp, ' ');
  Result := Temp;
end;

function TMyFtp.BackOneDir: Boolean;
var
  S: string;
begin
  S := FCurDir;
  S := StripLastToken(S, '/');
  if S = '/' then begin
    Result := False;
    Exit;
  end;

  if S <> '' then begin
    ChangeDirExact(S);
    Result := True;
  end else begin
    ChangeDirExact('/');
    Result := True;
  end;

end;

// Changes to specific directory in S
function TMyFtp.ChangeDirExact(S: string): Boolean;
begin
  if S <> '' then
    FtpSetCurrentDirectory(FFTPHandle, PChar(S));
  Result := True;
  FindFiles;
  SetUpNewDir;
end;

// Assumes S has been returned by GetFindDataString;
function TMyFtp.ChangeDirCustom(S: string): Boolean;
begin
  S := CustomToFileName(S);
  if S <> '' then
    FtpSetCurrentDirectory(FFTPHandle, PChar(S));
  Result := True;
  FindFiles;
  SetUpNewDir;
end;

function TMyFtp.GetFile(FTPFile, NewFile: string): Boolean;
begin
  Result := FtpGetFile(FFTPHandle, PChar(FTPFile), PChar(NewFile),
               False, File_Attribute_Normal,
               Ftp_Transfer_Type_Binary, 0);
end;

function TMyFtp.SendFile1(FTPFile, NewFile: string): Boolean;
const
  Size:DWord = 3000;
var
  Transfer: Bool;
  Error: DWord;
  S: string;
begin
  Transfer := FtpPutFile(FFTPHandle, PChar(FTPFile), 
                         PChar(NewFile),
                         Ftp_Transfer_Type_Binary, 0);

  if not Transfer then begin
    Error := GetLastError;
    ShowMessage(Format('Error Number: %d. Hex: %x', 
                       [Error, Error]));
    SetLength(S, Size);
    if not InternetGetLastResponseInfo(Error, PChar(S), Size) then 
    begin
      Error := GetLastError;
      ShowMessage(Format('Error Number: %d. Hex: %x', 
        [Error, Error]));
    end;
    ShowMessage(Format('Error Number: %d. Hex: %x Info: %s', 
                       [Error, Error, S]));
  end else
    ShowMessage('Success');
  Result := Transfer;
end;

function TMyFtp.SendFile2(FTPFile, NewFile: string): Boolean;
var
  FHandle: HInternet;
begin
  FHandle :=  FtpOpenFile(FFTPHandle, 'sam.txt', GENERIC_READ,
                           FTP_TRANSFER_TYPE_BINARY, 0);
  if FHandle <> nil then
  InternetCloseHandle(FHandle)
  else
    ShowMessage('Failed');
  Result := True;
end;

end.