Delphi Programming / Object Pascal
サイトのトップページへ リンクのページへ ロゴマーク
[掲載 2008年11月11日] [更新 2013年02月03日]　Delphi サンプルプログラム集
   
773_TIdFTP でダウンロードとアップロード
動作確認等 Windows 7 U64(SP2) + Delphi XE Pro + Indy 10 (Ver 10.5.7)
773_Indy_FTPGetPut.zip　[4,495 KB]　2013年01月31日版 (EXE 同梱)



  • 2011年01月21日
  • Delphi 2010, XE, Indy 10.5.7 以降対応のコードに変更
  • 日本語ファイル名対応の参考コードを追加
  • 2013年01月31日
  • アップロードのサンプルに IdFTP1.TransferType := ftBinary; を追加
    これがないと，転送データが欠落する (CRC が正常に機能しないのか ?)



TIdFTP を使用したダウンロードとアップロードのサンプルコード


Delphi に附属している Indy というインターネット関係を操作するためのコンポーネントのうち，TIdFTP を使用したサンプルです．FTP サーバからファイルをダウンロード，アップロードするプログラムです．
以下のサンプルコードでは，TIdFTP の Passive プロパティ (パッシブ転送モード) がデフォルトのままの False になっています．必要に応じて変更してください．また，日本語のファイル名処理の参考コードがありますが，日本語のファイル名の使用を薦めているわけではありません．むしろ使用すべきではないと考えています．

PASV (パッシブ) モードがデフォルトの False だと，サーバによっては，次のようなエラーが発生し，タイムアウトすることがあります．425 はポートが開けないか，使用できない時の値です． 

425 Can't build data connection: Operation timed out. 
425 Unable to build data connection: Connection timed out






01_FTP サーバからダウンロード ( TIdAntiFreeze 使用 )


FTP サーバからファイルをダウンロードするテストプログラムです．IdFTP コンポーネントの GET メソッドは，ストリームにまとめてダウンロードするため，途中のキャンセルはできません．
ここでは， TIdAntiFreeze コンポーネントを使用して [キャンセル] 機能を実装しています．これは別スレッドで実行するわけではないので，ダウンロード中にフォームを移動したりすると，その間中断します．


図1
設計時画面
図2
ダウンロード中

リスト1
FTPサーバ上のファイルをダウンロード ( IdAntiFreeze コンポ使用 ) 
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, IdBaseComponent, IdComponent,
  IdTCPConnection, IdTCPClient, IdFTP, IdAntiFreezeBase, IdAntiFreeze,
  ComCtrls, IdExplicitTLSClientServerBase;

type
  TForm1 = class(TForm)
    Button1: TButton;
    LabeledEdit1 : TLabeledEdit;
    LabeledEdit2 : TLabeledEdit;
    LabeledEdit3 : TLabeledEdit;
    LabeledEdit4 : TLabeledEdit;
    IdFTP1: TIdFTP;
    ProgressBar1: TProgressBar;
    Button2: TButton;
    IdAntiFreeze1: TIdAntiFreeze;
    procedure Button1Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure IdFTP1Work(Sender: TObject; AWorkMode: TWorkMode;
      AWorkCount: Int64);
    procedure IdFTP1WorkBegin(Sender: TObject; AWorkMode: TWorkMode;
      AWorkCountMax: Int64);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
    IniFileName : String;
    SourceFile  : String;
    SaveFile    : String;
    FileSize    : Int64;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses HTTPApp, IniFiles, IdFTPCommon;

{$R *.dfm}

//=============================================================================
//  EditにFTP関係情報をセット
//  1つ上の階層からFTPInfo.iniを読み出してセット
//
//  LabelEdit4.textはダウンロードするサーバ上のフルパスファイル名
//  ex. /mrxray.on.coocan.jp/homepage/Delphi/ZipExe/plSetPrinter.zip
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
var
  AIni : TInifile;
begin
  IniFileName := '..\FTPInfo.ini';
  AIni        := TIniFile.Create(IniFileName);
  try
   if FileExists(IniFileName) then begin
     LabeledEdit1.Text := AIni.ReadString('FTPInfo', 'ServerName',  '');
     LabeledEdit2.Text := AIni.ReadString('FTPInfo', 'UserID',      '');
     LabeledEdit3.Text := AIni.ReadString('FTPInfo', 'PassWord',    '');
     LabeledEdit4.Text := AIni.ReadString('Others',  'GetFileName', '');
   end;
  finally
    FreeAndNil(AIni);
  end;
end;

//=============================================================================
//  設定をIniファイルに保存
//=============================================================================
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
  AIni : TInifile;
begin
  AIni := TIniFile.Create(IniFileName);
  try
    try
      AIni.WriteString('FTPInfo', 'ServerName',  LabeledEdit1.Text);
      AIni.WriteString('FTPInfo', 'UserID',      LabeledEdit2.Text);
      AIni.WriteString('FTPInfo', 'PassWord',    LabeledEdit3.Text);
      AIni.WriteString('Others',  'GetFileName', LabeledEdit4.Text);
    except
    end;
  finally
    FreeAndNil(AIni);
  end;

  //ダウンロード中にフォームを閉じてしまった場合に必要
  if IdFTP1.Connected then begin
    IdFTP1.Abort;
    IdFTP1.Disconnect;
  end;
end;

//=============================================================================
//  FTPでファイルをダウンロード
//  UnixPathToDosPath関数にはusesにHTTPAppが必要
//  ftBinaryは，IdFTPCommon.pasで定義されている
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  FStream : TFileStream;
begin
  Screen.Cursor := crHourGlass;
  ProgressBar1.Position := 0;

  //保存ファイル名はこのプロジェクトのフォルダでサーバ上と同名に
  //SourceFileはサーバ上のファイル名
  SourceFile := LabeledEdit4.Text;
  SaveFile   := ExtractFilePath(ParamStr(0)) +
                ExtractFileName(UnixPathToDosPath(SourceFile));

  IdFTP1.Host     := LabeledEdit1.Text;
  IdFTP1.Username := LabeledEdit2.Text;
  IdFTP1.Password := LabeledEdit3.Text;

  try
    IdFTP1.Connect;
  except
    Screen.Cursor := crDefault;
    IdFTP1.Disconnect;
    MessageDlg('サーバの接続に失敗しました．', mtInformation, [mbOK], 0);
    exit;
  end;

  FileSize := IdFTP1.Size(SourceFile);
  //ファイルのサイズが取得できたら実行
  //他の確認方法があるかも知れない
  if FileSize > 0 then begin
    FStream := TFileStream.Create(SaveFile, fmCreate);
    try
      try
        //バイナリでもテキストファイルでもftBinaryの指定が必要
        IdFTP1.TransferType := ftBinary;
        IdFTP1.Get(SourceFile, FStream);
      except
        //中断または失敗
      end;
    finally
      FreeAndNil(FStream);
    end;
  end else begin
    MessageDlg('ファイルが見つかりません．', mtInformation, [mbOK], 0);
  end;
  Screen.Cursor := crDefault;
  IdFTP1.Disconnect;
