怎样用D7的IDFTPServer做一个FTP服务器?(100分)

最好有原码。。。

控件的Demo里有一个

我找过的，没有这个。可步可以发给我一个！？
hhjj0131@sina.com

已发,请查收![]

话题1591274的标题是： 挑战Indy FTP服务器，关键问题均已解决，已贴出源码！！！ 下午5点，散分结贴，关注有分！！！ (300分)
分类：控件 - 使用 Xelloss (2003-01-21 8:42:00)
不知道高手们有没用Indy的
TIdFTPServer做过FTP服务器

小弟在制作中遇到以下问题：
1。如何为服务器配置域名，IP
2。如何配置用户，密码
3。如何设置用户根目录，如何设置权限
4。服务器端除了TIdFTPServer是否还要放置其他相关控件

望高手们指教，急啊。
另：一旦开发完成，所有源码发给UP的人，留下Mail吧。

Xelloss (2003-01-21 9:01:00)
大侠们帮帮忙吧，分不是问题

LiChaoHui (2003-01-21 9:07:00)
用ICS的Ftp服务器组件吧
域名需要申请

王公子 (2003-01-21 9:11:00)
要固定IP
用ＩＩＳ挺好弄的呀

Xelloss (2003-01-21 9:13:00)
是不是Indy的不好？
另外，我是在局域网用，不需要Internet域名
只要知道如何配置。

Xelloss (2003-01-21 9:16:00)
除了FTP服务，我还要处理别的事情
要不然我就用IIS或Serv_U了。

Xelloss (2003-01-21 9:35:00)
真的没人知道吗？

aqing79 (2003-01-22 11:13:00)
unit ftpMain;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs,inifiles, ComCtrls, StdCtrls, Psock, NMFtp;

type
TmainForm = class(TForm)
NMFTP1: TNMFTP;
Button1: TButton;
host: TEdit;
port: TEdit;
Label1: TLabel;
userid: TEdit;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
password: TEdit;
CheckBox1: TCheckBox;
ProServer: TEdit;
Label5: TLabel;
Label6: TLabel;
ProPort: TEdit;
Button2: TButton;
StatusBar1: TStatusBar;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure NMFTP1Status(Sender: TComponent; Status: String);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure Button2Click(Sender: TObject);
procedure NMFTP1UnSupportedFunction(Trans_Type: TCmdType);
procedure NMFTP1Connect(Sender: TObject);
private
{ Private declarations }
Phost:string;
pPort:integer;
Puserid:string;
Ppassword:string;
PProServer:string;
PProPort:integer;
public
{ Public declarations }
end;

var
mainForm: TmainForm;

implementation

uses ftpSend;

{$R *.dfm}

procedure TmainForm.FormCreate(Sender: TObject);
var
temp:string;
RasFile:TIniFile;
begin
temp:=ExtractFilePath( ParamStr(0))+'ft.ras';
rasfile:=TIniFile.Create(temp);
try
Phost:=RasFile.ReadString('Server','host','www.chinaren.com');
host.Text:=Phost;

pPort:=strtoint(RasFile.ReadString('Server','port','21'));
port.Text:=IntToStr(pPort);

Puserid:=RasFile.ReadString('Server','Userid','anonymous');
userid.Text:=Puserid;

Ppassword:=RasFile.ReadString('Server','Password','user@host.com');
password.Text:=Ppassword;

PProServer:=RasFile.ReadString('ProServer','ProServer','');
ProServer.Text:=PProServer;

pPort:=StrToInt(RasFile.ReadString('ProServer','ProPort','80'));
ProPort.Text:=IntToStr(PProPort);

finally
RasFile.Free;
end;
end;

procedure TmainForm.Button1Click(Sender: TObject);
begin
if NMFTP1.Connected then
exit;
If CheckBox1.Checked then
Begin
NMFTP1.Proxy := ProServer.Text;
NMFTP1.ProxyPort := StrToInt(ProServer.Text);
end;
NMFTP1.Host := host.Text;
NMFTP1.Port := StrToInt(port.Text);
NMFTP1.Timeout := 5000;
NMFTP1.UserID := userid.Text;
NMFTP1.Password := password.Text;
try
NMFTP1.Connect;

except
On E:Exception do
ShowMessage(E.message);
end;
end;

procedure TmainForm.NMFTP1Status(Sender: TComponent; Status: String);
begin
StatusBar1.SimpleText:=Status;
end;

procedure TmainForm.FormClose(Sender: TObject; var Action: TCloseAction);
var
rasfile:TIniFile;
temp:string;
begin
temp:=ExtractFilePath( ParamStr(0))+'ft.ras';
rasfile := TIniFile.Create(temp);
try
rasfile.WriteString('Server','host',host.Text);
Phost:=host.Text;

rasfile.WriteString('Server','Port',port.text);
pPort:=StrToInt(port.Text);

