1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:
259:
260:
261:
262:
263:
264:
265:
266:
267:
268:
269:
270:
271:
272:
273:
274:
275:
276:
277:
278:

unit Shared_FtpUpload;
(* ************************************************************************* 
     Software für den Schwimmsport 
     - FTP-Upload mit Indy als Thread - 
     (c) 2006 B.Stickan, www.easywk.de 
     Stand: 08.06.2006 

     Beschreibung: der Thread führt einen FTP-Upload durch. Dabei können
     mehrere Dateien upgeloadet werden. Mit "AddToFileList" werden Dateien 
     zur Uploadliste hinzugefügt. Die Dateien müssen alle im selben 
     Quellverzeichnis liegen. Das Quellverzeichnis wird mit "SetSourceDir" 
     gesetzt. Die FTP-Konfiguration wird aus mit "LoadConfig" aus 
     einer INI-Datei geladen. 

     Der Thread selber schläft die meiste Zeit. Er wird mit "StartUpload" 
     geweckt und beginnt dann mit dem Transfer. Ist der Transfer erfolgreich 
     abgeschlossen, wird die interne Dateiliste gelöscht, der Status 
     steht auf ftpREADY und der Thread schläft wieder. Wenn der Thread 
     schläft (Suspended=True) und der Status nicht auf ftpREADY steht, 
     zeigt der Status an, bei welcher FTP-Aktion ein Fehler aufgetreten ist. 
     Während ein Upload läuft, wird ein weiterer StartUpload verworfen. 

     History 
   ************************************************************************* *) 
interface 

uses 
  Classes, SyncObjs, IdIntercept, IdBaseComponent, IdComponent, 
  IdTCPConnection, IdTCPClient, IdFTP, IdFTPCommon, IdAntiFreeze, 
  IdAntiFreezeBase, BitteWarten; 

type 
  TFtpConfig = 
    record 
      Hostname  : String;       // Name des Hosts 
      Username  : String;       // Username zum Einloggen 
      Password  : String;       // Passwort zum Einloggen 
      Passive   : Boolean;      // Passiver Transfer? 
      TargetPath: String;       // Zielverzeichnis auf dem Host 
    end; 

  TFtpAction =  // Statusmeldung 
    ( ftpCONNECTING, ftpCHANGEDIR, ftpUPLOADING, ftpREADY ); 

  TFtpUpload = class(TThread) 
    private 
      Semaphore : TCriticalSection; 
      Ftp       : TIdFtp; 
      Config    : TFtpConfig; 
      HasJob    : Boolean; 
      FileList  : TStrings; 
      IState    : TFtpAction; 
      IFileCnt  : Integer; 
      SourceDir : String; 
    public

      NeuerName : String;
      WForm : TWaitForm;
      
      // was macht der FTP gerade bzw. was hat er zuletzt gemacht? 
      property State:TFtpAction read IState; 
      // Nummer der Datei, die gerade upgeloaded wir - 1-Basis 
      property ActiveFile:Integer read IFileCnt; 
      // erzeugen 
      constructor Create(Form: TWaitForm; NName:String); 
      // freigeben 
      destructor Free; 
      // die eigentliche Ausführungsroutine
      procedure Execute; override;
      // Konfiguration aus Ini-Datei laden
      procedure LoadConfig(FtpHost,FtpUser, FtpPass, FtpPath: String);
      // Dateien zur Uploadliste hinzufügen 
      procedure AddFileToListe(Filename:String); 
      // Quellverzeichnis setzen 
      procedure SetSourceDir(Dirname:String);
      // Upload starten 
      function StartUpload:Boolean;
      procedure FtpWork(Sender: TObject; AWorkMode: TWorkMode;
        AWorkCount: Integer);

      procedure WorkBegin(ASender: TObject; AWorkMode: TWorkMode;
        AWorkCountMax: Integer);
    end;

implementation 

uses 
  IniFiles, SysUtils; 

(* ************************************************************************* 
     Ausführen 
   ************************************************************************* *) 
procedure TFtpUpload.AddFileToListe(Filename: String); 
begin 
  // Sicherstellen, dass die Fileliste nicht anderweitig verwendet wird 
  Semaphore.Acquire; 
  FileList.Add(ExtractFilename(Filename)); 
  Semaphore.Release;

end; 

(* ************************************************************************* 
     Erzeugen 
   ************************************************************************* *) 
constructor TFtpUpload.Create(Form: TWaitForm; NName: String);
begin
  // bei erzeugen CreateSuspended ignorieren!
  // immer Suspended anfangen

  inherited Create(True);

  WForm := Form;
  NeuerName := NName;

  // Objekte anlegen
  Semaphore:=TCriticalSection.Create;
  Ftp:=TIdFtp.Create(NIL);

  ftp.OnWorkBegin := Self.WorkBegin;
  ftp.OnWork      := FtPWork;
  
  FileList:=TStringList.Create;
  // Initialisierungen
  Priority:=tpNORMAL;
  FreeOnTerminate:=FALSE;
  IState:=ftpREADY;
  IFileCnt:=0;
  SourceDir:='';
  // noch haben wir keinen Auftrag
  HasJob:=FALSE;
 
end; 

(* ************************************************************************* 
     Ausführen 
   ************************************************************************* *) 
procedure TFtpUpload.Execute;
var cnt:Integer;
    Extension: String;