end;

//=============================================================================
//  キャンセルボタン
//  ダウンロード途中のファイルは削除した方がいいかも知れない
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  if IdFTP1.Connected then begin
    IdFTP1.Abort;
    IdFTP1.Disconnect;
  end;
end;

//=============================================================================
//  IdHTTPのOnWorkBeginイベント
//  プログレスバーの最大値をセット
//=============================================================================
procedure TForm1.IdFTP1WorkBegin(Sender: TObject; AWorkMode: TWorkMode;
  AWorkCountMax: Int64);
begin
  ProgressBar1.Max := FileSize;
end;

//=============================================================================
//  IdFTPのOnWorkイベント
//  ダウンロードの進捗(進行)状況をプログレスバーに表示
//=============================================================================
procedure TForm1.IdFTP1Work(Sender: TObject; AWorkMode: TWorkMode;
  AWorkCount: Int64);
begin
  //Abortメソッドで処理の中断を可能にする
  IdAntiFreeze1.Process;
  ProgressBar1.Position := AWorkCount;
end;

end.



02_ファイル名が日本語のファイルをダウンロード


ホスト (サーバ) のディレクトリ名やファイル名が日本語の場合は，そのままでは「ファイルが見つからない」ことになってダウンロードできません．サーバが認識する文字コードページと構造に変換する必要があります．
次のリストは，UTF-8 の場合の例です．MECSUtils のルーチンを利用しています．デベロッパーキャンプの資料の「SJIS から Unicode へ！ マイグレーションテクニック(PDF)」の [文字コード関連] (P41以降) の記事も参考にしてください．


リスト2
FTP サーバ上のディレクトリやファイル名が日本語の場合の処理
uses に MECSUtils が必要 

procedure TForm1.Button1Click(Sender: TObject);
var
  FStream : TFileStream;
  U8     : UTF8String;
  Src    : String;
begin
  Screen.Cursor := crHourGlass;
  ProgressBar1.Position := 0;

  //保存ファイル名はこのプロジェクトのフォルダでサーバ上と同名に
  //SourceFileはサーバ上のファイル名
  SourceFile := LabeledEdit4.Text;
  SaveFile   := ExtractFilePath(ParamStr(0)) +
                ExtractFileName(UnixPathToDosPath(SourceFile));

  IdFTP1.Host     := LabeledEdit1.Text;
  IdFTP1.Username := LabeledEdit2.Text;
  IdFTP1.Password := LabeledEdit3.Text;

  try
    IdFTP1.Connect;
  except
    Screen.Cursor := crDefault;
    IdFTP1.Disconnect;
    MessageDlg('サーバの接続に失敗しました．', mtInformation, [mbOK], 0);
    exit;
  end;

  U8  := UTF8String(SourceFile);
  Src := MecsStretchElement(U8);

  FileSize := IdFTP1.Size(Src);
  //ファイルのサイズが取得できたら実行
  //他の確認方法があるかも知れない
  if FileSize > 0 then begin
    FStream := TFileStream.Create(SaveFile, fmCreate);
    try
      try
        IdFTP1.TransferType := ftBinary;
        IdFTP1.Get(Src, FStream);
      except
        //中断または失敗
      end;
    finally
      FreeAndNil(FStream);
    end;
  end else begin
    MessageDlg('ファイルが見つかりません．', mtInformation, [mbOK], 0);
  end;
  Screen.Cursor := crDefault;
  IdFTP1.Disconnect;
end;



03_FTP サーバからダウンロード ( TIdThreadComponent 使用 )


同じく FTP サーバ上のファイルをダウンロードするテストプログラムです．Indy のスレッドコンポーネントである，IdThreadComponent を使用して，ダウンロード中の [キャンセル] を実装しています．別スレッドでダウンロードしますので，ダウンロード中にフォームを移動したりしても，ダウンロードは中断されません．


図3
設計時画面
図4
ダウンロード中

リスト3
FTP サーバ上のファイルをダウンロード ( IdTheadComponent 使用 ) 
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, IdBaseComponent, IdComponent,
  IdTCPConnection, IdTCPClient, IdFTP,ComCtrls, IdThreadComponent,
  IdExplicitTLSClientServerBase;

type
  TForm1 = class(TForm)
    Button1: TButton;
    LabeledEdit1 : TLabeledEdit;
    LabeledEdit2 : TLabeledEdit;
    LabeledEdit3 : TLabeledEdit;
    LabeledEdit4 : TLabeledEdit;
    IdFTP1: TIdFTP;
    Button2: TButton;
    IdThreadComponent1: TIdThreadComponent;
    Panel2: TPanel;
    Panel1: TPanel;
    ProgressBar1: TProgressBar;
    procedure Button1Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Button2Click(Sender: TObject);
    procedure IdThreadComponent1Run(Sender: TIdThreadComponent);
    procedure IdFTP1Work(ASender: TObject; AWorkMode: TWorkMode;
      AWorkCount: Int64);
    procedure IdFTP1WorkBegin(ASender: TObject; AWorkMode: TWorkMode;
      AWorkCountMax: Int64);
  private
    { Private 宣言 }
    IniFileName : String;
    SourceFile  : String;
    SaveFile    : String;
    FileSize    : Int64;
    FStream     : TFileStream;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses HTTPApp,IniFiles, IdFTPCommon;

{$R *.dfm}

//=============================================================================
//  EditにFTP関係情報をセット
//  1つ上の階層からFTPInfo.iniを読み出してセット
//
//  LabelEdit4.textはダウンロードするサーバ上のファイル名
//  ex. /mrxray.on.coocan.jp/homepage/Delphi/ZipExe/plSetPrinter.zip
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
var
  AIni : TInifile;
begin
  IniFileName := '..\FTPInfo.ini';
  AIni        := TIniFile.Create(IniFileName);
  try
   if FileExists(IniFileName) then begin
     LabeledEdit1.Text := AIni.ReadString('FTPInfo', 'ServerName','');
     LabeledEdit2.Text := AIni.ReadString('FTPInfo', 'UserID','');
     LabeledEdit3.Text := AIni.ReadString('FTPInfo', 'PassWord','');
     LabeledEdit4.Text := AIni.ReadString('Others',  'GetFileName','');
   end;
  finally
    FreeAndNil(AIni);
  end;
end;

//=============================================================================
//  設定をIniファイルに保存
//=============================================================================
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
  AIni : TInifile;
begin
  AIni := TIniFile.Create(IniFileName);
  try
    try
      AIni.WriteString('FTPInfo', 'ServerName', LabeledEdit1.Text);
      AIni.WriteString('FTPInfo', 'UserID',     LabeledEdit2.Text);
      AIni.WriteString('FTPInfo', 'PassWord',   LabeledEdit3.Text);
      AIni.WriteString('Others',  'GetFileName',LabeledEdit4.Text);
    except
    end;
  finally
    FreeAndNil(AIni);
  end;
  FreeAndNil(FStream);

  if IdFTP1.Connected then begin
    IdFTP1.Abort;
    IdFTP1.Disconnect;
    IdThreadComponent1.Stop;
  end;
