Chip 2001 September/Chip_2001-09_cd1.bin/zkuste/delphi/nastroje/d5/MFTP.ZIP/src/FtpMsg.pas

Pascal/Delphi Source File | 2000-05-23 | 7.6 KB | 309 lines

unit FtpMsg;

interface

uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, RichEdit,
   StdCtrls, ComCtrls, Ftp;

{$I mftp.inc}

type
   TMessengerStyle = (msgClassic, msgMFtp, msgMFtpTime);
   TMessageType  = (msgCommand, {$ifndef NODEBUG}msgDebug,{$endif} msgError, msgException, msgReply, msgStatus);

   TMessengerShowEvent = procedure (Sender: TObject; info: FtpInfo; var Show: Boolean) of object;
   TMessengerShowEventE = procedure (Sender: TObject; error: FtpError; var Show: Boolean) of object;

   TMFtpMessenger = class(TCustomRichEdit)
   private
      FFtp:                      TMFtp;

      FStyle:                    TMessengerStyle;
      FShowEvent:                TMessengerShowEvent;
      FShowEventE:               TMessengerShowEventE;

      FAScroll:                  Boolean;
      ShowDisconnect:            Boolean;

      HOnFtpInfo:                Integer;
      HOnFtpError:               Integer;

      procedure AddLine(const S: String);

      procedure NewOnFtpInfo(Sender: TObject; info: FtpInfo; addinfo: String);
      procedure NewOnFtpError(Sender: TObject; error: FtpError; addinfo: String);

      procedure SetClient(NewFtp: TMFtp);
      procedure SetStyle(NewStyle: TMessengerStyle);
   protected
      NoBlankLine:               Boolean;
   public
      constructor Create(AOwner: TComponent); override;

      procedure AddMessage(Msg: String; MsgType: TMessageType);
   published
      property AutoScroll: Boolean read FAScroll write FAScroll;
      property Client: TMFtp read FFtp write SetClient;
      property Style: TMessengerStyle read FStyle write SetStyle;

      property OnErrorShow: TMessengerShowEventE read FShowEventE write FShowEventE;
      property OnMessageShow: TMessengerShowEvent read FShowEvent write FShowEvent;

      property Align;
      property HideScrollBars;
      property HideSelection;
      property PopupMenu;
      property ScrollBars;
      property WordWrap;

      property OnClick;
      property OnDblClick;
      property OnEnter;
      property OnExit;
      property OnMouseDown;
      property OnMouseMove;
      property OnMouseUp;

      property Anchors;
      property BiDiMode;
      property BorderWidth;
      property Constraints;
      property DragKind;
      property DragMode;
      property ParentBiDiMode;

      property OnEndDock;
      property OnMouseWheel;
      property OnMouseWheelDown;
      property OnMouseWheelUp;
      property OnStartDock;
   end;

implementation

{ TMFtpMessanger }

constructor TMFtpMessenger.Create;
begin
   inherited Create(AOwner);

   FAScroll := True;
   NoBlankLine := False;
   ImeMode := imClose;
   ReadOnly := True;
   WordWrap := False;

   ShowDisconnect := False;
end;

procedure TMFtpMessenger.SetClient;
begin
   if FFtp = NewFtp then Exit;

   if Assigned(FFtp) then
   begin
      with FFtp do
      begin
         UnRegisterInfoEvent(HOnFtpInfo);
         UnRegisterInfoEvent(HOnFtpError);
      end;
   end;

   FFtp := NewFtp;

   if not Assigned(FFtp) then Exit;

   with FFtp do
   begin
      HOnFtpInfo := RegisterInfoEvent(NewOnFtpInfo);
      HOnFtpError := RegisterErrorEvent(NewOnFtpError);
   end;
end;

procedure TMFtpMessenger.SetStyle;
begin
   FStyle := NewStyle;

   if FStyle = msgClassic then
      Font.Name := 'Courier New'
   else
      Font.Name := 'MS Sans Serif';
end;

procedure TMFtpMessenger.AddLine;
begin
   if NoBlankLine then
      if Trim(S) = '' then Exit;

   Lines.Add(S);

   if FAScroll then
      SendMessage(Handle, EM_LINESCROLL, 0, 1);
end;

