|
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.
ホスト (サーバ) のディレクトリ名やファイル名が日本語の場合は,そのままでは「ファイルが見つからない」ことになってダウンロードできません.サーバが認識する文字コードページと構造に変換する必要があります.
次のリストは,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.
ホスト (サーバ) のディレクトリ名やファイル名が日本語の場合は,そのままアップロードしても正しい名前でアップロードできません.次にその名前でダウンロードすることはできません.アップロードする際に,サーバ (ホスト側) が認識する文字コードページと構造に変換する必要があります.
次のリストは,サーバーの文字コードが 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.
|