ftpmsg.pas

Monster FTP Client 强大的ftp客户控件,支持Proxy等

unit FtpMsg;

interface

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

type TMessageStyle = (msgClassic, msgMFtp);
     TMessageType  = (msgCommand, msgError, msgException, msgReply, msgStatus);

type
   TMFtpMessager = class(TCustomRichEdit)
   private
      FFtp:                      TMFtp;

      FStyle:                    TMessageStyle;

      ShowDisconnect:            Boolean;

      HOnFtpInfo:                Integer;
      HOnFtpError:               Integer;

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

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

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

      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;

      {$ifdef VER120}
      property Anchors;
      property BiDiMode;
      property BorderWidth;
      property Constraints;
      property DragKind;
      property DragMode;
      property ParentBiDiMode;
      {$endif}

      {$ifdef VER120}
      property OnEndDock;
      property OnMouseWheel;
      property OnMouseWheelDown;
      property OnMouseWheelUp;
      property OnStartDock;
      {$endif}
   end;

implementation

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

   ReadOnly := True;
   WordWrap := False;

   ShowDisconnect := False;
end;

procedure TMFtpMessager.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 TMFtpMessager.SetStyle;
begin
   FStyle := NewStyle;

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

procedure TMFtpMessager.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 := 'COMMAND:>   ';
         end;
         msgError:
         begin
            C := clRed;
            P := 'ERROR:>     ';
         end;
         msgException:
         begin
            C := clRed;
            P := 'Exception:> ';
         end;
         msgReply:
         begin
            //C := clBlack;
            P := '            ';
         end;
         msgStatus:
         begin
            C := clBlue;
            P := 'STATUS:>    ';
         end;
      end;

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

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

         Lines.Add('            ' + Msg)
      end;
   end
   else
   begin
      case MsgType of
         msgCommand:
         begin
            C := clBlue;
         end;
         msgError:
         begin
            C := clRed;
         end;
         msgException:
         begin
            C := clRed;
         end;
         msgReply:
         begin
            C := clGreen;
         end;
         msgStatus:
         begin
            C := clPurple;
         end;
      end;

      SelStart := -1;
      SelAttributes.Color := C;
      Lines.Add(Msg);
   end;
end;

procedure TMFtpMessager.NewOnFtpInfo;
begin
   case info of
      ftpServerConnected:
      begin
         with FFtp do
         begin
            if (Server = '') and (addinfo = '') then
               AddMessage('Connected to specified server, waiting for welcome message'#13#10, msgStatus)
            else
            if (Server <> '') and (Server <> addinfo) then
            begin
               if addinfo <> '' then
                  AddMessage('Connected to ' + Server + '(ip: ' + addinfo + '), waiting for welcome message'#13#10, msgStatus)
               else
                  AddMessage('Connected to ' + Server + ', waiting for welcome message'#13#10, msgStatus);
            end
            else
            begin
               AddMessage('Connected to ' + addinfo + ', waiting for welcome message'#13#10, msgStatus);
            end;
         end;
         ShowDisconnect := True;
      end;
      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('Disconnected'#13#10, msgStatus);
            ShowDisconnect := False;
         end;
      end;
      ftpNothing: AddMessage(addinfo + #13#10, msgStatus);
      ftpLoggedIn: AddMessage('Login successful'#13#10, msgStatus);
   end;
end;

procedure TMFtpMessager.NewOnFtpError;
begin
   AddMessage(addinfo + #13#10, msgError);
end;

end.