end;

//=============================================================================
//  FTPでファイルをダウンロードする
//  UnixPathToDosPath関数にはusesにHTTPAppが必要
//  ftBinaryは，IdFTPCommon.pasで定義されている
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  Screen.Cursor  := crHourGlass;
  Panel2.Caption := '';
  Panel2.Update;
  ProgressBar1.Position := 0;

  //保存ファイル名はこのプロジェクトのフォルダでサーバ上と同名に
  //SourceFileはサーバ上のファイル名
  SourceFile := LabeledEdit4.Text;
  SaveFile   := ExtractFilePath(ParamStr(0)) +
                ExtractFileName(UnixPathToDosPath(SourceFile));

  IdFTP1.Host     := LabeledEdit1.Text;
  IdFTP1.Username := LabeledEdit2.Text;
  IdFTP1.Password := LabeledEdit3.Text;

  try
    IdFTP1.Connect;
  except
    Screen.Cursor := crDefault;
    IdFTP1.Disconnect;
    MessageDlg('サーバの接続に失敗しました．', mtInformation, [mbOK], 0);
    exit;
  end;

  if IdFTP1.Connected then begin
    FileSize := IdFTP1.Size(SourceFile);

    //ファイルのサイズが取得できたら実行
    if FileSize > 0 then begin
      //バイナリでもテキストファイルでもftBinaryの指定が必要
      IdFTP1.TransferType := ftBinary;
      IdThreadComponent1.Start;
    end else begin
      IdFTP1.Disconnect;
      Screen.Cursor := crDefault;
      MessageDlg('ファイルが見つかりません．', mtInformation, [mbOK], 0);
    end;
  end;
end;

//=============================================================================
//  キャンセルボタン
//  ダウンロード途中のファイルは削除した方がいいかも知れない
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  if IdFTP1.Connected then begin
    IdFTP1.Abort;
    IdFTP1.Disconnect;
    IdThreadComponent1.Stop;
 end;
end;

//=============================================================================
//  ファイルのダウンロード
//  Abortメソッドでキャンセル可能なようにスレッドで実行
//  FStreamをグローバルにしているのは，ダウンロードの途中でFormを閉じてしまうと
//  スレッド内で作動中のFStreamが残ってしまうため
//
//  SourcFile : ダウンロードするサーバ上のファイル名
//  SaveFile  : ダウンロード後のファイル名
//=============================================================================
procedure TForm1.IdThreadComponent1Run(Sender: TIdThreadComponent);
begin
  if not Assigned(FStream) then begin
    FStream := TFileStream.Create(SaveFile, fmCreate);
  end;

  try
    try
      IdFTP1.Get(SourceFile, FStream);
      Panel2.Caption := 'ダウンロード終了';
    except
      Panel2.Caption := 'ダウンロード中止';
    end;
  finally
    //Terminateしてから次の作業をしないとファイルの中身消滅
    IdThreadComponent1.Terminate;
    if IdFTP1.Connected then begin
      IdFTP1.Abort;
      IdFTP1.Disconnect;
    end;
    FreeAndNil(FStream);
    Screen.Cursor := crDefault;
  end;
end;

//=============================================================================
//  IdHTTPのOnWorkBeginイベント
//  プログレスバーの最大値をセット
//=============================================================================
procedure TForm1.IdFTP1WorkBegin(ASender: TObject; AWorkMode: TWorkMode;
  AWorkCountMax: Int64);
begin
  ProgressBar1.Max := FileSize;
end;

//=============================================================================
//  IdFTPのOnWorkイベント
//  ダウンロードの進捗(進行)状況をプログレスバーに表示
//=============================================================================
procedure TForm1.IdFTP1Work(ASender: TObject; AWorkMode: TWorkMode;
  AWorkCount: Int64);
begin
  ProgressBar1.Position := AWorkCount;
end;

end.



04_FTP サーバからダウンロード ( TThread 使用 )


同じく FTP サーバ上のファイルをダウンロードするテストプログラムです．TThread を使用して別スレッドでダウンロードします．


図5
設計時画面
図6
ダウンロード中

リスト4
FTP サーバ上のファイルをダウンロード (TThread 使用) 
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, IdBaseComponent, IdComponent,
  IdTCPConnection, IdTCPClient, IdFTP,ComCtrls, IdExplicitTLSClientServerBase;

type
  TIdFTPGetThread = class(TThread)
  private
    FIdFTP      : TIdFTP;
    FUrl        : String;
    FSaveFile   : String;
    FFileSize   : Integer;
    FPosition   : Integer;
    AStream     : TFileStream;
   procedure DisplayProgress;
  protected
    procedure Execute; override;
    procedure DoOnTerminate(Sender: TObject);
    procedure ADoOnWork(Sender: TObject; AWorkMode: TWorkMode;
      AWorkCount: Int64);
   procedure ADoOnWorkBegin(Sender: TObject; AWorkMode: TWorkMode;
     AWorkCountMax: Int64);
  public
    constructor Create(AIdFTP: TIdFTP;const Url,SaveFileName : String);
    destructor Destroy; override;
    procedure Cancel;
  end;



  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    LabeledEdit1: TLabeledEdit;
    LabeledEdit2: TLabeledEdit;
    LabeledEdit3: TLabeledEdit;
    LabeledEdit4: TLabeledEdit;
    Panel2: TPanel;
    ProgressBar1: TProgressBar;
    IdFTP1: TIdFTP;
    Panel1: TPanel;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private 宣言 }
    IniFileName : String;
    SourceFile  : String;
    SaveFile    : String;
    AThead      : TIdFTPGetThread;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses HTTPApp, IniFiles, IdFTPCommon;

{$R *.dfm}

{ TIdFTPGetThread }

//-----------------------------------------------------------------------------
//  IdFTPでダウンロード(GET)するスレッドのCreate処理
//-----------------------------------------------------------------------------
constructor TIdFTPGetThread.Create(AIdFTP: TIdFTP;
  const Url,SaveFileName: String);
begin
  inherited Create(False);
  OnTerminate        := DoOnTerminate;
  FUrl               := Url;
  FSaveFile          := SaveFileName;
  FIdFTP             := AIdFTP;
  FIdFTP.OnWorkBegin := ADoOnWorkBegin;
  FIdFTP.OnWork      := ADoOnWork;
  FFileSize          := FIdFTP.Size(FUrl);

  FreeOnTerminate := False;
end;

//-----------------------------------------------------------------------------
//  Destroy処理
//-----------------------------------------------------------------------------
destructor TIdFTPGetThread.Destroy;
begin
  inherited;
end;