rasfile.WriteString('Server','userid',userid.text);
Puserid:=userid.Text;

rasfile.WriteString('Server','password',password.Text);
Ppassword:=password.Text;

rasfile.WriteString('ProServer','ProServer',ProServer.text);
PProServer:=ProServer.Text;

rasfile.WriteString('ProServer','Proport',ProPort.Text);
PProPort:=StrToInt(ProPort.Text);

finally
rasfile.Free;
end;

end;
procedure TmainForm.Button2Click(Sender: TObject);
begin
NMFTP1.Disconnect;
end;

procedure TmainForm.NMFTP1UnSupportedFunction(Trans_Type: TCmdType);
begin
Case Trans_Type of
cmdChangeDir: ShowMessage('ChangeDir unsupported');
cmdMakeDir: ShowMessage('MakeDir unsupported');
cmdDelete: ShowMessage('Delete unsupported');
cmdRemoveDir: ShowMessage('RemoveDir unsupported');
cmdList: ShowMessage('List unsupported');
cmdRename: ShowMessage('Rename unsupported');
cmdUpRestore: ShowMessage('UploadRestore unsupported');
cmdDownRestore: ShowMessage('DownloadRestore unsupported');
cmdDownload: ShowMessage('Download unsupported');
cmdUpload: ShowMessage('Upload unsupported');
cmdAppend: ShowMessage('UploadAppend unsupported');
cmdReInit: ShowMessage('ReInit unsupported');
cmdAllocate: ShowMessage('Allocate unsupported');
cmdNList: ShowMessage('NList unsupported');
cmdDoCommand: ShowMessage('DoCommand unsupported');
end;
end;

procedure TmainForm.NMFTP1Connect(Sender: TObject);
begin
sendform.ShowModal;
end;

end.
//不知行不行

Xelloss (2003-01-22 14:28:00)
to aqing79:
你的是NMFTP，是客户端程序。
我想要的是服务器程序，如：IIS，Serv_u。

不敢奢望得到所有源码
只需要一些指导，先行谢过。

Xelloss (2003-01-23 9:27:00)
源码：
unit ServiceMainU;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, SvcMgr, Dialogs,
IdBaseComponent, IdComponent, IdTCPServer, IdFTPServer, Registry, forms,
IdUserAccounts, IdThreadMgr, IdThreadMgrPool, IdThreadMgrDefault, IdFTPList;

type
TServMain = class(TService)
IdFTPServ: TIdFTPServer;
IdUserMan: TIdUserManager;
procedure ServiceAfterInstall(Sender: TService);
procedure ServiceAfterUninstall(Sender: TService);
procedure ServiceStart(Sender: TService; var Started: Boolean);
procedure ServiceStop(Sender: TService; var Stopped: Boolean);
procedure ServiceExecute(Sender: TService);
procedure IdFTPServAfterUserLogin(ASender: TIdFTPServerThread);
procedure IdFTPServException(AThread: TIdPeerThread;
AException: Exception);
procedure IdFTPServRetrieveFile(ASender: TIdFTPServerThread;
const AFileName: String; var VStream: TStream);
procedure IdFTPServChangeDirectory(ASender: TIdFTPServerThread;
var VDirectory: String);
procedure IdFTPServListDirectory(ASender: TIdFTPServerThread;
const APath: String; ADirectoryListing: TIdFTPListItems);
procedure IdFTPServBeforeCommandHandler(ASender: TIdTCPServer;
const AData: String; AThread: TIdPeerThread);
procedure IdFTPServGetCustomListFormat(ASender: TIdFTPServer;
AItem: TIdFTPListItem; var VText: String);
procedure IdFTPServMakeDirectory(ASender: TIdFTPServerThread;
var VDirectory: String);
procedure IdFTPServUserLogin(ASender: TIdFTPServerThread;
const AUsername, APassword: String; var AAuthenticated: Boolean);
procedure IdFTPServStoreFile(ASender: TIdFTPServerThread;
const AFileName: String; AAppend: Boolean; var VStream: TStream);
private
{ Private declarations }
public
function GetServiceController: TServiceController; override;
{ Public declarations }
end;

var
ServMain: TServMain;

const
csRegEventLog = 'SYSTEM/CurrentControlSet/Services/Eventlog/Application';
csServiceName = 'ServMain';

implementation

uses MainU;

{$R *.DFM}

procedure ServiceController(CtrlCode: DWord); stdcall;
begin
ServMain.Controller(CtrlCode);
end;

function TServMain.GetServiceController: TServiceController;
begin
Result := ServiceController;
end;