procedure TMFtpMessenger.AddMessage;
var C: TColor;
    P: String;
    i: Integer;
begin
   if Trim(Msg) = '' then Exit;

   C := clBlack;    {to make compiler happy :-)}

   if FStyle = msgClassic then
   begin
      case MsgType of
         msgCommand:
         begin
            C := clGreen;
            P := msgCommandx;
         end;

         {$ifndef NODEBUG}
         msgDebug:
         begin
            C := clRed;
            P := 'DEBUG:>     ';
         end;
         {$endif}

         msgError:
         begin
            C := clRed;
            P := msgErrorx;
         end;

         msgException:
         begin
            C := clRed;
            P := msgExceptionx;
         end;

         msgReply:
         begin
            //C := clBlack;
            P := msgReplyx;
         end;

         msgStatus:
         begin
            C := clBlue;
            P := msgStatusx;
         end;
      end;

      SelStart := -1;
      SelAttributes.Color := C;
      Msg := P + Msg;
      i := Pos(#13#10, Msg);
      if i = 0 then
      begin
         AddLine(Msg)
      end
      else
      begin
         AddLine(Copy(Msg, 1, i - 1));
         Delete(Msg, 1, i + 1);
         i := Pos(#13#10, Msg);

         while i <> 0 do
         begin
            AddLine('            ' + Copy(Msg, 1, i - 1));
            Delete(Msg, 1, i + 1);
            i := Pos(#13#10, Msg);
         end;

         AddLine('            ' + Msg)
      end;
   end
   else
   begin
      case MsgType of
         msgCommand:   C := clBlue;
         {$ifndef NODEBUG}
         msgDebug:     C := clRed;
         {$endif}
         msgError:     C := clRed;
         msgException: C := clRed;
         msgReply:     C := clGreen;
         msgStatus:    C := clPurple;
      end;

      SelStart := -1;
      SelAttributes.Color := C;

      if (Style = msgMFtpTime) and (MsgType <> msgReply) then
         Msg:='[' + DateTimetoStr(Now) + '] ' + Msg;
      AddLine(Msg);
   end;
end;

procedure TMFtpMessenger.NewOnFtpInfo;
var Show: Boolean;
begin
   if Assigned(FShowEvent) then
   begin
      Show := True;
      FShowEvent(Self, info, Show);
      if not Show then Exit;
   end;

   case info of
      ftpServerConnected:
      begin
         with FFtp do
         begin
            if (Server = '') and (addinfo = '') then
               AddMessage(msgConnectTo + msgSpecifiedS + msgWelcome, msgStatus)
            else
            if (Server <> '') and (Server <> addinfo) then
            begin
               if addinfo <> '' then
                  AddMessage(msgConnectTo + Server + '(ip: ' + addinfo + ')' + msgWelcome, msgStatus)
               else
                  AddMessage(msgConnectTo + Server + msgWelcome, msgStatus);
            end
            else
            begin
               AddMessage(msgConnectTo + addinfo + msgWelcome, msgStatus);
            end;
         end;
         ShowDisconnect := True;
      end;
      {$ifndef NODEBUG}
      ftpDebug:    AddMessage(addinfo, msgDebug);
      {$endif}
      ftpTraceIn:  AddMessage(addinfo, msgReply);
      ftpTraceOut: AddMessage(addinfo, msgCommand);
      ftpRetrying: AddMessage(addinfo + #13#10, msgStatus);
      ftpNotSupportResume: AddMessage(addinfo + #13#10, msgStatus);
      ftpSupportResume:    AddMessage(addinfo + #13#10, msgStatus);
      ftpServerDisconnected:
      begin
         if ShowDisconnect then
         begin
            AddMessage(msgDisconnected + #13#10, msgStatus);
            ShowDisconnect := False;
         end;
      end;
      ftpNothing: AddMessage(addinfo + #13#10, msgStatus);
      ftpLoggedIn: AddMessage(msgLoginS + #13#10, msgStatus);
   end;
end;

procedure TMFtpMessenger.NewOnFtpError;
var Show: Boolean;
begin
   if Assigned(FShowEventE) then
   begin
      Show := True;
      FShowEventE(Self, error, Show);
      if not Show then Exit;
   end;

   AddMessage(addinfo + #13#10, msgError);
end;

end.