//-----------------------------------------------------------------------------
//  スレッド(PUTメソッド)実行
//  ftBinaryは，IdFTPCommon.pasで定義されている
//-----------------------------------------------------------------------------
procedure TIdFTPGetThread.Execute;
begin
  Screen.Cursor := crHourGlass;
  AStream       := TFileStream.Create(FSaveFile, fmCreate);
  try
    try
      //バイナリでもテキストファイルでもftBinaryの指定が必要
      FIdFTP.TransferType := ftBinary;
      FIdFTP.Get(FUrl, AStream);
      Form1.Panel1.Caption := 'ダウンロード終了';
    except
      Form1.Panel1.Caption := 'ダウンロード中止';
    end;
  finally
    FreeAndNil(AStream);
  end;
end;

//-----------------------------------------------------------------------------
//  Terminateした時の処理
//-----------------------------------------------------------------------------
procedure TIdFTPGetThread.DoOnTerminate(Sender: TObject);
begin
  Screen.Cursor := crDefault;

  if FIdFTP.Connected  then FIdFtp.Disconnect;
  if Assigned(AStream) then FreeAndNil(AStream);
end;
//-----------------------------------------------------------------------------
//  キャンセルされたら
//-----------------------------------------------------------------------------
procedure TIdFTPGetThread.Cancel;
begin
  Terminate;
  FIdFTP.Abort;
  FIdFtp.Disconnect;
end;

//-----------------------------------------------------------------------------
//  IdHTTPのOnWorkBeginイベント
//  Form1のプログレスバーの最大値を設定
//-----------------------------------------------------------------------------
procedure TIdFTPGetThread.ADoOnWorkBegin(Sender: TObject; AWorkMode: TWorkMode;
  AWorkCountMax: Int64);
begin
  Form1.ProgressBar1.Max := FFileSize;
end;

//-----------------------------------------------------------------------------
//  IdHTTPのOnWorkイベント
//  Form1のプログレスバーを更新
//-----------------------------------------------------------------------------
procedure TIdFTPGetThread.ADoOnWork(Sender: TObject; AWorkMode: TWorkMode;
  AWorkCount: Int64);
begin
  FPosition := AWorkCount;
  Synchronize(DisplayProgress);
end;

//-----------------------------------------------------------------------------
//  ダウンロードの進行状況表示
//-----------------------------------------------------------------------------
procedure TIdFTPGetThread.DisplayProgress;
var
  StrText : String;
begin
  Form1.ProgressBar1.Position := FPosition;

  StrText := IntToStr(FFileSize - FPosition);
  Form1.Panel1.Caption :='残り　' + StrText+' バイト';
end;

//-----------------------------------------------------------------------------


//=============================================================================
//  EditにFTP関係情報をセット
//  1つ上の階層からFTPInfo.iniを読み出してセット
//
//  LabelEdit4.textはGET(ダウンロード)するサーバ上のフルパスファイル名
//  サーバ上にこのファイルが存在していないとエラー
//  ex. /mrxray.on.coocan.jp/homepage/Delphi/ZipExe/plSetPrinter.zip
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
var
  AIni : TInifile;
begin
  IniFileName := '..\FTPInfo.ini';
  AIni := TIniFile.Create(IniFileName);
  try
   if FileExists(IniFileName) then begin
     LabeledEdit1.Text := AIni.ReadString('FTPInfo', 'ServerName',  '');
     LabeledEdit2.Text := AIni.ReadString('FTPInfo', 'UserID',      '');
     LabeledEdit3.Text := AIni.ReadString('FTPInfo', 'PassWord',    '');
     LabeledEdit4.Text := AIni.ReadString('Others',  'GetFileName', '');
   end;
  finally
    FreeAndNil(AIni);
  end;
end;

//=============================================================================
//  設定をIniファイルに保存
//=============================================================================
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
  AIni : TInifile;
begin
  AIni := TIniFile.Create(IniFileName);
  try
    try
      AIni.WriteString('FTPInfo', 'ServerName', LabeledEdit1.Text);
      AIni.WriteString('FTPInfo', 'UserID',     LabeledEdit2.Text);
      AIni.WriteString('FTPInfo', 'PassWord',   LabeledEdit3.Text);
      AIni.WriteString('Others',  'GetFileName',LabeledEdit4.Text);
    except
    end;
  finally
    FreeAndNil(AIni);
  end;

  //以下のコードを正常動作させるには，ATheadのFreeOnTerminateをFalseにしておく
  if IdFTP1.Connected then begin
    IdFTP1.Abort;
    AThead.Terminate;
  end;
  if Assigned(AThead) then AThead.Free;
end;

//=============================================================================
//  FTPでファイルをダウンロード
//
//  SourcFile : ダウンロードするサーバ上のフルパスファイル名
//  SaveFile  : ダウンロードして保存するローカル上のフルパスファイル名
//
//  UnixPathToDosPath関数にはusesにHTTPAppが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  Screen.Cursor := crHourGlass;
  ProgressBar1.Position := 0;

  //保存ファイル名はこのプロジェクトのフォルダでサーバ上と同名に
  //SourceFileはサーバ上のファイル名
  SourceFile := LabeledEdit4.Text;
  SaveFile   := ExtractFilePath(ParamStr(0)) +
                ExtractFileName(UnixPathToDosPath(SourceFile));

  IdFTP1.Host     := LabeledEdit1.Text;
  IdFTP1.Username := LabeledEdit2.Text;
  IdFTP1.Password := LabeledEdit3.Text;

  try
    IdFTP1.Connect;
  except
    Screen.Cursor := crDefault;
    IdFTP1.Disconnect;
    MessageDlg('サーバの接続に失敗しました．', mtInformation, [mbOK], 0);
    exit;
  end;

  if IdFTP1.Connected then begin
    if Assigned(AThead) then AThead.Free;

    AThead := TIdFTPGetThread.Create(IdFTP1, SourceFile, SaveFile);
  end;
end;

//=============================================================================
//  キャンセルボタン
//  転送先のファイルは削除した方がいいかも知れない
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  if Assigned(AThead) then AThead.Cancel;
end;

end.



05_FTP サーバへアップロード ( TIdAntiFreeze 使用 )


FTP サーバへファイルをアップロード ( 転送 ) するテストプログラムです．IdFTP コンポの PUT メソッドは，ファイルの内容をまとめて転送するため，そのままでは途中キャンセルはできません．
ここでは， TIdAntiFreeze コンポーネントを使用して [キャンセル] 機能を実装しています．これは別スレッドで実行するわけではないので，ダウンロード中にフォームを移動したりすると，その間ダウンロードが中断します．


[備考]
ファイルをアップロードするには，サーバーの，アップロードしたファイルを保存するディレクトリの属性 (パーミッション) を書き込み可能にしておく必要があります．
属性の設定が必要なのはファイルを保存するディレクトリだけです．そのディレクトリの上位のディレクトリは書き込み可能にする必要はありません．


図7
設計時画面
図8
アップロード中

