代码拉取完成,页面将自动刷新
unit FtpServerFrm;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
LazUTF8, windirs, ExtCtrls, Menus, IdFtpServer, IdFTPListOutput, IdFtpList,
IdCustomTCPServer, IdContext, windows, registry, IdReply;
type
{ TFtpServerForm }
TFtpServerForm = class(TForm)
btnCloseFtp: TButton;
BtnOpenFtp: TButton;
BtnDirectory: TButton;
ChkAnonymous: TCheckBox;
EdtDirectory: TEdit;
EdtUser: TEdit;
EdtPass: TEdit;
EdtPort: TEdit;
IdFTPSvr: TIdFTPServer;
Images: TImageList;
Label1: TLabel;
Label3: TLabel;
Label4: TLabel;
MiRestore: TMenuItem;
MenuItem2: TMenuItem;
MiClose: TMenuItem;
moNotes: TMemo;
DirDialog: TSelectDirectoryDialog;
PanHeader: TPanel;
PopMenu: TPopupMenu;
SystrayIcon: TTrayIcon;
procedure btnCloseFtpClick(Sender: TObject);
procedure BtnDirectoryClick(Sender: TObject);
procedure BtnOpenFtpClick(Sender: TObject);
procedure ChkAnonymousClick(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormCloseQuery(Sender: TObject; var CanClose: boolean);
procedure FormCreate(Sender: TObject);
procedure IdFTPSvrChangeDirectory(ASender: TIdFTPServerContext; var VDirectory: string);
procedure IdFTPSvrDeleteFile(ASender: TIdFTPServerContext; const APathName: string);
procedure IdFTPSvrDisconnect(AContext: TIdContext);
procedure IdFTPSvrGetFileSize(ASender: TIdFTPServerContext; const AFilename: string; var VFileSize: Int64);
procedure IdFTPSvrListDirectory(ASender: TIdFTPServerContext; const APath: string; ADirectoryListing: TIdFTPListOutput; const ACmd: String; const ASwitches: String);
procedure IdFTPSvrMakeDirectory(ASender: TIdFTPServerContext; var VDirectory: string);
procedure IdFTPSvrRemoveDirectory(ASender: TIdFTPServerContext; var VDirectory: string);
procedure IdFTPSvrRenameFile(ASender: TIdFTPServerContext; const ARenameFromFile, ARenameToFile: string);
procedure IdFTPSvrRetrieveFile(ASender: TIdFTPServerContext; const AFileName: string; var VStream: TStream);
procedure IdFTPSvrStoreFile(ASender: TIdFTPServerContext; const AFileName: string; AAppend: Boolean; var VStream: TStream);
procedure IdFTPSvrUserLogin(ASender: TIdFTPServerContext; const AUsername, APassword: string; var AAuthenticated: Boolean);
procedure MiRestoreClick(Sender: TObject);
procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND;//此处先声明拦截过程
private
EnableClose : Boolean;
ScreenW, ScreenH : Integer;
Registry: TRegistry;
public
function ReplaceChars(APath: String): String;
function GetSizeOfFile(AFile : String) : Integer;
end;
var
FtpServerForm: TFtpServerForm;
implementation
{$R *.lfm}
{ TFtpServerForm }
procedure TFtpServerForm.FormCreate(Sender: TObject);
begin
EnableClose := False;
ScreenW := Screen.Width;
ScreenH := Screen.Height;
end;
procedure TFtpServerForm.IdFTPSvrChangeDirectory(ASender: TIdFTPServerContext; var VDirectory: string);
begin
ASender.CurrentDir := VDirectory;
//moNotes.Append('IdFTPSvrChangeDirectory-->VDirectory: ' + VDirectory);
end;
procedure TFtpServerForm.IdFTPSvrListDirectory(ASender: TIdFTPServerContext;
const APath: string; ADirectoryListing: TIdFTPListOutput; const ACmd: String;
const ASwitches: String);
var
LFTPItem : TIdFTPListItem;
Info : SysUtils.TSearchRec;
SRI : Integer;
Filter, UpperDir : string;
begin
ADirectoryListing.DirFormat := doWin32;
Filter := ReplaceChars(EdtDirectory.Text + APath + '\*.*');
SRI := FindFirst(Filter, faAnyFile - faHidden - faSysFile, Info);
While SRI = 0 do
begin
LFTPItem := ADirectoryListing.Add;
LFTPItem.FileName := Info.Name;
LFTPItem.Size := Info.Size;
LFTPItem.ModifiedDate := FileDateToDateTime(Info.Time);
if Info.Attr = faDirectory then
LFTPItem.ItemType := ditDirectory
else
LFTPItem.ItemType := ditFile;
SRI := FindNext(Info);
end;
SysUtils.FindClose(Info);
if not (ReplaceChars(EdtDirectory.Text + APath) = EdtDirectory.Text) then
begin
UpperDir := ReplaceChars(EdtDirectory.Text + APath + '\..');
SetCurrentDir(UpperDir);
end;
end;
procedure TFtpServerForm.IdFTPSvrMakeDirectory(ASender: TIdFTPServerContext; var VDirectory: string);
begin
if not ForceDirectories(ReplaceChars(EdtDirectory.Text + '\' + VDirectory)) then
begin
//Raise Exception.Create('Unable to create directory');
moNotes.Append(DateTimeToStr(Now) +#32 + 'Unable to create directory。');
end;
end;
procedure TFtpServerForm.IdFTPSvrRemoveDirectory(ASender: TIdFTPServerContext; var VDirectory: string);
var
LFile : String;
begin
LFile := ReplaceChars(EdtDirectory.Text + '\' + VDirectory + '\');
// You should delete the directory here.
DeleteDirectory(LFile, False);
end;
procedure TFtpServerForm.IdFTPSvrRenameFile(ASender: TIdFTPServerContext;
const ARenameFromFile, ARenameToFile: string);
var
OldName, NewName: string;
begin
OldName := ReplaceChars(EdtDirectory.Text + '\' + ARenameFromFile);
NewName := ReplaceChars(EdtDirectory.Text + '\' + ARenameToFile);
RenameFile(OldName, NewName);
end;
procedure TFtpServerForm.IdFTPSvrDeleteFile(ASender: TIdFTPServerContext; const APathName: string);
var
FileName: string;
begin
FileName := ReplaceChars(EdtDirectory.Text + '\' + APathname);
SysUtils.DeleteFile(FileName);
end;
procedure TFtpServerForm.IdFTPSvrDisconnect(AContext: TIdContext);
begin
moNotes.Append(DateTimeToStr(Now) +#32 + AContext.Binding.PeerIP + ' : 用户退出服务器。');
end;
procedure TFtpServerForm.IdFTPSvrRetrieveFile(ASender: TIdFTPServerContext; const AFileName: string; var VStream: TStream);
begin
VStream := TFileStream.Create(ReplaceChars(EdtDirectory.Text + '\' + AFilename), fmOpenRead);
end;
procedure TFtpServerForm.IdFTPSvrStoreFile(ASender: TIdFTPServerContext; const AFileName: string; AAppend: Boolean; var VStream: TStream);
begin
if not Aappend then
begin
VStream := TFileStream.Create(ReplaceChars(EdtDirectory.Text + '\' + AFilename), fmCreate)
end
else
VStream := TFileStream.Create(ReplaceChars(EdtDirectory.Text + '\' + AFilename), fmOpenWrite);
end;
procedure TFtpServerForm.IdFTPSvrUserLogin(ASender: TIdFTPServerContext; const AUsername, APassword: string; var AAuthenticated: Boolean);
begin
// We just set AAuthenticated to true so any username / password is accepted
// You should check them here - AUsername and APassword
if ChkAnonymous.Checked then
begin
AAuthenticated := True;
moNotes.Append(DateTimeToStr(Now) +#32 + ASender.Binding.PeerIP + ' : 匿名登录服务器成功。');
end else
if (AUsername=EdtUser.Text) and (APassword=EdtPass.Text) then
begin
AAuthenticated := True;
moNotes.Append(DateTimeToStr(Now) +#32 + ASender.Binding.PeerIP + ' : 用户登录服务器成功。');
end else
begin
AAuthenticated := False;
moNotes.Append(DateTimeToStr(Now) +#32 + ASender.Binding.PeerIP + ' : 尝试登录服务器失败。');
end;
end;
procedure TFtpServerForm.MiRestoreClick(Sender: TObject);
begin
WindowState := wsNormal;
Self.Show;
Self.Left := (ScreenW - Self.Width) div 2;
Self.Top := (ScreenH - Self.Height) div 2;
end;
function TFtpServerForm.ReplaceChars(APath: String): String;
var
s:string;
begin
s := StringReplace(APath, '/', '\', [rfReplaceAll]);
s := StringReplace(s, '\\\', '\', [rfReplaceAll]);
s := StringReplace(s, '\\', '\', [rfReplaceAll]);
Result := s;
end;
function TFtpServerForm.GetSizeOfFile(AFile: String): Integer;
var
FStream : TFileStream;
begin
try
FStream := TFileStream.Create(AFile, fmOpenRead);
try
Result := FStream.Size;
finally
FreeAndNil(FStream);
end;
except
Result := 0;
end;
end;
procedure TFtpServerForm.IdFTPSvrGetFileSize(ASender: TIdFTPServerContext; const AFilename: string; var VFileSize: Int64);
var
LFile : String;
begin
LFile := ReplaceChars( EdtDirectory.Text + AFilename );
try
if FileExists(LFile) then
VFileSize := GetSizeOfFile(LFile)
else
VFileSize := 0;
except
VFileSize := 0;
end;
end;
procedure TFtpServerForm.WMSysCommand(var Msg: TWMSysCommand);
begin
//ShowMessage(IntToStr(Msg.CmdType)); //61536
if (Msg.CmdType=SC_CLOSE) then
begin
WindowState := wsMinimized;
Self.Hide;
end else
inherited;
end;
procedure TFtpServerForm.btnCloseFtpClick(Sender: TObject);
begin
Registry.WriteString('Directory',EdtDirectory.Text);
Registry.WriteString('UserName',EdtUser.Text);
Registry.WriteString('PassWord',EdtPass.Text);
if ChkAnonymous.Checked then Registry.WriteInteger('Anonymous',1) else Registry.WriteInteger('Anonymous',0);
Registry.WriteInteger('DefaultPort', StrToIntDef(EdtPort.Text,21));
EnableClose := True;
Close;
end;
procedure TFtpServerForm.BtnDirectoryClick(Sender: TObject);
begin
if DirDialog.Execute then
begin
EdtDirectory.Text := DirDialog.FileName;
end;
end;
procedure TFtpServerForm.BtnOpenFtpClick(Sender: TObject);
begin
IdFTPSvr.Active := False;
IdFTPSvr.DefaultDataPort := StrToIntDef(EdtPort.Text,21);
IdFTPSvr.AllowAnonymousLogin := ChkAnonymous.Checked;
IdFTPSvr.Active := True;
//
moNotes.Append(DateTimeToStr(Now)+#32 +'FTP服务器已经开启。');
end;
procedure TFtpServerForm.ChkAnonymousClick(Sender: TObject);
begin
EdtUser.Enabled := not ChkAnonymous.Checked;
EdtPass.Enabled := not ChkAnonymous.Checked;
IdFTPSvr.AllowAnonymousLogin := ChkAnonymous.Checked;
end;
procedure TFtpServerForm.FormActivate(Sender: TObject);
begin
EdtDirectory.Text := GetWindowsSpecialDir(CSIDL_DESKTOPDIRECTORY, False);
//
Registry := TRegistry.Create;
Registry.RootKey := HKEY_CURRENT_USER;
Registry.OpenKey('Software', False);
if Registry.OpenKey('FtpServer', True) then
begin
if Registry.ValueExists('Directory') then
EdtDirectory.Text := Registry.ReadString('Directory')
else
Registry.WriteString('Directory',EdtDirectory.Text);
// --------
if Registry.ValueExists('UserName') then
EdtUser.Text := Registry.ReadString('UserName')
else
Registry.WriteString('UserName',EdtUser.Text);
// --------
if Registry.ValueExists('PassWord') then
EdtPass.Text := Registry.ReadString('PassWord')
else
Registry.WriteString('PassWord',EdtPass.Text);
// --------
if Registry.ValueExists('Anonymous') then
ChkAnonymous.Checked := (0<>Registry.ReadInteger('Anonymous'))
else
if ChkAnonymous.Checked then Registry.WriteInteger('Anonymous', 1) else Registry.WriteInteger('Anonymous', 0);
// --------
if Registry.ValueExists('DefaultPort') then
EdtPort.Text := IntToStr(Registry.ReadInteger('DefaultPort'))
else
Registry.WriteInteger('DefaultPort', StrToIntDef(EdtPort.Text,21));
end;
//
ChkAnonymousClick(Sender);
BtnOpenFtpClick(Sender);
Self.Hide;
WindowState := wsMinimized;
SystrayIcon.Show;
end;
procedure TFtpServerForm.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
IdFTPSvr.Active := False;
CloseAction := caFree;
end;
procedure TFtpServerForm.FormCloseQuery(Sender: TObject; var CanClose: boolean);
begin
CanClose := EnableClose;
end;
end.
此处可能存在不合适展示的内容,页面不予展示。您可通过相关编辑功能自查并修改。
如您确认内容无涉及 不当用语 / 纯广告导流 / 暴力 / 低俗色情 / 侵权 / 盗版 / 虚假 / 无价值内容或违法国家有关法律法规的内容,可点击提交进行申诉,我们将尽快为您处理。