begin

  Extension := '';
  
  // solange kein Endsignal laufen wir im Kreis 
  while (not Self.Terminated) do 
    begin 
      // wenn wir einen Auftrag haben, führen wir den Upload durch 
      // ansonsten legen wir uns schlafen 
      if not HasJob then 
        Self.Suspend 
      else 
        begin 
          // Config eintragen 
          Ftp.Host:=Config.Hostname; ;
          Ftp.Username:=Config.Username; ;
          Ftp.Password:=Config.Password; ;
          Ftp.Passive:=Config.Passive; ;
          Ftp.TransferType:=ftBINARY; ;
          try 
            // Verbindung aufbauen 
            IState:=ftpCONNECTING; 
            IFileCnt:=0; 
            Ftp.Connect; ;
            // ins Zielverzeichnis wechseln 
            if Trim(Config.TargetPath)<>'' then 
              begin 
                IState:=ftpCHANGEDIR; 
                Ftp.ChangeDir(Trim(C...g.TargetPath)); ;
              end; 
            // in der Zeit des Sendes ist kein Zugriff auf die 
            // Fileliste möglich!!! 
            Semaphore.Acquire; 
            // Alle Dateien aus der Dateiliste senden 
            // jedes Mal Terminate abfragen, damit Abbruch möglich ist 
            for cnt:=0 to FileList.Count-1 do 
              if (not Self.Terminated) and 
                 FileExists(SourceDir+FileList[cnt]) then 
                begin 
                  Inc(IFileCnt); 
                  IState:=ftpUPLOADING;

                  {-------------------------}
                  { Zuerst kommen die Daten }
                  { dann die Meta-Datei     }
                  {-------------------------}
                  if cnt=0 then
                    Extension := '.tar.gz'
                  else
                    Extension := '.meta';

                  Ftp.Put(SourceDir+Fi...NeuerName+Extension);
                end; 
            // wenn wir hier ankommen, war der gesamte Upload ok 
            // die Fileliste wird gelöscht 
            IState:=ftpREADY; 
            FileList.Clear; 
          finally 
            Ftp.Disconnect; ;
            Semaphore.Release; 
            Self.HasJob:=FALSE; 
            Self.Suspend; 
          end; 
        end; 
    end; 
end; 

(* ************************************************************************* 
     Freigeben 
   ************************************************************************* *) 
destructor TFtpUpload.Free; 
begin
  Ftp.Abort;
  Ftp.Quit;

  // Ftp.Disconnect;

  FileList.Free;
  Ftp.Free;
  Semaphore.Free;
  inherited Destroy;
 
end; 

(* ************************************************************************* 
     Konfiguration aus Ini-Datei laden 
   ************************************************************************* *) 
procedure TFtpUpload.LoadConfig(FtpHost,FtpUser, FtpPass, FtpPath: String);
var Ini:TIniFile; 
begin 
  Config.Hostname:=FtpHost;
  Config.Username:=FtpUser;
  Config.Password:=FtpPass;
  Config.Passive:=FALSE;
  Config.TargetPath:=FtpPath; 
end; 

(* ************************************************************************* 
     Quellverzeichnis setzen 
   ************************************************************************* *) 
procedure TFtpUpload.SetSourceDir(Dirname: String); 
begin 
  // Sicherstellen, dass nicht anderweitig verwendet wird 
  Semaphore.Acquire; 
  Self.SourceDir:=IncludeTrailingPathDelimiter(Dirname); 
  Semaphore.Release; 
end; 

(* ************************************************************************* 
     Upload starten 
   ************************************************************************* *) 
function TFtpUpload.StartUpload:Boolean; 
begin 
  // wenn der Thread nicht Suspended ist, läuft noch ein Upload 
  // --> kein erneuter Start! 
  if Self.Suspended then 
    begin 
      Self.HasJob:=TRUE; 
      Self.Resume; 
      Result:=TRUE; 
    end 
  else Result:=FALSE; 
end; 

procedure TFtpUpload.WorkBegin(ASender: TObject; AWorkMode: TWorkMode;
  AWorkCountMax: Integer);
begin
  WForm.SetMax(AWorkCountMax);
  WForm.SetPosition(0);
end;

procedure TFtpUpload.FtpWork(Sender: TObject; AWorkMode: TWorkMode;
  AWorkCount: Integer);
begin
  //Aktualisieren der Fortschrittsanzeige:
  WForm.SetPosition(AWorkCount);
end;

end.					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:

procedure TForm1.upload(NeuerName: String);

var FileCnt:Integer;
    SourcePath: String;

begin

  SourcePath := ExtractFileDir(Application.ExeName);

  // Thread erzeugen
  FtpExec:=TFtpUpload.Create(WaitForm, NeuerName);


  // Konfig laden
  FtpExec.LoadConfig(FtpHost,FtpUser, FtpPass, FtpPath);
  // Quellverzeichnis setzen
  FtpExec.SetSourceDir(SourcePath);
  // Alle Dateien aus dem Quellverzeichnis für Übertragung vormerken


  FtpExec.AddFileToListe('temp.tar.gz');
  FtpExec.AddFileToListe('temp.meta');

  // Thread anstarten
  FtpExec.StartUpload;
      // Warten, bis der Thread suspended und damit fertig ist 
      while (not FtpExec.Suspended) do
        begin 
          // Rechenzeit freigeben
          Application.ProcessMessages;
      end; 
  // Thread löschen 
  FtpExec.Free; 

end;