リスト5
FTP サーバへファイルをアップロード (IdAntiFreeze コンポ使用) 
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, IdBaseComponent, IdComponent,
  IdTCPConnection, IdTCPClient, IdFTP,ComCtrls, IdAntiFreezeBase,
  IdAntiFreeze, IdExplicitTLSClientServerBase;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    LabeledEdit1: TLabeledEdit;
    LabeledEdit2: TLabeledEdit;
    LabeledEdit3: TLabeledEdit;
    LabeledEdit4: TLabeledEdit;
    LabeledEdit5: TLabeledEdit;
    OpenDialog1: TOpenDialog;
    Panel2: TPanel;
    ProgressBar1: TProgressBar;
    IdFTP1: TIdFTP;
    IdAntiFreeze1: TIdAntiFreeze;
    Panel1: TPanel;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure IdFTP1Work(ASender: TObject; AWorkMode: TWorkMode;
      AWorkCount: Int64);
    procedure IdFTP1WorkBegin(ASender: TObject; AWorkMode: TWorkMode;
      AWorkCountMax: Int64);
  private
    { Private 宣言 }
    IniFileName : String;
    SourceFile  : String;
    UpLoadFile  : String;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses IniFiles, IdFTPCommon;

{$R *.dfm}

//=============================================================================
//  EditにFTP関係情報をセット
//  1つ上の階層からFTPInfo.iniを読み出してセット
//
//  LabelEdit5.textはPUT(転送)するサーバ上のファイルディレクトリ名
//  サーバ上にこのディレクトリが存在していないとエラー
//  ex. /mrxray.on.coocan.jp/homepage/Delphi/
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
var
  AIni : TInifile;
begin
  IniFileName := '..\FTPInfo.ini';
  AIni        := TIniFile.Create(IniFileName);
  try
   if FileExists(IniFileName) then begin
     LabeledEdit1.Text := AIni.ReadString('FTPInfo', 'ServerName', '');
     LabeledEdit2.Text := AIni.ReadString('FTPInfo', 'UserID',     '');
     LabeledEdit3.Text := AIni.ReadString('FTPInfo', 'PassWord',   '');
     LabeledEdit4.Text := AIni.ReadString('Others',  'SourceFile', '');
     LabeledEdit5.Text := AIni.ReadString('Others',  'PutDir',     '');
   end;
  finally
    FreeAndNil(AIni);
  end;
end;

//=============================================================================
//  設定をIniファイルに保存
//=============================================================================
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
  AIni : TInifile;
begin
  AIni := TIniFile.Create(IniFileName);
  try
    try
      AIni.WriteString('FTPInfo', 'ServerName', LabeledEdit1.Text);
      AIni.WriteString('FTPInfo', 'UserID',     LabeledEdit2.Text);
      AIni.WriteString('FTPInfo', 'PassWord',   LabeledEdit3.Text);
      AIni.WriteString('Others',  'SourceFile', LabeledEdit4.Text);
      AIni.WriteString('Others',  'PutDir',     LabeledEdit5.Text);
    except
    end;
  finally
    FreeAndNil(AIni);
  end;
end;

//=============================================================================
//  PUT(転送)するファイルを選択
//  テストなので1つだけとする
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  OpenDialog1.Options    := OpenDialog1.Options - [ofAllowMultiSelect];
  OpenDialog1.OptionsEx  := [ofExNoPlacesBar];
  OpenDialog1.InitialDir := ExtractFileDir(ParamStr(0));

  if OpenDialog1.Execute then begin
    LabeledEdit4.Text := OpenDialog1.FileName;
  end;
end;

//=============================================================================
//  FTPでファイルをアップロードする
//
//  SourcFile   : アップロードするローカル上のフルパスファイル名
//  UpLoadFile  : アップロード後のサーバ上のファイル名
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  UpLoadDir : String;
begin
  Screen.Cursor:=crHourGlass;
  ProgressBar1.Position := 0;

  IdFTP1.Host     := LabeledEdit1.Text;
  IdFTP1.Username := LabeledEdit2.Text;
  IdFTP1.Password := LabeledEdit3.Text;
  SourceFile      := LabeledEdit4.Text;
  UpLoadFile      := ExtractFileName(SourceFile);
  UpLoaddir       := LabeledEdit5.Text;

  try
    IdFTP1.Connect;
  except
    Screen.Cursor := crDefault;
    IdFTP1.Disconnect;
    MessageDlg('サーバの接続に失敗しました．', mtInformation, [mbOK], 0);
    exit;
  end;

  if not FileExists(SourceFile) then begin
    Screen.Cursor := crDefault;
    IdFTP1.Disconnect;
    MessageDlg('ファイルが見つかりません．', mtInformation, [mbOK], 0);
  end else begin
    try
      IdFTP1.ChangeDir(UpLoadDir);
    except
      Screen.Cursor := crDefault;
      IdFTP1.Disconnect;
      MessageDlg('転送先のディレクトリが存在しません．', mtInformation, [mbOK], 0);
      exit;
    end;

    try
      IdFTP1.TransferType := ftBinary;　　
      IdFTP1.Put(SourceFile, UpLoadFile);
      Panel1.Caption := 'アップロード終了';
    except
      Panel1.Caption := 'アップロード中止';
    end;
    IdFTP1.Disconnect;
    Screen.Cursor := crDefault;
  end;
end;

//=============================================================================
//  キャンセルボタン
//  転送先のファイルは削除した方がいいかも知れない
//=============================================================================
procedure TForm1.Button3Click(Sender: TObject);
begin
  if IdFTP1.Connected then begin
    IdFTP1.Abort;
    IdFTP1.Disconnect;
  end;
end;

//=============================================================================
//  IdHTTPのOnWorkBeginイベント
//  プログレスバーの最大値をセット
//=============================================================================
procedure TForm1.IdFTP1WorkBegin(ASender: TObject; AWorkMode: TWorkMode;
  AWorkCountMax: Int64);
begin
  ProgressBar1.Max := AWorkCountMax;
end;

//=============================================================================
//  IdFTPのOnWorkイベント
//  ダウンロードの進捗(進行)状況をプログレスバーに表示
//=============================================================================
procedure TForm1.IdFTP1Work(ASender: TObject; AWorkMode: TWorkMode;
  AWorkCount: Int64);
var
  StrText : String;
begin
  //Abortメソッドで処理の中断を可能にする
  IdAntiFreeze1.Process;
  ProgressBar1.Position := AWorkCount;

  StrText := IntToStr(ProgressBar1.Max - AWorkCount);
  Panel1.Caption := '残り　' + StrText + ' バイト';
  Panel1.Update;
end;

end.



06_ファイル名が日本語のファイルをアップロード


ホスト (サーバ) のディレクトリ名やファイル名が日本語の場合は，そのままアップロードしても正しい名前でアップロードできません．次にその名前でダウンロードすることはできません．アップロードする際に，サーバ (ホスト側) が認識する文字コードページと構造に変換する必要があります．
次のリストは，サーバーの文字コードが UTF-8 の場合の例です．MECSUtils のルーチンを利用しています．デベロッパーキャンプの資料の「SJIS から Unicode へ！マイグレーションテクニック (PDF)」の [文字コード関連] (P41 以降) の記事も参考にしてください．

