ftp download

Hallo,

In der WinInet unit gibt's Funktionen für den Download von einem Ftp-Server:

InternetOpen
FtpOpenFile
InternetConnect
FtpOpenFile
InternetReadFile
usw.

Hier eine Beispiel Komponente:

[font size=2 face="Courier New"][font color="#000000"]unit MYFtp;

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;

[font color="#000080"]// A few utility functions

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

function GetFirstToken(S: string; Token: Char): string;
var
  Temp: string;
  Index: INteger;
begin
  Index := Pos(Token, S);
  if Index < 1then
  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 := 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;

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: DWORD;
  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';
    [font color="#000080"]//    FILE_ATTRIBUTE_COMPRESSED: S := 'C';
    [/font]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;

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

[font color="#000080"]// Assumes S has been returned by GetFindDataString;
[/font]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.
[/font][/font]

Kannst natürlich auch andere Komponenten verwenden wie ICS/Indy.

	Willkommen Gast. Bitte einloggen oder registrieren. 21.05.2012, 11:47:00