Procedure RegEventLog( aRegister : Boolean );
Var
reg : TRegistry;
Begin
reg := TRegistry.Create;
Try
reg.RootKey := HKEY_LOCAL_MACHINE;
If (reg.OpenKey(csRegEventLog, false)) Then
Begin
If (aRegister) Then
Begin
If (reg.OpenKey(csServiceName, true)) Then
Begin
reg.WriteString('EventMessageFile', ParamStr(0));
reg.WriteInteger('TypesSupported', EVENTLOG_ERROR_TYPE
OR EVENTLOG_WARNING_TYPE OR EVENTLOG_INFORMATION_TYPE);
End;
End
Else
reg.DeleteKey(csServiceName);
End;
Finally
reg.Free;
End;
End;

procedure TServMain.ServiceAfterInstall(Sender: TService);
begin
RegEventLog(true);
end;

procedure TServMain.ServiceAfterUninstall(Sender: TService);
begin
RegEventLog(false);
end;

procedure TServMain.ServiceStart(Sender: TService; var Started: Boolean);
begin
IdFTPServ.Active := true;//服务启动
Started := true;
end;

procedure TServMain.ServiceStop(Sender: TService; var Stopped: Boolean);
begin
IdFTPServ.Active := false;//服务停止
Stopped := true;
end;

procedure TServMain.ServiceExecute(Sender: TService);
begin
while not Terminated do//服务响应消息
begin
ServiceThread.ProcessRequests(False);
sleep(100);
end;
end;

procedure TServMain.IdFTPServAfterUserLogin(ASender: TIdFTPServerThread);
begin
end;

procedure TServMain.IdFTPServException(AThread: TIdPeerThread;
AException: Exception);
begin
//出错处理，以解决
end;

procedure TServMain.IdFTPServRetrieveFile(ASender: TIdFTPServerThread;
const AFileName: String; var VStream: TStream);
begin//文件下载，响应Get，以解决
VStream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyNone);
end;

procedure TServMain.IdFTPServChangeDirectory(ASender: TIdFTPServerThread;
var VDirectory: String);
begin//改变路径，以解决
if VDirectory[1] = '/' then
VDirectory := 'E:/ftproot' + VDirectory;
if pos(VDirectory, 'E:/ftproot/') <> 0 then
VDirectory := 'E:/ftproot';
end;

procedure TServMain.IdFTPServListDirectory(ASender: TIdFTPServerThread;
const APath: String; ADirectoryListing: TIdFTPListItems);
begin
end;

procedure TServMain.IdFTPServBeforeCommandHandler(ASender: TIdTCPServer;
const AData: String; AThread: TIdPeerThread);
begin

end;

procedure TServMain.IdFTPServGetCustomListFormat(ASender: TIdFTPServer;
AItem: TIdFTPListItem; var VText: String);
begin

end;

procedure TServMain.IdFTPServMakeDirectory(ASender: TIdFTPServerThread;
var VDirectory: String);
begin//创建新路经，以解决
VDirectory := StringReplace(VDirectory, '/', '/', [rfReplaceAll, rfIgnoreCase]);
ForceDirectories(VDirectory);
end;

procedure TServMain.IdFTPServUserLogin(ASender: TIdFTPServerThread;
const AUsername, APassword: String; var AAuthenticated: Boolean);
begin
AAuthenticated := true;//用户登录验证，已实现
end;

procedure TServMain.IdFTPServStoreFile(ASender: TIdFTPServerThread;
const AFileName: String; AAppend: Boolean; var VStream: TStream);
var//上传文件，终于解决
hd: integer;
begin
hd := filecreate(AFileName);
fileclose(hd);
VStream := TFileStream.Create(AFileName, fmOpenWrite or fmShareDenyNone);
end;

end;

end.

zhang_yz6666 (2003-01-23 10:35:00)
学习，帮你up
zcrj@vip.163.com

logingyw (2003-01-23 10:46:00)
关注！
：-）

vine (2003-01-23 10:53:00)
谢谢！

LiWD (2003-01-23 11:11:00)
谢谢! 有类似的客户端程序吗?
lwd_mail@163.net

Xelloss (2003-01-23 17:24:00)
多人接受答案了。

aqing79 (2003-01-24 21:40:00)
up

bamfk1023 (2003-06-24 21:55:00)
能不能也给我发一份源码
网页是的 Tservices 和 IdFtpServer的单元我都不知道从哪里来的
bamfk1023@163.com

hone (2003-07-04 17:07:00)
来晚了，能不能给我发源码，学习。谢谢
hone@2911.net

未来黑客 (2003-12-03 22:40:00)
这是什么原码？
我作了。
为什么登陆后不能列目录。

这的高人太少！！！！！！！！！！！！！！！！！
问谁谁也不说。
装了……………………………………………………



aqing79-60,LiChaoHui-50,LiWD-35,logingyw-35,vine-35,zhang_yz6666-35,王公子-50,的回答最终被接受。

INDY中也有例子

已收到，但我还是想问怎样设置Ftp的目录！？？？

这样的结果：
他就把当前盘作为ftp的目录，
但我只要一个目录就可以了，并且不一定是当前盘。
请给点主意！？

多人接受答案了。