全ての人が同じ仕様のコンピュータを使用しているわけではありません．メールの添付ファイル名もそうですが，日本語やインターネット禁止文字等をディレクトリ名やファイル名に使用しない方がいいでしょう．


リスト6
日本語のディレクトリやファイル名が日本語の場合の処理
uses に MECSUtils が必要 

procedure TForm1.Button2Click(Sender: TObject);
var
  UpLoadDir : String;
  U8      : UTF8String;
  DstDir  : UnicodeString;
  DstFile : UnicodeString;
begin
  Screen.Cursor:=crHourGlass;
  ProgressBar1.Position := 0;

  IdFTP1.Host     := LabeledEdit1.Text;
  IdFTP1.Username := LabeledEdit2.Text;
  IdFTP1.Password := LabeledEdit3.Text;
  SourceFile      := LabeledEdit4.Text;
  UpLoadFile      := ExtractFileName(SourceFile);
  UpLoaddir       := LabeledEdit5.Text;

  try
    IdFTP1.Connect;
  except
    Screen.Cursor := crDefault;
    IdFTP1.Disconnect;
    MessageDlg('サーバの接続に失敗しました．', mtInformation, [mbOK], 0);
    exit;
  end;

  if not FileExists(SourceFile) then begin
    Screen.Cursor := crDefault;
    IdFTP1.Disconnect;
    MessageDlg('ファイルが見つかりません．', mtInformation, [mbOK], 0);
  end else begin
    //ディレクトリ名をUTF-8に変換し，ホストで認識可能な構成にする
    U8      := UTF8String(UpLoadDir);
    DstDir  := MecsStretchElement(U8);

    //ファイル名をUTF-8に変換し，ホストで認識可能な構成にする
    U8      := UTF8String(UpLoadFile);
    DstFile := MecsStretchElement(U8);

    try
      IdFTP1.ChangeDir(DstDir);
    except
      Screen.Cursor := crDefault;
      IdFTP1.Disconnect;
      MessageDlg('転送先のディレクトリが存在しません．', mtInformation, [mbOK], 0);
      exit;
    end;

    try
      IdFTP1.TransferType := ftBinary;
      IdFTP1.Put(SourceFile, DstFile);
      Panel1.Caption := 'アップロード終了';
    except
      Panel1.Caption := 'アップロード中止';
    end;
    IdFTP1.Disconnect;
    Screen.Cursor := crDefault;
  end;
end;



07_FTP サーバへアップロード ( TIdThreadComponent 使用 )


同じく FTP サーバへファイルをアップロード (転送) するテストプログラムです．Indy のスレッドコンポーネントである，IdThreadComponent を使用して，アップロード中の [キャンセル] を実装しています．別スレッドでアップロードしますので，アップロード中にフォームを移動したりしてもアップロードの中断はありません．


[備考]
ファイルをアップロードするには，サーバーの，アップロードしたファイルを保存するディレクトリの属性 (パーミッション) を書き込み可能にしておく必要があります．
属性の設定が必要なのはファイルを保存するディレクトリだけです．そのディレクトリの上位のディレクトリは書き込み可能にする必要はありません．


図9
設計時画面
図10
アップロードを中止したところ

リスト7
FTP サーバへファイルをアップロード ( IdTheadComponent 使用 ) 
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, IdBaseComponent, IdComponent,
  IdTCPConnection, IdTCPClient, IdFTP,ComCtrls, IdThreadComponent,
  IdExplicitTLSClientServerBase;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    LabeledEdit1: TLabeledEdit;
    LabeledEdit2: TLabeledEdit;
    LabeledEdit3: TLabeledEdit;
    LabeledEdit4: TLabeledEdit;
    LabeledEdit5: TLabeledEdit;
    OpenDialog1: TOpenDialog;
    IdThreadComponent1: TIdThreadComponent;
    Panel1: TPanel;
    ProgressBar1: TProgressBar;
    IdFTP1: TIdFTP;
    Panel2: TPanel;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure IdThreadComponent1Run(Sender: TIdThreadComponent);
    procedure IdFTP1WorkBegin(ASender: TObject; AWorkMode: TWorkMode;
      AWorkCountMax: Int64);
    procedure IdFTP1Work(ASender: TObject; AWorkMode: TWorkMode;
      AWorkCount: Int64);
  private
    { Private 宣言 }
    IniFileName : String;
    SourceFile  : String;
    UpLoadFile  : String;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses IniFiles, IdFTPCommon;

{$R *.dfm}

//=============================================================================
//  EditにFTP関係情報をセット
//  1つ上の階層からFTPInfo.iniを読み出してセット
//
//  LabelEdit5.textはPUT(アップロード)先のサーバ上のディレクトリ名
//  サーバ上のディレクトリが存在していないとエラー
//  ex. LabeledEdit5.Text := '/mrxray.on.coocan.jp/homepage/Delphi/';
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
var
  AIni : TInifile;
begin
  IniFileName := '..\FTPInfo.ini';
  AIni        := TIniFile.Create(IniFileName);
  try
   if FileExists(IniFileName) then begin
     LabeledEdit1.Text := AIni.ReadString('FTPInfo', 'ServerName', '');
     LabeledEdit2.Text := AIni.ReadString('FTPInfo', 'UserID',     '');
     LabeledEdit3.Text := AIni.ReadString('FTPInfo', 'PassWord',   '');
     LabeledEdit4.Text := AIni.ReadString('Others',  'SourceFile', '');
     LabeledEdit5.Text := AIni.ReadString('Others',  'PutDir',     '');
   end;
  finally
    FreeAndNil(AIni);
  end;
end;

//=============================================================================
//  設定をIniファイルに保存
//=============================================================================
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
  AIni : TInifile;
begin
  AIni := TIniFile.Create(IniFileName);
  try
    try
      AIni.WriteString('FTPInfo', 'ServerName', LabeledEdit1.Text);
      AIni.WriteString('FTPInfo', 'UserID',     LabeledEdit2.Text);
      AIni.WriteString('FTPInfo', 'PassWord',   LabeledEdit3.Text);
      AIni.WriteString('Others',  'SourceFile', LabeledEdit4.Text);
      AIni.WriteString('Others',  'PutDir',     LabeledEdit5.Text);
    except
    end;
  finally
    FreeAndNil(AIni);
  end;

  if IdFTP1.Connected then begin
    IdFTP1.Abort;
    IdFTP1.Disconnect;
    IdThreadComponent1.Stop;
  end;
end;

//=============================================================================
//  PUT(転送)するファイルを選択
//  テストなので1つだけとする
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  OpenDialog1.Options    := OpenDialog1.Options - [ofAllowMultiSelect];
  OpenDialog1.OptionsEx  := [ofExNoPlacesBar];
  OpenDialog1.InitialDir := ExtractFileDir(ParamStr(0));

  if OpenDialog1.Execute then begin
    LabeledEdit4.Text := OpenDialog1.FileName;
  end;
