Beispiel zum Versenden von Dateien mit Indy

[Andi067]

So, weil ich jetzt auch recht lange gesucht habe und immer wieder "nur" auf dieses schöne Beispiel mit Indy 9 gekommen bin, hab ich es dann mal angepackt und eine (bei mir) mit Indy10 lauffähige Version hinbekommen. Leider tuts die Anzeige im Server nicht so ganz, war mir aber nicht wirklich wichtig. Ansonsten kann ja vieleicht jemand was damit anfangen...

F_Main.pas Server:

Delphi-Quellcode:

unit f_Main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, IdAntiFreezeBase, IdAntiFreeze, IdBaseComponent, IdComponent,IdCustomTCPServer,
  IdTCPServer, ComCtrls, IdStreamVCL,idtask,idcontext;

type
   TfrmMainServer = class(TForm)
    gb_Einstellungen: TGroupBox;
    ed_Port: TEdit;
    TcpServer: TIdTCPServer;
    IdAntiFreeze1: TIdAntiFreeze;
    Label1: TLabel;
    cmd_StartServer: TButton;
    cmd_EndServer: TButton;
    Label2: TLabel;
    lab_SvrStatus: TLabel;
    gb_Threads: TGroupBox;
    ScrollBox1: TScrollBox;
    gb_Test: TGroupBox;
    pBar: TProgressBar;
    Label3: TLabel;
    lab_FileSize: TLabel;
    Label5: TLabel;
    lab_ReceivedBytes: TLabel;
    procedure TcpServerExecute(AContext: TIdContext);
    procedure cmd_StartServerClick(Sender: TObject);
    procedure cmd_EndServerClick(Sender: TObject);
//    procedure TcpServerExecute1(AThread: TIdPeerThread);
    procedure FormShow(Sender: TObject);
  private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;

var
  frmMainServer: TfrmMainServer;

implementation

uses FileReceiver;

{$R *.DFM}

procedure TfrmMainServer.cmd_StartServerClick(Sender: TObject);
begin
   // erstmal eventuelle bestehende Verbindungen trennen
   TcpServer.Active := false;
   // Bindings leeren
   TcpServer.Bindings.Clear;
   // Port zuweisen, wenn kein gültiger Wert eingetragen ist 9876 als Standard verwenden
   TcpServer.DefaultPort := StrToIntDef(ed_Port.Text,9876);
   try
      TcpServer.Active := true;
   except
      raise;
   end;
   // Ist der Server erfolgreich gestartet worden ?
   if TcpServer.Active then begin
      // jetzt die Anzeige-Elemente dem Status anpassen
      cmd_EndServer.Enabled := true;
      cmd_StartServer.Enabled := false;
      lab_SvrStatus.Font.Color := clGreen;
      lab_SvrStatus.Caption := 'Gestartet';
   end;
end;

procedure TfrmMainServer.cmd_EndServerClick(Sender: TObject);
begin
   // Server anhalten/deaktivieren
   try
      TcpServer.Active := false;
   except
      raise;
   end;
   // Ist der Server erfolgreich beendet worden
   if not TcpServer.Active then begin
      // jetzt die Anzeige-Elemente dem Status anpassen
      cmd_EndServer.Enabled := false;
      cmd_StartServer.Enabled := true;
      lab_SvrStatus.Font.Color := clRed;
      lab_SvrStatus.Caption := 'Deaktiviert';
   end;
end;

procedure TfrmMainServer.TcpServerExecute(AContext: TIdContext);
Var sClientMsg : String;
      FileReceiver : TFileReceiver;