end;

//=============================================================================
//  FTPでファイルをアップロードする
//
//  SourcFile   : アップロードするローカル上のファイル名
//  UpLoadFile  : アップロード後のサーバ上のファイル名
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  UpLoadDir : String;
begin
  Screen.Cursor  := crHourGlass;
  Panel2.Caption := '';
  Panel2.Update;
  ProgressBar1.Position := 0;

  IdFTP1.Host     := LabeledEdit1.Text;
  IdFTP1.Username := LabeledEdit2.Text;
  IdFTP1.Password := LabeledEdit3.Text;
  SourceFile      := LabeledEdit4.Text;
  UpLoadFile      := ExtractFileName(SourceFile);
  UpLoaddir       := LabeledEdit5.Text;

  try
    IdFTP1.Connect;
  except
    Screen.Cursor := crDefault;
    IdFTP1.Disconnect;
    MessageDlg('サーバの接続に失敗しました．', mtInformation, [mbOK], 0);
    exit;
  end;

  if not FileExists(SourceFile) then begin
    Screen.Cursor := crDefault;
    IdFTP1.Disconnect;
    MessageDlg('ファイルが見つかりません．', mtInformation, [mbOK], 0);
  end else begin
    try
      IdFTP1.ChangeDir(UpLoadDir);
    except
      Screen.Cursor := crDefault;
      IdFTP1.Disconnect;
      MessageDlg('転送先のディレクトリが存在しません．', mtInformation, [mbOK], 0);
      exit;
    end;

    IdThreadComponent1.Start;
  end;
end;

//=============================================================================
//  キャンセルボタン
//  転送先のファイルは削除した方がいいかも知れない
//=============================================================================
procedure TForm1.Button3Click(Sender: TObject);
begin
  if IdFTP1.Connected then begin
    IdFTP1.Abort;
    IdFTP1.Disconnect;
    IdThreadComponent1.Stop;
  end;
end;

//=============================================================================
//  ファイルのアップロード
//  Abortメソッドでキャンセル可能なようにスレッドで実行
//
//  SourcFile  : 転送するローカル上のフルパスファイル名
//  UpLoadFile : 転送先のサーバ上のファイル名
//=============================================================================
procedure TForm1.IdThreadComponent1Run(Sender: TIdThreadComponent);
begin
  Screen.Cursor := crHourGlass;
  try
    try
      IdFTP1.TransferType := ftBinary;　　
      IdFTP1.Put(SourceFile, UpLoadFile);
      Panel2.Caption := 'アップロード終了';
    except
      //このコードでは転送先のディレクトリが存在しない場合もここにくる
      Panel2.Caption := 'アップロード中止';
    end;
  finally
    IdThreadComponent1.Terminate;
    if IdFTP1.Connected then begin
      IdFTP1.Abort;
      IdFTP1.Disconnect;
    end;
    Screen.Cursor := crDefault;
  end;
end;

//=============================================================================
//  IdHTTPのOnWorkBeginイベント
//  プログレスバーの最大値をセット
//=============================================================================
procedure TForm1.IdFTP1WorkBegin(ASender: TObject; AWorkMode: TWorkMode;
  AWorkCountMax: Int64);
begin
  ProgressBar1.Max := AWorkCountMax;
end;

//=============================================================================
//  IdFTPのOnWorkイベント
//  アップロードの進捗(進行)状況をプログレスバーに表示
//=============================================================================
procedure TForm1.IdFTP1Work(ASender: TObject; AWorkMode: TWorkMode;
  AWorkCount: Int64);
var
  StrText : String;
begin
  ProgressBar1.Position := AWorkCount;

  StrText := IntToStr(ProgressBar1.Max - AWorkCount);
  Panel2.Caption :='残り　' + StrText + ' バイト';
  Panel2.Update;
end;

end.



08_FTP サーバへアップロード ( TThread 使用 )


同じく FTP サーバへファイルをアップロード (転送) するテストプログラムです．TThread を使用して別スレッドでアップロードします．


[備考]
ファイルをアップロードするには，サーバーの，アップロードしたファイルを保存するディレクトリの属性 (パーミッション) を書き込み可能にしておく必要があります．
属性の設定が必要なのはファイルを保存するディレクトリだけです．そのディレクトリの上位のディレクトリは書き込み可能にする必要はありません．


図11
設計時画面
図12
アップロード中

リスト8
FTP サーバへファイルをアップロード ( TThread 使用 ) 
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, IdBaseComponent, IdComponent,
  IdTCPConnection, IdTCPClient, IdFTP,ComCtrls, IdExplicitTLSClientServerBase;

type
  TIdFTPUpThread = class(TThread)
  private
    FIdFTP      : TIdFTP;
    FSourceFile : String;
    FUpLoadFile : String;
    FFileSize   : Integer;
    FPosition   : Integer;
   procedure DisplayProgress;
  protected
    procedure Execute; override;
    procedure DoOnTerminate(Sender: TObject);
    procedure ADoOnWork(ASender: TObject; AWorkMode: TWorkMode; AWorkCount: Int64);
    procedure ADoOnWorkBegin(ASender: TObject; AWorkMode: TWorkMode;
      AWorkCountMax: Int64);
  public
    constructor Create(AIdFTP: TIdFTP; SourceFile,UpLoadFile : String);
    destructor Destroy; override;
    procedure Cancel;
  end;

  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    LabeledEdit1: TLabeledEdit;
    LabeledEdit2: TLabeledEdit;
    LabeledEdit3: TLabeledEdit;
    LabeledEdit4: TLabeledEdit;
    LabeledEdit5: TLabeledEdit;
    OpenDialog1: TOpenDialog;
    Panel2: TPanel;
    ProgressBar1: TProgressBar;
    IdFTP1: TIdFTP;
    Panel1: TPanel;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private 宣言 }
    IniFileName : String;
    SourceFile  : String;
    UpLoadFile  : String;
    AThead      : TIdFTPUpThread;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses IniFiles,  IdFTPCommon;

{$R *.dfm}

{ TIdFTPUpThread }

//-----------------------------------------------------------------------------
//  IdFTPでアップロード(PUT)するスレッドのCreate処理
//-----------------------------------------------------------------------------
constructor TIdFTPUpThread.Create(AIdFTP:TIdFTP; SourceFile, UpLoadFile: String);
begin
  inherited Create(False);

  FIdFtp             := AIdFTP;
  OnTerminate        := DoOnTerminate;
  FIdFtp.OnWorkBegin := ADoOnWorkBegin;
  FIdFtp.OnWork      := ADoOnWork;

  FSourceFile     := SourceFile;
  FUpLoadFile     := UpLoadFile;
  FreeOnTerminate := False;
end;

//-----------------------------------------------------------------------------
//  Destroy処理
//-----------------------------------------------------------------------------
destructor TIdFTPUpThread.Destroy;
begin
  inherited;
end;

//-----------------------------------------------------------------------------
//  スレッド(PUTメソッド)実行
//-----------------------------------------------------------------------------
procedure TIdFTPUpThread.Execute;
begin
  Screen.Cursor := crHourGlass;
  try
    FIdFTP.TransferType := ftBinary;　　
    FIdFtp.Put(FSourceFile, FUpLoadFile);
    Form1.Panel1.Caption := 'アップロード終了';
  except
    Form1.Panel1.Caption := 'アップロード中止';
  end;
end;

//-----------------------------------------------------------------------------
//  Terminateした時の処理
//-----------------------------------------------------------------------------
procedure TIdFTPUpThread.DoOnTerminate(Sender: TObject);
begin
  Screen.Cursor := crDefault;
  if FIdFTP.Connected  then FIdFtp.Disconnect;
end;
//-----------------------------------------------------------------------------
//  キャンセルされたら
//-----------------------------------------------------------------------------
procedure TIdFTPUpThread.Cancel;
begin
  if FIdFTP.Connected  then FIdFTP.Abort;
  Terminate;
end;

//-----------------------------------------------------------------------------
//  IdHTTPのOnWorkBeginイベント
//  Form1のプログレスバーの最大値を設定
//-----------------------------------------------------------------------------
procedure TIdFTPUpThread.ADoOnWorkBegin(ASender: TObject; AWorkMode: TWorkMode;
  AWorkCountMax: Int64);
begin
  FFileSize := AWorkCountMax;
  Form1.ProgressBar1.Max := FFileSize;
end;

//-----------------------------------------------------------------------------
//  IdHTTPのOnWorkイベント
//  Form1のプログレスバーを更新
//-----------------------------------------------------------------------------
procedure TIdFTPUpThread.ADoOnWork(ASender: TObject; AWorkMode: TWorkMode;
  AWorkCount: Int64);
begin
  FPosition := AWorkCount;
  Synchronize(DisplayProgress);
end;

//-----------------------------------------------------------------------------
//  アップロードの進行状況表示
//-----------------------------------------------------------------------------
procedure TIdFTPUpThread.DisplayProgress;
var
  StrText : String;
begin
  Form1.ProgressBar1.Position := FPosition;
  StrText := IntToStr(FFileSize - FPosition);
  Form1.Panel1.Caption := '残り　' + StrText + ' バイト';
end;

//-----------------------------------------------------------------------------


//=============================================================================
//  EditにFTP関係情報をセット
//  1つ上の階層からFTPInfo.iniを読み出してセット
//
//  LabelEdit5.textはPUT(アップロード)先のサーバ上のディレクトリ名
//  サーバ上のディレクトリが存在していないとエラー
//  ex. LabeledEdit5.Text := '/mrxray.on.coocan.jp/homepage/Delphi/';
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
var
  AIni : TInifile;
begin
  IniFileName := '..\FTPInfo.ini';
  AIni        := TIniFile.Create(IniFileName);
  try
   if FileExists(IniFileName) then begin
     LabeledEdit1.Text := AIni.ReadString('FTPInfo', 'ServerName', '');
     LabeledEdit2.Text := AIni.ReadString('FTPInfo', 'UserID',     '');
     LabeledEdit3.Text := AIni.ReadString('FTPInfo', 'PassWord',   '');
     LabeledEdit4.Text := AIni.ReadString('Others',  'SourceFile', '');
     LabeledEdit5.Text := AIni.ReadString('Others',  'PutDir',     '');
   end;
  finally
    FreeAndNil(AIni);
  end;
end;

//=============================================================================
//  設定をIniファイルに保存
//=============================================================================
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
  AIni : TInifile;
begin
  AIni := TIniFile.Create(IniFileName);
  try
    try
      AIni.WriteString('FTPInfo', 'ServerName', LabeledEdit1.Text);
      AIni.WriteString('FTPInfo', 'UserID',     LabeledEdit2.Text);
      AIni.WriteString('FTPInfo', 'PassWord',   LabeledEdit3.Text);
      AIni.WriteString('Others',  'SourceFile', LabeledEdit4.Text);
      AIni.WriteString('Others',  'PutDir',     LabeledEdit5.Text);
    except
    end;
  finally
    FreeAndNil(AIni);
  end;

  //以下のコードを正常動作させるには，ATheadのFreeOnTerminateをFalseにしておく
  if IdFTP1.Connected then begin
    IdFTP1.Abort;
    AThead.Terminate;
  end;
  if Assigned(AThead) then AThead.Free;
end;

//=============================================================================
//  PUT(転送)するファイルを選択
//  テストなので1つだけとする
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  OpenDialog1.Options    := OpenDialog1.Options - [ofAllowMultiSelect];
  OpenDialog1.OptionsEx  := [ofExNoPlacesBar];
  OpenDialog1.InitialDir := ExtractFileDir(ParamStr(0));

  if OpenDialog1.Execute then begin
    LabeledEdit4.Text := OpenDialog1.FileName;
  end;
end;

//=============================================================================
//  FTPでファイルをアップロードする
//
//  SourcFile   : アップロードするローカル上のフルパスファイル名
//  UpLoadFile  : アップロード後のサーバ上のファイル名
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  UpLoadDir : String;
begin
  Screen.Cursor := crHourGlass;
  ProgressBar1.Position := 0;

  IdFTP1.Host     := LabeledEdit1.Text;
  IdFTP1.Username := LabeledEdit2.Text;
  IdFTP1.Password := LabeledEdit3.Text;
  SourceFile      := LabeledEdit4.Text;
  UpLoadFile      := ExtractFileName(SourceFile);
  UpLoaddir       := LabeledEdit5.Text;

  try
    IdFTP1.Connect;
  except
    Screen.Cursor := crDefault;
    IdFTP1.Quit;
    IdFTP1.Disconnect;
    MessageDlg('サーバの接続に失敗しました．', mtInformation, [mbOK], 0);
    exit;
  end;

  if not FileExists(SourceFile) then begin
    Screen.Cursor := crDefault;
    IdFTP1.Quit;
    IdFTP1.Disconnect;
    MessageDlg('ファイルが見つかりません．', mtInformation, [mbOK], 0);
  end else begin
    try
      IdFTP1.ChangeDir(UpLoadDir);
    except
      Screen.Cursor := crDefault;
      IdFTP1.Quit;
      IdFTP1.Disconnect;
      MessageDlg('転送先のディレクトリが存在しません．', mtInformation, [mbOK], 0);
      exit;
    end;

    if Assigned(AThead) then AThead.Free;
    AThead := TIdFTPUpThread.Create(IdFTP1, SourceFile, UpLoadFile);
  end;
end;

//=============================================================================
//  キャンセルボタン
//  転送先のファイルは削除した方がいいかも知れない
//=============================================================================
procedure TForm1.Button3Click(Sender: TObject);
begin
  if Assigned(AThead) then AThead.Cancel;
end;

end.