begin
   try
      // Clientnachricht lesen
      sClientMsg := AContext.Connection.IOHandler.ReadLn(#$A,5500);
      FileReceiver := TFileReceiver.Create(AContext,sClientMsg);
      try
         // gültige Nachricht vom Client ?
         if FileReceiver.ServerMsgOK then begin
            // Datei jetzt empfangen
            if FileReceiver.Start then
               // Bestätigung zum Clientschreiben
               AContext.Connection.IOHandler.WriteLn('FILEOK')
            else
               // Error-Nachricht schreiben
               AContext.Connection.IOHandler.WriteLn('FILEERROR');
         end;
      finally
         FileReceiver.free;
      end;
   except
      AContext.Connection.Disconnect;
   end;
end;

{procedure TfrmMainServer.TcpServerExecute1(AThread: TIdPeerThread);
Var sClientMsg : String;
      FileReceiver : TFileReceiver;
begin
   try
      // Clientnachricht lesen
      sClientMsg := AThread.Connection.ReadLn(#$A,5500);
      FileReceiver := TFileReceiver.Create(AThread,sClientMsg);
      try
         // gültige Nachricht vom Client ?
         if FileReceiver.ServerMsgOK then begin
            // Datei jetzt empfangen
            if FileReceiver.Start then
               // Bestätigung zum Clientschreiben
               AThread.Connection.WriteLn('FILEOK')
            else
               // Error-Nachricht schreiben
               AThread.Connection.WriteLn('FILEERROR');
         end;
      finally
         FileReceiver.free;
      end;
   except
      AThread.Connection.Disconnect;
   end;
end;
}
procedure TfrmMainServer.FormShow(Sender: TObject);
begin
   // test-groupbox löschen
   gb_Test.free;
end;

end.

Filereceiver.pas

Delphi-Quellcode:

unit FileReceiver;

interface

uses Classes, SysUtils, stdctrls, comctrls, IdTCPServer,
//Neu
   idcontext;

type

   TFileReceiver = Class
      private
         fServerMsgOk : Boolean;
         // Optische Elemente zur Darstellung des Threads
         fGB : TGroupBox;
         fpBar : TProgressBar;
         fLabFSText : TLabel;
         fLabFS : TLabel;
         fLabReText : TLabel;
         fLabRe : TLabel;
         // Indy-Server-Thread
//alt         AThread : TIdPeerThread;
         AThread : TIdContext;
         // wichtige Elemente zum Empfangen der Datei
         iFileSize : Cardinal;
         iReceivedBytes : Cardinal;
         sFileName  : String;
         tmpMS : TMemoryStream;
         procedure CreateElements;
         procedure DestroyElements;
         Function VBSplit(Liste : TStringList; Text2Split : String; SeperatorStr : String) : Boolean;
         procedure UpdateProgress;
      protected
         //
      public
//alt      Constructor Create(Thread : TIdPeerThread; Msg : String);
      Constructor Create(Thread : TIdContext; Msg : String);
         Destructor Free;

         property ServerMsgOK : Boolean read fServerMsgOk write fServerMsgOk;
         
         function Start : Boolean;
   end;

implementation

uses f_Main, Controls;

{ TFileReceiver }

constructor TFileReceiver.Create(Thread: TIdContext; Msg: String);
Var strL : TStringList;
begin
   fServerMsgOk := false;
   AThread := Thread;
   if AThread = Nil then 
      exit;
   // Zwischenspeicher zum empfangen der Pakete erzeugen
   tmpMS := TMemoryStream.Create;
   // Nachricht vom Client splitten
   strL := TStringList.create;
   try
      VBSplit(strL,Msg,'|');
      // eine gültige Client-Nachricht besteht aus zwei Teilen
      if strL.Count = 2 then begin
         // zweites Elemt die Gesamtdateigrösse
         iFileSize := StrToIntDef(strL[0],0);
         fLabFS.Caption := Inttostr(iFileSize)+' Bytes'; 
         // drittes Element enthält den Filenamen
         sFileName := strL[1];
         //prüfen, ob gültige Werte übertragen wurden
         fServerMsgOk := ((iFileSize > 0) and (Length(sFileName) > 0));
      end;
   finally
      strL.free;
   end;
   CreateElements;
end;

destructor TFileReceiver.Free;
begin
   tmpMS.Clear;
   FreeAndNil(tmpMS);
  DestroyElements;
end;


procedure TFileReceiver.CreateElements;
begin
   // GroupBox erzeigen
   fGB := TGroupBox.Create(frmMainServer.ScrollBox1);
   fGB.Parent := frmMainServer.ScrollBox1;
   fGB.Height := 57;
   fGB.Align  := alTop;
   fGB.Caption := 'Client('+AThread.Connection.Socket.Binding.PeerIP+') überträgt '+sFileName;
   fGB.Visible := true;

   // Progressbar erzeugen
   fpBar := TProgressBar.Create(fGB);
//   fpBar.Parent := fGB;
   fpBar.Left := 8;
   fpBar.Top := 24;
   fpBar.Width := 337;
   fpBar.Anchors := [akLeft,akTop,akRight];
   fpBar.Visible := true;

   // Labels erzeugen
   fLabFSText := TLabel.create(fGB);
//    fLabFSText.Parent := fGB;
   fLabFSText.Left := 368;
   fLabFSText.top  := 16;
   fLabFSText.Anchors := [akTop,akRight];
   fLabFSText.Caption := 'Filesize: ';
   fLabFSText.Visible := true;

   fLabFS := TLabel.create(fGB);
//   fLabFS.Parent := fGB;
   fLabFS.Caption := '0,00 KB';
   fLabFS.left := 547;
   fLabFS.top := 16;
   fLabFS.Anchors := [akTop,akRight];
   fLabFS.Alignment := taRightJustify;
   fLabFS.Visible := true;
   fLabFS.Caption := FormatFloat('0.00',iFileSize/1024)+' KB';

   fLabReText := TLabel.create(fGB);
//   fLabReText.Parent := fGB;
   fLabReText.Left := 368;
   fLabReText.top  := 32;
   fLabReText.Anchors := [akTop,akRight];
   fLabReText.Caption := 'Received: ';
   fLabReText.Visible := true;

   fLabRe := TLabel.create(fGB);
 //   fLabRe.Parent := fGB;
   fLabRe.Caption := '0,00 KB';
   fLabRe.left := 547;
   fLabRe.top := 32;
   fLabRe.Anchors := [akTop,akRight];
   fLabRe.Alignment := taRightJustify;
   fLabRe.Visible := true;

   //fgb.Repaint;
   frmMainServer.ScrollBox1.Repaint;

end;

procedure TFileReceiver.DestroyElements;
begin
   // hier nur die Groupbox freigeben, alle anderen Controls nicht Childs der GroupBox
   // und werden somit mit freigegeben
   fGB.free;
end;

// ********* VBSplit ***********************************************************
// Author    23.3.2001 J. Freese alias DataCool
// Function  Splits a string in different substring speraded by SeperatorStr
// Param     List where the substrings were added
//           Text2Split string which should be splitted
//           SeperatorStr String which are used as Seperator
// Return    true if success
function TFileReceiver.VBSplit(Liste: TStringList; Text2Split, SeperatorStr: String): Boolean;
Var Posi      : Longint;
      strTemp : String;
      strPart : String;
      bInLoop : Boolean;
      sepLen  : Longint;
begin
   result  := true;
   bInLoop := false;
   try
      //Liste leeren
      Liste.clear;
      strTemp   := Text2Split;
      sepLen    := Length(SeperatorStr);
      Posi      := Pos(SeperatorStr,strTemp);
      While Posi > 0 do begin
         bInLoop := true;
         strPart := Copy(strTemp,1,Posi-1);
         Liste.Add(strPart);
         strTemp := copy(strTemp,Posi+sepLen,Length(strTemp)-(Posi+sepLen-1));
         Posi    := Pos(SeperatorStr,strTemp);
      end;
      if (bInLoop) or (Length(strTemp)>0) then
         Liste.add(strTemp);
   except
      Result := false;
   end;
end;

function TFileReceiver.Start : Boolean;
Var bError : Boolean;
      bReady : Boolean;
      fs     : TFileStream;
begin
   result := true;
   if iFileSize > 0 then begin
      // Alle Startwerte setzen
      bError := false;
      bReady := false;
      iReceivedBytes := 0;
      // erstmal versuchen die Datei zu erstellen
      // das Zielverzeichnis wo die Daten gespeichert werden sollen könnt Ihr nachher selber bestimmen
      sFileName := 'C:\'+sFileName;
      try
         fs := TFileStream.Create(sFileName,fmCreate or fmShareExclusive);
      except
         // Fehler beim Erstellen der Datei aufgetreten
         result := false;
         exit;
      end;
      try
         // Solange keine Abbruch Bediengung erreicht ist Stream-Pakete lesen
         While //(not AThread.Terminated) and
            (AThread.Connection.Connected) and
                  (not bError) and (not bReady) do begin
            // Buffer(Speicher-Stream) leeren
            tmpMS.clear;
            try
               // versuchen Stream zu Lesen
               AThread.Connection.IOHandler.ReadStream(tmpMS);
               // Steht jetzt auch wirklich was im Stream drin
               if tmpMS.Size > 0 then begin
                  // die gelesenen Bytes jetzt direkt in den FileStream schreiben
                  fs.copyFrom(tmpMS,0);
                  // Anzahl der gelesenen Bytes erhöhen
                  iReceivedBytes := iReceivedBytes + tmpMS.Size;
                  // jetzt durch den Thread die Methode UpdateProgress ausführen
                  // dieses muss mit Syncronize gemacht werden, mehr dazu in Delphi Hilfe
                //   AThread.Synchronize(UpdateProgress);
           updateProgress;
               end;
               bReady := (fs.Size = iFileSize);
            except
               // Fehler beim Lesen des Stream aufgetreten, Speicher leeren
               tmpMS.Clear;
               // Vorgang abbrechen
               bError := true;
            end;
         end;
      finally
         fs.free;
         if bError then
            DeleteFile(sFileName);
      end;
      result := FileExists(sFileName);
   end;
end;

procedure TFileReceiver.UpdateProgress;
Var ipBarPos : Longint;
begin
   // Label anpassen
   fLabRe.Caption := FormatFloat('0.00',iReceivedBytes/1024)+' KB';
   // Prozent-Wert für Progressbar-Fortschritt ausrechnen
   ipBarPos := Round(iReceivedBytes/iFileSize*100);
   // neue Position setzen
   fpBar.Position := ipBarPos;
   // GroupBox und alle Unterelemente neu zeichnen
   fgb.Repaint;
end;

end.

und schließlich F_Main.pas (Client)

Delphi-Quellcode:

unit f_Main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls, IdAntiFreezeBase, IdAntiFreeze, IdBaseComponent, IdComponent,
   IdTCPConnection, IdTCPClient, Buttons, ComCtrls;

Const

   // jede Datei wird in mehere Stücke a folgende Größe zerlegt
   cFileSplitSize : Longint = 20*1024; // Bytes = 20 KB 

   // Trennzeichen was bei der Kommunikation mit dem Server benutzt wird
   cSplitChar : String = '|';

type
  TfrmMainClient = class(TForm)
    gb_Server: TGroupBox;
    Ed_ServerIP: TEdit;
    Label1: TLabel;
    Label2: TLabel;
    ed_Port: TEdit;
    TcpCon: TIdTCPClient;
    IdAntiFreeze1: TIdAntiFreeze;
    gb_File: TGroupBox;
    ed_File: TEdit;
    sb_FindFile: TSpeedButton;
    OpenDlg: TOpenDialog;
    cmd_Send: TBitBtn;
    pBar_SendProgress: TProgressBar;
    lab_SendProgress: TLabel;
    lab_SendSpeedText: TLabel;
    lab_Speed: TLabel;
    procedure sb_FindFileClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure cmd_SendClick(Sender: TObject);
  private
      { Private-Deklarationen }
      procedure HideSendComponents;
      procedure ShowSendComponents;
      function  checkValues : Boolean;
  public
      { Public-Deklarationen }
      iFileSize : Longint;
  end;

var
  frmMainClient: TfrmMainClient;

implementation

{$R *.DFM}

// Datei die verschickt werden soll suchen
procedure TfrmMainClient.sb_FindFileClick(Sender: TObject);
begin
   // Wenn kein Startverzeichnis gesetzt ist
   if OpenDlg.InitialDir = '' then
      // setzen wir das Startverzeichnis auf das Anwendungsverzeichnis
      OpenDlg.InitialDir := ExtractFilePath(Application.ExeName);
   // OpenFileDialog ausführen
   if OpenDlg.Execute then begin
      ed_File.Text := OpenDlg.FileName;
   end;
end;

// Alle Komponenten die zum Anzeigen des Sendevorgangs benötigt werden einblenden
procedure TfrmMainClient.ShowSendComponents;
begin
   frmMainClient.Height := 226;
   lab_SendProgress.Visible := true;
   lab_SendSpeedText.Visible := true;
   lab_Speed.Visible := true;
   pBar_SendProgress.Visible := true;
end;

// Alle Komponenten die zum Anzeigen des Sendevorgangs benötigt werden ausblenden
procedure TfrmMainClient.HideSendComponents;
begin
   lab_SendProgress.Visible := false;
   lab_SendSpeedText.Visible := false;
   lab_Speed.Visible := false;
   pBar_SendProgress.Visible := false;
   frmMainClient.Height := 190;
end;


procedure TfrmMainClient.FormShow(Sender: TObject);
begin
   // Beim Start des Programms Sende-Komponenten ausblenden
   HideSendComponents;
end;

// alle Angaben die zum Versenden der Datei benötigt werden, auf Gültigkeit überprüfen
function TfrmMainClient.checkValues: Boolean;                    
Var iTmp : Longint;
begin
   result := true; 
   // Ist eine Server-IP angegeben ?
   if Length(trim(Ed_ServerIP.Text)) = 0 then begin
      Messagedlg('Bitte tragen Sie die IP-Adresse des Servers ein !',mtInformation,[mbok],0);
      Ed_ServerIP.SetFocus;
      result := false;
      exit;
   end;
   // Handelt es sich bei der Port-Angabe um einen ganzzahligen Wert ?
   iTmp := StrToIntDef(ed_Port.text,-1);
   if iTmp = -1 then begin
      Messagedlg('Bitte tragen Sie eine gültige Portnummer ein !',mtInformation,[mbok],0);
      ed_Port.SetFocus;
      result := false;
      exit;
   end;
   // überprüfen, ob die Datei die verschickt werden soll existiert
   if not FileExists(ed_File.Text) then begin
      Messagedlg('Die angegebene Datei existiert nicht, bitte wählen Sie eine Datei aus!',mtInformation,[mbok],0);
      ed_File.SetFocus;
      result := false;
      exit;
   end;
end;

procedure TfrmMainClient.cmd_SendClick(Sender: TObject);
Var fs    : TFileStream;     // Zum Lesen der Datei
      tmpMs : TMemoryStream;   // temporärer Speicherstream zum Splitten der Datei, ab bestimmter Grösse
      iTmpSize   : Longint;    // Zähler um sich zu merken, wieviel Bytes schon gebuffert/gesendet wurden wurden
      iNextSize  : Longint;    // Byte-Anzahl die gelesen werden sollen
      bError     : Boolean;    // Bool-Schalter für Fehlererkennung
      sMsgToSvr  : String;     // Nachricht für den Server
      iSendTime  : Cardinal;  // Zeitmesser auch nachher zum lesen
      iTimeDiff  : Cardinal;  // Var zum Zeit-Differenz berechnen 
      BytesperSek : Double;
      sCmd        : String;
begin
   // als erstes die Usereingaben prüfen
   if not checkValues then exit;

   // als erstes versuchen die Datei zu öffnen, so das niemand mehr in diese Datei schreiben kann
   try
      fs := TFileStream.Create(ed_File.Text,fmOpenRead or fmShareDenyWrite);
   except
      MessageDlg(ed_File.Text+' kann nicht geöffnet werden ! '+#10#13
               +'Wahrscheinlich ist diese Datei von einer anderen Anwendung geöffnet !',
               mtError,[mbok],0);
      exit;
   end;
   // Verbindung zum Server herstellen
   TcpCon.Disconnect;
   TcpCon.Host := Ed_ServerIP.text;
   TcpCon.Port := StrToIntDef(ed_Port.Text,9876);
   // Versuchen eine Verbindung zum Server herzustellen
   try
      TcpCon.Connect(5000); // max. 5 Sek. um die Verbindung zum Server herzustellen
   except
      Messagedlg('Es konnte keine Verbindung zum Server: '+Ed_ServerIP.text+' auf Port: '+ed_Port.Text+' hergestelt werden!',
             mtError,[mbok],0);
      exit;
   end;
   if TcpCon.Connected then begin
      // Übertragungskomponenten anzeigen
      ShowSendComponents;
      // jetzt muss der Server natürlich wissen wieviele Bytes vom Client kommen, 
      // und wie die Datei heisst
      sMsgToSvr := inttostr(fs.size)+cSplitChar+ExtractFileName(ed_File.Text);
      // Nachricht zum Server schicken
      TcpCon.WriteLn(sMsgToSvr);
      // Server ist bereit zum Empfangen und die Verbindung besteht jetzt anfangen 
      // die Datei zu Senden
      tmpMS := TMemoryStream.Create;
      try
         // Gesamtgrösse der Datei merken
         iFileSize := fs.Size;
         // Bufferzähler auf Null u. Error auf false
         iTmpSize  := 0;
         bError    := false;
         // Stream Position wieder auf Anfang setzen (nur zur Sicherheit)
         fs.Position := 0;
         // Solange nicht alle Daten im versendet wurden, diese Stückweise versenden
         while (iTmpSize < iFileSize) and (not bError) do begin
            tmpMs.clear;
             // Anwenung etwas Zeit zur Nachrichten-Verarbeitung geben
            Application.ProcessMessages;
            iSendTime := GetTickCount;
            try
               // als ersten berechnen wie viel Bytes zum Senden noch da sind
               iNextSize := iFileSize - iTmpSize;
               // Wenn die Byte Anzahl > der FileSplitSize ist, dann muss weiter gesplittet werden
               if iNextSize > cFileSplitSize then
                  iNextSize := cFileSplitSize;
               iTmpSize := iTmpSize + tmpMs.CopyFrom(fs,iNextSize);
               TcpCon.OpenWriteBuffer;
               TcpCon.WriteStream(tmpMS,true,true);
               TcpCon.CloseWriteBuffer;
               // Wenn die Übertragung im Lan über Delphi getestet wird, bitte folgendes Sleep
               // aktivieren, das verlangsamt zwar die Übertragung, aber ansonsten gibt es 
               // bei der Berechnung der Sendegeschwindigkeit, divion 0 error
               sleep(25); // im realen Betrieb auskommentieren
               // Zeit die fürs Senden gebraucht wurde ausrechnen
               iTimeDiff := GetTickCount - iSendTime;
               // Fortschrittsanzeige aktualisieren
               pBar_SendProgress.Position := Round(iTmpSize/iFileSize*100);
               pBar_SendProgress.Repaint;
               // aktuelle Geschwindigkeit ausrechnen
               try 
                  BytesperSek := round(tmpMs.Size/1024/iTimeDiff*1000);
               except 
                  BytesperSek :=0; 
               end;
               // Geschwindigkeit anzeigen
               lab_Speed.Caption := FormatFloat('0.00',BytesperSek)+ ' KB/Sek.';
               lab_Speed.Repaint;
            except
               bError := true;
            end;
         end;
         // Bestätigung vom Server lesen
         try
            sCmd := TcpCon.ReadLn(#$A,7500);
         except
            sCmd := 'TimeOut-Error';
         end;
         // Verbindung trennen
         TcpCon.Disconnect;
      finally
         tmpMs.Clear;
         FreeAndNil(tmpMs);
      end;
      HideSendComponents;
      // War die Übertragung der DAtei erfolgreich ?
      if (not bError) and (sCmd = 'FILEOK') then 
         Messagedlg('Datei wurde erfolgreich versendet!',mtInformation,[mbok],0)
      else   
         Messagedlg('Fehler beim versenden der Datei!',mtError,[mbok],0)
   end;
end;


end.

Vieleicht hilfts ja jemandem...
Gruß
A