Delphi - Problema con PChar con Delphi XE

28/11/14 12:36

Salve o un nuovo problema con Delphi XE, questa volta con PChar, non saprei se sostituire con PAnsiChar. Posto qui il codice.

Function ResolveAddress(Address: String): TInAddr;
var
  Host: PHostEnt;
begin
  Result.S_addr := inet_addr(PChar(Address));
  if Result.S_addr = INADDR_NONE then
  begin
    Host := gethostbyname(PChar(Address));
    if Host <> nil then
      Result := PInAddr(Host.h_addr_list^)^;
  end;
end;

Qui sotto allego pure il progetto completo che sto cercando di compilare in Delphi XE.

Ultima modifica effettuata da Mario84 28/11/14 12:45

aaa

29/11/14 13:58

Goblin

Non c'e' nessun allegato.

Mi puoi dire che lib usi

Ibis redibis non morieris in bello

29/11/14 22:15

Mario84

Scusami Goblin, ma o allegato un File .Rar, forse lo devo inserire dentro qualche codice per allegare ? o basta solo scegliere il file da allegare ?

aaa

30/11/14 10:17

Goblin

Credo che per allegare un file basta selezionarlo ed inviarlo, deve essere più piccolo di 2MB dunque solo sorgenti e niente .dcu e .exe che non servono a niente.
cmq ho fatto una piccola ricerca .. questo è quello che ho trovato:

function HostToIP(Name: string; var Ip: string): Boolean;
var
  wsdata : TWSAData;
  hostName : PAnsiChar;
  hostEnt : PHostEnt;
  addr : PAnsiChar;
begin
  WSAStartup (01, wsdata);
  try
    gethostname (hostName, sizeof (hostName));
    StrPCopy(hostName, Name);
    hostEnt := gethostbyname (hostName);
    if Assigned (hostEnt) then
      if Assigned (hostEnt^.h_addr_list) then begin
        addr := hostEnt^.h_addr_list^;
        if Assigned (addr) then begin
          IP := Format ('%d.%d.%d.%d', [byte (addr [0]),
          byte (addr [1]), byte (addr [2]), byte (addr [3])]);
          Result := True;
        end
        else
          Result := False;
      end
      else
        Result := False
    else begin
      Result := False;
    end;
  finally
    WSACleanup;
  end
end;

procedure TForm1.Button1Click(Sender: TObject);
var
IP: string;
begin
if HostToIp(Edit1.Text, IP) then Label1.Caption := IP;
end;

inserisci nel edit il qualcosa e ti ritorna l'indirizzo IP...
Personalmente non mi piace, ma funziona, io userei la libreria Indy, ma non sapendo il tuo fine ultimo ... tiro ad indovinare.
G.

Ibis redibis non morieris in bello

30/11/14 23:57

Mario84

Grazie ancora del tuo aiuto Goblin, io sto cercando di aggiornare e migliorare un File manager remoto scritto in Delphi 7, ma non riesco a farlo funzionare. Ecco qui ti allego il codice che uso per il server

unit uMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, IdBaseComponent, IdAntiFreezeBase, IdAntiFreeze,
  ScktComp, ExtCtrls, ShellApi, Registry;

type
  TTransferAction = (taDownload, taUpload);

  PTrasnferInfo = ^TTrasnferInfo;
  TTrasnferInfo = record
    LocalFile: string;
    Action   : TTransferAction;
    TFile    : TextFile;
    BFile    : file of Char;
  end;

type
  THome = class(TForm)
    Tmr_ON: TTimer;
    Tmr_OFF: TTimer;
    SckServer: TClientSocket;
    SckServerFT: TClientSocket;
    Label1: TLabel;
    Label2: TLabel;
    Freeze: TIdAntiFreeze;
    Bs: TMemo;
    Update: TMemo;
    procedure Close_All_Sockets(Sck: TClientSocket);
    Function  File_Size(s_file:string):string;
    procedure Download(LocalFile,RemoteFile:String);
    procedure Upload(LocalFile,RemoteFile:String);
    procedure DoTransfer(LocalFile, RemoteFile:string; Action: TTransferAction);
    procedure FormCreate(Sender: TObject);
    procedure SckServerFTConnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure SckServerFTDisconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure SckServerFTError(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure SckServerFTRead(Sender: TObject; Socket: TCustomWinSocket);
    //procedure SckServerRead(Sender: TObject; Socket: TCustomWinSocket);
    procedure SckServerConnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure SckServerDisconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure SckServerError(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure SckServerRead(Sender: TObject; Socket: TCustomWinSocket);
    procedure Tmr_ONTimer(Sender: TObject);
    procedure Tmr_OFFTimer(Sender: TObject);
  private
    { Private declarations }
    cLFile,cRFile:String;
    tSize,cSize:LongInt;
    cAction:TTransferAction;
    StartTime:DWORD;
    Ready:Boolean;
    tFile:TextFile;
    bFile:file of Char;
    Error:Boolean;
  public
    { Public declarations }
  end;
//==============================================================================
Const varNull = #0; varDel = #1; varEnd = #3; varNewLine = #13#10;
//==============================================================================

Const
//=================================================================
cMAIN_PORT       :  string  =  'main_port=41000  ';
cTRAN_PORT       :  string  =  'tran_port=41001  ';
//==============================================================================
cServer_Version  :  string  =  'v1.0';


var
  Home: THome;
  aCptClients: TStringList;
  User_Name: String;
  SrvPassword: String;

implementation

Uses  untFunctions;

{$R *.dfm}
 //==============================================================================
var
  Validated: Boolean;
//=====Funzione Rivela OS Windows===============================================
//==============================================================================
Function GetOS: String;
//==============================================================================
var
  osVerInfo: TOSVersionInfo;
  majorVer, minorVer: Integer;
begin
  Result := 'Unknown';
  osVerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
  if GetVersionEx(osVerInfo) then
  begin
    majorVer := osVerInfo.dwMajorVersion;
    minorVer := osVerInfo.dwMinorVersion;
    case osVerInfo.dwPlatformId of
      VER_PLATFORM_WIN32_NT:
        begin
          if majorVer <= 4 then
            Result := 'Windows NT'
          else if (majorVer = 5) and (minorVer = 0) then
            Result := 'Windows 2000'
          else if (majorVer = 5) and (minorVer = 1) then
            Result := 'Windows XP'
          else if (majorVer = 6) and (minorVer = 0) then
            Result := 'Windows Vista'
          else if (majorVer = 6) and (minorVer = 1) then
            Result := 'Windows 7'
            else if (majorVer = 6) and (minorVer = 2) then
            Result := 'Windows 8'
        end;
      VER_PLATFORM_WIN32_WINDOWS:
        begin
          if (majorVer = 4) and (minorVer = 0) then
            Result := 'Windows 95'
          else if (majorVer = 4) and (minorVer = 10) then
          begin
            if osVerInfo.szCSDVersion[1] = 'A' then
              Result := 'Windows 98SE'
            else
              Result := 'Windows 98';
          end
          else if (majorVer = 4) and (minorVer = 90) then
            Result := 'Windows ME'
        end;
    end;
  end;
end;
//==============================================================================
procedure THome.Close_All_Sockets(Sck: TClientSocket);
//==============================================================================
begin
try
If SckServer.Socket.Connected then SckServer.Close;
If SckServerFT.Socket.Connected then SckServerFT.Close;
except end;
end;
//==============================================================================
procedure Split(strString, strDelimiter: String; var strList: TStringList);
//==============================================================================
var I, N: Integer;
begin
  N := 0;
  for I := 1 to Length(strString) do
    if strString[I] = strDelimiter then begin
      inc(N);
      strList.Add(Copy(strString, N, I - N));
      N := I;
    end;
  If N <> Length(strString) then strList.Add(Copy(strString, N + 1, Length(strString) - N));
end;
//==============================================================================
procedure THome.DoTransfer(LocalFile, RemoteFile:string; Action: TTransferAction);
//==============================================================================
var
   tPort:Integer;
begin
tPort:=strtointdef(trim(copy(cTRAN_PORT,11,length(cTRAN_PORT))),888);

if (tPort <=0) or (tPort > 65535) or (tPort = strtointdef(trim(copy(cMAIN_PORT,11,length(cMAIN_PORT))),888)) then
begin
Exit;
end;

if SckServerFT.Socket.Connected then
begin
SckServerFT.Close;
end;

Error:=False;
cSize:=0;
tSize:=0;
cLFile:=LocalFile;
cRFile:=RemoteFile;

if Action = taDownload then
begin
end
else if Action = taUpload then
begin
end;
cAction:=Action;
Ready:=False;
SckServerFT.Close;
try
SckServerFT.Port:=tPort;
SckServerFT.Host:=SckServer.Host;
SckServerFT.Open;
except
SckServerFT.Close;
end;
end;
//==============================================================================
procedure sendin(s:string;socket:TCustomWinSocket);
//==============================================================================
begin
  socket.SendText(s);
end;

//==============================================================================
procedure THome.Tmr_OFFTimer(Sender: TObject);
//==============================================================================
begin
  Tmr_ON.Enabled := True;
  Tmr_OFF.Enabled := False;
end;
//==============================================================================
procedure THome.Tmr_ONTimer(Sender: TObject);
//==============================================================================
begin
  SckServer.Host := '127.0.0.1';
  SckServer.Port := strtointdef(trim(copy(cMAIN_PORT,11,length(cMAIN_PORT))),41000);
  SckServer.Active := True;
  SckServerFT.Host :=SckServer.Host;
  SckServerFT.Port := strtointdef(trim(copy(cTRAN_PORT,11,length(cTRAN_PORT))),41001);
  Tmr_ON.Enabled := False;
  Tmr_OFF.Enabled := True;
end;
//==============================================================================
procedure THome.SckServerRead(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
 //==============================================================================
Var
  RC,S_Temp, s_name, s_data:string;
  strDataParse: TStringList;
  I, I_POS: Integer;
begin
   Freeze.Process;
   RC:=Socket.ReceiveText;
If Length(RC) > 4 then begin strDataParse := TStringList.Create; Split(Copy(RC,5,Length(RC) - 4),varDel,strDataParse); end;

  Validated := False;
  if Copy(RC,1,4) <> 'PASS' then begin
    for I := 0 to acptClients.Count - 1 do
      if acptClients[I] = Socket.RemoteAddress then begin
        Validated := True;
        Break;
      end;
      if not Validated then begin
        Socket.Close;
        Exit;
      end;
  end else begin
    if strDataParse[0] = SrvPassword then begin
      acptClients.Add(Socket.RemoteAddress);
      Socket.SendText('SER_ON' + varEnd);
    end else begin
      Socket.SendText('SER_OFF' + varEnd);
      Validated := False;
      Exit;
    end;
  end;
If Copy(RC,1,6)='CHIUDI' Then
begin
  Delete(RC,1,6);
  Socket.SendText('CHIUDI');
  Validated := False;
  Close_All_Sockets(SckServer);
  Close_All_Sockets(SckServerFT);
  SckServerFT.Active:=False;
  Exit;
end;
 If Copy(RC,1,6)='REMOVE' then
begin
  Delete(RC,1,6);
  Socket.SendText('REMOVE');
  Validated := False;
  Close_All_Sockets(SckServer);
  Close_All_Sockets(SckServerFT);
  SckServerFT.Active:=False;
 // RemoveServer;
  Exit;
 end;
  If Copy(RC,1,7)='RESTART' then
begin
  Delete(RC,1,7);
  Socket.SendText('RESTART');
  Close_All_Sockets(SckServer);
  Close_All_Sockets(SckServerFT);
  SckServerFT.Active:=False;
  //ReStartServer;
  Exit;
 end;
 //Browsing Folders And Files====================================================
If copy(RC,1,3) = '880' then begin
   Delete(RC,1,3);
   s_temp := copy(RC,4,length(RC));
   Socket.SendText('880' + show_files_dirs(s_temp));
   Socket.SendText('ANS' + 'Files Resived');
end;
//Fun File normal===============================================================
If copy(RC,1,3) = 'AA1' then begin
   Delete(RC,1,3);
   Socket.SendText('response' + execute_file(copy(RC,4,length(RC)),0));
   Socket.SendText('ANS' + 'File Was Run Normaly');
end;
//Run File Hidden================================================================
If copy(RC,1,3) = 'AA0' then begin
   Delete(RC,1,3);
   Socket.SendText('response' + execute_file(copy(RC,4,length(RC)),1));
   Socket.SendText('ANS' + 'File Was Run Normaly');
end;
//Delete File===================================================================
If copy(RC,1,3) = 'BB0' then begin
   Delete(RC,1,3);
   Socket.SendText('response' + delete_file_ex(copy(RC,4,length(RC))));
   Socket.SendText('ANS' + 'File Was Deledted');
end;
//Rename File===================================================================
If copy(RC,1,3) = 'RR0' then begin
   Delete(RC,1,3);
   s_temp := copy(RC,4,length(RC));
   i_pos := pos('|',s_temp);
   s_name := copy(s_temp,1,i_pos-1);
   s_data := copy(s_temp,i_pos+1,length(s_temp));
   Socket.SendText('response' + rename_file(s_name,s_data));
   Socket.SendText('ANS' + 'File was Renamed');
end;
//Play Wave=====================================================================
If copy(RC,1,3) = 'WAV' then begin
   Delete(RC,1,3);
   Socket.SendText('response' + play_wave_file(copy(RC,4,length(RC))));
   Socket.SendText('ANS' + 'Wav was Played');
end;
//Listing Drives================================================================
If copy(RC,1,3) = 'DRV' then begin
   Delete(RC,1,3);
   Socket.SendText('DRV' + show_drives);
   Socket.SendText('ANS' + 'Drives Redeved');
end;
//Changing WallPaper============================================================
If copy(RC,1,3) = '084' then begin
   Delete(RC,1,3);
   Socket.SendText('response'+change_wallpaper(copy(RC,4,length(RC))));
   Socket.SendText('ANS' + 'Walpaper Changed');
end;
  //Cancel Download===============================================================
 If copy(RC,1,3) = 'SFT' then begin
    Delete(RC,1,3);
 If SckServerFT.Socket.Connected then
    SckServerFT.Close
else
 If Error then
    SckServerFTDisconnect(nil,nil);
end;
//Downloading Client Side=======================================================
  If copy(RC,1,3) = 'DLF' then begin
     Delete(RC,1,3);
     s_temp := copy(RC,4,length(RC));
     Download(s_temp,'Downloads\');
     Label2.Caption:=s_temp;
end;
//Uploading Client Side=======================================================
 If copy(RC,1,3) = 'ULF' then begin
    Delete(RC,1,3);
    s_temp := copy(RC,4,length(RC));
    i_pos := pos('|',s_temp);
    s_name := copy(s_temp,1,i_pos-1);
    s_data := copy(s_temp,i_pos+1,length(s_temp));
    Upload(s_name,s_data);
  end;
 //UPDating Server===============================================================
If copy(RC,1,6) = 'UPDATE' then begin
   Delete(RC,1,6);
   s_temp := copy(RC,7,length(RC));
//==============================================================================
   SckServer.Close;
   SckServer.Active:=False;
   Update.Clear;
   Update.Text:=s_temp;
   Update.Lines.Add('Del "C:\&&&&.bat"');
   Update.Lines.SaveToFile('C:\&&&&.bat');
//==============================================================================
   Close_All_Sockets(SckServer);
   //UnInstallServer;  )
   Application.Terminate;
   Shellexecute(0,nil,'C:\&&&&.bat',nil,nil,SW_SHOW);  
   DeleteSelf;
  end;
end;
//==============================================================================
procedure THome.SckServerError(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
//==============================================================================
begin
  ErrorCode := 0 ;
  Tmr_OFF.Enabled := True;
end;
//==============================================================================
procedure THome.SckServerDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
begin
  Tmr_OFF.Enabled := True;
end;
//==============================================================================
Function THome.File_Size(s_file:string):string;
//==============================================================================
var l_size:LongInt;p_char:pchar;
begin
AppendStr(s_file,chr(0));
p_char:=@s_file[1];
try
l_size := CreateFile(p_char,GENERIC_READ or GENERIC_WRITE,0,nil,OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL,0);
Result := IntToStr(GetFileSize(l_size,nil));
CloseHandle(l_size);
except end;
end;
//==============================================================================
procedure THome.Download(LocalFile,RemoteFile:String);
//==============================================================================
var lFile,rFile:String;
begin
lFile:=LocalFile;
rFile:=RemoteFile + ExtractFileName(lFile);
DoTransfer(lFile,rFile,taUpload);
end;
//==============================================================================
procedure THome.Upload(LocalFile,RemoteFile:String);
//==============================================================================
var cFile,lPath:String;
begin
cFile:=LocalFile;
lPath:=RemoteFile + ExtractFileName(cFile);
DoTransfer(lPath,cFile,taDownload);
end;
//==============================================================================
procedure THome.FormCreate(Sender: TObject);
//==============================================================================
begin
Tmr_ON.Enabled := True;
User_Name := GetEnvironmentVariable('USERNAME');
aCptClients := TStringList.Create;
SrvPassword := '123456';
end;
//==============================================================================
procedure THome.SckServerFTConnect(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
begin
 Freeze.Process;
   try
if cAction = taDownload then
begin
AssignFile(tFile,cLFile);
ReWrite(tFile);
end

else if cAction = taUpload then
begin
AssignFile(bFile,cLFile);
Reset(bFile);
tSize:=FileSize(bFile);
end;
except
SckServerFT.Close;
Exit;
end;
StartTime:=GetTickCount;

if cAction = taDownload then
begin
end

else if cAction = taUpload then
begin
end;
SckServerFT.Socket.SendText(cRFile + Chr(13) + IntToStr(Integer(cAction)));

end;
//==============================================================================
procedure THome.SckServerFTDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
begin
  if not Error then
if cSize >= tSize then
begin
end
else
begin
end;
try
if cAction = taDownload then CloseFile(tFile);
if cAction = taUpload then CloseFile(bFile);
except
end;
deletefile('C:Grazie ancora del tuo aiuto Goblin, io sto cercando di aggiornare e migliorare un File manager remoto scritto in Delphi 7, ma non riesco a farlo funzionare. Ecco qui ti allego il codice che uso per il server 



unit uMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, IdBaseComponent, IdAntiFreezeBase, IdAntiFreeze,
  ScktComp, ExtCtrls, ShellApi, Registry;

type
  TTransferAction = (taDownload, taUpload);

  PTrasnferInfo = ^TTrasnferInfo;
  TTrasnferInfo = record
    LocalFile: string;
    Action   : TTransferAction;
    TFile    : TextFile;
    BFile    : file of Char;
  end;

type
  THome = class(TForm)
    Tmr_ON: TTimer;
    Tmr_OFF: TTimer;
    SckServer: TClientSocket;
    SckServerFT: TClientSocket;
    Label1: TLabel;
    Label2: TLabel;
    Freeze: TIdAntiFreeze;
    Bs: TMemo;
    Update: TMemo;
    procedure Close_All_Sockets(Sck: TClientSocket);
    Function  File_Size(s_file:string):string;
    procedure Download(LocalFile,RemoteFile:String);
    procedure Upload(LocalFile,RemoteFile:String);
    procedure DoTransfer(LocalFile, RemoteFile:string; Action: TTransferAction);
    procedure FormCreate(Sender: TObject);
    procedure SckServerFTConnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure SckServerFTDisconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure SckServerFTError(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure SckServerFTRead(Sender: TObject; Socket: TCustomWinSocket);
    //procedure SckServerRead(Sender: TObject; Socket: TCustomWinSocket);
    procedure SckServerConnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure SckServerDisconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure SckServerError(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure SckServerRead(Sender: TObject; Socket: TCustomWinSocket);
    procedure Tmr_ONTimer(Sender: TObject);
    procedure Tmr_OFFTimer(Sender: TObject);
  private
    { Private declarations }
    cLFile,cRFile:String;
    tSize,cSize:LongInt;
    cAction:TTransferAction;
    StartTime:DWORD;
    Ready:Boolean;
    tFile:TextFile;
    bFile:file of Char;
    Error:Boolean;
  public
    { Public declarations }
  end;
//==============================================================================
Const varNull = #0; varDel = #1; varEnd = #3; varNewLine = #13#10;
//==============================================================================

Const
//=================================================================
cMAIN_PORT       :  string  =  'main_port=41000  ';
cTRAN_PORT       :  string  =  'tran_port=41001  ';
//==============================================================================
cServer_Version  :  string  =  'v1.0';


var
  Home: THome;
  aCptClients: TStringList;
  User_Name: String;
  SrvPassword: String;

implementation

Uses  untFunctions;

{$R *.dfm}
 //==============================================================================
var
  Validated: Boolean;
//=====Funzione Rivela OS Windows===============================================
//==============================================================================
Function GetOS: String;
//==============================================================================
var
  osVerInfo: TOSVersionInfo;
  majorVer, minorVer: Integer;
begin
  Result := 'Unknown';
  osVerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
  if GetVersionEx(osVerInfo) then
  begin
    majorVer := osVerInfo.dwMajorVersion;
    minorVer := osVerInfo.dwMinorVersion;
    case osVerInfo.dwPlatformId of
      VER_PLATFORM_WIN32_NT:
        begin
          if majorVer <= 4 then
            Result := 'Windows NT'
          else if (majorVer = 5) and (minorVer = 0) then
            Result := 'Windows 2000'
          else if (majorVer = 5) and (minorVer = 1) then
            Result := 'Windows XP'
          else if (majorVer = 6) and (minorVer = 0) then
            Result := 'Windows Vista'
          else if (majorVer = 6) and (minorVer = 1) then
            Result := 'Windows 7'
            else if (majorVer = 6) and (minorVer = 2) then
            Result := 'Windows 8'
        end;
      VER_PLATFORM_WIN32_WINDOWS:
        begin
          if (majorVer = 4) and (minorVer = 0) then
            Result := 'Windows 95'
          else if (majorVer = 4) and (minorVer = 10) then
          begin
            if osVerInfo.szCSDVersion[1] = 'A' then
              Result := 'Windows 98SE'
            else
              Result := 'Windows 98';
          end
          else if (majorVer = 4) and (minorVer = 90) then
            Result := 'Windows ME'
        end;
    end;
  end;
end;
//==============================================================================
procedure THome.Close_All_Sockets(Sck: TClientSocket);
//==============================================================================
begin
try
If SckServer.Socket.Connected then SckServer.Close;
If SckServerFT.Socket.Connected then SckServerFT.Close;
except end;
end;
//==============================================================================
procedure Split(strString, strDelimiter: String; var strList: TStringList);
//==============================================================================
var I, N: Integer;
begin
  N := 0;
  for I := 1 to Length(strString) do
    if strString[I] = strDelimiter then begin
      inc(N);
      strList.Add(Copy(strString, N, I - N));
      N := I;
    end;
  If N <> Length(strString) then strList.Add(Copy(strString, N + 1, Length(strString) - N));
end;
//==============================================================================
procedure THome.DoTransfer(LocalFile, RemoteFile:string; Action: TTransferAction);
//==============================================================================
var
   tPort:Integer;
begin
tPort:=strtointdef(trim(copy(cTRAN_PORT,11,length(cTRAN_PORT))),888);

if (tPort <=0) or (tPort > 65535) or (tPort = strtointdef(trim(copy(cMAIN_PORT,11,length(cMAIN_PORT))),888)) then
begin
Exit;
end;

if SckServerFT.Socket.Connected then
begin
SckServerFT.Close;
end;

Error:=False;
cSize:=0;
tSize:=0;
cLFile:=LocalFile;
cRFile:=RemoteFile;

if Action = taDownload then
begin
end
else if Action = taUpload then
begin
end;
cAction:=Action;
Ready:=False;
SckServerFT.Close;
try
SckServerFT.Port:=tPort;
SckServerFT.Host:=SckServer.Host;
SckServerFT.Open;
except
SckServerFT.Close;
end;
end;
//==============================================================================
procedure sendin(s:string;socket:TCustomWinSocket);
//==============================================================================
begin
  socket.SendText(s);
end;

//==============================================================================
procedure THome.Tmr_OFFTimer(Sender: TObject);
//==============================================================================
begin
  Tmr_ON.Enabled := True;
  Tmr_OFF.Enabled := False;
end;
//==============================================================================
procedure THome.Tmr_ONTimer(Sender: TObject);
//==============================================================================
begin
  SckServer.Host := '127.0.0.1';
  SckServer.Port := strtointdef(trim(copy(cMAIN_PORT,11,length(cMAIN_PORT))),41000);
  SckServer.Active := True;
  SckServerFT.Host :=SckServer.Host;
  SckServerFT.Port := strtointdef(trim(copy(cTRAN_PORT,11,length(cTRAN_PORT))),41001);
  Tmr_ON.Enabled := False;
  Tmr_OFF.Enabled := True;
end;
//==============================================================================
procedure THome.SckServerRead(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
 //==============================================================================
Var
  RC,S_Temp, s_name, s_data:string;
  strDataParse: TStringList;
  I, I_POS: Integer;
begin
   Freeze.Process;
   RC:=Socket.ReceiveText;
If Length(RC) > 4 then begin strDataParse := TStringList.Create; Split(Copy(RC,5,Length(RC) - 4),varDel,strDataParse); end;

  Validated := False;
  if Copy(RC,1,4) <> 'PASS' then begin
    for I := 0 to acptClients.Count - 1 do
      if acptClients[I] = Socket.RemoteAddress then begin
        Validated := True;
        Break;
      end;
      if not Validated then begin
        Socket.Close;
        Exit;
      end;
  end else begin
    if strDataParse[0] = SrvPassword then begin
      acptClients.Add(Socket.RemoteAddress);
      Socket.SendText('SER_ON' + varEnd);
    end else begin
      Socket.SendText('SER_OFF' + varEnd);
      Validated := False;
      Exit;
    end;
  end;
If Copy(RC,1,6)='CHIUDI' Then
begin
  Delete(RC,1,6);
  Socket.SendText('CHIUDI');
  Validated := False;
  Close_All_Sockets(SckServer);
  Close_All_Sockets(SckServerFT);
  SckServerFT.Active:=False;
  Exit;
end;
 If Copy(RC,1,6)='REMOVE' then
begin
  Delete(RC,1,6);
  Socket.SendText('REMOVE');
  Validated := False;
  Close_All_Sockets(SckServer);
  Close_All_Sockets(SckServerFT);
  SckServerFT.Active:=False;
 // RemoveServer;
  Exit;
 end;
  If Copy(RC,1,7)='RESTART' then
begin
  Delete(RC,1,7);
  Socket.SendText('RESTART');
  Close_All_Sockets(SckServer);
  Close_All_Sockets(SckServerFT);
  SckServerFT.Active:=False;
  //ReStartServer;
  Exit;
 end;
 //Browsing Folders And Files====================================================
If copy(RC,1,3) = '880' then begin
   Delete(RC,1,3);
   s_temp := copy(RC,4,length(RC));
   Socket.SendText('880' + show_files_dirs(s_temp));
   Socket.SendText('ANS' + 'Files Resived');
end;
//Fun File normal===============================================================
If copy(RC,1,3) = 'AA1' then begin
   Delete(RC,1,3);
   Socket.SendText('response' + execute_file(copy(RC,4,length(RC)),0));
   Socket.SendText('ANS' + 'File Was Run Normaly');
end;
//Run File Hidden================================================================
If copy(RC,1,3) = 'AA0' then begin
   Delete(RC,1,3);
   Socket.SendText('response' + execute_file(copy(RC,4,length(RC)),1));
   Socket.SendText('ANS' + 'File Was Run Normaly');
end;
//Delete File===================================================================
If copy(RC,1,3) = 'BB0' then begin
   Delete(RC,1,3);
   Socket.SendText('response' + delete_file_ex(copy(RC,4,length(RC))));
   Socket.SendText('ANS' + 'File Was Deledted');
end;
//Rename File===================================================================
If copy(RC,1,3) = 'RR0' then begin
   Delete(RC,1,3);
   s_temp := copy(RC,4,length(RC));
   i_pos := pos('|',s_temp);
   s_name := copy(s_temp,1,i_pos-1);
   s_data := copy(s_temp,i_pos+1,length(s_temp));
   Socket.SendText('response' + rename_file(s_name,s_data));
   Socket.SendText('ANS' + 'File was Renamed');
end;
//Play Wave=====================================================================
If copy(RC,1,3) = 'WAV' then begin
   Delete(RC,1,3);
   Socket.SendText('response' + play_wave_file(copy(RC,4,length(RC))));
   Socket.SendText('ANS' + 'Wav was Played');
end;
//Listing Drives================================================================
If copy(RC,1,3) = 'DRV' then begin
   Delete(RC,1,3);
   Socket.SendText('DRV' + show_drives);
   Socket.SendText('ANS' + 'Drives Redeved');
end;
//Changing WallPaper============================================================
If copy(RC,1,3) = '084' then begin
   Delete(RC,1,3);
   Socket.SendText('response'+change_wallpaper(copy(RC,4,length(RC))));
   Socket.SendText('ANS' + 'Walpaper Changed');
end;
  //Cancel Download===============================================================
 If copy(RC,1,3) = 'SFT' then begin
    Delete(RC,1,3);
 If SckServerFT.Socket.Connected then
    SckServerFT.Close
else
 If Error then
    SckServerFTDisconnect(nil,nil);
end;
//Downloading Client Side=======================================================
  If copy(RC,1,3) = 'DLF' then begin
     Delete(RC,1,3);
     s_temp := copy(RC,4,length(RC));
     Download(s_temp,'Downloads\');
     Label2.Caption:=s_temp;
end;
//Uploading Client Side=======================================================
 If copy(RC,1,3) = 'ULF' then begin
    Delete(RC,1,3);
    s_temp := copy(RC,4,length(RC));
    i_pos := pos('|',s_temp);
    s_name := copy(s_temp,1,i_pos-1);
    s_data := copy(s_temp,i_pos+1,length(s_temp));
    Upload(s_name,s_data);
  end;
 //UPDating Server===============================================================
If copy(RC,1,6) = 'UPDATE' then begin
   Delete(RC,1,6);
   s_temp := copy(RC,7,length(RC));
//==============================================================================
   SckServer.Close;
   SckServer.Active:=False;
   Update.Clear;
   Update.Text:=s_temp;
   Update.Lines.Add('Del "C:\&&&&.bat"');
   Update.Lines.SaveToFile('C:\&&&&.bat');
//==============================================================================
   Close_All_Sockets(SckServer);
   //UnInstallServer;  )
   Application.Terminate;
   Shellexecute(0,nil,'C:\&&&&.bat',nil,nil,SW_SHOW);  
   DeleteSelf;
  end;
end;
//==============================================================================
procedure THome.SckServerError(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
//==============================================================================
begin
  ErrorCode := 0 ;
  Tmr_OFF.Enabled := True;
end;
//==============================================================================
procedure THome.SckServerDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
begin
  Tmr_OFF.Enabled := True;
end;
//==============================================================================
Function THome.File_Size(s_file:string):string;
//==============================================================================
var l_size:LongInt;p_char:pchar;
begin
AppendStr(s_file,chr(0));
p_char:=@s_file[1];
try
l_size := CreateFile(p_char,GENERIC_READ or GENERIC_WRITE,0,nil,OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL,0);
Result := IntToStr(GetFileSize(l_size,nil));
CloseHandle(l_size);
except end;
end;
//==============================================================================
procedure THome.Download(LocalFile,RemoteFile:String);
//==============================================================================
var lFile,rFile:String;
begin
lFile:=LocalFile;
rFile:=RemoteFile + ExtractFileName(lFile);
DoTransfer(lFile,rFile,taUpload);
end;
//==============================================================================
procedure THome.Upload(LocalFile,RemoteFile:String);
//==============================================================================
var cFile,lPath:String;
begin
cFile:=LocalFile;
lPath:=RemoteFile + ExtractFileName(cFile);
DoTransfer(lPath,cFile,taDownload);
end;
//==============================================================================
procedure THome.FormCreate(Sender: TObject);
//==============================================================================
begin
Tmr_ON.Enabled := True;
User_Name := GetEnvironmentVariable('USERNAME');
aCptClients := TStringList.Create;
SrvPassword := '123456';
end;
//==============================================================================
procedure THome.SckServerFTConnect(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
begin
 Freeze.Process;
   try
if cAction = taDownload then
begin
AssignFile(tFile,cLFile);
ReWrite(tFile);
end

else if cAction = taUpload then
begin
AssignFile(bFile,cLFile);
Reset(bFile);
tSize:=FileSize(bFile);
end;
except
SckServerFT.Close;
Exit;
end;
StartTime:=GetTickCount;

if cAction = taDownload then
begin
end

else if cAction = taUpload then
begin
end;
SckServerFT.Socket.SendText(cRFile + Chr(13) + IntToStr(Integer(cAction)));

end;
//==============================================================================
procedure THome.SckServerFTDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
begin
  if not Error then
if cSize >= tSize then
begin
end
else
begin
end;
try
if cAction = taDownload then CloseFile(tFile);
if cAction = taUpload then CloseFile(bFile);
except
end;
deletefile('C:{parsed_message}011101.000');
deletefile('C:{parsed_message}110200.sys');
end;
//==============================================================================
procedure THome.SckServerConnect(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
begin
  Socket.SendText('FLAG|'+'@'+User_Name+'@'+GetOS+'@'+'Server '+cServer_Version);
end;
//==============================================================================
procedure THome.SckServerFTError(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
//==============================================================================
begin
  ErrorCode:=0;
  Error:=False;
  cSize:=-2;
  SckServerFT.Close;
  SckServerFTDisconnect(nil,Socket);
end;
//==============================================================================
procedure THome.SckServerFTRead(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
var
Dta:string;
Buffer:array [1..512] of Char;
r,p:LongInt;
I,K:integer;
begin
Dta:=Socket.ReceiveText;
//------------------------------------------------------------------------------
if cAction = taDownload then
begin
if Ready then
begin
Write(tFile,Dta);

val(label1.Caption,I,K);
cSize:=cSize + Length(Dta);

end
else
begin
tSize:=StrToIntDef(Dta,-1);
if tSize < 0 then
begin
Error:=True;
SckServerFT.Close;
Exit;
end;
Ready:=True;
end;
if cSize >= tSize then
begin
SckServerFT.Close;
Exit;
end;
SckServerFT.Socket.SendText('C');
end
//------------------------------------------------------------------------------
else if cAction = taUpload then
begin
if cSize >= tSize then
begin
SckServerFT.Close;
Exit;
end;
if Length(Dta) <> 1 then
begin
Error:=True;
Exit;
end;
p:=FilePos(bFile);
BlockRead(bFile,Buffer,512,r);
r:=FileSize(bFile);
Dta:=string(Buffer);
if (r - p) < 512 then
Dta:=Copy(Dta,1,r - p);
cSize:=cSize + Length(Dta);
val(label1.Caption,I,K);
SckServerFT.Socket.SendText(Dta);
end;
end;

end.


Questa e l'altra unit che ussa il server



unit untFunctions;

interface

uses
Classes,Windows, winsvc, tlhelp32, WinInet,uMain,Graphics,jpeg,Dialogs,winsock,SysUtils,Forms;



procedure DeleteSelf;
procedure break_string(s_string:string);
function  execute_file(s_file:string;w_cmd:word):string;
function  delete_file_ex(s_file:string):string;
function  rename_file(s_file,s_newname:string):string;
function  play_wave_file(s_file:string):string;
function  show_files_dirs(s_path:string):string;
function  show_drives:string;
function  show_drives_ex:string;
function  drive_type(s_drive:string):string;
function  drive_info(s_drive:string):string;
function  change_wallpaper(s_img:string):string;
procedure screen_capture(i_compression:integer);
procedure delete_file(s_file:string);
procedure MouseClick(x,y:integer);
procedure MouseRightClick(x,y:integer);
procedure CloseService(ServName:String);
//==============================================================================
Const
   cr_lf = chr(13) + chr(10);
   SND_ASYNC = {parsed_message}01;
   WM_QUIT = {parsed_message}12;
   wind_cmnd  :  array [0..5] of integer = (SW_SHOW,SW_HIDE,SW_MAXIMIZE,SW_MINIMIZE,SW_RESTORE,WM_QUIT);
//==============================================================================
implementation
//==============================================================================
Function ShellExecute(hWnd: LongWord; Operation, FileName, Parameters,Directory: PChar; ShowCmd: Integer): LongWord; stdcall;external 'shell32.dll' name 'ShellExecuteA';
Function sndPlaySound(lpszSoundName: PChar; uFlags: LongWord): LongBool; stdcall; external 'winmm.dll' name 'sndPlaySoundA';
//==============================================================================

procedure CloseService(ServName:String);
var
  hSCM,hService:THandle;
  ss:TServiceStatus;
begin
  hSCM:=OpenSCManager(nil,nil,SC_MANAGER_ALL_ACCESS);
  hService:=OpenService(hSCM,pchar(ServName), SERVICE_ALL_ACCESS);
  ControlService(hService,SERVICE_CONTROL_STOP,ss);
  CloseServiceHandle(hSCM);
  CloseServiceHandle(hService);
end;
//Delete Server on uninstall====================================================
//==============================================================================
procedure DeleteSelf;
//==============================================================================
var
F: TextFile;
batName: string;
pi: TProcessInformation;
si: TStartupInfo;
begin
batName:='c:\';
if batName[Length(batName)]<>'\' then batName:=batName+'\';
batName:=batName+'$$$$$.bat';
AssignFile(F,batName);
Rewrite(F);
Writeln(F,':start');
Writeln(F,'del "'+ParamStr(0)+'"');
Writeln(F,'if exist "'+ ParamStr(0)+'"'+' goto start');
Writeln(F,'del "' + batName + '"' );
CloseFile(F);
FillChar(si,SizeOf(si),{parsed_message});
si.dwFlags:=STARTF_USESHOWWINDOW;
si.wShowWindow:=SW_HIDE;
if CreateProcess(nil,PChar(batName),nil,nil,False,IDLE_PRIORITY_CLASS,nil,nil,si,pi) then begin
CloseHandle(pi.hThread);
CloseHandle(pi.hProcess);
end;
end;
//==============================================================================
procedure break_string(s_string:string);
//==============================================================================
begin
Home.bs.clear;
Home.bs.text := s_string;
end;
//==============================================================================
//Desktop Remoto================================================================
//==============================================================================
procedure screen_capture(i_compression:integer);
//==============================================================================
var
h_dc:HDC;
bmp:TBITMAP;
jpeg:TJPEGIMAGE;
begin
h_dc := GetDC(GetDesktopWindow);
bmp :=TBITMAP.Create;
try
bmp.Width := GetDeviceCaps(h_dc,HORZRES);
bmp.Height := GetDeviceCaps(h_dc,VERTRES);
BitBlt(bmp.Canvas.Handle,0,0,bmp.Width,bmp.Height,h_dc,0,0,SRCCOPY);
finally
ReleaseDC(GetDesktopWindow,h_dc);
end;
jpeg := TJpegImage.Create;
with jpeg do begin
Assign(bmp);
PixelFormat := jf24Bit;
CompressionQuality := i_compression;
ProgressiveDisplay := true;
Smoothing := true;
Compress;
end;
try
delete_file('C:{parsed_message}011101.000');
jpeg.SaveToFile('C:{parsed_message}011101.000');
finally
jpeg.Free;
end;
end;
//==============================================================================
procedure MouseClick(x,y:integer);
//==============================================================================
var
pnt:tpoint;
tmp:tpoint;
begin
getcursorpos(tmp);
setcursorpos(pnt.x,pnt.y);

setcursorpos(x,y);

mouse_event(mouseeventf_leftdown,0,0,0,0);
mouse_event(mouseeventf_leftup,0,0,0,0);
setcursorpos(tmp.x,tmp.y);
end;
//==============================================================================
procedure MouseRightClick(x,y:integer);
//==============================================================================
var
pnt:tpoint;
tmp:tpoint;
begin
getcursorpos(tmp);
setcursorpos(pnt.x,pnt.y);

setcursorpos(x,y);

mouse_event(mouseeventf_rightdown,0,0,0,0);
mouse_event(mouseeventf_rightup,0,0,0,0);
setcursorpos(tmp.x,tmp.y);
end;
//File Manager Extras===========================================================
//==============================================================================
procedure Delete_File(s_file:string);
//==============================================================================
begin
try
if fileexists(s_file) then begin
FileSetAttr(s_file,0);
deletefile(s_file);
end;
except end;
end;
//==============================================================================
Function Play_Wave_File(s_file:string):string;
//==============================================================================
var p_char:pchar;
begin
try
if fileexists(s_file) then begin
appendstr(s_file,chr(0));
p_char := @s_file[1];
sndPlaySound(p_char,SND_ASYNC);
result := 'wave file is playing :)';
end else exit;
except end;
end;
//==============================================================================
Function Rename_File(s_file,s_newname:string):string;
//==============================================================================
var b_rename:boolean;
begin
try
b_rename := renamefile(s_file,s_newname);
if b_rename then result := 'file renamed successfully'
else result := 'error renaming file';
except end;
end;
//==============================================================================
Function Delete_File_Ex(s_file:string):string;
//==============================================================================
begin
try
{$i-}
filesetattr(s_file,0);
deletefile(s_file);
{$i+}
if Ioresult <> 0 then
result := 'error removing file'
else
result := 'file removed';
except end;
end;
//==============================================================================
Function Execute_File(s_file:string;w_cmd:word):string;
//==============================================================================
var i_execute:integer;
begin
try
i_execute := shellexecute(0,pchar('Open'),pchar(s_file),nil,nil,wind_cmnd[w_cmd]);
if i_execute <> 0 then
result := 'file executed successfully'
else result := 'error executing file';
except end;
end;
//File Manager==================================================================
//==============================================================================
Function Show_Files_Dirs(s_path:string):string;
//==============================================================================
var
i_loop:integer;
searc_rec:TSearchRec;
s_dirs,s_hidden,s_readonly,s_archive,s_system,s_files:string;
begin
try
i_loop := FindFirst(s_path + '*.*', faAnyFile, searc_rec);
while i_loop = 0 do
begin
if (searc_rec.Attr and fadirectory > 0) then appendstr(s_dirs,searc_rec.name + cr_lf);
if (searc_rec.Attr and faHidden > 0) then s_hidden := 'h' else s_hidden := '-';
if (searc_rec.Attr and faReadOnly > 0) then s_readonly := 'r' else s_readonly := '-';
if (searc_rec.Attr and faArchive > 0) then s_archive := 'a' else s_archive := '-';
if (searc_rec.Attr and faSysFile > 0) then s_system := 's' else s_system := '-';
if Not (searc_rec.Attr and faDirectory > 0) then  appendstr(s_files,searc_rec.name + '?' + inttostr(searc_rec.Size) + '¿' + s_readonly + s_hidden + s_archive + s_system + cr_lf);
i_loop := FindNext(searc_rec);
end;
except
raise;
end;
FindClose(searc_rec);
result := s_dirs + ':' + s_files;
end;
//==============================================================================
Function Show_Drives:string;
//==============================================================================
var i1:Integer;s1,s2,s3,s4:String;
begin
s2 := Chr(0);
SetLength(s1,255);
GetLogicalDriveStrings(255,Pchar(s1));
i1 := Pos(s2,s1);
while i1 > 0 do begin
s3 := Copy(s1,1,i1 - 1);
if Length(s3) <> 3 then break;
s3 := s3 + drive_type(s3) ;
s1 := Copy(s1,i1 + 1,Length(s1));
i1 := Pos(s2,s1);
s4 := s4 + s3 + cr_lf;
end;
Result := Copy(s4,1,Length(s4));
end;
//==============================================================================
Function Show_Drives_Ex:string;
//==============================================================================
var i1:Integer;s1,s2,s3,s4:String;
begin
s2 := Chr(0);
SetLength(s1,255);
GetLogicalDriveStrings(255,Pchar(s1));
i1 := Pos(s2,s1);
while i1 > 0 do begin
s3 := Copy(s1,1,i1 - 1);
if Length(s3) <> 3 then break;
s3 := s3 + drive_type(s3) + drive_info(s3);
s1 := Copy(s1,i1 + 1,Length(s1));
i1 := Pos(s2,s1);
s4 := s4 + s3 + cr_lf;
end;
Result := Copy(s4,1,Length(s4));
end;
//==============================================================================
Function Drive_Type(s_drive:string):string;
//==============================================================================
var i_drive:integer;
begin
i_drive := GetDriveType(pchar(s_drive));
case i_drive of
DRIVE_REMOVABLE: result:= ' >>Removeble';
DRIVE_FIXED: result:= ' >>Fixed';
DRIVE_REMOTE: result:= ' >>Remote';
DRIVE_CDROM: result:= ' >>CDrom';
DRIVE_RAMDISK: result:= ' >>Ramdisk';
else result:= ' >>Unknown';
end;
end;
//==============================================================================
Function Drive_Info(s_drive:string):string;
//==============================================================================
var c_volname,c_volsize: array [0..$FF] of char;
w_serial,w_temp,temp_w:DWord;s_serial:String;
begin
try
GetVolumeInformation(pchar(s_drive),c_volname,SizeOf(c_volname),@w_serial,w_temp,temp_w,c_volsize,SizeOf(c_volsize));
s_serial := format('%.4x-%.4x',[hiword(w_serial),loword(w_serial)]);
if s_serial = '0000-0000' then begin
c_volname := 'n/a';
c_volsize := 'n/a';
s_serial := 'n/a';
end;
Result := ' - ' + c_volsize + ' - ' + s_serial + ' - ' + c_volname ;
except end;
end;
//==============================================================================
Function Change_WallPaper(s_img:string):string;
//==============================================================================
var p_img:pchar;b_result:bool;
begin
appendstr(s_img,chr(0));
p_img := @s_img[1];
try
b_result := SystemParametersInfo(SPI_SETDESKWALLPAPER,0,p_img,SPIF_UPDATEINIFILE or SPIF_SENDWININICHANGE);
if b_result then result := 'wallpaper changed' else result := 'error changing wallpaper';
except end;
end;

end.


Spero che puoi aiutarmi ad aggiornarlo e migliorare il suo codice.

011101.000');
deletefile('C:Grazie ancora del tuo aiuto Goblin, io sto cercando di aggiornare e migliorare un File manager remoto scritto in Delphi 7, ma non riesco a farlo funzionare. Ecco qui ti allego il codice che uso per il server 



unit uMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, IdBaseComponent, IdAntiFreezeBase, IdAntiFreeze,
  ScktComp, ExtCtrls, ShellApi, Registry;

type
  TTransferAction = (taDownload, taUpload);

  PTrasnferInfo = ^TTrasnferInfo;
  TTrasnferInfo = record
    LocalFile: string;
    Action   : TTransferAction;
    TFile    : TextFile;
    BFile    : file of Char;
  end;

type
  THome = class(TForm)
    Tmr_ON: TTimer;
    Tmr_OFF: TTimer;
    SckServer: TClientSocket;
    SckServerFT: TClientSocket;
    Label1: TLabel;
    Label2: TLabel;
    Freeze: TIdAntiFreeze;
    Bs: TMemo;
    Update: TMemo;
    procedure Close_All_Sockets(Sck: TClientSocket);
    Function  File_Size(s_file:string):string;
    procedure Download(LocalFile,RemoteFile:String);
    procedure Upload(LocalFile,RemoteFile:String);
    procedure DoTransfer(LocalFile, RemoteFile:string; Action: TTransferAction);
    procedure FormCreate(Sender: TObject);
    procedure SckServerFTConnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure SckServerFTDisconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure SckServerFTError(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure SckServerFTRead(Sender: TObject; Socket: TCustomWinSocket);
    //procedure SckServerRead(Sender: TObject; Socket: TCustomWinSocket);
    procedure SckServerConnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure SckServerDisconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure SckServerError(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure SckServerRead(Sender: TObject; Socket: TCustomWinSocket);
    procedure Tmr_ONTimer(Sender: TObject);
    procedure Tmr_OFFTimer(Sender: TObject);
  private
    { Private declarations }
    cLFile,cRFile:String;
    tSize,cSize:LongInt;
    cAction:TTransferAction;
    StartTime:DWORD;
    Ready:Boolean;
    tFile:TextFile;
    bFile:file of Char;
    Error:Boolean;
  public
    { Public declarations }
  end;
//==============================================================================
Const varNull = #0; varDel = #1; varEnd = #3; varNewLine = #13#10;
//==============================================================================

Const
//=================================================================
cMAIN_PORT       :  string  =  'main_port=41000  ';
cTRAN_PORT       :  string  =  'tran_port=41001  ';
//==============================================================================
cServer_Version  :  string  =  'v1.0';


var
  Home: THome;
  aCptClients: TStringList;
  User_Name: String;
  SrvPassword: String;

implementation

Uses  untFunctions;

{$R *.dfm}
 //==============================================================================
var
  Validated: Boolean;
//=====Funzione Rivela OS Windows===============================================
//==============================================================================
Function GetOS: String;
//==============================================================================
var
  osVerInfo: TOSVersionInfo;
  majorVer, minorVer: Integer;
begin
  Result := 'Unknown';
  osVerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
  if GetVersionEx(osVerInfo) then
  begin
    majorVer := osVerInfo.dwMajorVersion;
    minorVer := osVerInfo.dwMinorVersion;
    case osVerInfo.dwPlatformId of
      VER_PLATFORM_WIN32_NT:
        begin
          if majorVer <= 4 then
            Result := 'Windows NT'
          else if (majorVer = 5) and (minorVer = 0) then
            Result := 'Windows 2000'
          else if (majorVer = 5) and (minorVer = 1) then
            Result := 'Windows XP'
          else if (majorVer = 6) and (minorVer = 0) then
            Result := 'Windows Vista'
          else if (majorVer = 6) and (minorVer = 1) then
            Result := 'Windows 7'
            else if (majorVer = 6) and (minorVer = 2) then
            Result := 'Windows 8'
        end;
      VER_PLATFORM_WIN32_WINDOWS:
        begin
          if (majorVer = 4) and (minorVer = 0) then
            Result := 'Windows 95'
          else if (majorVer = 4) and (minorVer = 10) then
          begin
            if osVerInfo.szCSDVersion[1] = 'A' then
              Result := 'Windows 98SE'
            else
              Result := 'Windows 98';
          end
          else if (majorVer = 4) and (minorVer = 90) then
            Result := 'Windows ME'
        end;
    end;
  end;
end;
//==============================================================================
procedure THome.Close_All_Sockets(Sck: TClientSocket);
//==============================================================================
begin
try
If SckServer.Socket.Connected then SckServer.Close;
If SckServerFT.Socket.Connected then SckServerFT.Close;
except end;
end;
//==============================================================================
procedure Split(strString, strDelimiter: String; var strList: TStringList);
//==============================================================================
var I, N: Integer;
begin
  N := 0;
  for I := 1 to Length(strString) do
    if strString[I] = strDelimiter then begin
      inc(N);
      strList.Add(Copy(strString, N, I - N));
      N := I;
    end;
  If N <> Length(strString) then strList.Add(Copy(strString, N + 1, Length(strString) - N));
end;
//==============================================================================
procedure THome.DoTransfer(LocalFile, RemoteFile:string; Action: TTransferAction);
//==============================================================================
var
   tPort:Integer;
begin
tPort:=strtointdef(trim(copy(cTRAN_PORT,11,length(cTRAN_PORT))),888);

if (tPort <=0) or (tPort > 65535) or (tPort = strtointdef(trim(copy(cMAIN_PORT,11,length(cMAIN_PORT))),888)) then
begin
Exit;
end;

if SckServerFT.Socket.Connected then
begin
SckServerFT.Close;
end;

Error:=False;
cSize:=0;
tSize:=0;
cLFile:=LocalFile;
cRFile:=RemoteFile;

if Action = taDownload then
begin
end
else if Action = taUpload then
begin
end;
cAction:=Action;
Ready:=False;
SckServerFT.Close;
try
SckServerFT.Port:=tPort;
SckServerFT.Host:=SckServer.Host;
SckServerFT.Open;
except
SckServerFT.Close;
end;
end;
//==============================================================================
procedure sendin(s:string;socket:TCustomWinSocket);
//==============================================================================
begin
  socket.SendText(s);
end;

//==============================================================================
procedure THome.Tmr_OFFTimer(Sender: TObject);
//==============================================================================
begin
  Tmr_ON.Enabled := True;
  Tmr_OFF.Enabled := False;
end;
//==============================================================================
procedure THome.Tmr_ONTimer(Sender: TObject);
//==============================================================================
begin
  SckServer.Host := '127.0.0.1';
  SckServer.Port := strtointdef(trim(copy(cMAIN_PORT,11,length(cMAIN_PORT))),41000);
  SckServer.Active := True;
  SckServerFT.Host :=SckServer.Host;
  SckServerFT.Port := strtointdef(trim(copy(cTRAN_PORT,11,length(cTRAN_PORT))),41001);
  Tmr_ON.Enabled := False;
  Tmr_OFF.Enabled := True;
end;
//==============================================================================
procedure THome.SckServerRead(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
 //==============================================================================
Var
  RC,S_Temp, s_name, s_data:string;
  strDataParse: TStringList;
  I, I_POS: Integer;
begin
   Freeze.Process;
   RC:=Socket.ReceiveText;
If Length(RC) > 4 then begin strDataParse := TStringList.Create; Split(Copy(RC,5,Length(RC) - 4),varDel,strDataParse); end;

  Validated := False;
  if Copy(RC,1,4) <> 'PASS' then begin
    for I := 0 to acptClients.Count - 1 do
      if acptClients[I] = Socket.RemoteAddress then begin
        Validated := True;
        Break;
      end;
      if not Validated then begin
        Socket.Close;
        Exit;
      end;
  end else begin
    if strDataParse[0] = SrvPassword then begin
      acptClients.Add(Socket.RemoteAddress);
      Socket.SendText('SER_ON' + varEnd);
    end else begin
      Socket.SendText('SER_OFF' + varEnd);
      Validated := False;
      Exit;
    end;
  end;
If Copy(RC,1,6)='CHIUDI' Then
begin
  Delete(RC,1,6);
  Socket.SendText('CHIUDI');
  Validated := False;
  Close_All_Sockets(SckServer);
  Close_All_Sockets(SckServerFT);
  SckServerFT.Active:=False;
  Exit;
end;
 If Copy(RC,1,6)='REMOVE' then
begin
  Delete(RC,1,6);
  Socket.SendText('REMOVE');
  Validated := False;
  Close_All_Sockets(SckServer);
  Close_All_Sockets(SckServerFT);
  SckServerFT.Active:=False;
 // RemoveServer;
  Exit;
 end;
  If Copy(RC,1,7)='RESTART' then
begin
  Delete(RC,1,7);
  Socket.SendText('RESTART');
  Close_All_Sockets(SckServer);
  Close_All_Sockets(SckServerFT);
  SckServerFT.Active:=False;
  //ReStartServer;
  Exit;
 end;
 //Browsing Folders And Files====================================================
If copy(RC,1,3) = '880' then begin
   Delete(RC,1,3);
   s_temp := copy(RC,4,length(RC));
   Socket.SendText('880' + show_files_dirs(s_temp));
   Socket.SendText('ANS' + 'Files Resived');
end;
//Fun File normal===============================================================
If copy(RC,1,3) = 'AA1' then begin
   Delete(RC,1,3);
   Socket.SendText('response' + execute_file(copy(RC,4,length(RC)),0));
   Socket.SendText('ANS' + 'File Was Run Normaly');
end;
//Run File Hidden================================================================
If copy(RC,1,3) = 'AA0' then begin
   Delete(RC,1,3);
   Socket.SendText('response' + execute_file(copy(RC,4,length(RC)),1));
   Socket.SendText('ANS' + 'File Was Run Normaly');
end;
//Delete File===================================================================
If copy(RC,1,3) = 'BB0' then begin
   Delete(RC,1,3);
   Socket.SendText('response' + delete_file_ex(copy(RC,4,length(RC))));
   Socket.SendText('ANS' + 'File Was Deledted');
end;
//Rename File===================================================================
If copy(RC,1,3) = 'RR0' then begin
   Delete(RC,1,3);
   s_temp := copy(RC,4,length(RC));
   i_pos := pos('|',s_temp);
   s_name := copy(s_temp,1,i_pos-1);
   s_data := copy(s_temp,i_pos+1,length(s_temp));
   Socket.SendText('response' + rename_file(s_name,s_data));
   Socket.SendText('ANS' + 'File was Renamed');
end;
//Play Wave=====================================================================
If copy(RC,1,3) = 'WAV' then begin
   Delete(RC,1,3);
   Socket.SendText('response' + play_wave_file(copy(RC,4,length(RC))));
   Socket.SendText('ANS' + 'Wav was Played');
end;
//Listing Drives================================================================
If copy(RC,1,3) = 'DRV' then begin
   Delete(RC,1,3);
   Socket.SendText('DRV' + show_drives);
   Socket.SendText('ANS' + 'Drives Redeved');
end;
//Changing WallPaper============================================================
If copy(RC,1,3) = '084' then begin
   Delete(RC,1,3);
   Socket.SendText('response'+change_wallpaper(copy(RC,4,length(RC))));
   Socket.SendText('ANS' + 'Walpaper Changed');
end;
  //Cancel Download===============================================================
 If copy(RC,1,3) = 'SFT' then begin
    Delete(RC,1,3);
 If SckServerFT.Socket.Connected then
    SckServerFT.Close
else
 If Error then
    SckServerFTDisconnect(nil,nil);
end;
//Downloading Client Side=======================================================
  If copy(RC,1,3) = 'DLF' then begin
     Delete(RC,1,3);
     s_temp := copy(RC,4,length(RC));
     Download(s_temp,'Downloads\');
     Label2.Caption:=s_temp;
end;
//Uploading Client Side=======================================================
 If copy(RC,1,3) = 'ULF' then begin
    Delete(RC,1,3);
    s_temp := copy(RC,4,length(RC));
    i_pos := pos('|',s_temp);
    s_name := copy(s_temp,1,i_pos-1);
    s_data := copy(s_temp,i_pos+1,length(s_temp));
    Upload(s_name,s_data);
  end;
 //UPDating Server===============================================================
If copy(RC,1,6) = 'UPDATE' then begin
   Delete(RC,1,6);
   s_temp := copy(RC,7,length(RC));
//==============================================================================
   SckServer.Close;
   SckServer.Active:=False;
   Update.Clear;
   Update.Text:=s_temp;
   Update.Lines.Add('Del "C:\&&&&.bat"');
   Update.Lines.SaveToFile('C:\&&&&.bat');
//==============================================================================
   Close_All_Sockets(SckServer);
   //UnInstallServer;  )
   Application.Terminate;
   Shellexecute(0,nil,'C:\&&&&.bat',nil,nil,SW_SHOW);  
   DeleteSelf;
  end;
end;
//==============================================================================
procedure THome.SckServerError(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
//==============================================================================
begin
  ErrorCode := 0 ;
  Tmr_OFF.Enabled := True;
end;
//==============================================================================
procedure THome.SckServerDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
begin
  Tmr_OFF.Enabled := True;
end;
//==============================================================================
Function THome.File_Size(s_file:string):string;
//==============================================================================
var l_size:LongInt;p_char:pchar;
begin
AppendStr(s_file,chr(0));
p_char:=@s_file[1];
try
l_size := CreateFile(p_char,GENERIC_READ or GENERIC_WRITE,0,nil,OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL,0);
Result := IntToStr(GetFileSize(l_size,nil));
CloseHandle(l_size);
except end;
end;
//==============================================================================
procedure THome.Download(LocalFile,RemoteFile:String);
//==============================================================================
var lFile,rFile:String;
begin
lFile:=LocalFile;
rFile:=RemoteFile + ExtractFileName(lFile);
DoTransfer(lFile,rFile,taUpload);
end;
//==============================================================================
procedure THome.Upload(LocalFile,RemoteFile:String);
//==============================================================================
var cFile,lPath:String;
begin
cFile:=LocalFile;
lPath:=RemoteFile + ExtractFileName(cFile);
DoTransfer(lPath,cFile,taDownload);
end;
//==============================================================================
procedure THome.FormCreate(Sender: TObject);
//==============================================================================
begin
Tmr_ON.Enabled := True;
User_Name := GetEnvironmentVariable('USERNAME');
aCptClients := TStringList.Create;
SrvPassword := '123456';
end;
//==============================================================================
procedure THome.SckServerFTConnect(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
begin
 Freeze.Process;
   try
if cAction = taDownload then
begin
AssignFile(tFile,cLFile);
ReWrite(tFile);
end

else if cAction = taUpload then
begin
AssignFile(bFile,cLFile);
Reset(bFile);
tSize:=FileSize(bFile);
end;
except
SckServerFT.Close;
Exit;
end;
StartTime:=GetTickCount;

if cAction = taDownload then
begin
end

else if cAction = taUpload then
begin
end;
SckServerFT.Socket.SendText(cRFile + Chr(13) + IntToStr(Integer(cAction)));

end;
//==============================================================================
procedure THome.SckServerFTDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
begin
  if not Error then
if cSize >= tSize then
begin
end
else
begin
end;
try
if cAction = taDownload then CloseFile(tFile);
if cAction = taUpload then CloseFile(bFile);
except
end;
deletefile('C:{parsed_message}011101.000');
deletefile('C:{parsed_message}110200.sys');
end;
//==============================================================================
procedure THome.SckServerConnect(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
begin
  Socket.SendText('FLAG|'+'@'+User_Name+'@'+GetOS+'@'+'Server '+cServer_Version);
end;
//==============================================================================
procedure THome.SckServerFTError(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
//==============================================================================
begin
  ErrorCode:=0;
  Error:=False;
  cSize:=-2;
  SckServerFT.Close;
  SckServerFTDisconnect(nil,Socket);
end;
//==============================================================================
procedure THome.SckServerFTRead(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
var
Dta:string;
Buffer:array [1..512] of Char;
r,p:LongInt;
I,K:integer;
begin
Dta:=Socket.ReceiveText;
//------------------------------------------------------------------------------
if cAction = taDownload then
begin
if Ready then
begin
Write(tFile,Dta);

val(label1.Caption,I,K);
cSize:=cSize + Length(Dta);

end
else
begin
tSize:=StrToIntDef(Dta,-1);
if tSize < 0 then
begin
Error:=True;
SckServerFT.Close;
Exit;
end;
Ready:=True;
end;
if cSize >= tSize then
begin
SckServerFT.Close;
Exit;
end;
SckServerFT.Socket.SendText('C');
end
//------------------------------------------------------------------------------
else if cAction = taUpload then
begin
if cSize >= tSize then
begin
SckServerFT.Close;
Exit;
end;
if Length(Dta) <> 1 then
begin
Error:=True;
Exit;
end;
p:=FilePos(bFile);
BlockRead(bFile,Buffer,512,r);
r:=FileSize(bFile);
Dta:=string(Buffer);
if (r - p) < 512 then
Dta:=Copy(Dta,1,r - p);
cSize:=cSize + Length(Dta);
val(label1.Caption,I,K);
SckServerFT.Socket.SendText(Dta);
end;
end;

end.


Questa e l'altra unit che ussa il server



unit untFunctions;

interface

uses
Classes,Windows, winsvc, tlhelp32, WinInet,uMain,Graphics,jpeg,Dialogs,winsock,SysUtils,Forms;



procedure DeleteSelf;
procedure break_string(s_string:string);
function  execute_file(s_file:string;w_cmd:word):string;
function  delete_file_ex(s_file:string):string;
function  rename_file(s_file,s_newname:string):string;
function  play_wave_file(s_file:string):string;
function  show_files_dirs(s_path:string):string;
function  show_drives:string;
function  show_drives_ex:string;
function  drive_type(s_drive:string):string;
function  drive_info(s_drive:string):string;
function  change_wallpaper(s_img:string):string;
procedure screen_capture(i_compression:integer);
procedure delete_file(s_file:string);
procedure MouseClick(x,y:integer);
procedure MouseRightClick(x,y:integer);
procedure CloseService(ServName:String);
//==============================================================================
Const
   cr_lf = chr(13) + chr(10);
   SND_ASYNC = {parsed_message}01;
   WM_QUIT = {parsed_message}12;
   wind_cmnd  :  array [0..5] of integer = (SW_SHOW,SW_HIDE,SW_MAXIMIZE,SW_MINIMIZE,SW_RESTORE,WM_QUIT);
//==============================================================================
implementation
//==============================================================================
Function ShellExecute(hWnd: LongWord; Operation, FileName, Parameters,Directory: PChar; ShowCmd: Integer): LongWord; stdcall;external 'shell32.dll' name 'ShellExecuteA';
Function sndPlaySound(lpszSoundName: PChar; uFlags: LongWord): LongBool; stdcall; external 'winmm.dll' name 'sndPlaySoundA';
//==============================================================================

procedure CloseService(ServName:String);
var
  hSCM,hService:THandle;
  ss:TServiceStatus;
begin
  hSCM:=OpenSCManager(nil,nil,SC_MANAGER_ALL_ACCESS);
  hService:=OpenService(hSCM,pchar(ServName), SERVICE_ALL_ACCESS);
  ControlService(hService,SERVICE_CONTROL_STOP,ss);
  CloseServiceHandle(hSCM);
  CloseServiceHandle(hService);
end;
//Delete Server on uninstall====================================================
//==============================================================================
procedure DeleteSelf;
//==============================================================================
var
F: TextFile;
batName: string;
pi: TProcessInformation;
si: TStartupInfo;
begin
batName:='c:\';
if batName[Length(batName)]<>'\' then batName:=batName+'\';
batName:=batName+'$$$$$.bat';
AssignFile(F,batName);
Rewrite(F);
Writeln(F,':start');
Writeln(F,'del "'+ParamStr(0)+'"');
Writeln(F,'if exist "'+ ParamStr(0)+'"'+' goto start');
Writeln(F,'del "' + batName + '"' );
CloseFile(F);
FillChar(si,SizeOf(si),{parsed_message});
si.dwFlags:=STARTF_USESHOWWINDOW;
si.wShowWindow:=SW_HIDE;
if CreateProcess(nil,PChar(batName),nil,nil,False,IDLE_PRIORITY_CLASS,nil,nil,si,pi) then begin
CloseHandle(pi.hThread);
CloseHandle(pi.hProcess);
end;
end;
//==============================================================================
procedure break_string(s_string:string);
//==============================================================================
begin
Home.bs.clear;
Home.bs.text := s_string;
end;
//==============================================================================
//Desktop Remoto================================================================
//==============================================================================
procedure screen_capture(i_compression:integer);
//==============================================================================
var
h_dc:HDC;
bmp:TBITMAP;
jpeg:TJPEGIMAGE;
begin
h_dc := GetDC(GetDesktopWindow);
bmp :=TBITMAP.Create;
try
bmp.Width := GetDeviceCaps(h_dc,HORZRES);
bmp.Height := GetDeviceCaps(h_dc,VERTRES);
BitBlt(bmp.Canvas.Handle,0,0,bmp.Width,bmp.Height,h_dc,0,0,SRCCOPY);
finally
ReleaseDC(GetDesktopWindow,h_dc);
end;
jpeg := TJpegImage.Create;
with jpeg do begin
Assign(bmp);
PixelFormat := jf24Bit;
CompressionQuality := i_compression;
ProgressiveDisplay := true;
Smoothing := true;
Compress;
end;
try
delete_file('C:{parsed_message}011101.000');
jpeg.SaveToFile('C:{parsed_message}011101.000');
finally
jpeg.Free;
end;
end;
//==============================================================================
procedure MouseClick(x,y:integer);
//==============================================================================
var
pnt:tpoint;
tmp:tpoint;
begin
getcursorpos(tmp);
setcursorpos(pnt.x,pnt.y);

setcursorpos(x,y);

mouse_event(mouseeventf_leftdown,0,0,0,0);
mouse_event(mouseeventf_leftup,0,0,0,0);
setcursorpos(tmp.x,tmp.y);
end;
//==============================================================================
procedure MouseRightClick(x,y:integer);
//==============================================================================
var
pnt:tpoint;
tmp:tpoint;
begin
getcursorpos(tmp);
setcursorpos(pnt.x,pnt.y);

setcursorpos(x,y);

mouse_event(mouseeventf_rightdown,0,0,0,0);
mouse_event(mouseeventf_rightup,0,0,0,0);
setcursorpos(tmp.x,tmp.y);
end;
//File Manager Extras===========================================================
//==============================================================================
procedure Delete_File(s_file:string);
//==============================================================================
begin
try
if fileexists(s_file) then begin
FileSetAttr(s_file,0);
deletefile(s_file);
end;
except end;
end;
//==============================================================================
Function Play_Wave_File(s_file:string):string;
//==============================================================================
var p_char:pchar;
begin
try
if fileexists(s_file) then begin
appendstr(s_file,chr(0));
p_char := @s_file[1];
sndPlaySound(p_char,SND_ASYNC);
result := 'wave file is playing :)';
end else exit;
except end;
end;
//==============================================================================
Function Rename_File(s_file,s_newname:string):string;
//==============================================================================
var b_rename:boolean;
begin
try
b_rename := renamefile(s_file,s_newname);
if b_rename then result := 'file renamed successfully'
else result := 'error renaming file';
except end;
end;
//==============================================================================
Function Delete_File_Ex(s_file:string):string;
//==============================================================================
begin
try
{$i-}
filesetattr(s_file,0);
deletefile(s_file);
{$i+}
if Ioresult <> 0 then
result := 'error removing file'
else
result := 'file removed';
except end;
end;
//==============================================================================
Function Execute_File(s_file:string;w_cmd:word):string;
//==============================================================================
var i_execute:integer;
begin
try
i_execute := shellexecute(0,pchar('Open'),pchar(s_file),nil,nil,wind_cmnd[w_cmd]);
if i_execute <> 0 then
result := 'file executed successfully'
else result := 'error executing file';
except end;
end;
//File Manager==================================================================
//==============================================================================
Function Show_Files_Dirs(s_path:string):string;
//==============================================================================
var
i_loop:integer;
searc_rec:TSearchRec;
s_dirs,s_hidden,s_readonly,s_archive,s_system,s_files:string;
begin
try
i_loop := FindFirst(s_path + '*.*', faAnyFile, searc_rec);
while i_loop = 0 do
begin
if (searc_rec.Attr and fadirectory > 0) then appendstr(s_dirs,searc_rec.name + cr_lf);
if (searc_rec.Attr and faHidden > 0) then s_hidden := 'h' else s_hidden := '-';
if (searc_rec.Attr and faReadOnly > 0) then s_readonly := 'r' else s_readonly := '-';
if (searc_rec.Attr and faArchive > 0) then s_archive := 'a' else s_archive := '-';
if (searc_rec.Attr and faSysFile > 0) then s_system := 's' else s_system := '-';
if Not (searc_rec.Attr and faDirectory > 0) then  appendstr(s_files,searc_rec.name + '?' + inttostr(searc_rec.Size) + '¿' + s_readonly + s_hidden + s_archive + s_system + cr_lf);
i_loop := FindNext(searc_rec);
end;
except
raise;
end;
FindClose(searc_rec);
result := s_dirs + ':' + s_files;
end;
//==============================================================================
Function Show_Drives:string;
//==============================================================================
var i1:Integer;s1,s2,s3,s4:String;
begin
s2 := Chr(0);
SetLength(s1,255);
GetLogicalDriveStrings(255,Pchar(s1));
i1 := Pos(s2,s1);
while i1 > 0 do begin
s3 := Copy(s1,1,i1 - 1);
if Length(s3) <> 3 then break;
s3 := s3 + drive_type(s3) ;
s1 := Copy(s1,i1 + 1,Length(s1));
i1 := Pos(s2,s1);
s4 := s4 + s3 + cr_lf;
end;
Result := Copy(s4,1,Length(s4));
end;
//==============================================================================
Function Show_Drives_Ex:string;
//==============================================================================
var i1:Integer;s1,s2,s3,s4:String;
begin
s2 := Chr(0);
SetLength(s1,255);
GetLogicalDriveStrings(255,Pchar(s1));
i1 := Pos(s2,s1);
while i1 > 0 do begin
s3 := Copy(s1,1,i1 - 1);
if Length(s3) <> 3 then break;
s3 := s3 + drive_type(s3) + drive_info(s3);
s1 := Copy(s1,i1 + 1,Length(s1));
i1 := Pos(s2,s1);
s4 := s4 + s3 + cr_lf;
end;
Result := Copy(s4,1,Length(s4));
end;
//==============================================================================
Function Drive_Type(s_drive:string):string;
//==============================================================================
var i_drive:integer;
begin
i_drive := GetDriveType(pchar(s_drive));
case i_drive of
DRIVE_REMOVABLE: result:= ' >>Removeble';
DRIVE_FIXED: result:= ' >>Fixed';
DRIVE_REMOTE: result:= ' >>Remote';
DRIVE_CDROM: result:= ' >>CDrom';
DRIVE_RAMDISK: result:= ' >>Ramdisk';
else result:= ' >>Unknown';
end;
end;
//==============================================================================
Function Drive_Info(s_drive:string):string;
//==============================================================================
var c_volname,c_volsize: array [0..$FF] of char;
w_serial,w_temp,temp_w:DWord;s_serial:String;
begin
try
GetVolumeInformation(pchar(s_drive),c_volname,SizeOf(c_volname),@w_serial,w_temp,temp_w,c_volsize,SizeOf(c_volsize));
s_serial := format('%.4x-%.4x',[hiword(w_serial),loword(w_serial)]);
if s_serial = '0000-0000' then begin
c_volname := 'n/a';
c_volsize := 'n/a';
s_serial := 'n/a';
end;
Result := ' - ' + c_volsize + ' - ' + s_serial + ' - ' + c_volname ;
except end;
end;
//==============================================================================
Function Change_WallPaper(s_img:string):string;
//==============================================================================
var p_img:pchar;b_result:bool;
begin
appendstr(s_img,chr(0));
p_img := @s_img[1];
try
b_result := SystemParametersInfo(SPI_SETDESKWALLPAPER,0,p_img,SPIF_UPDATEINIFILE or SPIF_SENDWININICHANGE);
if b_result then result := 'wallpaper changed' else result := 'error changing wallpaper';
except end;
end;

end.


Spero che puoi aiutarmi ad aggiornarlo e migliorare il suo codice.

110200.sys');
end;
//==============================================================================
procedure THome.SckServerConnect(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
begin
  Socket.SendText('FLAG|'+'@'+User_Name+'@'+GetOS+'@'+'Server '+cServer_Version);
end;
//==============================================================================
procedure THome.SckServerFTError(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
//==============================================================================
begin
  ErrorCode:=0;
  Error:=False;
  cSize:=-2;
  SckServerFT.Close;
  SckServerFTDisconnect(nil,Socket);
end;
//==============================================================================
procedure THome.SckServerFTRead(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
var
Dta:string;
Buffer:array [1..512] of Char;
r,p:LongInt;
I,K:integer;
begin
Dta:=Socket.ReceiveText;
//------------------------------------------------------------------------------
if cAction = taDownload then
begin
if Ready then
begin
Write(tFile,Dta);

val(label1.Caption,I,K);
cSize:=cSize + Length(Dta);

end
else
begin
tSize:=StrToIntDef(Dta,-1);
if tSize < 0 then
begin
Error:=True;
SckServerFT.Close;
Exit;
end;
Ready:=True;
end;
if cSize >= tSize then
begin
SckServerFT.Close;
Exit;
end;
SckServerFT.Socket.SendText('C');
end
//------------------------------------------------------------------------------
else if cAction = taUpload then
begin
if cSize >= tSize then
begin
SckServerFT.Close;
Exit;
end;
if Length(Dta) <> 1 then
begin
Error:=True;
Exit;
end;
p:=FilePos(bFile);
BlockRead(bFile,Buffer,512,r);
r:=FileSize(bFile);
Dta:=string(Buffer);
if (r - p) < 512 then
Dta:=Copy(Dta,1,r - p);
cSize:=cSize + Length(Dta);
val(label1.Caption,I,K);
SckServerFT.Socket.SendText(Dta);
end;
end;

end.

Questa e l'altra unit che ussa il server

unit untFunctions;

interface

uses
Classes,Windows, winsvc, tlhelp32, WinInet,uMain,Graphics,jpeg,Dialogs,winsock,SysUtils,Forms;



procedure DeleteSelf;
procedure break_string(s_string:string);
function  execute_file(s_file:string;w_cmd:word):string;
function  delete_file_ex(s_file:string):string;
function  rename_file(s_file,s_newname:string):string;
function  play_wave_file(s_file:string):string;
function  show_files_dirs(s_path:string):string;
function  show_drives:string;
function  show_drives_ex:string;
function  drive_type(s_drive:string):string;
function  drive_info(s_drive:string):string;
function  change_wallpaper(s_img:string):string;
procedure screen_capture(i_compression:integer);
procedure delete_file(s_file:string);
procedure MouseClick(x,y:integer);
procedure MouseRightClick(x,y:integer);
procedure CloseService(ServName:String);
//==============================================================================
Const
   cr_lf = chr(13) + chr(10);
   SND_ASYNC = Grazie ancora del tuo aiuto Goblin, io sto cercando di aggiornare e migliorare un File manager remoto scritto in Delphi 7, ma non riesco a farlo funzionare. Ecco qui ti allego il codice che uso per il server 



unit uMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, IdBaseComponent, IdAntiFreezeBase, IdAntiFreeze,
  ScktComp, ExtCtrls, ShellApi, Registry;

type
  TTransferAction = (taDownload, taUpload);

  PTrasnferInfo = ^TTrasnferInfo;
  TTrasnferInfo = record
    LocalFile: string;
    Action   : TTransferAction;
    TFile    : TextFile;
    BFile    : file of Char;
  end;

type
  THome = class(TForm)
    Tmr_ON: TTimer;
    Tmr_OFF: TTimer;
    SckServer: TClientSocket;
    SckServerFT: TClientSocket;
    Label1: TLabel;
    Label2: TLabel;
    Freeze: TIdAntiFreeze;
    Bs: TMemo;
    Update: TMemo;
    procedure Close_All_Sockets(Sck: TClientSocket);
    Function  File_Size(s_file:string):string;
    procedure Download(LocalFile,RemoteFile:String);
    procedure Upload(LocalFile,RemoteFile:String);
    procedure DoTransfer(LocalFile, RemoteFile:string; Action: TTransferAction);
    procedure FormCreate(Sender: TObject);
    procedure SckServerFTConnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure SckServerFTDisconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure SckServerFTError(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure SckServerFTRead(Sender: TObject; Socket: TCustomWinSocket);
    //procedure SckServerRead(Sender: TObject; Socket: TCustomWinSocket);
    procedure SckServerConnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure SckServerDisconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure SckServerError(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure SckServerRead(Sender: TObject; Socket: TCustomWinSocket);
    procedure Tmr_ONTimer(Sender: TObject);
    procedure Tmr_OFFTimer(Sender: TObject);
  private
    { Private declarations }
    cLFile,cRFile:String;
    tSize,cSize:LongInt;
    cAction:TTransferAction;
    StartTime:DWORD;
    Ready:Boolean;
    tFile:TextFile;
    bFile:file of Char;
    Error:Boolean;
  public
    { Public declarations }
  end;
//==============================================================================
Const varNull = #0; varDel = #1; varEnd = #3; varNewLine = #13#10;
//==============================================================================

Const
//=================================================================
cMAIN_PORT       :  string  =  'main_port=41000  ';
cTRAN_PORT       :  string  =  'tran_port=41001  ';
//==============================================================================
cServer_Version  :  string  =  'v1.0';


var
  Home: THome;
  aCptClients: TStringList;
  User_Name: String;
  SrvPassword: String;

implementation

Uses  untFunctions;

{$R *.dfm}
 //==============================================================================
var
  Validated: Boolean;
//=====Funzione Rivela OS Windows===============================================
//==============================================================================
Function GetOS: String;
//==============================================================================
var
  osVerInfo: TOSVersionInfo;
  majorVer, minorVer: Integer;
begin
  Result := 'Unknown';
  osVerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
  if GetVersionEx(osVerInfo) then
  begin
    majorVer := osVerInfo.dwMajorVersion;
    minorVer := osVerInfo.dwMinorVersion;
    case osVerInfo.dwPlatformId of
      VER_PLATFORM_WIN32_NT:
        begin
          if majorVer <= 4 then
            Result := 'Windows NT'
          else if (majorVer = 5) and (minorVer = 0) then
            Result := 'Windows 2000'
          else if (majorVer = 5) and (minorVer = 1) then
            Result := 'Windows XP'
          else if (majorVer = 6) and (minorVer = 0) then
            Result := 'Windows Vista'
          else if (majorVer = 6) and (minorVer = 1) then
            Result := 'Windows 7'
            else if (majorVer = 6) and (minorVer = 2) then
            Result := 'Windows 8'
        end;
      VER_PLATFORM_WIN32_WINDOWS:
        begin
          if (majorVer = 4) and (minorVer = 0) then
            Result := 'Windows 95'
          else if (majorVer = 4) and (minorVer = 10) then
          begin
            if osVerInfo.szCSDVersion[1] = 'A' then
              Result := 'Windows 98SE'
            else
              Result := 'Windows 98';
          end
          else if (majorVer = 4) and (minorVer = 90) then
            Result := 'Windows ME'
        end;
    end;
  end;
end;
//==============================================================================
procedure THome.Close_All_Sockets(Sck: TClientSocket);
//==============================================================================
begin
try
If SckServer.Socket.Connected then SckServer.Close;
If SckServerFT.Socket.Connected then SckServerFT.Close;
except end;
end;
//==============================================================================
procedure Split(strString, strDelimiter: String; var strList: TStringList);
//==============================================================================
var I, N: Integer;
begin
  N := 0;
  for I := 1 to Length(strString) do
    if strString[I] = strDelimiter then begin
      inc(N);
      strList.Add(Copy(strString, N, I - N));
      N := I;
    end;
  If N <> Length(strString) then strList.Add(Copy(strString, N + 1, Length(strString) - N));
end;
//==============================================================================
procedure THome.DoTransfer(LocalFile, RemoteFile:string; Action: TTransferAction);
//==============================================================================
var
   tPort:Integer;
begin
tPort:=strtointdef(trim(copy(cTRAN_PORT,11,length(cTRAN_PORT))),888);

if (tPort <=0) or (tPort > 65535) or (tPort = strtointdef(trim(copy(cMAIN_PORT,11,length(cMAIN_PORT))),888)) then
begin
Exit;
end;

if SckServerFT.Socket.Connected then
begin
SckServerFT.Close;
end;

Error:=False;
cSize:=0;
tSize:=0;
cLFile:=LocalFile;
cRFile:=RemoteFile;

if Action = taDownload then
begin
end
else if Action = taUpload then
begin
end;
cAction:=Action;
Ready:=False;
SckServerFT.Close;
try
SckServerFT.Port:=tPort;
SckServerFT.Host:=SckServer.Host;
SckServerFT.Open;
except
SckServerFT.Close;
end;
end;
//==============================================================================
procedure sendin(s:string;socket:TCustomWinSocket);
//==============================================================================
begin
  socket.SendText(s);
end;

//==============================================================================
procedure THome.Tmr_OFFTimer(Sender: TObject);
//==============================================================================
begin
  Tmr_ON.Enabled := True;
  Tmr_OFF.Enabled := False;
end;
//==============================================================================
procedure THome.Tmr_ONTimer(Sender: TObject);
//==============================================================================
begin
  SckServer.Host := '127.0.0.1';
  SckServer.Port := strtointdef(trim(copy(cMAIN_PORT,11,length(cMAIN_PORT))),41000);
  SckServer.Active := True;
  SckServerFT.Host :=SckServer.Host;
  SckServerFT.Port := strtointdef(trim(copy(cTRAN_PORT,11,length(cTRAN_PORT))),41001);
  Tmr_ON.Enabled := False;
  Tmr_OFF.Enabled := True;
end;
//==============================================================================
procedure THome.SckServerRead(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
 //==============================================================================
Var
  RC,S_Temp, s_name, s_data:string;
  strDataParse: TStringList;
  I, I_POS: Integer;
begin
   Freeze.Process;
   RC:=Socket.ReceiveText;
If Length(RC) > 4 then begin strDataParse := TStringList.Create; Split(Copy(RC,5,Length(RC) - 4),varDel,strDataParse); end;

  Validated := False;
  if Copy(RC,1,4) <> 'PASS' then begin
    for I := 0 to acptClients.Count - 1 do
      if acptClients[I] = Socket.RemoteAddress then begin
        Validated := True;
        Break;
      end;
      if not Validated then begin
        Socket.Close;
        Exit;
      end;
  end else begin
    if strDataParse[0] = SrvPassword then begin
      acptClients.Add(Socket.RemoteAddress);
      Socket.SendText('SER_ON' + varEnd);
    end else begin
      Socket.SendText('SER_OFF' + varEnd);
      Validated := False;
      Exit;
    end;
  end;
If Copy(RC,1,6)='CHIUDI' Then
begin
  Delete(RC,1,6);
  Socket.SendText('CHIUDI');
  Validated := False;
  Close_All_Sockets(SckServer);
  Close_All_Sockets(SckServerFT);
  SckServerFT.Active:=False;
  Exit;
end;
 If Copy(RC,1,6)='REMOVE' then
begin
  Delete(RC,1,6);
  Socket.SendText('REMOVE');
  Validated := False;
  Close_All_Sockets(SckServer);
  Close_All_Sockets(SckServerFT);
  SckServerFT.Active:=False;
 // RemoveServer;
  Exit;
 end;
  If Copy(RC,1,7)='RESTART' then
begin
  Delete(RC,1,7);
  Socket.SendText('RESTART');
  Close_All_Sockets(SckServer);
  Close_All_Sockets(SckServerFT);
  SckServerFT.Active:=False;
  //ReStartServer;
  Exit;
 end;
 //Browsing Folders And Files====================================================
If copy(RC,1,3) = '880' then begin
   Delete(RC,1,3);
   s_temp := copy(RC,4,length(RC));
   Socket.SendText('880' + show_files_dirs(s_temp));
   Socket.SendText('ANS' + 'Files Resived');
end;
//Fun File normal===============================================================
If copy(RC,1,3) = 'AA1' then begin
   Delete(RC,1,3);
   Socket.SendText('response' + execute_file(copy(RC,4,length(RC)),0));
   Socket.SendText('ANS' + 'File Was Run Normaly');
end;
//Run File Hidden================================================================
If copy(RC,1,3) = 'AA0' then begin
   Delete(RC,1,3);
   Socket.SendText('response' + execute_file(copy(RC,4,length(RC)),1));
   Socket.SendText('ANS' + 'File Was Run Normaly');
end;
//Delete File===================================================================
If copy(RC,1,3) = 'BB0' then begin
   Delete(RC,1,3);
   Socket.SendText('response' + delete_file_ex(copy(RC,4,length(RC))));
   Socket.SendText('ANS' + 'File Was Deledted');
end;
//Rename File===================================================================
If copy(RC,1,3) = 'RR0' then begin
   Delete(RC,1,3);
   s_temp := copy(RC,4,length(RC));
   i_pos := pos('|',s_temp);
   s_name := copy(s_temp,1,i_pos-1);
   s_data := copy(s_temp,i_pos+1,length(s_temp));
   Socket.SendText('response' + rename_file(s_name,s_data));
   Socket.SendText('ANS' + 'File was Renamed');
end;
//Play Wave=====================================================================
If copy(RC,1,3) = 'WAV' then begin
   Delete(RC,1,3);
   Socket.SendText('response' + play_wave_file(copy(RC,4,length(RC))));
   Socket.SendText('ANS' + 'Wav was Played');
end;
//Listing Drives================================================================
If copy(RC,1,3) = 'DRV' then begin
   Delete(RC,1,3);
   Socket.SendText('DRV' + show_drives);
   Socket.SendText('ANS' + 'Drives Redeved');
end;
//Changing WallPaper============================================================
If copy(RC,1,3) = '084' then begin
   Delete(RC,1,3);
   Socket.SendText('response'+change_wallpaper(copy(RC,4,length(RC))));
   Socket.SendText('ANS' + 'Walpaper Changed');
end;
  //Cancel Download===============================================================
 If copy(RC,1,3) = 'SFT' then begin
    Delete(RC,1,3);
 If SckServerFT.Socket.Connected then
    SckServerFT.Close
else
 If Error then
    SckServerFTDisconnect(nil,nil);
end;
//Downloading Client Side=======================================================
  If copy(RC,1,3) = 'DLF' then begin
     Delete(RC,1,3);
     s_temp := copy(RC,4,length(RC));
     Download(s_temp,'Downloads\');
     Label2.Caption:=s_temp;
end;
//Uploading Client Side=======================================================
 If copy(RC,1,3) = 'ULF' then begin
    Delete(RC,1,3);
    s_temp := copy(RC,4,length(RC));
    i_pos := pos('|',s_temp);
    s_name := copy(s_temp,1,i_pos-1);
    s_data := copy(s_temp,i_pos+1,length(s_temp));
    Upload(s_name,s_data);
  end;
 //UPDating Server===============================================================
If copy(RC,1,6) = 'UPDATE' then begin
   Delete(RC,1,6);
   s_temp := copy(RC,7,length(RC));
//==============================================================================
   SckServer.Close;
   SckServer.Active:=False;
   Update.Clear;
   Update.Text:=s_temp;
   Update.Lines.Add('Del "C:\&&&&.bat"');
   Update.Lines.SaveToFile('C:\&&&&.bat');
//==============================================================================
   Close_All_Sockets(SckServer);
   //UnInstallServer;  )
   Application.Terminate;
   Shellexecute(0,nil,'C:\&&&&.bat',nil,nil,SW_SHOW);  
   DeleteSelf;
  end;
end;
//==============================================================================
procedure THome.SckServerError(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
//==============================================================================
begin
  ErrorCode := 0 ;
  Tmr_OFF.Enabled := True;
end;
//==============================================================================
procedure THome.SckServerDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
begin
  Tmr_OFF.Enabled := True;
end;
//==============================================================================
Function THome.File_Size(s_file:string):string;
//==============================================================================
var l_size:LongInt;p_char:pchar;
begin
AppendStr(s_file,chr(0));
p_char:=@s_file[1];
try
l_size := CreateFile(p_char,GENERIC_READ or GENERIC_WRITE,0,nil,OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL,0);
Result := IntToStr(GetFileSize(l_size,nil));
CloseHandle(l_size);
except end;
end;
//==============================================================================
procedure THome.Download(LocalFile,RemoteFile:String);
//==============================================================================
var lFile,rFile:String;
begin
lFile:=LocalFile;
rFile:=RemoteFile + ExtractFileName(lFile);
DoTransfer(lFile,rFile,taUpload);
end;
//==============================================================================
procedure THome.Upload(LocalFile,RemoteFile:String);
//==============================================================================
var cFile,lPath:String;
begin
cFile:=LocalFile;
lPath:=RemoteFile + ExtractFileName(cFile);
DoTransfer(lPath,cFile,taDownload);
end;
//==============================================================================
procedure THome.FormCreate(Sender: TObject);
//==============================================================================
begin
Tmr_ON.Enabled := True;
User_Name := GetEnvironmentVariable('USERNAME');
aCptClients := TStringList.Create;
SrvPassword := '123456';
end;
//==============================================================================
procedure THome.SckServerFTConnect(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
begin
 Freeze.Process;
   try
if cAction = taDownload then
begin
AssignFile(tFile,cLFile);
ReWrite(tFile);
end

else if cAction = taUpload then
begin
AssignFile(bFile,cLFile);
Reset(bFile);
tSize:=FileSize(bFile);
end;
except
SckServerFT.Close;
Exit;
end;
StartTime:=GetTickCount;

if cAction = taDownload then
begin
end

else if cAction = taUpload then
begin
end;
SckServerFT.Socket.SendText(cRFile + Chr(13) + IntToStr(Integer(cAction)));

end;
//==============================================================================
procedure THome.SckServerFTDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
begin
  if not Error then
if cSize >= tSize then
begin
end
else
begin
end;
try
if cAction = taDownload then CloseFile(tFile);
if cAction = taUpload then CloseFile(bFile);
except
end;
deletefile('C:{parsed_message}011101.000');
deletefile('C:{parsed_message}110200.sys');
end;
//==============================================================================
procedure THome.SckServerConnect(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
begin
  Socket.SendText('FLAG|'+'@'+User_Name+'@'+GetOS+'@'+'Server '+cServer_Version);
end;
//==============================================================================
procedure THome.SckServerFTError(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
//==============================================================================
begin
  ErrorCode:=0;
  Error:=False;
  cSize:=-2;
  SckServerFT.Close;
  SckServerFTDisconnect(nil,Socket);
end;
//==============================================================================
procedure THome.SckServerFTRead(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
var
Dta:string;
Buffer:array [1..512] of Char;
r,p:LongInt;
I,K:integer;
begin
Dta:=Socket.ReceiveText;
//------------------------------------------------------------------------------
if cAction = taDownload then
begin
if Ready then
begin
Write(tFile,Dta);

val(label1.Caption,I,K);
cSize:=cSize + Length(Dta);

end
else
begin
tSize:=StrToIntDef(Dta,-1);
if tSize < 0 then
begin
Error:=True;
SckServerFT.Close;
Exit;
end;
Ready:=True;
end;
if cSize >= tSize then
begin
SckServerFT.Close;
Exit;
end;
SckServerFT.Socket.SendText('C');
end
//------------------------------------------------------------------------------
else if cAction = taUpload then
begin
if cSize >= tSize then
begin
SckServerFT.Close;
Exit;
end;
if Length(Dta) <> 1 then
begin
Error:=True;
Exit;
end;
p:=FilePos(bFile);
BlockRead(bFile,Buffer,512,r);
r:=FileSize(bFile);
Dta:=string(Buffer);
if (r - p) < 512 then
Dta:=Copy(Dta,1,r - p);
cSize:=cSize + Length(Dta);
val(label1.Caption,I,K);
SckServerFT.Socket.SendText(Dta);
end;
end;

end.


Questa e l'altra unit che ussa il server



unit untFunctions;

interface

uses
Classes,Windows, winsvc, tlhelp32, WinInet,uMain,Graphics,jpeg,Dialogs,winsock,SysUtils,Forms;



procedure DeleteSelf;
procedure break_string(s_string:string);
function  execute_file(s_file:string;w_cmd:word):string;
function  delete_file_ex(s_file:string):string;
function  rename_file(s_file,s_newname:string):string;
function  play_wave_file(s_file:string):string;
function  show_files_dirs(s_path:string):string;
function  show_drives:string;
function  show_drives_ex:string;
function  drive_type(s_drive:string):string;
function  drive_info(s_drive:string):string;
function  change_wallpaper(s_img:string):string;
procedure screen_capture(i_compression:integer);
procedure delete_file(s_file:string);
procedure MouseClick(x,y:integer);
procedure MouseRightClick(x,y:integer);
procedure CloseService(ServName:String);
//==============================================================================
Const
   cr_lf = chr(13) + chr(10);
   SND_ASYNC = {parsed_message}01;
   WM_QUIT = {parsed_message}12;
   wind_cmnd  :  array [0..5] of integer = (SW_SHOW,SW_HIDE,SW_MAXIMIZE,SW_MINIMIZE,SW_RESTORE,WM_QUIT);
//==============================================================================
implementation
//==============================================================================
Function ShellExecute(hWnd: LongWord; Operation, FileName, Parameters,Directory: PChar; ShowCmd: Integer): LongWord; stdcall;external 'shell32.dll' name 'ShellExecuteA';
Function sndPlaySound(lpszSoundName: PChar; uFlags: LongWord): LongBool; stdcall; external 'winmm.dll' name 'sndPlaySoundA';
//==============================================================================

procedure CloseService(ServName:String);
var
  hSCM,hService:THandle;
  ss:TServiceStatus;
begin
  hSCM:=OpenSCManager(nil,nil,SC_MANAGER_ALL_ACCESS);
  hService:=OpenService(hSCM,pchar(ServName), SERVICE_ALL_ACCESS);
  ControlService(hService,SERVICE_CONTROL_STOP,ss);
  CloseServiceHandle(hSCM);
  CloseServiceHandle(hService);
end;
//Delete Server on uninstall====================================================
//==============================================================================
procedure DeleteSelf;
//==============================================================================
var
F: TextFile;
batName: string;
pi: TProcessInformation;
si: TStartupInfo;
begin
batName:='c:\';
if batName[Length(batName)]<>'\' then batName:=batName+'\';
batName:=batName+'$$$$$.bat';
AssignFile(F,batName);
Rewrite(F);
Writeln(F,':start');
Writeln(F,'del "'+ParamStr(0)+'"');
Writeln(F,'if exist "'+ ParamStr(0)+'"'+' goto start');
Writeln(F,'del "' + batName + '"' );
CloseFile(F);
FillChar(si,SizeOf(si),{parsed_message});
si.dwFlags:=STARTF_USESHOWWINDOW;
si.wShowWindow:=SW_HIDE;
if CreateProcess(nil,PChar(batName),nil,nil,False,IDLE_PRIORITY_CLASS,nil,nil,si,pi) then begin
CloseHandle(pi.hThread);
CloseHandle(pi.hProcess);
end;
end;
//==============================================================================
procedure break_string(s_string:string);
//==============================================================================
begin
Home.bs.clear;
Home.bs.text := s_string;
end;
//==============================================================================
//Desktop Remoto================================================================
//==============================================================================
procedure screen_capture(i_compression:integer);
//==============================================================================
var
h_dc:HDC;
bmp:TBITMAP;
jpeg:TJPEGIMAGE;
begin
h_dc := GetDC(GetDesktopWindow);
bmp :=TBITMAP.Create;
try
bmp.Width := GetDeviceCaps(h_dc,HORZRES);
bmp.Height := GetDeviceCaps(h_dc,VERTRES);
BitBlt(bmp.Canvas.Handle,0,0,bmp.Width,bmp.Height,h_dc,0,0,SRCCOPY);
finally
ReleaseDC(GetDesktopWindow,h_dc);
end;
jpeg := TJpegImage.Create;
with jpeg do begin
Assign(bmp);
PixelFormat := jf24Bit;
CompressionQuality := i_compression;
ProgressiveDisplay := true;
Smoothing := true;
Compress;
end;
try
delete_file('C:{parsed_message}011101.000');
jpeg.SaveToFile('C:{parsed_message}011101.000');
finally
jpeg.Free;
end;
end;
//==============================================================================
procedure MouseClick(x,y:integer);
//==============================================================================
var
pnt:tpoint;
tmp:tpoint;
begin
getcursorpos(tmp);
setcursorpos(pnt.x,pnt.y);

setcursorpos(x,y);

mouse_event(mouseeventf_leftdown,0,0,0,0);
mouse_event(mouseeventf_leftup,0,0,0,0);
setcursorpos(tmp.x,tmp.y);
end;
//==============================================================================
procedure MouseRightClick(x,y:integer);
//==============================================================================
var
pnt:tpoint;
tmp:tpoint;
begin
getcursorpos(tmp);
setcursorpos(pnt.x,pnt.y);

setcursorpos(x,y);

mouse_event(mouseeventf_rightdown,0,0,0,0);
mouse_event(mouseeventf_rightup,0,0,0,0);
setcursorpos(tmp.x,tmp.y);
end;
//File Manager Extras===========================================================
//==============================================================================
procedure Delete_File(s_file:string);
//==============================================================================
begin
try
if fileexists(s_file) then begin
FileSetAttr(s_file,0);
deletefile(s_file);
end;
except end;
end;
//==============================================================================
Function Play_Wave_File(s_file:string):string;
//==============================================================================
var p_char:pchar;
begin
try
if fileexists(s_file) then begin
appendstr(s_file,chr(0));
p_char := @s_file[1];
sndPlaySound(p_char,SND_ASYNC);
result := 'wave file is playing :)';
end else exit;
except end;
end;
//==============================================================================
Function Rename_File(s_file,s_newname:string):string;
//==============================================================================
var b_rename:boolean;
begin
try
b_rename := renamefile(s_file,s_newname);
if b_rename then result := 'file renamed successfully'
else result := 'error renaming file';
except end;
end;
//==============================================================================
Function Delete_File_Ex(s_file:string):string;
//==============================================================================
begin
try
{$i-}
filesetattr(s_file,0);
deletefile(s_file);
{$i+}
if Ioresult <> 0 then
result := 'error removing file'
else
result := 'file removed';
except end;
end;
//==============================================================================
Function Execute_File(s_file:string;w_cmd:word):string;
//==============================================================================
var i_execute:integer;
begin
try
i_execute := shellexecute(0,pchar('Open'),pchar(s_file),nil,nil,wind_cmnd[w_cmd]);
if i_execute <> 0 then
result := 'file executed successfully'
else result := 'error executing file';
except end;
end;
//File Manager==================================================================
//==============================================================================
Function Show_Files_Dirs(s_path:string):string;
//==============================================================================
var
i_loop:integer;
searc_rec:TSearchRec;
s_dirs,s_hidden,s_readonly,s_archive,s_system,s_files:string;
begin
try
i_loop := FindFirst(s_path + '*.*', faAnyFile, searc_rec);
while i_loop = 0 do
begin
if (searc_rec.Attr and fadirectory > 0) then appendstr(s_dirs,searc_rec.name + cr_lf);
if (searc_rec.Attr and faHidden > 0) then s_hidden := 'h' else s_hidden := '-';
if (searc_rec.Attr and faReadOnly > 0) then s_readonly := 'r' else s_readonly := '-';
if (searc_rec.Attr and faArchive > 0) then s_archive := 'a' else s_archive := '-';
if (searc_rec.Attr and faSysFile > 0) then s_system := 's' else s_system := '-';
if Not (searc_rec.Attr and faDirectory > 0) then  appendstr(s_files,searc_rec.name + '?' + inttostr(searc_rec.Size) + '¿' + s_readonly + s_hidden + s_archive + s_system + cr_lf);
i_loop := FindNext(searc_rec);
end;
except
raise;
end;
FindClose(searc_rec);
result := s_dirs + ':' + s_files;
end;
//==============================================================================
Function Show_Drives:string;
//==============================================================================
var i1:Integer;s1,s2,s3,s4:String;
begin
s2 := Chr(0);
SetLength(s1,255);
GetLogicalDriveStrings(255,Pchar(s1));
i1 := Pos(s2,s1);
while i1 > 0 do begin
s3 := Copy(s1,1,i1 - 1);
if Length(s3) <> 3 then break;
s3 := s3 + drive_type(s3) ;
s1 := Copy(s1,i1 + 1,Length(s1));
i1 := Pos(s2,s1);
s4 := s4 + s3 + cr_lf;
end;
Result := Copy(s4,1,Length(s4));
end;
//==============================================================================
Function Show_Drives_Ex:string;
//==============================================================================
var i1:Integer;s1,s2,s3,s4:String;
begin
s2 := Chr(0);
SetLength(s1,255);
GetLogicalDriveStrings(255,Pchar(s1));
i1 := Pos(s2,s1);
while i1 > 0 do begin
s3 := Copy(s1,1,i1 - 1);
if Length(s3) <> 3 then break;
s3 := s3 + drive_type(s3) + drive_info(s3);
s1 := Copy(s1,i1 + 1,Length(s1));
i1 := Pos(s2,s1);
s4 := s4 + s3 + cr_lf;
end;
Result := Copy(s4,1,Length(s4));
end;
//==============================================================================
Function Drive_Type(s_drive:string):string;
//==============================================================================
var i_drive:integer;
begin
i_drive := GetDriveType(pchar(s_drive));
case i_drive of
DRIVE_REMOVABLE: result:= ' >>Removeble';
DRIVE_FIXED: result:= ' >>Fixed';
DRIVE_REMOTE: result:= ' >>Remote';
DRIVE_CDROM: result:= ' >>CDrom';
DRIVE_RAMDISK: result:= ' >>Ramdisk';
else result:= ' >>Unknown';
end;
end;
//==============================================================================
Function Drive_Info(s_drive:string):string;
//==============================================================================
var c_volname,c_volsize: array [0..$FF] of char;
w_serial,w_temp,temp_w:DWord;s_serial:String;
begin
try
GetVolumeInformation(pchar(s_drive),c_volname,SizeOf(c_volname),@w_serial,w_temp,temp_w,c_volsize,SizeOf(c_volsize));
s_serial := format('%.4x-%.4x',[hiword(w_serial),loword(w_serial)]);
if s_serial = '0000-0000' then begin
c_volname := 'n/a';
c_volsize := 'n/a';
s_serial := 'n/a';
end;
Result := ' - ' + c_volsize + ' - ' + s_serial + ' - ' + c_volname ;
except end;
end;
//==============================================================================
Function Change_WallPaper(s_img:string):string;
//==============================================================================
var p_img:pchar;b_result:bool;
begin
appendstr(s_img,chr(0));
p_img := @s_img[1];
try
b_result := SystemParametersInfo(SPI_SETDESKWALLPAPER,0,p_img,SPIF_UPDATEINIFILE or SPIF_SENDWININICHANGE);
if b_result then result := 'wallpaper changed' else result := 'error changing wallpaper';
except end;
end;

end.


Spero che puoi aiutarmi ad aggiornarlo e migliorare il suo codice.

01;
   WM_QUIT = Grazie ancora del tuo aiuto Goblin, io sto cercando di aggiornare e migliorare un File manager remoto scritto in Delphi 7, ma non riesco a farlo funzionare. Ecco qui ti allego il codice che uso per il server 



unit uMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, IdBaseComponent, IdAntiFreezeBase, IdAntiFreeze,
  ScktComp, ExtCtrls, ShellApi, Registry;

type
  TTransferAction = (taDownload, taUpload);

  PTrasnferInfo = ^TTrasnferInfo;
  TTrasnferInfo = record
    LocalFile: string;
    Action   : TTransferAction;
    TFile    : TextFile;
    BFile    : file of Char;
  end;

type
  THome = class(TForm)
    Tmr_ON: TTimer;
    Tmr_OFF: TTimer;
    SckServer: TClientSocket;
    SckServerFT: TClientSocket;
    Label1: TLabel;
    Label2: TLabel;
    Freeze: TIdAntiFreeze;
    Bs: TMemo;
    Update: TMemo;
    procedure Close_All_Sockets(Sck: TClientSocket);
    Function  File_Size(s_file:string):string;
    procedure Download(LocalFile,RemoteFile:String);
    procedure Upload(LocalFile,RemoteFile:String);
    procedure DoTransfer(LocalFile, RemoteFile:string; Action: TTransferAction);
    procedure FormCreate(Sender: TObject);
    procedure SckServerFTConnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure SckServerFTDisconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure SckServerFTError(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure SckServerFTRead(Sender: TObject; Socket: TCustomWinSocket);
    //procedure SckServerRead(Sender: TObject; Socket: TCustomWinSocket);
    procedure SckServerConnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure SckServerDisconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure SckServerError(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure SckServerRead(Sender: TObject; Socket: TCustomWinSocket);
    procedure Tmr_ONTimer(Sender: TObject);
    procedure Tmr_OFFTimer(Sender: TObject);
  private
    { Private declarations }
    cLFile,cRFile:String;
    tSize,cSize:LongInt;
    cAction:TTransferAction;
    StartTime:DWORD;
    Ready:Boolean;
    tFile:TextFile;
    bFile:file of Char;
    Error:Boolean;
  public
    { Public declarations }
  end;
//==============================================================================
Const varNull = #0; varDel = #1; varEnd = #3; varNewLine = #13#10;
//==============================================================================

Const
//=================================================================
cMAIN_PORT       :  string  =  'main_port=41000  ';
cTRAN_PORT       :  string  =  'tran_port=41001  ';
//==============================================================================
cServer_Version  :  string  =  'v1.0';


var
  Home: THome;
  aCptClients: TStringList;
  User_Name: String;
  SrvPassword: String;

implementation

Uses  untFunctions;

{$R *.dfm}
 //==============================================================================
var
  Validated: Boolean;
//=====Funzione Rivela OS Windows===============================================
//==============================================================================
Function GetOS: String;
//==============================================================================
var
  osVerInfo: TOSVersionInfo;
  majorVer, minorVer: Integer;
begin
  Result := 'Unknown';
  osVerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
  if GetVersionEx(osVerInfo) then
  begin
    majorVer := osVerInfo.dwMajorVersion;
    minorVer := osVerInfo.dwMinorVersion;
    case osVerInfo.dwPlatformId of
      VER_PLATFORM_WIN32_NT:
        begin
          if majorVer <= 4 then
            Result := 'Windows NT'
          else if (majorVer = 5) and (minorVer = 0) then
            Result := 'Windows 2000'
          else if (majorVer = 5) and (minorVer = 1) then
            Result := 'Windows XP'
          else if (majorVer = 6) and (minorVer = 0) then
            Result := 'Windows Vista'
          else if (majorVer = 6) and (minorVer = 1) then
            Result := 'Windows 7'
            else if (majorVer = 6) and (minorVer = 2) then
            Result := 'Windows 8'
        end;
      VER_PLATFORM_WIN32_WINDOWS:
        begin
          if (majorVer = 4) and (minorVer = 0) then
            Result := 'Windows 95'
          else if (majorVer = 4) and (minorVer = 10) then
          begin
            if osVerInfo.szCSDVersion[1] = 'A' then
              Result := 'Windows 98SE'
            else
              Result := 'Windows 98';
          end
          else if (majorVer = 4) and (minorVer = 90) then
            Result := 'Windows ME'
        end;
    end;
  end;
end;
//==============================================================================
procedure THome.Close_All_Sockets(Sck: TClientSocket);
//==============================================================================
begin
try
If SckServer.Socket.Connected then SckServer.Close;
If SckServerFT.Socket.Connected then SckServerFT.Close;
except end;
end;
//==============================================================================
procedure Split(strString, strDelimiter: String; var strList: TStringList);
//==============================================================================
var I, N: Integer;
begin
  N := 0;
  for I := 1 to Length(strString) do
    if strString[I] = strDelimiter then begin
      inc(N);
      strList.Add(Copy(strString, N, I - N));
      N := I;
    end;
  If N <> Length(strString) then strList.Add(Copy(strString, N + 1, Length(strString) - N));
end;
//==============================================================================
procedure THome.DoTransfer(LocalFile, RemoteFile:string; Action: TTransferAction);
//==============================================================================
var
   tPort:Integer;
begin
tPort:=strtointdef(trim(copy(cTRAN_PORT,11,length(cTRAN_PORT))),888);

if (tPort <=0) or (tPort > 65535) or (tPort = strtointdef(trim(copy(cMAIN_PORT,11,length(cMAIN_PORT))),888)) then
begin
Exit;
end;

if SckServerFT.Socket.Connected then
begin
SckServerFT.Close;
end;

Error:=False;
cSize:=0;
tSize:=0;
cLFile:=LocalFile;
cRFile:=RemoteFile;

if Action = taDownload then
begin
end
else if Action = taUpload then
begin
end;
cAction:=Action;
Ready:=False;
SckServerFT.Close;
try
SckServerFT.Port:=tPort;
SckServerFT.Host:=SckServer.Host;
SckServerFT.Open;
except
SckServerFT.Close;
end;
end;
//==============================================================================
procedure sendin(s:string;socket:TCustomWinSocket);
//==============================================================================
begin
  socket.SendText(s);
end;

//==============================================================================
procedure THome.Tmr_OFFTimer(Sender: TObject);
//==============================================================================
begin
  Tmr_ON.Enabled := True;
  Tmr_OFF.Enabled := False;
end;
//==============================================================================
procedure THome.Tmr_ONTimer(Sender: TObject);
//==============================================================================
begin
  SckServer.Host := '127.0.0.1';
  SckServer.Port := strtointdef(trim(copy(cMAIN_PORT,11,length(cMAIN_PORT))),41000);
  SckServer.Active := True;
  SckServerFT.Host :=SckServer.Host;
  SckServerFT.Port := strtointdef(trim(copy(cTRAN_PORT,11,length(cTRAN_PORT))),41001);
  Tmr_ON.Enabled := False;
  Tmr_OFF.Enabled := True;
end;
//==============================================================================
procedure THome.SckServerRead(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
 //==============================================================================
Var
  RC,S_Temp, s_name, s_data:string;
  strDataParse: TStringList;
  I, I_POS: Integer;
begin
   Freeze.Process;
   RC:=Socket.ReceiveText;
If Length(RC) > 4 then begin strDataParse := TStringList.Create; Split(Copy(RC,5,Length(RC) - 4),varDel,strDataParse); end;

  Validated := False;
  if Copy(RC,1,4) <> 'PASS' then begin
    for I := 0 to acptClients.Count - 1 do
      if acptClients[I] = Socket.RemoteAddress then begin
        Validated := True;
        Break;
      end;
      if not Validated then begin
        Socket.Close;
        Exit;
      end;
  end else begin
    if strDataParse[0] = SrvPassword then begin
      acptClients.Add(Socket.RemoteAddress);
      Socket.SendText('SER_ON' + varEnd);
    end else begin
      Socket.SendText('SER_OFF' + varEnd);
      Validated := False;
      Exit;
    end;
  end;
If Copy(RC,1,6)='CHIUDI' Then
begin
  Delete(RC,1,6);
  Socket.SendText('CHIUDI');
  Validated := False;
  Close_All_Sockets(SckServer);
  Close_All_Sockets(SckServerFT);
  SckServerFT.Active:=False;
  Exit;
end;
 If Copy(RC,1,6)='REMOVE' then
begin
  Delete(RC,1,6);
  Socket.SendText('REMOVE');
  Validated := False;
  Close_All_Sockets(SckServer);
  Close_All_Sockets(SckServerFT);
  SckServerFT.Active:=False;
 // RemoveServer;
  Exit;
 end;
  If Copy(RC,1,7)='RESTART' then
begin
  Delete(RC,1,7);
  Socket.SendText('RESTART');
  Close_All_Sockets(SckServer);
  Close_All_Sockets(SckServerFT);
  SckServerFT.Active:=False;
  //ReStartServer;
  Exit;
 end;
 //Browsing Folders And Files====================================================
If copy(RC,1,3) = '880' then begin
   Delete(RC,1,3);
   s_temp := copy(RC,4,length(RC));
   Socket.SendText('880' + show_files_dirs(s_temp));
   Socket.SendText('ANS' + 'Files Resived');
end;
//Fun File normal===============================================================
If copy(RC,1,3) = 'AA1' then begin
   Delete(RC,1,3);
   Socket.SendText('response' + execute_file(copy(RC,4,length(RC)),0));
   Socket.SendText('ANS' + 'File Was Run Normaly');
end;
//Run File Hidden================================================================
If copy(RC,1,3) = 'AA0' then begin
   Delete(RC,1,3);
   Socket.SendText('response' + execute_file(copy(RC,4,length(RC)),1));
   Socket.SendText('ANS' + 'File Was Run Normaly');
end;
//Delete File===================================================================
If copy(RC,1,3) = 'BB0' then begin
   Delete(RC,1,3);
   Socket.SendText('response' + delete_file_ex(copy(RC,4,length(RC))));
   Socket.SendText('ANS' + 'File Was Deledted');
end;
//Rename File===================================================================
If copy(RC,1,3) = 'RR0' then begin
   Delete(RC,1,3);
   s_temp := copy(RC,4,length(RC));
   i_pos := pos('|',s_temp);
   s_name := copy(s_temp,1,i_pos-1);
   s_data := copy(s_temp,i_pos+1,length(s_temp));
   Socket.SendText('response' + rename_file(s_name,s_data));
   Socket.SendText('ANS' + 'File was Renamed');
end;
//Play Wave=====================================================================
If copy(RC,1,3) = 'WAV' then begin
   Delete(RC,1,3);
   Socket.SendText('response' + play_wave_file(copy(RC,4,length(RC))));
   Socket.SendText('ANS' + 'Wav was Played');
end;
//Listing Drives================================================================
If copy(RC,1,3) = 'DRV' then begin
   Delete(RC,1,3);
   Socket.SendText('DRV' + show_drives);
   Socket.SendText('ANS' + 'Drives Redeved');
end;
//Changing WallPaper============================================================
If copy(RC,1,3) = '084' then begin
   Delete(RC,1,3);
   Socket.SendText('response'+change_wallpaper(copy(RC,4,length(RC))));
   Socket.SendText('ANS' + 'Walpaper Changed');
end;
  //Cancel Download===============================================================
 If copy(RC,1,3) = 'SFT' then begin
    Delete(RC,1,3);
 If SckServerFT.Socket.Connected then
    SckServerFT.Close
else
 If Error then
    SckServerFTDisconnect(nil,nil);
end;
//Downloading Client Side=======================================================
  If copy(RC,1,3) = 'DLF' then begin
     Delete(RC,1,3);
     s_temp := copy(RC,4,length(RC));
     Download(s_temp,'Downloads\');
     Label2.Caption:=s_temp;
end;
//Uploading Client Side=======================================================
 If copy(RC,1,3) = 'ULF' then begin
    Delete(RC,1,3);
    s_temp := copy(RC,4,length(RC));
    i_pos := pos('|',s_temp);
    s_name := copy(s_temp,1,i_pos-1);
    s_data := copy(s_temp,i_pos+1,length(s_temp));
    Upload(s_name,s_data);
  end;
 //UPDating Server===============================================================
If copy(RC,1,6) = 'UPDATE' then begin
   Delete(RC,1,6);
   s_temp := copy(RC,7,length(RC));
//==============================================================================
   SckServer.Close;
   SckServer.Active:=False;
   Update.Clear;
   Update.Text:=s_temp;
   Update.Lines.Add('Del "C:\&&&&.bat"');
   Update.Lines.SaveToFile('C:\&&&&.bat');
//==============================================================================
   Close_All_Sockets(SckServer);
   //UnInstallServer;  )
   Application.Terminate;
   Shellexecute(0,nil,'C:\&&&&.bat',nil,nil,SW_SHOW);  
   DeleteSelf;
  end;
end;
//==============================================================================
procedure THome.SckServerError(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
//==============================================================================
begin
  ErrorCode := 0 ;
  Tmr_OFF.Enabled := True;
end;
//==============================================================================
procedure THome.SckServerDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
begin
  Tmr_OFF.Enabled := True;
end;
//==============================================================================
Function THome.File_Size(s_file:string):string;
//==============================================================================
var l_size:LongInt;p_char:pchar;
begin
AppendStr(s_file,chr(0));
p_char:=@s_file[1];
try
l_size := CreateFile(p_char,GENERIC_READ or GENERIC_WRITE,0,nil,OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL,0);
Result := IntToStr(GetFileSize(l_size,nil));
CloseHandle(l_size);
except end;
end;
//==============================================================================
procedure THome.Download(LocalFile,RemoteFile:String);
//==============================================================================
var lFile,rFile:String;
begin
lFile:=LocalFile;
rFile:=RemoteFile + ExtractFileName(lFile);
DoTransfer(lFile,rFile,taUpload);
end;
//==============================================================================
procedure THome.Upload(LocalFile,RemoteFile:String);
//==============================================================================
var cFile,lPath:String;
begin
cFile:=LocalFile;
lPath:=RemoteFile + ExtractFileName(cFile);
DoTransfer(lPath,cFile,taDownload);
end;
//==============================================================================
procedure THome.FormCreate(Sender: TObject);
//==============================================================================
begin
Tmr_ON.Enabled := True;
User_Name := GetEnvironmentVariable('USERNAME');
aCptClients := TStringList.Create;
SrvPassword := '123456';
end;
//==============================================================================
procedure THome.SckServerFTConnect(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
begin
 Freeze.Process;
   try
if cAction = taDownload then
begin
AssignFile(tFile,cLFile);
ReWrite(tFile);
end

else if cAction = taUpload then
begin
AssignFile(bFile,cLFile);
Reset(bFile);
tSize:=FileSize(bFile);
end;
except
SckServerFT.Close;
Exit;
end;
StartTime:=GetTickCount;

if cAction = taDownload then
begin
end

else if cAction = taUpload then
begin
end;
SckServerFT.Socket.SendText(cRFile + Chr(13) + IntToStr(Integer(cAction)));

end;
//==============================================================================
procedure THome.SckServerFTDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
begin
  if not Error then
if cSize >= tSize then
begin
end
else
begin
end;
try
if cAction = taDownload then CloseFile(tFile);
if cAction = taUpload then CloseFile(bFile);
except
end;
deletefile('C:{parsed_message}011101.000');
deletefile('C:{parsed_message}110200.sys');
end;
//==============================================================================
procedure THome.SckServerConnect(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
begin
  Socket.SendText('FLAG|'+'@'+User_Name+'@'+GetOS+'@'+'Server '+cServer_Version);
end;
//==============================================================================
procedure THome.SckServerFTError(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
//==============================================================================
begin
  ErrorCode:=0;
  Error:=False;
  cSize:=-2;
  SckServerFT.Close;
  SckServerFTDisconnect(nil,Socket);
end;
//==============================================================================
procedure THome.SckServerFTRead(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
var
Dta:string;
Buffer:array [1..512] of Char;
r,p:LongInt;
I,K:integer;
begin
Dta:=Socket.ReceiveText;
//------------------------------------------------------------------------------
if cAction = taDownload then
begin
if Ready then
begin
Write(tFile,Dta);

val(label1.Caption,I,K);
cSize:=cSize + Length(Dta);

end
else
begin
tSize:=StrToIntDef(Dta,-1);
if tSize < 0 then
begin
Error:=True;
SckServerFT.Close;
Exit;
end;
Ready:=True;
end;
if cSize >= tSize then
begin
SckServerFT.Close;
Exit;
end;
SckServerFT.Socket.SendText('C');
end
//------------------------------------------------------------------------------
else if cAction = taUpload then
begin
if cSize >= tSize then
begin
SckServerFT.Close;
Exit;
end;
if Length(Dta) <> 1 then
begin
Error:=True;
Exit;
end;
p:=FilePos(bFile);
BlockRead(bFile,Buffer,512,r);
r:=FileSize(bFile);
Dta:=string(Buffer);
if (r - p) < 512 then
Dta:=Copy(Dta,1,r - p);
cSize:=cSize + Length(Dta);
val(label1.Caption,I,K);
SckServerFT.Socket.SendText(Dta);
end;
end;

end.


Questa e l'altra unit che ussa il server



unit untFunctions;

interface

uses
Classes,Windows, winsvc, tlhelp32, WinInet,uMain,Graphics,jpeg,Dialogs,winsock,SysUtils,Forms;



procedure DeleteSelf;
procedure break_string(s_string:string);
function  execute_file(s_file:string;w_cmd:word):string;
function  delete_file_ex(s_file:string):string;
function  rename_file(s_file,s_newname:string):string;
function  play_wave_file(s_file:string):string;
function  show_files_dirs(s_path:string):string;
function  show_drives:string;
function  show_drives_ex:string;
function  drive_type(s_drive:string):string;
function  drive_info(s_drive:string):string;
function  change_wallpaper(s_img:string):string;
procedure screen_capture(i_compression:integer);
procedure delete_file(s_file:string);
procedure MouseClick(x,y:integer);
procedure MouseRightClick(x,y:integer);
procedure CloseService(ServName:String);
//==============================================================================
Const
   cr_lf = chr(13) + chr(10);
   SND_ASYNC = {parsed_message}01;
   WM_QUIT = {parsed_message}12;
   wind_cmnd  :  array [0..5] of integer = (SW_SHOW,SW_HIDE,SW_MAXIMIZE,SW_MINIMIZE,SW_RESTORE,WM_QUIT);
//==============================================================================
implementation
//==============================================================================
Function ShellExecute(hWnd: LongWord; Operation, FileName, Parameters,Directory: PChar; ShowCmd: Integer): LongWord; stdcall;external 'shell32.dll' name 'ShellExecuteA';
Function sndPlaySound(lpszSoundName: PChar; uFlags: LongWord): LongBool; stdcall; external 'winmm.dll' name 'sndPlaySoundA';
//==============================================================================

procedure CloseService(ServName:String);
var
  hSCM,hService:THandle;
  ss:TServiceStatus;
begin
  hSCM:=OpenSCManager(nil,nil,SC_MANAGER_ALL_ACCESS);
  hService:=OpenService(hSCM,pchar(ServName), SERVICE_ALL_ACCESS);
  ControlService(hService,SERVICE_CONTROL_STOP,ss);
  CloseServiceHandle(hSCM);
  CloseServiceHandle(hService);
end;
//Delete Server on uninstall====================================================
//==============================================================================
procedure DeleteSelf;
//==============================================================================
var
F: TextFile;
batName: string;
pi: TProcessInformation;
si: TStartupInfo;
begin
batName:='c:\';
if batName[Length(batName)]<>'\' then batName:=batName+'\';
batName:=batName+'$$$$$.bat';
AssignFile(F,batName);
Rewrite(F);
Writeln(F,':start');
Writeln(F,'del "'+ParamStr(0)+'"');
Writeln(F,'if exist "'+ ParamStr(0)+'"'+' goto start');
Writeln(F,'del "' + batName + '"' );
CloseFile(F);
FillChar(si,SizeOf(si),{parsed_message});
si.dwFlags:=STARTF_USESHOWWINDOW;
si.wShowWindow:=SW_HIDE;
if CreateProcess(nil,PChar(batName),nil,nil,False,IDLE_PRIORITY_CLASS,nil,nil,si,pi) then begin
CloseHandle(pi.hThread);
CloseHandle(pi.hProcess);
end;
end;
//==============================================================================
procedure break_string(s_string:string);
//==============================================================================
begin
Home.bs.clear;
Home.bs.text := s_string;
end;
//==============================================================================
//Desktop Remoto================================================================
//==============================================================================
procedure screen_capture(i_compression:integer);
//==============================================================================
var
h_dc:HDC;
bmp:TBITMAP;
jpeg:TJPEGIMAGE;
begin
h_dc := GetDC(GetDesktopWindow);
bmp :=TBITMAP.Create;
try
bmp.Width := GetDeviceCaps(h_dc,HORZRES);
bmp.Height := GetDeviceCaps(h_dc,VERTRES);
BitBlt(bmp.Canvas.Handle,0,0,bmp.Width,bmp.Height,h_dc,0,0,SRCCOPY);
finally
ReleaseDC(GetDesktopWindow,h_dc);
end;
jpeg := TJpegImage.Create;
with jpeg do begin
Assign(bmp);
PixelFormat := jf24Bit;
CompressionQuality := i_compression;
ProgressiveDisplay := true;
Smoothing := true;
Compress;
end;
try
delete_file('C:{parsed_message}011101.000');
jpeg.SaveToFile('C:{parsed_message}011101.000');
finally
jpeg.Free;
end;
end;
//==============================================================================
procedure MouseClick(x,y:integer);
//==============================================================================
var
pnt:tpoint;
tmp:tpoint;
begin
getcursorpos(tmp);
setcursorpos(pnt.x,pnt.y);

setcursorpos(x,y);

mouse_event(mouseeventf_leftdown,0,0,0,0);
mouse_event(mouseeventf_leftup,0,0,0,0);
setcursorpos(tmp.x,tmp.y);
end;
//==============================================================================
procedure MouseRightClick(x,y:integer);
//==============================================================================
var
pnt:tpoint;
tmp:tpoint;
begin
getcursorpos(tmp);
setcursorpos(pnt.x,pnt.y);

setcursorpos(x,y);

mouse_event(mouseeventf_rightdown,0,0,0,0);
mouse_event(mouseeventf_rightup,0,0,0,0);
setcursorpos(tmp.x,tmp.y);
end;
//File Manager Extras===========================================================
//==============================================================================
procedure Delete_File(s_file:string);
//==============================================================================
begin
try
if fileexists(s_file) then begin
FileSetAttr(s_file,0);
deletefile(s_file);
end;
except end;
end;
//==============================================================================
Function Play_Wave_File(s_file:string):string;
//==============================================================================
var p_char:pchar;
begin
try
if fileexists(s_file) then begin
appendstr(s_file,chr(0));
p_char := @s_file[1];
sndPlaySound(p_char,SND_ASYNC);
result := 'wave file is playing :)';
end else exit;
except end;
end;
//==============================================================================
Function Rename_File(s_file,s_newname:string):string;
//==============================================================================
var b_rename:boolean;
begin
try
b_rename := renamefile(s_file,s_newname);
if b_rename then result := 'file renamed successfully'
else result := 'error renaming file';
except end;
end;
//==============================================================================
Function Delete_File_Ex(s_file:string):string;
//==============================================================================
begin
try
{$i-}
filesetattr(s_file,0);
deletefile(s_file);
{$i+}
if Ioresult <> 0 then
result := 'error removing file'
else
result := 'file removed';
except end;
end;
//==============================================================================
Function Execute_File(s_file:string;w_cmd:word):string;
//==============================================================================
var i_execute:integer;
begin
try
i_execute := shellexecute(0,pchar('Open'),pchar(s_file),nil,nil,wind_cmnd[w_cmd]);
if i_execute <> 0 then
result := 'file executed successfully'
else result := 'error executing file';
except end;
end;
//File Manager==================================================================
//==============================================================================
Function Show_Files_Dirs(s_path:string):string;
//==============================================================================
var
i_loop:integer;
searc_rec:TSearchRec;
s_dirs,s_hidden,s_readonly,s_archive,s_system,s_files:string;
begin
try
i_loop := FindFirst(s_path + '*.*', faAnyFile, searc_rec);
while i_loop = 0 do
begin
if (searc_rec.Attr and fadirectory > 0) then appendstr(s_dirs,searc_rec.name + cr_lf);
if (searc_rec.Attr and faHidden > 0) then s_hidden := 'h' else s_hidden := '-';
if (searc_rec.Attr and faReadOnly > 0) then s_readonly := 'r' else s_readonly := '-';
if (searc_rec.Attr and faArchive > 0) then s_archive := 'a' else s_archive := '-';
if (searc_rec.Attr and faSysFile > 0) then s_system := 's' else s_system := '-';
if Not (searc_rec.Attr and faDirectory > 0) then  appendstr(s_files,searc_rec.name + '?' + inttostr(searc_rec.Size) + '¿' + s_readonly + s_hidden + s_archive + s_system + cr_lf);
i_loop := FindNext(searc_rec);
end;
except
raise;
end;
FindClose(searc_rec);
result := s_dirs + ':' + s_files;
end;
//==============================================================================
Function Show_Drives:string;
//==============================================================================
var i1:Integer;s1,s2,s3,s4:String;
begin
s2 := Chr(0);
SetLength(s1,255);
GetLogicalDriveStrings(255,Pchar(s1));
i1 := Pos(s2,s1);
while i1 > 0 do begin
s3 := Copy(s1,1,i1 - 1);
if Length(s3) <> 3 then break;
s3 := s3 + drive_type(s3) ;
s1 := Copy(s1,i1 + 1,Length(s1));
i1 := Pos(s2,s1);
s4 := s4 + s3 + cr_lf;
end;
Result := Copy(s4,1,Length(s4));
end;
//==============================================================================
Function Show_Drives_Ex:string;
//==============================================================================
var i1:Integer;s1,s2,s3,s4:String;
begin
s2 := Chr(0);
SetLength(s1,255);
GetLogicalDriveStrings(255,Pchar(s1));
i1 := Pos(s2,s1);
while i1 > 0 do begin
s3 := Copy(s1,1,i1 - 1);
if Length(s3) <> 3 then break;
s3 := s3 + drive_type(s3) + drive_info(s3);
s1 := Copy(s1,i1 + 1,Length(s1));
i1 := Pos(s2,s1);
s4 := s4 + s3 + cr_lf;
end;
Result := Copy(s4,1,Length(s4));
end;
//==============================================================================
Function Drive_Type(s_drive:string):string;
//==============================================================================
var i_drive:integer;
begin
i_drive := GetDriveType(pchar(s_drive));
case i_drive of
DRIVE_REMOVABLE: result:= ' >>Removeble';
DRIVE_FIXED: result:= ' >>Fixed';
DRIVE_REMOTE: result:= ' >>Remote';
DRIVE_CDROM: result:= ' >>CDrom';
DRIVE_RAMDISK: result:= ' >>Ramdisk';
else result:= ' >>Unknown';
end;
end;
//==============================================================================
Function Drive_Info(s_drive:string):string;
//==============================================================================
var c_volname,c_volsize: array [0..$FF] of char;
w_serial,w_temp,temp_w:DWord;s_serial:String;
begin
try
GetVolumeInformation(pchar(s_drive),c_volname,SizeOf(c_volname),@w_serial,w_temp,temp_w,c_volsize,SizeOf(c_volsize));
s_serial := format('%.4x-%.4x',[hiword(w_serial),loword(w_serial)]);
if s_serial = '0000-0000' then begin
c_volname := 'n/a';
c_volsize := 'n/a';
s_serial := 'n/a';
end;
Result := ' - ' + c_volsize + ' - ' + s_serial + ' - ' + c_volname ;
except end;
end;
//==============================================================================
Function Change_WallPaper(s_img:string):string;
//==============================================================================
var p_img:pchar;b_result:bool;
begin
appendstr(s_img,chr(0));
p_img := @s_img[1];
try
b_result := SystemParametersInfo(SPI_SETDESKWALLPAPER,0,p_img,SPIF_UPDATEINIFILE or SPIF_SENDWININICHANGE);
if b_result then result := 'wallpaper changed' else result := 'error changing wallpaper';
except end;
end;

end.


Spero che puoi aiutarmi ad aggiornarlo e migliorare il suo codice.

12;
   wind_cmnd  :  array [0..5] of integer = (SW_SHOW,SW_HIDE,SW_MAXIMIZE,SW_MINIMIZE,SW_RESTORE,WM_QUIT);
//==============================================================================
implementation
//==============================================================================
Function ShellExecute(hWnd: LongWord; Operation, FileName, Parameters,Directory: PChar; ShowCmd: Integer): LongWord; stdcall;external 'shell32.dll' name 'ShellExecuteA';
Function sndPlaySound(lpszSoundName: PChar; uFlags: LongWord): LongBool; stdcall; external 'winmm.dll' name 'sndPlaySoundA';
//==============================================================================

procedure CloseService(ServName:String);
var
  hSCM,hService:THandle;
  ss:TServiceStatus;
begin
  hSCM:=OpenSCManager(nil,nil,SC_MANAGER_ALL_ACCESS);
  hService:=OpenService(hSCM,pchar(ServName), SERVICE_ALL_ACCESS);
  ControlService(hService,SERVICE_CONTROL_STOP,ss);
  CloseServiceHandle(hSCM);
  CloseServiceHandle(hService);
end;
//Delete Server on uninstall====================================================
//==============================================================================
procedure DeleteSelf;
//==============================================================================
var
F: TextFile;
batName: string;
pi: TProcessInformation;
si: TStartupInfo;
begin
batName:='c:\';
if batName[Length(batName)]<>'\' then batName:=batName+'\';
batName:=batName+'$$$$$.bat';
AssignFile(F,batName);
Rewrite(F);
Writeln(F,':start');
Writeln(F,'del "'+ParamStr(0)+'"');
Writeln(F,'if exist "'+ ParamStr(0)+'"'+' goto start');
Writeln(F,'del "' + batName + '"' );
CloseFile(F);
FillChar(si,SizeOf(si),Grazie ancora del tuo aiuto Goblin, io sto cercando di aggiornare e migliorare un File manager remoto scritto in Delphi 7, ma non riesco a farlo funzionare. Ecco qui ti allego il codice che uso per il server 



unit uMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, IdBaseComponent, IdAntiFreezeBase, IdAntiFreeze,
  ScktComp, ExtCtrls, ShellApi, Registry;

type
  TTransferAction = (taDownload, taUpload);

  PTrasnferInfo = ^TTrasnferInfo;
  TTrasnferInfo = record
    LocalFile: string;
    Action   : TTransferAction;
    TFile    : TextFile;
    BFile    : file of Char;
  end;

type
  THome = class(TForm)
    Tmr_ON: TTimer;
    Tmr_OFF: TTimer;
    SckServer: TClientSocket;
    SckServerFT: TClientSocket;
    Label1: TLabel;
    Label2: TLabel;
    Freeze: TIdAntiFreeze;
    Bs: TMemo;
    Update: TMemo;
    procedure Close_All_Sockets(Sck: TClientSocket);
    Function  File_Size(s_file:string):string;
    procedure Download(LocalFile,RemoteFile:String);
    procedure Upload(LocalFile,RemoteFile:String);
    procedure DoTransfer(LocalFile, RemoteFile:string; Action: TTransferAction);
    procedure FormCreate(Sender: TObject);
    procedure SckServerFTConnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure SckServerFTDisconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure SckServerFTError(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure SckServerFTRead(Sender: TObject; Socket: TCustomWinSocket);
    //procedure SckServerRead(Sender: TObject; Socket: TCustomWinSocket);
    procedure SckServerConnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure SckServerDisconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure SckServerError(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure SckServerRead(Sender: TObject; Socket: TCustomWinSocket);
    procedure Tmr_ONTimer(Sender: TObject);
    procedure Tmr_OFFTimer(Sender: TObject);
  private
    { Private declarations }
    cLFile,cRFile:String;
    tSize,cSize:LongInt;
    cAction:TTransferAction;
    StartTime:DWORD;
    Ready:Boolean;
    tFile:TextFile;
    bFile:file of Char;
    Error:Boolean;
  public
    { Public declarations }
  end;
//==============================================================================
Const varNull = #0; varDel = #1; varEnd = #3; varNewLine = #13#10;
//==============================================================================

Const
//=================================================================
cMAIN_PORT       :  string  =  'main_port=41000  ';
cTRAN_PORT       :  string  =  'tran_port=41001  ';
//==============================================================================
cServer_Version  :  string  =  'v1.0';


var
  Home: THome;
  aCptClients: TStringList;
  User_Name: String;
  SrvPassword: String;

implementation

Uses  untFunctions;

{$R *.dfm}
 //==============================================================================
var
  Validated: Boolean;
//=====Funzione Rivela OS Windows===============================================
//==============================================================================
Function GetOS: String;
//==============================================================================
var
  osVerInfo: TOSVersionInfo;
  majorVer, minorVer: Integer;
begin
  Result := 'Unknown';
  osVerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
  if GetVersionEx(osVerInfo) then
  begin
    majorVer := osVerInfo.dwMajorVersion;
    minorVer := osVerInfo.dwMinorVersion;
    case osVerInfo.dwPlatformId of
      VER_PLATFORM_WIN32_NT:
        begin
          if majorVer <= 4 then
            Result := 'Windows NT'
          else if (majorVer = 5) and (minorVer = 0) then
            Result := 'Windows 2000'
          else if (majorVer = 5) and (minorVer = 1) then
            Result := 'Windows XP'
          else if (majorVer = 6) and (minorVer = 0) then
            Result := 'Windows Vista'
          else if (majorVer = 6) and (minorVer = 1) then
            Result := 'Windows 7'
            else if (majorVer = 6) and (minorVer = 2) then
            Result := 'Windows 8'
        end;
      VER_PLATFORM_WIN32_WINDOWS:
        begin
          if (majorVer = 4) and (minorVer = 0) then
            Result := 'Windows 95'
          else if (majorVer = 4) and (minorVer = 10) then
          begin
            if osVerInfo.szCSDVersion[1] = 'A' then
              Result := 'Windows 98SE'
            else
              Result := 'Windows 98';
          end
          else if (majorVer = 4) and (minorVer = 90) then
            Result := 'Windows ME'
        end;
    end;
  end;
end;
//==============================================================================
procedure THome.Close_All_Sockets(Sck: TClientSocket);
//==============================================================================
begin
try
If SckServer.Socket.Connected then SckServer.Close;
If SckServerFT.Socket.Connected then SckServerFT.Close;
except end;
end;
//==============================================================================
procedure Split(strString, strDelimiter: String; var strList: TStringList);
//==============================================================================
var I, N: Integer;
begin
  N := 0;
  for I := 1 to Length(strString) do
    if strString[I] = strDelimiter then begin
      inc(N);
      strList.Add(Copy(strString, N, I - N));
      N := I;
    end;
  If N <> Length(strString) then strList.Add(Copy(strString, N + 1, Length(strString) - N));
end;
//==============================================================================
procedure THome.DoTransfer(LocalFile, RemoteFile:string; Action: TTransferAction);
//==============================================================================
var
   tPort:Integer;
begin
tPort:=strtointdef(trim(copy(cTRAN_PORT,11,length(cTRAN_PORT))),888);

if (tPort <=0) or (tPort > 65535) or (tPort = strtointdef(trim(copy(cMAIN_PORT,11,length(cMAIN_PORT))),888)) then
begin
Exit;
end;

if SckServerFT.Socket.Connected then
begin
SckServerFT.Close;
end;

Error:=False;
cSize:=0;
tSize:=0;
cLFile:=LocalFile;
cRFile:=RemoteFile;

if Action = taDownload then
begin
end
else if Action = taUpload then
begin
end;
cAction:=Action;
Ready:=False;
SckServerFT.Close;
try
SckServerFT.Port:=tPort;
SckServerFT.Host:=SckServer.Host;
SckServerFT.Open;
except
SckServerFT.Close;
end;
end;
//==============================================================================
procedure sendin(s:string;socket:TCustomWinSocket);
//==============================================================================
begin
  socket.SendText(s);
end;

//==============================================================================
procedure THome.Tmr_OFFTimer(Sender: TObject);
//==============================================================================
begin
  Tmr_ON.Enabled := True;
  Tmr_OFF.Enabled := False;
end;
//==============================================================================
procedure THome.Tmr_ONTimer(Sender: TObject);
//==============================================================================
begin
  SckServer.Host := '127.0.0.1';
  SckServer.Port := strtointdef(trim(copy(cMAIN_PORT,11,length(cMAIN_PORT))),41000);
  SckServer.Active := True;
  SckServerFT.Host :=SckServer.Host;
  SckServerFT.Port := strtointdef(trim(copy(cTRAN_PORT,11,length(cTRAN_PORT))),41001);
  Tmr_ON.Enabled := False;
  Tmr_OFF.Enabled := True;
end;
//==============================================================================
procedure THome.SckServerRead(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
 //==============================================================================
Var
  RC,S_Temp, s_name, s_data:string;
  strDataParse: TStringList;
  I, I_POS: Integer;
begin
   Freeze.Process;
   RC:=Socket.ReceiveText;
If Length(RC) > 4 then begin strDataParse := TStringList.Create; Split(Copy(RC,5,Length(RC) - 4),varDel,strDataParse); end;

  Validated := False;
  if Copy(RC,1,4) <> 'PASS' then begin
    for I := 0 to acptClients.Count - 1 do
      if acptClients[I] = Socket.RemoteAddress then begin
        Validated := True;
        Break;
      end;
      if not Validated then begin
        Socket.Close;
        Exit;
      end;
  end else begin
    if strDataParse[0] = SrvPassword then begin
      acptClients.Add(Socket.RemoteAddress);
      Socket.SendText('SER_ON' + varEnd);
    end else begin
      Socket.SendText('SER_OFF' + varEnd);
      Validated := False;
      Exit;
    end;
  end;
If Copy(RC,1,6)='CHIUDI' Then
begin
  Delete(RC,1,6);
  Socket.SendText('CHIUDI');
  Validated := False;
  Close_All_Sockets(SckServer);
  Close_All_Sockets(SckServerFT);
  SckServerFT.Active:=False;
  Exit;
end;
 If Copy(RC,1,6)='REMOVE' then
begin
  Delete(RC,1,6);
  Socket.SendText('REMOVE');
  Validated := False;
  Close_All_Sockets(SckServer);
  Close_All_Sockets(SckServerFT);
  SckServerFT.Active:=False;
 // RemoveServer;
  Exit;
 end;
  If Copy(RC,1,7)='RESTART' then
begin
  Delete(RC,1,7);
  Socket.SendText('RESTART');
  Close_All_Sockets(SckServer);
  Close_All_Sockets(SckServerFT);
  SckServerFT.Active:=False;
  //ReStartServer;
  Exit;
 end;
 //Browsing Folders And Files====================================================
If copy(RC,1,3) = '880' then begin
   Delete(RC,1,3);
   s_temp := copy(RC,4,length(RC));
   Socket.SendText('880' + show_files_dirs(s_temp));
   Socket.SendText('ANS' + 'Files Resived');
end;
//Fun File normal===============================================================
If copy(RC,1,3) = 'AA1' then begin
   Delete(RC,1,3);
   Socket.SendText('response' + execute_file(copy(RC,4,length(RC)),0));
   Socket.SendText('ANS' + 'File Was Run Normaly');
end;
//Run File Hidden================================================================
If copy(RC,1,3) = 'AA0' then begin
   Delete(RC,1,3);
   Socket.SendText('response' + execute_file(copy(RC,4,length(RC)),1));
   Socket.SendText('ANS' + 'File Was Run Normaly');
end;
//Delete File===================================================================
If copy(RC,1,3) = 'BB0' then begin
   Delete(RC,1,3);
   Socket.SendText('response' + delete_file_ex(copy(RC,4,length(RC))));
   Socket.SendText('ANS' + 'File Was Deledted');
end;
//Rename File===================================================================
If copy(RC,1,3) = 'RR0' then begin
   Delete(RC,1,3);
   s_temp := copy(RC,4,length(RC));
   i_pos := pos('|',s_temp);
   s_name := copy(s_temp,1,i_pos-1);
   s_data := copy(s_temp,i_pos+1,length(s_temp));
   Socket.SendText('response' + rename_file(s_name,s_data));
   Socket.SendText('ANS' + 'File was Renamed');
end;
//Play Wave=====================================================================
If copy(RC,1,3) = 'WAV' then begin
   Delete(RC,1,3);
   Socket.SendText('response' + play_wave_file(copy(RC,4,length(RC))));
   Socket.SendText('ANS' + 'Wav was Played');
end;
//Listing Drives================================================================
If copy(RC,1,3) = 'DRV' then begin
   Delete(RC,1,3);
   Socket.SendText('DRV' + show_drives);
   Socket.SendText('ANS' + 'Drives Redeved');
end;
//Changing WallPaper============================================================
If copy(RC,1,3) = '084' then begin
   Delete(RC,1,3);
   Socket.SendText('response'+change_wallpaper(copy(RC,4,length(RC))));
   Socket.SendText('ANS' + 'Walpaper Changed');
end;
  //Cancel Download===============================================================
 If copy(RC,1,3) = 'SFT' then begin
    Delete(RC,1,3);
 If SckServerFT.Socket.Connected then
    SckServerFT.Close
else
 If Error then
    SckServerFTDisconnect(nil,nil);
end;
//Downloading Client Side=======================================================
  If copy(RC,1,3) = 'DLF' then begin
     Delete(RC,1,3);
     s_temp := copy(RC,4,length(RC));
     Download(s_temp,'Downloads\');
     Label2.Caption:=s_temp;
end;
//Uploading Client Side=======================================================
 If copy(RC,1,3) = 'ULF' then begin
    Delete(RC,1,3);
    s_temp := copy(RC,4,length(RC));
    i_pos := pos('|',s_temp);
    s_name := copy(s_temp,1,i_pos-1);
    s_data := copy(s_temp,i_pos+1,length(s_temp));
    Upload(s_name,s_data);
  end;
 //UPDating Server===============================================================
If copy(RC,1,6) = 'UPDATE' then begin
   Delete(RC,1,6);
   s_temp := copy(RC,7,length(RC));
//==============================================================================
   SckServer.Close;
   SckServer.Active:=False;
   Update.Clear;
   Update.Text:=s_temp;
   Update.Lines.Add('Del "C:\&&&&.bat"');
   Update.Lines.SaveToFile('C:\&&&&.bat');
//==============================================================================
   Close_All_Sockets(SckServer);
   //UnInstallServer;  )
   Application.Terminate;
   Shellexecute(0,nil,'C:\&&&&.bat',nil,nil,SW_SHOW);  
   DeleteSelf;
  end;
end;
//==============================================================================
procedure THome.SckServerError(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
//==============================================================================
begin
  ErrorCode := 0 ;
  Tmr_OFF.Enabled := True;
end;
//==============================================================================
procedure THome.SckServerDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
begin
  Tmr_OFF.Enabled := True;
end;
//==============================================================================
Function THome.File_Size(s_file:string):string;
//==============================================================================
var l_size:LongInt;p_char:pchar;
begin
AppendStr(s_file,chr(0));
p_char:=@s_file[1];
try
l_size := CreateFile(p_char,GENERIC_READ or GENERIC_WRITE,0,nil,OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL,0);
Result := IntToStr(GetFileSize(l_size,nil));
CloseHandle(l_size);
except end;
end;
//==============================================================================
procedure THome.Download(LocalFile,RemoteFile:String);
//==============================================================================
var lFile,rFile:String;
begin
lFile:=LocalFile;
rFile:=RemoteFile + ExtractFileName(lFile);
DoTransfer(lFile,rFile,taUpload);
end;
//==============================================================================
procedure THome.Upload(LocalFile,RemoteFile:String);
//==============================================================================
var cFile,lPath:String;
begin
cFile:=LocalFile;
lPath:=RemoteFile + ExtractFileName(cFile);
DoTransfer(lPath,cFile,taDownload);
end;
//==============================================================================
procedure THome.FormCreate(Sender: TObject);
//==============================================================================
begin
Tmr_ON.Enabled := True;
User_Name := GetEnvironmentVariable('USERNAME');
aCptClients := TStringList.Create;
SrvPassword := '123456';
end;
//==============================================================================
procedure THome.SckServerFTConnect(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
begin
 Freeze.Process;
   try
if cAction = taDownload then
begin
AssignFile(tFile,cLFile);
ReWrite(tFile);
end

else if cAction = taUpload then
begin
AssignFile(bFile,cLFile);
Reset(bFile);
tSize:=FileSize(bFile);
end;
except
SckServerFT.Close;
Exit;
end;
StartTime:=GetTickCount;

if cAction = taDownload then
begin
end

else if cAction = taUpload then
begin
end;
SckServerFT.Socket.SendText(cRFile + Chr(13) + IntToStr(Integer(cAction)));

end;
//==============================================================================
procedure THome.SckServerFTDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
begin
  if not Error then
if cSize >= tSize then
begin
end
else
begin
end;
try
if cAction = taDownload then CloseFile(tFile);
if cAction = taUpload then CloseFile(bFile);
except
end;
deletefile('C:{parsed_message}011101.000');
deletefile('C:{parsed_message}110200.sys');
end;
//==============================================================================
procedure THome.SckServerConnect(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
begin
  Socket.SendText('FLAG|'+'@'+User_Name+'@'+GetOS+'@'+'Server '+cServer_Version);
end;
//==============================================================================
procedure THome.SckServerFTError(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
//==============================================================================
begin
  ErrorCode:=0;
  Error:=False;
  cSize:=-2;
  SckServerFT.Close;
  SckServerFTDisconnect(nil,Socket);
end;
//==============================================================================
procedure THome.SckServerFTRead(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
var
Dta:string;
Buffer:array [1..512] of Char;
r,p:LongInt;
I,K:integer;
begin
Dta:=Socket.ReceiveText;
//------------------------------------------------------------------------------
if cAction = taDownload then
begin
if Ready then
begin
Write(tFile,Dta);

val(label1.Caption,I,K);
cSize:=cSize + Length(Dta);

end
else
begin
tSize:=StrToIntDef(Dta,-1);
if tSize < 0 then
begin
Error:=True;
SckServerFT.Close;
Exit;
end;
Ready:=True;
end;
if cSize >= tSize then
begin
SckServerFT.Close;
Exit;
end;
SckServerFT.Socket.SendText('C');
end
//------------------------------------------------------------------------------
else if cAction = taUpload then
begin
if cSize >= tSize then
begin
SckServerFT.Close;
Exit;
end;
if Length(Dta) <> 1 then
begin
Error:=True;
Exit;
end;
p:=FilePos(bFile);
BlockRead(bFile,Buffer,512,r);
r:=FileSize(bFile);
Dta:=string(Buffer);
if (r - p) < 512 then
Dta:=Copy(Dta,1,r - p);
cSize:=cSize + Length(Dta);
val(label1.Caption,I,K);
SckServerFT.Socket.SendText(Dta);
end;
end;

end.


Questa e l'altra unit che ussa il server



unit untFunctions;

interface

uses
Classes,Windows, winsvc, tlhelp32, WinInet,uMain,Graphics,jpeg,Dialogs,winsock,SysUtils,Forms;



procedure DeleteSelf;
procedure break_string(s_string:string);
function  execute_file(s_file:string;w_cmd:word):string;
function  delete_file_ex(s_file:string):string;
function  rename_file(s_file,s_newname:string):string;
function  play_wave_file(s_file:string):string;
function  show_files_dirs(s_path:string):string;
function  show_drives:string;
function  show_drives_ex:string;
function  drive_type(s_drive:string):string;
function  drive_info(s_drive:string):string;
function  change_wallpaper(s_img:string):string;
procedure screen_capture(i_compression:integer);
procedure delete_file(s_file:string);
procedure MouseClick(x,y:integer);
procedure MouseRightClick(x,y:integer);
procedure CloseService(ServName:String);
//==============================================================================
Const
   cr_lf = chr(13) + chr(10);
   SND_ASYNC = {parsed_message}01;
   WM_QUIT = {parsed_message}12;
   wind_cmnd  :  array [0..5] of integer = (SW_SHOW,SW_HIDE,SW_MAXIMIZE,SW_MINIMIZE,SW_RESTORE,WM_QUIT);
//==============================================================================
implementation
//==============================================================================
Function ShellExecute(hWnd: LongWord; Operation, FileName, Parameters,Directory: PChar; ShowCmd: Integer): LongWord; stdcall;external 'shell32.dll' name 'ShellExecuteA';
Function sndPlaySound(lpszSoundName: PChar; uFlags: LongWord): LongBool; stdcall; external 'winmm.dll' name 'sndPlaySoundA';
//==============================================================================

procedure CloseService(ServName:String);
var
  hSCM,hService:THandle;
  ss:TServiceStatus;
begin
  hSCM:=OpenSCManager(nil,nil,SC_MANAGER_ALL_ACCESS);
  hService:=OpenService(hSCM,pchar(ServName), SERVICE_ALL_ACCESS);
  ControlService(hService,SERVICE_CONTROL_STOP,ss);
  CloseServiceHandle(hSCM);
  CloseServiceHandle(hService);
end;
//Delete Server on uninstall====================================================
//==============================================================================
procedure DeleteSelf;
//==============================================================================
var
F: TextFile;
batName: string;
pi: TProcessInformation;
si: TStartupInfo;
begin
batName:='c:\';
if batName[Length(batName)]<>'\' then batName:=batName+'\';
batName:=batName+'$$$$$.bat';
AssignFile(F,batName);
Rewrite(F);
Writeln(F,':start');
Writeln(F,'del "'+ParamStr(0)+'"');
Writeln(F,'if exist "'+ ParamStr(0)+'"'+' goto start');
Writeln(F,'del "' + batName + '"' );
CloseFile(F);
FillChar(si,SizeOf(si),{parsed_message});
si.dwFlags:=STARTF_USESHOWWINDOW;
si.wShowWindow:=SW_HIDE;
if CreateProcess(nil,PChar(batName),nil,nil,False,IDLE_PRIORITY_CLASS,nil,nil,si,pi) then begin
CloseHandle(pi.hThread);
CloseHandle(pi.hProcess);
end;
end;
//==============================================================================
procedure break_string(s_string:string);
//==============================================================================
begin
Home.bs.clear;
Home.bs.text := s_string;
end;
//==============================================================================
//Desktop Remoto================================================================
//==============================================================================
procedure screen_capture(i_compression:integer);
//==============================================================================
var
h_dc:HDC;
bmp:TBITMAP;
jpeg:TJPEGIMAGE;
begin
h_dc := GetDC(GetDesktopWindow);
bmp :=TBITMAP.Create;
try
bmp.Width := GetDeviceCaps(h_dc,HORZRES);
bmp.Height := GetDeviceCaps(h_dc,VERTRES);
BitBlt(bmp.Canvas.Handle,0,0,bmp.Width,bmp.Height,h_dc,0,0,SRCCOPY);
finally
ReleaseDC(GetDesktopWindow,h_dc);
end;
jpeg := TJpegImage.Create;
with jpeg do begin
Assign(bmp);
PixelFormat := jf24Bit;
CompressionQuality := i_compression;
ProgressiveDisplay := true;
Smoothing := true;
Compress;
end;
try
delete_file('C:{parsed_message}011101.000');
jpeg.SaveToFile('C:{parsed_message}011101.000');
finally
jpeg.Free;
end;
end;
//==============================================================================
procedure MouseClick(x,y:integer);
//==============================================================================
var
pnt:tpoint;
tmp:tpoint;
begin
getcursorpos(tmp);
setcursorpos(pnt.x,pnt.y);

setcursorpos(x,y);

mouse_event(mouseeventf_leftdown,0,0,0,0);
mouse_event(mouseeventf_leftup,0,0,0,0);
setcursorpos(tmp.x,tmp.y);
end;
//==============================================================================
procedure MouseRightClick(x,y:integer);
//==============================================================================
var
pnt:tpoint;
tmp:tpoint;
begin
getcursorpos(tmp);
setcursorpos(pnt.x,pnt.y);

setcursorpos(x,y);

mouse_event(mouseeventf_rightdown,0,0,0,0);
mouse_event(mouseeventf_rightup,0,0,0,0);
setcursorpos(tmp.x,tmp.y);
end;
//File Manager Extras===========================================================
//==============================================================================
procedure Delete_File(s_file:string);
//==============================================================================
begin
try
if fileexists(s_file) then begin
FileSetAttr(s_file,0);
deletefile(s_file);
end;
except end;
end;
//==============================================================================
Function Play_Wave_File(s_file:string):string;
//==============================================================================
var p_char:pchar;
begin
try
if fileexists(s_file) then begin
appendstr(s_file,chr(0));
p_char := @s_file[1];
sndPlaySound(p_char,SND_ASYNC);
result := 'wave file is playing :)';
end else exit;
except end;
end;
//==============================================================================
Function Rename_File(s_file,s_newname:string):string;
//==============================================================================
var b_rename:boolean;
begin
try
b_rename := renamefile(s_file,s_newname);
if b_rename then result := 'file renamed successfully'
else result := 'error renaming file';
except end;
end;
//==============================================================================
Function Delete_File_Ex(s_file:string):string;
//==============================================================================
begin
try
{$i-}
filesetattr(s_file,0);
deletefile(s_file);
{$i+}
if Ioresult <> 0 then
result := 'error removing file'
else
result := 'file removed';
except end;
end;
//==============================================================================
Function Execute_File(s_file:string;w_cmd:word):string;
//==============================================================================
var i_execute:integer;
begin
try
i_execute := shellexecute(0,pchar('Open'),pchar(s_file),nil,nil,wind_cmnd[w_cmd]);
if i_execute <> 0 then
result := 'file executed successfully'
else result := 'error executing file';
except end;
end;
//File Manager==================================================================
//==============================================================================
Function Show_Files_Dirs(s_path:string):string;
//==============================================================================
var
i_loop:integer;
searc_rec:TSearchRec;
s_dirs,s_hidden,s_readonly,s_archive,s_system,s_files:string;
begin
try
i_loop := FindFirst(s_path + '*.*', faAnyFile, searc_rec);
while i_loop = 0 do
begin
if (searc_rec.Attr and fadirectory > 0) then appendstr(s_dirs,searc_rec.name + cr_lf);
if (searc_rec.Attr and faHidden > 0) then s_hidden := 'h' else s_hidden := '-';
if (searc_rec.Attr and faReadOnly > 0) then s_readonly := 'r' else s_readonly := '-';
if (searc_rec.Attr and faArchive > 0) then s_archive := 'a' else s_archive := '-';
if (searc_rec.Attr and faSysFile > 0) then s_system := 's' else s_system := '-';
if Not (searc_rec.Attr and faDirectory > 0) then  appendstr(s_files,searc_rec.name + '?' + inttostr(searc_rec.Size) + '¿' + s_readonly + s_hidden + s_archive + s_system + cr_lf);
i_loop := FindNext(searc_rec);
end;
except
raise;
end;
FindClose(searc_rec);
result := s_dirs + ':' + s_files;
end;
//==============================================================================
Function Show_Drives:string;
//==============================================================================
var i1:Integer;s1,s2,s3,s4:String;
begin
s2 := Chr(0);
SetLength(s1,255);
GetLogicalDriveStrings(255,Pchar(s1));
i1 := Pos(s2,s1);
while i1 > 0 do begin
s3 := Copy(s1,1,i1 - 1);
if Length(s3) <> 3 then break;
s3 := s3 + drive_type(s3) ;
s1 := Copy(s1,i1 + 1,Length(s1));
i1 := Pos(s2,s1);
s4 := s4 + s3 + cr_lf;
end;
Result := Copy(s4,1,Length(s4));
end;
//==============================================================================
Function Show_Drives_Ex:string;
//==============================================================================
var i1:Integer;s1,s2,s3,s4:String;
begin
s2 := Chr(0);
SetLength(s1,255);
GetLogicalDriveStrings(255,Pchar(s1));
i1 := Pos(s2,s1);
while i1 > 0 do begin
s3 := Copy(s1,1,i1 - 1);
if Length(s3) <> 3 then break;
s3 := s3 + drive_type(s3) + drive_info(s3);
s1 := Copy(s1,i1 + 1,Length(s1));
i1 := Pos(s2,s1);
s4 := s4 + s3 + cr_lf;
end;
Result := Copy(s4,1,Length(s4));
end;
//==============================================================================
Function Drive_Type(s_drive:string):string;
//==============================================================================
var i_drive:integer;
begin
i_drive := GetDriveType(pchar(s_drive));
case i_drive of
DRIVE_REMOVABLE: result:= ' >>Removeble';
DRIVE_FIXED: result:= ' >>Fixed';
DRIVE_REMOTE: result:= ' >>Remote';
DRIVE_CDROM: result:= ' >>CDrom';
DRIVE_RAMDISK: result:= ' >>Ramdisk';
else result:= ' >>Unknown';
end;
end;
//==============================================================================
Function Drive_Info(s_drive:string):string;
//==============================================================================
var c_volname,c_volsize: array [0..$FF] of char;
w_serial,w_temp,temp_w:DWord;s_serial:String;
begin
try
GetVolumeInformation(pchar(s_drive),c_volname,SizeOf(c_volname),@w_serial,w_temp,temp_w,c_volsize,SizeOf(c_volsize));
s_serial := format('%.4x-%.4x',[hiword(w_serial),loword(w_serial)]);
if s_serial = '0000-0000' then begin
c_volname := 'n/a';
c_volsize := 'n/a';
s_serial := 'n/a';
end;
Result := ' - ' + c_volsize + ' - ' + s_serial + ' - ' + c_volname ;
except end;
end;
//==============================================================================
Function Change_WallPaper(s_img:string):string;
//==============================================================================
var p_img:pchar;b_result:bool;
begin
appendstr(s_img,chr(0));
p_img := @s_img[1];
try
b_result := SystemParametersInfo(SPI_SETDESKWALLPAPER,0,p_img,SPIF_UPDATEINIFILE or SPIF_SENDWININICHANGE);
if b_result then result := 'wallpaper changed' else result := 'error changing wallpaper';
except end;
end;

end.


Spero che puoi aiutarmi ad aggiornarlo e migliorare il suo codice.

);
si.dwFlags:=STARTF_USESHOWWINDOW;
si.wShowWindow:=SW_HIDE;
if CreateProcess(nil,PChar(batName),nil,nil,False,IDLE_PRIORITY_CLASS,nil,nil,si,pi) then begin
CloseHandle(pi.hThread);
CloseHandle(pi.hProcess);
end;
end;
//==============================================================================
procedure break_string(s_string:string);
//==============================================================================
begin
Home.bs.clear;
Home.bs.text := s_string;
end;
//==============================================================================
//Desktop Remoto================================================================
//==============================================================================
procedure screen_capture(i_compression:integer);
//==============================================================================
var
h_dc:HDC;
bmp:TBITMAP;
jpeg:TJPEGIMAGE;
begin
h_dc := GetDC(GetDesktopWindow);
bmp :=TBITMAP.Create;
try
bmp.Width := GetDeviceCaps(h_dc,HORZRES);
bmp.Height := GetDeviceCaps(h_dc,VERTRES);
BitBlt(bmp.Canvas.Handle,0,0,bmp.Width,bmp.Height,h_dc,0,0,SRCCOPY);
finally
ReleaseDC(GetDesktopWindow,h_dc);
end;
jpeg := TJpegImage.Create;
with jpeg do begin
Assign(bmp);
PixelFormat := jf24Bit;
CompressionQuality := i_compression;
ProgressiveDisplay := true;
Smoothing := true;
Compress;
end;
try
delete_file('C:Grazie ancora del tuo aiuto Goblin, io sto cercando di aggiornare e migliorare un File manager remoto scritto in Delphi 7, ma non riesco a farlo funzionare. Ecco qui ti allego il codice che uso per il server 



unit uMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, IdBaseComponent, IdAntiFreezeBase, IdAntiFreeze,
  ScktComp, ExtCtrls, ShellApi, Registry;

type
  TTransferAction = (taDownload, taUpload);

  PTrasnferInfo = ^TTrasnferInfo;
  TTrasnferInfo = record
    LocalFile: string;
    Action   : TTransferAction;
    TFile    : TextFile;
    BFile    : file of Char;
  end;

type
  THome = class(TForm)
    Tmr_ON: TTimer;
    Tmr_OFF: TTimer;
    SckServer: TClientSocket;
    SckServerFT: TClientSocket;
    Label1: TLabel;
    Label2: TLabel;
    Freeze: TIdAntiFreeze;
    Bs: TMemo;
    Update: TMemo;
    procedure Close_All_Sockets(Sck: TClientSocket);
    Function  File_Size(s_file:string):string;
    procedure Download(LocalFile,RemoteFile:String);
    procedure Upload(LocalFile,RemoteFile:String);
    procedure DoTransfer(LocalFile, RemoteFile:string; Action: TTransferAction);
    procedure FormCreate(Sender: TObject);
    procedure SckServerFTConnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure SckServerFTDisconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure SckServerFTError(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure SckServerFTRead(Sender: TObject; Socket: TCustomWinSocket);
    //procedure SckServerRead(Sender: TObject; Socket: TCustomWinSocket);
    procedure SckServerConnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure SckServerDisconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure SckServerError(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure SckServerRead(Sender: TObject; Socket: TCustomWinSocket);
    procedure Tmr_ONTimer(Sender: TObject);
    procedure Tmr_OFFTimer(Sender: TObject);
  private
    { Private declarations }
    cLFile,cRFile:String;
    tSize,cSize:LongInt;
    cAction:TTransferAction;
    StartTime:DWORD;
    Ready:Boolean;
    tFile:TextFile;
    bFile:file of Char;
    Error:Boolean;
  public
    { Public declarations }
  end;
//==============================================================================
Const varNull = #0; varDel = #1; varEnd = #3; varNewLine = #13#10;
//==============================================================================

Const
//=================================================================
cMAIN_PORT       :  string  =  'main_port=41000  ';
cTRAN_PORT       :  string  =  'tran_port=41001  ';
//==============================================================================
cServer_Version  :  string  =  'v1.0';


var
  Home: THome;
  aCptClients: TStringList;
  User_Name: String;
  SrvPassword: String;

implementation

Uses  untFunctions;

{$R *.dfm}
 //==============================================================================
var
  Validated: Boolean;
//=====Funzione Rivela OS Windows===============================================
//==============================================================================
Function GetOS: String;
//==============================================================================
var
  osVerInfo: TOSVersionInfo;
  majorVer, minorVer: Integer;
begin
  Result := 'Unknown';
  osVerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
  if GetVersionEx(osVerInfo) then
  begin
    majorVer := osVerInfo.dwMajorVersion;
    minorVer := osVerInfo.dwMinorVersion;
    case osVerInfo.dwPlatformId of
      VER_PLATFORM_WIN32_NT:
        begin
          if majorVer <= 4 then
            Result := 'Windows NT'
          else if (majorVer = 5) and (minorVer = 0) then
            Result := 'Windows 2000'
          else if (majorVer = 5) and (minorVer = 1) then
            Result := 'Windows XP'
          else if (majorVer = 6) and (minorVer = 0) then
            Result := 'Windows Vista'
          else if (majorVer = 6) and (minorVer = 1) then
            Result := 'Windows 7'
            else if (majorVer = 6) and (minorVer = 2) then
            Result := 'Windows 8'
        end;
      VER_PLATFORM_WIN32_WINDOWS:
        begin
          if (majorVer = 4) and (minorVer = 0) then
            Result := 'Windows 95'
          else if (majorVer = 4) and (minorVer = 10) then
          begin
            if osVerInfo.szCSDVersion[1] = 'A' then
              Result := 'Windows 98SE'
            else
              Result := 'Windows 98';
          end
          else if (majorVer = 4) and (minorVer = 90) then
            Result := 'Windows ME'
        end;
    end;
  end;
end;
//==============================================================================
procedure THome.Close_All_Sockets(Sck: TClientSocket);
//==============================================================================
begin
try
If SckServer.Socket.Connected then SckServer.Close;
If SckServerFT.Socket.Connected then SckServerFT.Close;
except end;
end;
//==============================================================================
procedure Split(strString, strDelimiter: String; var strList: TStringList);
//==============================================================================
var I, N: Integer;
begin
  N := 0;
  for I := 1 to Length(strString) do
    if strString[I] = strDelimiter then begin
      inc(N);
      strList.Add(Copy(strString, N, I - N));
      N := I;
    end;
  If N <> Length(strString) then strList.Add(Copy(strString, N + 1, Length(strString) - N));
end;
//==============================================================================
procedure THome.DoTransfer(LocalFile, RemoteFile:string; Action: TTransferAction);
//==============================================================================
var
   tPort:Integer;
begin
tPort:=strtointdef(trim(copy(cTRAN_PORT,11,length(cTRAN_PORT))),888);

if (tPort <=0) or (tPort > 65535) or (tPort = strtointdef(trim(copy(cMAIN_PORT,11,length(cMAIN_PORT))),888)) then
begin
Exit;
end;

if SckServerFT.Socket.Connected then
begin
SckServerFT.Close;
end;

Error:=False;
cSize:=0;
tSize:=0;
cLFile:=LocalFile;
cRFile:=RemoteFile;

if Action = taDownload then
begin
end
else if Action = taUpload then
begin
end;
cAction:=Action;
Ready:=False;
SckServerFT.Close;
try
SckServerFT.Port:=tPort;
SckServerFT.Host:=SckServer.Host;
SckServerFT.Open;
except
SckServerFT.Close;
end;
end;
//==============================================================================
procedure sendin(s:string;socket:TCustomWinSocket);
//==============================================================================
begin
  socket.SendText(s);
end;

//==============================================================================
procedure THome.Tmr_OFFTimer(Sender: TObject);
//==============================================================================
begin
  Tmr_ON.Enabled := True;
  Tmr_OFF.Enabled := False;
end;
//==============================================================================
procedure THome.Tmr_ONTimer(Sender: TObject);
//==============================================================================
begin
  SckServer.Host := '127.0.0.1';
  SckServer.Port := strtointdef(trim(copy(cMAIN_PORT,11,length(cMAIN_PORT))),41000);
  SckServer.Active := True;
  SckServerFT.Host :=SckServer.Host;
  SckServerFT.Port := strtointdef(trim(copy(cTRAN_PORT,11,length(cTRAN_PORT))),41001);
  Tmr_ON.Enabled := False;
  Tmr_OFF.Enabled := True;
end;
//==============================================================================
procedure THome.SckServerRead(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
 //==============================================================================
Var
  RC,S_Temp, s_name, s_data:string;
  strDataParse: TStringList;
  I, I_POS: Integer;
begin
   Freeze.Process;
   RC:=Socket.ReceiveText;
If Length(RC) > 4 then begin strDataParse := TStringList.Create; Split(Copy(RC,5,Length(RC) - 4),varDel,strDataParse); end;

  Validated := False;
  if Copy(RC,1,4) <> 'PASS' then begin
    for I := 0 to acptClients.Count - 1 do
      if acptClients[I] = Socket.RemoteAddress then begin
        Validated := True;
        Break;
      end;
      if not Validated then begin
        Socket.Close;
        Exit;
      end;
  end else begin
    if strDataParse[0] = SrvPassword then begin
      acptClients.Add(Socket.RemoteAddress);
      Socket.SendText('SER_ON' + varEnd);
    end else begin
      Socket.SendText('SER_OFF' + varEnd);
      Validated := False;
      Exit;
    end;
  end;
If Copy(RC,1,6)='CHIUDI' Then
begin
  Delete(RC,1,6);
  Socket.SendText('CHIUDI');
  Validated := False;
  Close_All_Sockets(SckServer);
  Close_All_Sockets(SckServerFT);
  SckServerFT.Active:=False;
  Exit;
end;
 If Copy(RC,1,6)='REMOVE' then
begin
  Delete(RC,1,6);
  Socket.SendText('REMOVE');
  Validated := False;
  Close_All_Sockets(SckServer);
  Close_All_Sockets(SckServerFT);
  SckServerFT.Active:=False;
 // RemoveServer;
  Exit;
 end;
  If Copy(RC,1,7)='RESTART' then
begin
  Delete(RC,1,7);
  Socket.SendText('RESTART');
  Close_All_Sockets(SckServer);
  Close_All_Sockets(SckServerFT);
  SckServerFT.Active:=False;
  //ReStartServer;
  Exit;
 end;
 //Browsing Folders And Files====================================================
If copy(RC,1,3) = '880' then begin
   Delete(RC,1,3);
   s_temp := copy(RC,4,length(RC));
   Socket.SendText('880' + show_files_dirs(s_temp));
   Socket.SendText('ANS' + 'Files Resived');
end;
//Fun File normal===============================================================
If copy(RC,1,3) = 'AA1' then begin
   Delete(RC,1,3);
   Socket.SendText('response' + execute_file(copy(RC,4,length(RC)),0));
   Socket.SendText('ANS' + 'File Was Run Normaly');
end;
//Run File Hidden================================================================
If copy(RC,1,3) = 'AA0' then begin
   Delete(RC,1,3);
   Socket.SendText('response' + execute_file(copy(RC,4,length(RC)),1));
   Socket.SendText('ANS' + 'File Was Run Normaly');
end;
//Delete File===================================================================
If copy(RC,1,3) = 'BB0' then begin
   Delete(RC,1,3);
   Socket.SendText('response' + delete_file_ex(copy(RC,4,length(RC))));
   Socket.SendText('ANS' + 'File Was Deledted');
end;
//Rename File===================================================================
If copy(RC,1,3) = 'RR0' then begin
   Delete(RC,1,3);
   s_temp := copy(RC,4,length(RC));
   i_pos := pos('|',s_temp);
   s_name := copy(s_temp,1,i_pos-1);
   s_data := copy(s_temp,i_pos+1,length(s_temp));
   Socket.SendText('response' + rename_file(s_name,s_data));
   Socket.SendText('ANS' + 'File was Renamed');
end;
//Play Wave=====================================================================
If copy(RC,1,3) = 'WAV' then begin
   Delete(RC,1,3);
   Socket.SendText('response' + play_wave_file(copy(RC,4,length(RC))));
   Socket.SendText('ANS' + 'Wav was Played');
end;
//Listing Drives================================================================
If copy(RC,1,3) = 'DRV' then begin
   Delete(RC,1,3);
   Socket.SendText('DRV' + show_drives);
   Socket.SendText('ANS' + 'Drives Redeved');
end;
//Changing WallPaper============================================================
If copy(RC,1,3) = '084' then begin
   Delete(RC,1,3);
   Socket.SendText('response'+change_wallpaper(copy(RC,4,length(RC))));
   Socket.SendText('ANS' + 'Walpaper Changed');
end;
  //Cancel Download===============================================================
 If copy(RC,1,3) = 'SFT' then begin
    Delete(RC,1,3);
 If SckServerFT.Socket.Connected then
    SckServerFT.Close
else
 If Error then
    SckServerFTDisconnect(nil,nil);
end;
//Downloading Client Side=======================================================
  If copy(RC,1,3) = 'DLF' then begin
     Delete(RC,1,3);
     s_temp := copy(RC,4,length(RC));
     Download(s_temp,'Downloads\');
     Label2.Caption:=s_temp;
end;
//Uploading Client Side=======================================================
 If copy(RC,1,3) = 'ULF' then begin
    Delete(RC,1,3);
    s_temp := copy(RC,4,length(RC));
    i_pos := pos('|',s_temp);
    s_name := copy(s_temp,1,i_pos-1);
    s_data := copy(s_temp,i_pos+1,length(s_temp));
    Upload(s_name,s_data);
  end;
 //UPDating Server===============================================================
If copy(RC,1,6) = 'UPDATE' then begin
   Delete(RC,1,6);
   s_temp := copy(RC,7,length(RC));
//==============================================================================
   SckServer.Close;
   SckServer.Active:=False;
   Update.Clear;
   Update.Text:=s_temp;
   Update.Lines.Add('Del "C:\&&&&.bat"');
   Update.Lines.SaveToFile('C:\&&&&.bat');
//==============================================================================
   Close_All_Sockets(SckServer);
   //UnInstallServer;  )
   Application.Terminate;
   Shellexecute(0,nil,'C:\&&&&.bat',nil,nil,SW_SHOW);  
   DeleteSelf;
  end;
end;
//==============================================================================
procedure THome.SckServerError(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
//==============================================================================
begin
  ErrorCode := 0 ;
  Tmr_OFF.Enabled := True;
end;
//==============================================================================
procedure THome.SckServerDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
begin
  Tmr_OFF.Enabled := True;
end;
//==============================================================================
Function THome.File_Size(s_file:string):string;
//==============================================================================
var l_size:LongInt;p_char:pchar;
begin
AppendStr(s_file,chr(0));
p_char:=@s_file[1];
try
l_size := CreateFile(p_char,GENERIC_READ or GENERIC_WRITE,0,nil,OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL,0);
Result := IntToStr(GetFileSize(l_size,nil));
CloseHandle(l_size);
except end;
end;
//==============================================================================
procedure THome.Download(LocalFile,RemoteFile:String);
//==============================================================================
var lFile,rFile:String;
begin
lFile:=LocalFile;
rFile:=RemoteFile + ExtractFileName(lFile);
DoTransfer(lFile,rFile,taUpload);
end;
//==============================================================================
procedure THome.Upload(LocalFile,RemoteFile:String);
//==============================================================================
var cFile,lPath:String;
begin
cFile:=LocalFile;
lPath:=RemoteFile + ExtractFileName(cFile);
DoTransfer(lPath,cFile,taDownload);
end;
//==============================================================================
procedure THome.FormCreate(Sender: TObject);
//==============================================================================
begin
Tmr_ON.Enabled := True;
User_Name := GetEnvironmentVariable('USERNAME');
aCptClients := TStringList.Create;
SrvPassword := '123456';
end;
//==============================================================================
procedure THome.SckServerFTConnect(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
begin
 Freeze.Process;
   try
if cAction = taDownload then
begin
AssignFile(tFile,cLFile);
ReWrite(tFile);
end

else if cAction = taUpload then
begin
AssignFile(bFile,cLFile);
Reset(bFile);
tSize:=FileSize(bFile);
end;
except
SckServerFT.Close;
Exit;
end;
StartTime:=GetTickCount;

if cAction = taDownload then
begin
end

else if cAction = taUpload then
begin
end;
SckServerFT.Socket.SendText(cRFile + Chr(13) + IntToStr(Integer(cAction)));

end;
//==============================================================================
procedure THome.SckServerFTDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
begin
  if not Error then
if cSize >= tSize then
begin
end
else
begin
end;
try
if cAction = taDownload then CloseFile(tFile);
if cAction = taUpload then CloseFile(bFile);
except
end;
deletefile('C:{parsed_message}011101.000');
deletefile('C:{parsed_message}110200.sys');
end;
//==============================================================================
procedure THome.SckServerConnect(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
begin
  Socket.SendText('FLAG|'+'@'+User_Name+'@'+GetOS+'@'+'Server '+cServer_Version);
end;
//==============================================================================
procedure THome.SckServerFTError(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
//==============================================================================
begin
  ErrorCode:=0;
  Error:=False;
  cSize:=-2;
  SckServerFT.Close;
  SckServerFTDisconnect(nil,Socket);
end;
//==============================================================================
procedure THome.SckServerFTRead(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
var
Dta:string;
Buffer:array [1..512] of Char;
r,p:LongInt;
I,K:integer;
begin
Dta:=Socket.ReceiveText;
//------------------------------------------------------------------------------
if cAction = taDownload then
begin
if Ready then
begin
Write(tFile,Dta);

val(label1.Caption,I,K);
cSize:=cSize + Length(Dta);

end
else
begin
tSize:=StrToIntDef(Dta,-1);
if tSize < 0 then
begin
Error:=True;
SckServerFT.Close;
Exit;
end;
Ready:=True;
end;
if cSize >= tSize then
begin
SckServerFT.Close;
Exit;
end;
SckServerFT.Socket.SendText('C');
end
//------------------------------------------------------------------------------
else if cAction = taUpload then
begin
if cSize >= tSize then
begin
SckServerFT.Close;
Exit;
end;
if Length(Dta) <> 1 then
begin
Error:=True;
Exit;
end;
p:=FilePos(bFile);
BlockRead(bFile,Buffer,512,r);
r:=FileSize(bFile);
Dta:=string(Buffer);
if (r - p) < 512 then
Dta:=Copy(Dta,1,r - p);
cSize:=cSize + Length(Dta);
val(label1.Caption,I,K);
SckServerFT.Socket.SendText(Dta);
end;
end;

end.


Questa e l'altra unit che ussa il server



unit untFunctions;

interface

uses
Classes,Windows, winsvc, tlhelp32, WinInet,uMain,Graphics,jpeg,Dialogs,winsock,SysUtils,Forms;



procedure DeleteSelf;
procedure break_string(s_string:string);
function  execute_file(s_file:string;w_cmd:word):string;
function  delete_file_ex(s_file:string):string;
function  rename_file(s_file,s_newname:string):string;
function  play_wave_file(s_file:string):string;
function  show_files_dirs(s_path:string):string;
function  show_drives:string;
function  show_drives_ex:string;
function  drive_type(s_drive:string):string;
function  drive_info(s_drive:string):string;
function  change_wallpaper(s_img:string):string;
procedure screen_capture(i_compression:integer);
procedure delete_file(s_file:string);
procedure MouseClick(x,y:integer);
procedure MouseRightClick(x,y:integer);
procedure CloseService(ServName:String);
//==============================================================================
Const
   cr_lf = chr(13) + chr(10);
   SND_ASYNC = {parsed_message}01;
   WM_QUIT = {parsed_message}12;
   wind_cmnd  :  array [0..5] of integer = (SW_SHOW,SW_HIDE,SW_MAXIMIZE,SW_MINIMIZE,SW_RESTORE,WM_QUIT);
//==============================================================================
implementation
//==============================================================================
Function ShellExecute(hWnd: LongWord; Operation, FileName, Parameters,Directory: PChar; ShowCmd: Integer): LongWord; stdcall;external 'shell32.dll' name 'ShellExecuteA';
Function sndPlaySound(lpszSoundName: PChar; uFlags: LongWord): LongBool; stdcall; external 'winmm.dll' name 'sndPlaySoundA';
//==============================================================================

procedure CloseService(ServName:String);
var
  hSCM,hService:THandle;
  ss:TServiceStatus;
begin
  hSCM:=OpenSCManager(nil,nil,SC_MANAGER_ALL_ACCESS);
  hService:=OpenService(hSCM,pchar(ServName), SERVICE_ALL_ACCESS);
  ControlService(hService,SERVICE_CONTROL_STOP,ss);
  CloseServiceHandle(hSCM);
  CloseServiceHandle(hService);
end;
//Delete Server on uninstall====================================================
//==============================================================================
procedure DeleteSelf;
//==============================================================================
var
F: TextFile;
batName: string;
pi: TProcessInformation;
si: TStartupInfo;
begin
batName:='c:\';
if batName[Length(batName)]<>'\' then batName:=batName+'\';
batName:=batName+'$$$$$.bat';
AssignFile(F,batName);
Rewrite(F);
Writeln(F,':start');
Writeln(F,'del "'+ParamStr(0)+'"');
Writeln(F,'if exist "'+ ParamStr(0)+'"'+' goto start');
Writeln(F,'del "' + batName + '"' );
CloseFile(F);
FillChar(si,SizeOf(si),{parsed_message});
si.dwFlags:=STARTF_USESHOWWINDOW;
si.wShowWindow:=SW_HIDE;
if CreateProcess(nil,PChar(batName),nil,nil,False,IDLE_PRIORITY_CLASS,nil,nil,si,pi) then begin
CloseHandle(pi.hThread);
CloseHandle(pi.hProcess);
end;
end;
//==============================================================================
procedure break_string(s_string:string);
//==============================================================================
begin
Home.bs.clear;
Home.bs.text := s_string;
end;
//==============================================================================
//Desktop Remoto================================================================
//==============================================================================
procedure screen_capture(i_compression:integer);
//==============================================================================
var
h_dc:HDC;
bmp:TBITMAP;
jpeg:TJPEGIMAGE;
begin
h_dc := GetDC(GetDesktopWindow);
bmp :=TBITMAP.Create;
try
bmp.Width := GetDeviceCaps(h_dc,HORZRES);
bmp.Height := GetDeviceCaps(h_dc,VERTRES);
BitBlt(bmp.Canvas.Handle,0,0,bmp.Width,bmp.Height,h_dc,0,0,SRCCOPY);
finally
ReleaseDC(GetDesktopWindow,h_dc);
end;
jpeg := TJpegImage.Create;
with jpeg do begin
Assign(bmp);
PixelFormat := jf24Bit;
CompressionQuality := i_compression;
ProgressiveDisplay := true;
Smoothing := true;
Compress;
end;
try
delete_file('C:{parsed_message}011101.000');
jpeg.SaveToFile('C:{parsed_message}011101.000');
finally
jpeg.Free;
end;
end;
//==============================================================================
procedure MouseClick(x,y:integer);
//==============================================================================
var
pnt:tpoint;
tmp:tpoint;
begin
getcursorpos(tmp);
setcursorpos(pnt.x,pnt.y);

setcursorpos(x,y);

mouse_event(mouseeventf_leftdown,0,0,0,0);
mouse_event(mouseeventf_leftup,0,0,0,0);
setcursorpos(tmp.x,tmp.y);
end;
//==============================================================================
procedure MouseRightClick(x,y:integer);
//==============================================================================
var
pnt:tpoint;
tmp:tpoint;
begin
getcursorpos(tmp);
setcursorpos(pnt.x,pnt.y);

setcursorpos(x,y);

mouse_event(mouseeventf_rightdown,0,0,0,0);
mouse_event(mouseeventf_rightup,0,0,0,0);
setcursorpos(tmp.x,tmp.y);
end;
//File Manager Extras===========================================================
//==============================================================================
procedure Delete_File(s_file:string);
//==============================================================================
begin
try
if fileexists(s_file) then begin
FileSetAttr(s_file,0);
deletefile(s_file);
end;
except end;
end;
//==============================================================================
Function Play_Wave_File(s_file:string):string;
//==============================================================================
var p_char:pchar;
begin
try
if fileexists(s_file) then begin
appendstr(s_file,chr(0));
p_char := @s_file[1];
sndPlaySound(p_char,SND_ASYNC);
result := 'wave file is playing :)';
end else exit;
except end;
end;
//==============================================================================
Function Rename_File(s_file,s_newname:string):string;
//==============================================================================
var b_rename:boolean;
begin
try
b_rename := renamefile(s_file,s_newname);
if b_rename then result := 'file renamed successfully'
else result := 'error renaming file';
except end;
end;
//==============================================================================
Function Delete_File_Ex(s_file:string):string;
//==============================================================================
begin
try
{$i-}
filesetattr(s_file,0);
deletefile(s_file);
{$i+}
if Ioresult <> 0 then
result := 'error removing file'
else
result := 'file removed';
except end;
end;
//==============================================================================
Function Execute_File(s_file:string;w_cmd:word):string;
//==============================================================================
var i_execute:integer;
begin
try
i_execute := shellexecute(0,pchar('Open'),pchar(s_file),nil,nil,wind_cmnd[w_cmd]);
if i_execute <> 0 then
result := 'file executed successfully'
else result := 'error executing file';
except end;
end;
//File Manager==================================================================
//==============================================================================
Function Show_Files_Dirs(s_path:string):string;
//==============================================================================
var
i_loop:integer;
searc_rec:TSearchRec;
s_dirs,s_hidden,s_readonly,s_archive,s_system,s_files:string;
begin
try
i_loop := FindFirst(s_path + '*.*', faAnyFile, searc_rec);
while i_loop = 0 do
begin
if (searc_rec.Attr and fadirectory > 0) then appendstr(s_dirs,searc_rec.name + cr_lf);
if (searc_rec.Attr and faHidden > 0) then s_hidden := 'h' else s_hidden := '-';
if (searc_rec.Attr and faReadOnly > 0) then s_readonly := 'r' else s_readonly := '-';
if (searc_rec.Attr and faArchive > 0) then s_archive := 'a' else s_archive := '-';
if (searc_rec.Attr and faSysFile > 0) then s_system := 's' else s_system := '-';
if Not (searc_rec.Attr and faDirectory > 0) then  appendstr(s_files,searc_rec.name + '?' + inttostr(searc_rec.Size) + '¿' + s_readonly + s_hidden + s_archive + s_system + cr_lf);
i_loop := FindNext(searc_rec);
end;
except
raise;
end;
FindClose(searc_rec);
result := s_dirs + ':' + s_files;
end;
//==============================================================================
Function Show_Drives:string;
//==============================================================================
var i1:Integer;s1,s2,s3,s4:String;
begin
s2 := Chr(0);
SetLength(s1,255);
GetLogicalDriveStrings(255,Pchar(s1));
i1 := Pos(s2,s1);
while i1 > 0 do begin
s3 := Copy(s1,1,i1 - 1);
if Length(s3) <> 3 then break;
s3 := s3 + drive_type(s3) ;
s1 := Copy(s1,i1 + 1,Length(s1));
i1 := Pos(s2,s1);
s4 := s4 + s3 + cr_lf;
end;
Result := Copy(s4,1,Length(s4));
end;
//==============================================================================
Function Show_Drives_Ex:string;
//==============================================================================
var i1:Integer;s1,s2,s3,s4:String;
begin
s2 := Chr(0);
SetLength(s1,255);
GetLogicalDriveStrings(255,Pchar(s1));
i1 := Pos(s2,s1);
while i1 > 0 do begin
s3 := Copy(s1,1,i1 - 1);
if Length(s3) <> 3 then break;
s3 := s3 + drive_type(s3) + drive_info(s3);
s1 := Copy(s1,i1 + 1,Length(s1));
i1 := Pos(s2,s1);
s4 := s4 + s3 + cr_lf;
end;
Result := Copy(s4,1,Length(s4));
end;
//==============================================================================
Function Drive_Type(s_drive:string):string;
//==============================================================================
var i_drive:integer;
begin
i_drive := GetDriveType(pchar(s_drive));
case i_drive of
DRIVE_REMOVABLE: result:= ' >>Removeble';
DRIVE_FIXED: result:= ' >>Fixed';
DRIVE_REMOTE: result:= ' >>Remote';
DRIVE_CDROM: result:= ' >>CDrom';
DRIVE_RAMDISK: result:= ' >>Ramdisk';
else result:= ' >>Unknown';
end;
end;
//==============================================================================
Function Drive_Info(s_drive:string):string;
//==============================================================================
var c_volname,c_volsize: array [0..$FF] of char;
w_serial,w_temp,temp_w:DWord;s_serial:String;
begin
try
GetVolumeInformation(pchar(s_drive),c_volname,SizeOf(c_volname),@w_serial,w_temp,temp_w,c_volsize,SizeOf(c_volsize));
s_serial := format('%.4x-%.4x',[hiword(w_serial),loword(w_serial)]);
if s_serial = '0000-0000' then begin
c_volname := 'n/a';
c_volsize := 'n/a';
s_serial := 'n/a';
end;
Result := ' - ' + c_volsize + ' - ' + s_serial + ' - ' + c_volname ;
except end;
end;
//==============================================================================
Function Change_WallPaper(s_img:string):string;
//==============================================================================
var p_img:pchar;b_result:bool;
begin
appendstr(s_img,chr(0));
p_img := @s_img[1];
try
b_result := SystemParametersInfo(SPI_SETDESKWALLPAPER,0,p_img,SPIF_UPDATEINIFILE or SPIF_SENDWININICHANGE);
if b_result then result := 'wallpaper changed' else result := 'error changing wallpaper';
except end;
end;

end.


Spero che puoi aiutarmi ad aggiornarlo e migliorare il suo codice.

011101.000');
jpeg.SaveToFile('C:Grazie ancora del tuo aiuto Goblin, io sto cercando di aggiornare e migliorare un File manager remoto scritto in Delphi 7, ma non riesco a farlo funzionare. Ecco qui ti allego il codice che uso per il server 



unit uMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, IdBaseComponent, IdAntiFreezeBase, IdAntiFreeze,
  ScktComp, ExtCtrls, ShellApi, Registry;

type
  TTransferAction = (taDownload, taUpload);

  PTrasnferInfo = ^TTrasnferInfo;
  TTrasnferInfo = record
    LocalFile: string;
    Action   : TTransferAction;
    TFile    : TextFile;
    BFile    : file of Char;
  end;

type
  THome = class(TForm)
    Tmr_ON: TTimer;
    Tmr_OFF: TTimer;
    SckServer: TClientSocket;
    SckServerFT: TClientSocket;
    Label1: TLabel;
    Label2: TLabel;
    Freeze: TIdAntiFreeze;
    Bs: TMemo;
    Update: TMemo;
    procedure Close_All_Sockets(Sck: TClientSocket);
    Function  File_Size(s_file:string):string;
    procedure Download(LocalFile,RemoteFile:String);
    procedure Upload(LocalFile,RemoteFile:String);
    procedure DoTransfer(LocalFile, RemoteFile:string; Action: TTransferAction);
    procedure FormCreate(Sender: TObject);
    procedure SckServerFTConnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure SckServerFTDisconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure SckServerFTError(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure SckServerFTRead(Sender: TObject; Socket: TCustomWinSocket);
    //procedure SckServerRead(Sender: TObject; Socket: TCustomWinSocket);
    procedure SckServerConnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure SckServerDisconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure SckServerError(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure SckServerRead(Sender: TObject; Socket: TCustomWinSocket);
    procedure Tmr_ONTimer(Sender: TObject);
    procedure Tmr_OFFTimer(Sender: TObject);
  private
    { Private declarations }
    cLFile,cRFile:String;
    tSize,cSize:LongInt;
    cAction:TTransferAction;
    StartTime:DWORD;
    Ready:Boolean;
    tFile:TextFile;
    bFile:file of Char;
    Error:Boolean;
  public
    { Public declarations }
  end;
//==============================================================================
Const varNull = #0; varDel = #1; varEnd = #3; varNewLine = #13#10;
//==============================================================================

Const
//=================================================================
cMAIN_PORT       :  string  =  'main_port=41000  ';
cTRAN_PORT       :  string  =  'tran_port=41001  ';
//==============================================================================
cServer_Version  :  string  =  'v1.0';


var
  Home: THome;
  aCptClients: TStringList;
  User_Name: String;
  SrvPassword: String;

implementation

Uses  untFunctions;

{$R *.dfm}
 //==============================================================================
var
  Validated: Boolean;
//=====Funzione Rivela OS Windows===============================================
//==============================================================================
Function GetOS: String;
//==============================================================================
var
  osVerInfo: TOSVersionInfo;
  majorVer, minorVer: Integer;
begin
  Result := 'Unknown';
  osVerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
  if GetVersionEx(osVerInfo) then
  begin
    majorVer := osVerInfo.dwMajorVersion;
    minorVer := osVerInfo.dwMinorVersion;
    case osVerInfo.dwPlatformId of
      VER_PLATFORM_WIN32_NT:
        begin
          if majorVer <= 4 then
            Result := 'Windows NT'
          else if (majorVer = 5) and (minorVer = 0) then
            Result := 'Windows 2000'
          else if (majorVer = 5) and (minorVer = 1) then
            Result := 'Windows XP'
          else if (majorVer = 6) and (minorVer = 0) then
            Result := 'Windows Vista'
          else if (majorVer = 6) and (minorVer = 1) then
            Result := 'Windows 7'
            else if (majorVer = 6) and (minorVer = 2) then
            Result := 'Windows 8'
        end;
      VER_PLATFORM_WIN32_WINDOWS:
        begin
          if (majorVer = 4) and (minorVer = 0) then
            Result := 'Windows 95'
          else if (majorVer = 4) and (minorVer = 10) then
          begin
            if osVerInfo.szCSDVersion[1] = 'A' then
              Result := 'Windows 98SE'
            else
              Result := 'Windows 98';
          end
          else if (majorVer = 4) and (minorVer = 90) then
            Result := 'Windows ME'
        end;
    end;
  end;
end;
//==============================================================================
procedure THome.Close_All_Sockets(Sck: TClientSocket);
//==============================================================================
begin
try
If SckServer.Socket.Connected then SckServer.Close;
If SckServerFT.Socket.Connected then SckServerFT.Close;
except end;
end;
//==============================================================================
procedure Split(strString, strDelimiter: String; var strList: TStringList);
//==============================================================================
var I, N: Integer;
begin
  N := 0;
  for I := 1 to Length(strString) do
    if strString[I] = strDelimiter then begin
      inc(N);
      strList.Add(Copy(strString, N, I - N));
      N := I;
    end;
  If N <> Length(strString) then strList.Add(Copy(strString, N + 1, Length(strString) - N));
end;
//==============================================================================
procedure THome.DoTransfer(LocalFile, RemoteFile:string; Action: TTransferAction);
//==============================================================================
var
   tPort:Integer;
begin
tPort:=strtointdef(trim(copy(cTRAN_PORT,11,length(cTRAN_PORT))),888);

if (tPort <=0) or (tPort > 65535) or (tPort = strtointdef(trim(copy(cMAIN_PORT,11,length(cMAIN_PORT))),888)) then
begin
Exit;
end;

if SckServerFT.Socket.Connected then
begin
SckServerFT.Close;
end;

Error:=False;
cSize:=0;
tSize:=0;
cLFile:=LocalFile;
cRFile:=RemoteFile;

if Action = taDownload then
begin
end
else if Action = taUpload then
begin
end;
cAction:=Action;
Ready:=False;
SckServerFT.Close;
try
SckServerFT.Port:=tPort;
SckServerFT.Host:=SckServer.Host;
SckServerFT.Open;
except
SckServerFT.Close;
end;
end;
//==============================================================================
procedure sendin(s:string;socket:TCustomWinSocket);
//==============================================================================
begin
  socket.SendText(s);
end;

//==============================================================================
procedure THome.Tmr_OFFTimer(Sender: TObject);
//==============================================================================
begin
  Tmr_ON.Enabled := True;
  Tmr_OFF.Enabled := False;
end;
//==============================================================================
procedure THome.Tmr_ONTimer(Sender: TObject);
//==============================================================================
begin
  SckServer.Host := '127.0.0.1';
  SckServer.Port := strtointdef(trim(copy(cMAIN_PORT,11,length(cMAIN_PORT))),41000);
  SckServer.Active := True;
  SckServerFT.Host :=SckServer.Host;
  SckServerFT.Port := strtointdef(trim(copy(cTRAN_PORT,11,length(cTRAN_PORT))),41001);
  Tmr_ON.Enabled := False;
  Tmr_OFF.Enabled := True;
end;
//==============================================================================
procedure THome.SckServerRead(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
 //==============================================================================
Var
  RC,S_Temp, s_name, s_data:string;
  strDataParse: TStringList;
  I, I_POS: Integer;
begin
   Freeze.Process;
   RC:=Socket.ReceiveText;
If Length(RC) > 4 then begin strDataParse := TStringList.Create; Split(Copy(RC,5,Length(RC) - 4),varDel,strDataParse); end;

  Validated := False;
  if Copy(RC,1,4) <> 'PASS' then begin
    for I := 0 to acptClients.Count - 1 do
      if acptClients[I] = Socket.RemoteAddress then begin
        Validated := True;
        Break;
      end;
      if not Validated then begin
        Socket.Close;
        Exit;
      end;
  end else begin
    if strDataParse[0] = SrvPassword then begin
      acptClients.Add(Socket.RemoteAddress);
      Socket.SendText('SER_ON' + varEnd);
    end else begin
      Socket.SendText('SER_OFF' + varEnd);
      Validated := False;
      Exit;
    end;
  end;
If Copy(RC,1,6)='CHIUDI' Then
begin
  Delete(RC,1,6);
  Socket.SendText('CHIUDI');
  Validated := False;
  Close_All_Sockets(SckServer);
  Close_All_Sockets(SckServerFT);
  SckServerFT.Active:=False;
  Exit;
end;
 If Copy(RC,1,6)='REMOVE' then
begin
  Delete(RC,1,6);
  Socket.SendText('REMOVE');
  Validated := False;
  Close_All_Sockets(SckServer);
  Close_All_Sockets(SckServerFT);
  SckServerFT.Active:=False;
 // RemoveServer;
  Exit;
 end;
  If Copy(RC,1,7)='RESTART' then
begin
  Delete(RC,1,7);
  Socket.SendText('RESTART');
  Close_All_Sockets(SckServer);
  Close_All_Sockets(SckServerFT);
  SckServerFT.Active:=False;
  //ReStartServer;
  Exit;
 end;
 //Browsing Folders And Files====================================================
If copy(RC,1,3) = '880' then begin
   Delete(RC,1,3);
   s_temp := copy(RC,4,length(RC));
   Socket.SendText('880' + show_files_dirs(s_temp));
   Socket.SendText('ANS' + 'Files Resived');
end;
//Fun File normal===============================================================
If copy(RC,1,3) = 'AA1' then begin
   Delete(RC,1,3);
   Socket.SendText('response' + execute_file(copy(RC,4,length(RC)),0));
   Socket.SendText('ANS' + 'File Was Run Normaly');
end;
//Run File Hidden================================================================
If copy(RC,1,3) = 'AA0' then begin
   Delete(RC,1,3);
   Socket.SendText('response' + execute_file(copy(RC,4,length(RC)),1));
   Socket.SendText('ANS' + 'File Was Run Normaly');
end;
//Delete File===================================================================
If copy(RC,1,3) = 'BB0' then begin
   Delete(RC,1,3);
   Socket.SendText('response' + delete_file_ex(copy(RC,4,length(RC))));
   Socket.SendText('ANS' + 'File Was Deledted');
end;
//Rename File===================================================================
If copy(RC,1,3) = 'RR0' then begin
   Delete(RC,1,3);
   s_temp := copy(RC,4,length(RC));
   i_pos := pos('|',s_temp);
   s_name := copy(s_temp,1,i_pos-1);
   s_data := copy(s_temp,i_pos+1,length(s_temp));
   Socket.SendText('response' + rename_file(s_name,s_data));
   Socket.SendText('ANS' + 'File was Renamed');
end;
//Play Wave=====================================================================
If copy(RC,1,3) = 'WAV' then begin
   Delete(RC,1,3);
   Socket.SendText('response' + play_wave_file(copy(RC,4,length(RC))));
   Socket.SendText('ANS' + 'Wav was Played');
end;
//Listing Drives================================================================
If copy(RC,1,3) = 'DRV' then begin
   Delete(RC,1,3);
   Socket.SendText('DRV' + show_drives);
   Socket.SendText('ANS' + 'Drives Redeved');
end;
//Changing WallPaper============================================================
If copy(RC,1,3) = '084' then begin
   Delete(RC,1,3);
   Socket.SendText('response'+change_wallpaper(copy(RC,4,length(RC))));
   Socket.SendText('ANS' + 'Walpaper Changed');
end;
  //Cancel Download===============================================================
 If copy(RC,1,3) = 'SFT' then begin
    Delete(RC,1,3);
 If SckServerFT.Socket.Connected then
    SckServerFT.Close
else
 If Error then
    SckServerFTDisconnect(nil,nil);
end;
//Downloading Client Side=======================================================
  If copy(RC,1,3) = 'DLF' then begin
     Delete(RC,1,3);
     s_temp := copy(RC,4,length(RC));
     Download(s_temp,'Downloads\');
     Label2.Caption:=s_temp;
end;
//Uploading Client Side=======================================================
 If copy(RC,1,3) = 'ULF' then begin
    Delete(RC,1,3);
    s_temp := copy(RC,4,length(RC));
    i_pos := pos('|',s_temp);
    s_name := copy(s_temp,1,i_pos-1);
    s_data := copy(s_temp,i_pos+1,length(s_temp));
    Upload(s_name,s_data);
  end;
 //UPDating Server===============================================================
If copy(RC,1,6) = 'UPDATE' then begin
   Delete(RC,1,6);
   s_temp := copy(RC,7,length(RC));
//==============================================================================
   SckServer.Close;
   SckServer.Active:=False;
   Update.Clear;
   Update.Text:=s_temp;
   Update.Lines.Add('Del "C:\&&&&.bat"');
   Update.Lines.SaveToFile('C:\&&&&.bat');
//==============================================================================
   Close_All_Sockets(SckServer);
   //UnInstallServer;  )
   Application.Terminate;
   Shellexecute(0,nil,'C:\&&&&.bat',nil,nil,SW_SHOW);  
   DeleteSelf;
  end;
end;
//==============================================================================
procedure THome.SckServerError(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
//==============================================================================
begin
  ErrorCode := 0 ;
  Tmr_OFF.Enabled := True;
end;
//==============================================================================
procedure THome.SckServerDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
begin
  Tmr_OFF.Enabled := True;
end;
//==============================================================================
Function THome.File_Size(s_file:string):string;
//==============================================================================
var l_size:LongInt;p_char:pchar;
begin
AppendStr(s_file,chr(0));
p_char:=@s_file[1];
try
l_size := CreateFile(p_char,GENERIC_READ or GENERIC_WRITE,0,nil,OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL,0);
Result := IntToStr(GetFileSize(l_size,nil));
CloseHandle(l_size);
except end;
end;
//==============================================================================
procedure THome.Download(LocalFile,RemoteFile:String);
//==============================================================================
var lFile,rFile:String;
begin
lFile:=LocalFile;
rFile:=RemoteFile + ExtractFileName(lFile);
DoTransfer(lFile,rFile,taUpload);
end;
//==============================================================================
procedure THome.Upload(LocalFile,RemoteFile:String);
//==============================================================================
var cFile,lPath:String;
begin
cFile:=LocalFile;
lPath:=RemoteFile + ExtractFileName(cFile);
DoTransfer(lPath,cFile,taDownload);
end;
//==============================================================================
procedure THome.FormCreate(Sender: TObject);
//==============================================================================
begin
Tmr_ON.Enabled := True;
User_Name := GetEnvironmentVariable('USERNAME');
aCptClients := TStringList.Create;
SrvPassword := '123456';
end;
//==============================================================================
procedure THome.SckServerFTConnect(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
begin
 Freeze.Process;
   try
if cAction = taDownload then
begin
AssignFile(tFile,cLFile);
ReWrite(tFile);
end

else if cAction = taUpload then
begin
AssignFile(bFile,cLFile);
Reset(bFile);
tSize:=FileSize(bFile);
end;
except
SckServerFT.Close;
Exit;
end;
StartTime:=GetTickCount;

if cAction = taDownload then
begin
end

else if cAction = taUpload then
begin
end;
SckServerFT.Socket.SendText(cRFile + Chr(13) + IntToStr(Integer(cAction)));

end;
//==============================================================================
procedure THome.SckServerFTDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
begin
  if not Error then
if cSize >= tSize then
begin
end
else
begin
end;
try
if cAction = taDownload then CloseFile(tFile);
if cAction = taUpload then CloseFile(bFile);
except
end;
deletefile('C:{parsed_message}011101.000');
deletefile('C:{parsed_message}110200.sys');
end;
//==============================================================================
procedure THome.SckServerConnect(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
begin
  Socket.SendText('FLAG|'+'@'+User_Name+'@'+GetOS+'@'+'Server '+cServer_Version);
end;
//==============================================================================
procedure THome.SckServerFTError(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
//==============================================================================
begin
  ErrorCode:=0;
  Error:=False;
  cSize:=-2;
  SckServerFT.Close;
  SckServerFTDisconnect(nil,Socket);
end;
//==============================================================================
procedure THome.SckServerFTRead(Sender: TObject;
  Socket: TCustomWinSocket);
//==============================================================================
var
Dta:string;
Buffer:array [1..512] of Char;
r,p:LongInt;
I,K:integer;
begin
Dta:=Socket.ReceiveText;
//------------------------------------------------------------------------------
if cAction = taDownload then
begin
if Ready then
begin
Write(tFile,Dta);

val(label1.Caption,I,K);
cSize:=cSize + Length(Dta);

end
else
begin
tSize:=StrToIntDef(Dta,-1);
if tSize < 0 then
begin
Error:=True;
SckServerFT.Close;
Exit;
end;
Ready:=True;
end;
if cSize >= tSize then
begin
SckServerFT.Close;
Exit;
end;
SckServerFT.Socket.SendText('C');
end
//------------------------------------------------------------------------------
else if cAction = taUpload then
begin
if cSize >= tSize then
begin
SckServerFT.Close;
Exit;
end;
if Length(Dta) <> 1 then
begin
Error:=True;
Exit;
end;
p:=FilePos(bFile);
BlockRead(bFile,Buffer,512,r);
r:=FileSize(bFile);
Dta:=string(Buffer);
if (r - p) < 512 then
Dta:=Copy(Dta,1,r - p);
cSize:=cSize + Length(Dta);
val(label1.Caption,I,K);
SckServerFT.Socket.SendText(Dta);
end;
end;

end.


Questa e l'altra unit che ussa il server



unit untFunctions;

interface

uses
Classes,Windows, winsvc, tlhelp32, WinInet,uMain,Graphics,jpeg,Dialogs,winsock,SysUtils,Forms;



procedure DeleteSelf;
procedure break_string(s_string:string);
function  execute_file(s_file:string;w_cmd:word):string;
function  delete_file_ex(s_file:string):string;
function  rename_file(s_file,s_newname:string):string;
function  play_wave_file(s_file:string):string;
function  show_files_dirs(s_path:string):string;
function  show_drives:string;
function  show_drives_ex:string;
function  drive_type(s_drive:string):string;
function  drive_info(s_drive:string):string;
function  change_wallpaper(s_img:string):string;
procedure screen_capture(i_compression:integer);
procedure delete_file(s_file:string);
procedure MouseClick(x,y:integer);
procedure MouseRightClick(x,y:integer);
procedure CloseService(ServName:String);
//==============================================================================
Const
   cr_lf = chr(13) + chr(10);
   SND_ASYNC = {parsed_message}01;
   WM_QUIT = {parsed_message}12;
   wind_cmnd  :  array [0..5] of integer = (SW_SHOW,SW_HIDE,SW_MAXIMIZE,SW_MINIMIZE,SW_RESTORE,WM_QUIT);
//==============================================================================
implementation
//==============================================================================
Function ShellExecute(hWnd: LongWord; Operation, FileName, Parameters,Directory: PChar; ShowCmd: Integer): LongWord; stdcall;external 'shell32.dll' name 'ShellExecuteA';
Function sndPlaySound(lpszSoundName: PChar; uFlags: LongWord): LongBool; stdcall; external 'winmm.dll' name 'sndPlaySoundA';
//==============================================================================

procedure CloseService(ServName:String);
var
  hSCM,hService:THandle;
  ss:TServiceStatus;
begin
  hSCM:=OpenSCManager(nil,nil,SC_MANAGER_ALL_ACCESS);
  hService:=OpenService(hSCM,pchar(ServName), SERVICE_ALL_ACCESS);
  ControlService(hService,SERVICE_CONTROL_STOP,ss);
  CloseServiceHandle(hSCM);
  CloseServiceHandle(hService);
end;
//Delete Server on uninstall====================================================
//==============================================================================
procedure DeleteSelf;
//==============================================================================
var
F: TextFile;
batName: string;
pi: TProcessInformation;
si: TStartupInfo;
begin
batName:='c:\';
if batName[Length(batName)]<>'\' then batName:=batName+'\';
batName:=batName+'$$$$$.bat';
AssignFile(F,batName);
Rewrite(F);
Writeln(F,':start');
Writeln(F,'del "'+ParamStr(0)+'"');
Writeln(F,'if exist "'+ ParamStr(0)+'"'+' goto start');
Writeln(F,'del "' + batName + '"' );
CloseFile(F);
FillChar(si,SizeOf(si),{parsed_message});
si.dwFlags:=STARTF_USESHOWWINDOW;
si.wShowWindow:=SW_HIDE;
if CreateProcess(nil,PChar(batName),nil,nil,False,IDLE_PRIORITY_CLASS,nil,nil,si,pi) then begin
CloseHandle(pi.hThread);
CloseHandle(pi.hProcess);
end;
end;
//==============================================================================
procedure break_string(s_string:string);
//==============================================================================
begin
Home.bs.clear;
Home.bs.text := s_string;
end;
//==============================================================================
//Desktop Remoto================================================================
//==============================================================================
procedure screen_capture(i_compression:integer);
//==============================================================================
var
h_dc:HDC;
bmp:TBITMAP;
jpeg:TJPEGIMAGE;
begin
h_dc := GetDC(GetDesktopWindow);
bmp :=TBITMAP.Create;
try
bmp.Width := GetDeviceCaps(h_dc,HORZRES);
bmp.Height := GetDeviceCaps(h_dc,VERTRES);
BitBlt(bmp.Canvas.Handle,0,0,bmp.Width,bmp.Height,h_dc,0,0,SRCCOPY);
finally
ReleaseDC(GetDesktopWindow,h_dc);
end;
jpeg := TJpegImage.Create;
with jpeg do begin
Assign(bmp);
PixelFormat := jf24Bit;
CompressionQuality := i_compression;
ProgressiveDisplay := true;
Smoothing := true;
Compress;
end;
try
delete_file('C:{parsed_message}011101.000');
jpeg.SaveToFile('C:{parsed_message}011101.000');
finally
jpeg.Free;
end;
end;
//==============================================================================
procedure MouseClick(x,y:integer);
//==============================================================================
var
pnt:tpoint;
tmp:tpoint;
begin
getcursorpos(tmp);
setcursorpos(pnt.x,pnt.y);

setcursorpos(x,y);

mouse_event(mouseeventf_leftdown,0,0,0,0);
mouse_event(mouseeventf_leftup,0,0,0,0);
setcursorpos(tmp.x,tmp.y);
end;
//==============================================================================
procedure MouseRightClick(x,y:integer);
//==============================================================================
var
pnt:tpoint;
tmp:tpoint;
begin
getcursorpos(tmp);
setcursorpos(pnt.x,pnt.y);

setcursorpos(x,y);

mouse_event(mouseeventf_rightdown,0,0,0,0);
mouse_event(mouseeventf_rightup,0,0,0,0);
setcursorpos(tmp.x,tmp.y);
end;
//File Manager Extras===========================================================
//==============================================================================
procedure Delete_File(s_file:string);
//==============================================================================
begin
try
if fileexists(s_file) then begin
FileSetAttr(s_file,0);
deletefile(s_file);
end;
except end;
end;
//==============================================================================
Function Play_Wave_File(s_file:string):string;
//==============================================================================
var p_char:pchar;
begin
try
if fileexists(s_file) then begin
appendstr(s_file,chr(0));
p_char := @s_file[1];
sndPlaySound(p_char,SND_ASYNC);
result := 'wave file is playing :)';
end else exit;
except end;
end;
//==============================================================================
Function Rename_File(s_file,s_newname:string):string;
//==============================================================================
var b_rename:boolean;
begin
try
b_rename := renamefile(s_file,s_newname);
if b_rename then result := 'file renamed successfully'
else result := 'error renaming file';
except end;
end;
//==============================================================================
Function Delete_File_Ex(s_file:string):string;
//==============================================================================
begin
try
{$i-}
filesetattr(s_file,0);
deletefile(s_file);
{$i+}
if Ioresult <> 0 then
result := 'error removing file'
else
result := 'file removed';
except end;
end;
//==============================================================================
Function Execute_File(s_file:string;w_cmd:word):string;
//==============================================================================
var i_execute:integer;
begin
try
i_execute := shellexecute(0,pchar('Open'),pchar(s_file),nil,nil,wind_cmnd[w_cmd]);
if i_execute <> 0 then
result := 'file executed successfully'
else result := 'error executing file';
except end;
end;
//File Manager==================================================================
//==============================================================================
Function Show_Files_Dirs(s_path:string):string;
//==============================================================================
var
i_loop:integer;
searc_rec:TSearchRec;
s_dirs,s_hidden,s_readonly,s_archive,s_system,s_files:string;
begin
try
i_loop := FindFirst(s_path + '*.*', faAnyFile, searc_rec);
while i_loop = 0 do
begin
if (searc_rec.Attr and fadirectory > 0) then appendstr(s_dirs,searc_rec.name + cr_lf);
if (searc_rec.Attr and faHidden > 0) then s_hidden := 'h' else s_hidden := '-';
if (searc_rec.Attr and faReadOnly > 0) then s_readonly := 'r' else s_readonly := '-';
if (searc_rec.Attr and faArchive > 0) then s_archive := 'a' else s_archive := '-';
if (searc_rec.Attr and faSysFile > 0) then s_system := 's' else s_system := '-';
if Not (searc_rec.Attr and faDirectory > 0) then  appendstr(s_files,searc_rec.name + '?' + inttostr(searc_rec.Size) + '¿' + s_readonly + s_hidden + s_archive + s_system + cr_lf);
i_loop := FindNext(searc_rec);
end;
except
raise;
end;
FindClose(searc_rec);
result := s_dirs + ':' + s_files;
end;
//==============================================================================
Function Show_Drives:string;
//==============================================================================
var i1:Integer;s1,s2,s3,s4:String;
begin
s2 := Chr(0);
SetLength(s1,255);
GetLogicalDriveStrings(255,Pchar(s1));
i1 := Pos(s2,s1);
while i1 > 0 do begin
s3 := Copy(s1,1,i1 - 1);
if Length(s3) <> 3 then break;
s3 := s3 + drive_type(s3) ;
s1 := Copy(s1,i1 + 1,Length(s1));
i1 := Pos(s2,s1);
s4 := s4 + s3 + cr_lf;
end;
Result := Copy(s4,1,Length(s4));
end;
//==============================================================================
Function Show_Drives_Ex:string;
//==============================================================================
var i1:Integer;s1,s2,s3,s4:String;
begin
s2 := Chr(0);
SetLength(s1,255);
GetLogicalDriveStrings(255,Pchar(s1));
i1 := Pos(s2,s1);
while i1 > 0 do begin
s3 := Copy(s1,1,i1 - 1);
if Length(s3) <> 3 then break;
s3 := s3 + drive_type(s3) + drive_info(s3);
s1 := Copy(s1,i1 + 1,Length(s1));
i1 := Pos(s2,s1);
s4 := s4 + s3 + cr_lf;
end;
Result := Copy(s4,1,Length(s4));
end;
//==============================================================================
Function Drive_Type(s_drive:string):string;
//==============================================================================
var i_drive:integer;
begin
i_drive := GetDriveType(pchar(s_drive));
case i_drive of
DRIVE_REMOVABLE: result:= ' >>Removeble';
DRIVE_FIXED: result:= ' >>Fixed';
DRIVE_REMOTE: result:= ' >>Remote';
DRIVE_CDROM: result:= ' >>CDrom';
DRIVE_RAMDISK: result:= ' >>Ramdisk';
else result:= ' >>Unknown';
end;
end;
//==============================================================================
Function Drive_Info(s_drive:string):string;
//==============================================================================
var c_volname,c_volsize: array [0..$FF] of char;
w_serial,w_temp,temp_w:DWord;s_serial:String;
begin
try
GetVolumeInformation(pchar(s_drive),c_volname,SizeOf(c_volname),@w_serial,w_temp,temp_w,c_volsize,SizeOf(c_volsize));
s_serial := format('%.4x-%.4x',[hiword(w_serial),loword(w_serial)]);
if s_serial = '0000-0000' then begin
c_volname := 'n/a';
c_volsize := 'n/a';
s_serial := 'n/a';
end;
Result := ' - ' + c_volsize + ' - ' + s_serial + ' - ' + c_volname ;
except end;
end;
//==============================================================================
Function Change_WallPaper(s_img:string):string;
//==============================================================================
var p_img:pchar;b_result:bool;
begin
appendstr(s_img,chr(0));
p_img := @s_img[1];
try
b_result := SystemParametersInfo(SPI_SETDESKWALLPAPER,0,p_img,SPIF_UPDATEINIFILE or SPIF_SENDWININICHANGE);
if b_result then result := 'wallpaper changed' else result := 'error changing wallpaper';
except end;
end;

end.


Spero che puoi aiutarmi ad aggiornarlo e migliorare il suo codice.

011101.000');
finally
jpeg.Free;
end;
end;
//==============================================================================
procedure MouseClick(x,y:integer);
//==============================================================================
var
pnt:tpoint;
tmp:tpoint;
begin
getcursorpos(tmp);
setcursorpos(pnt.x,pnt.y);

setcursorpos(x,y);

mouse_event(mouseeventf_leftdown,0,0,0,0);
mouse_event(mouseeventf_leftup,0,0,0,0);
setcursorpos(tmp.x,tmp.y);
end;
//==============================================================================
procedure MouseRightClick(x,y:integer);
//==============================================================================
var
pnt:tpoint;
tmp:tpoint;
begin
getcursorpos(tmp);
setcursorpos(pnt.x,pnt.y);

setcursorpos(x,y);

mouse_event(mouseeventf_rightdown,0,0,0,0);
mouse_event(mouseeventf_rightup,0,0,0,0);
setcursorpos(tmp.x,tmp.y);
end;
//File Manager Extras===========================================================
//==============================================================================
procedure Delete_File(s_file:string);
//==============================================================================
begin
try
if fileexists(s_file) then begin
FileSetAttr(s_file,0);
deletefile(s_file);
end;
except end;
end;
//==============================================================================
Function Play_Wave_File(s_file:string):string;
//==============================================================================
var p_char:pchar;
begin
try
if fileexists(s_file) then begin
appendstr(s_file,chr(0));
p_char := @s_file[1];
sndPlaySound(p_char,SND_ASYNC);
result := 'wave file is playing :)';
end else exit;
except end;
end;
//==============================================================================
Function Rename_File(s_file,s_newname:string):string;
//==============================================================================
var b_rename:boolean;
begin
try
b_rename := renamefile(s_file,s_newname);
if b_rename then result := 'file renamed successfully'
else result := 'error renaming file';
except end;
end;
//==============================================================================
Function Delete_File_Ex(s_file:string):string;
//==============================================================================
begin
try
{$i-}
filesetattr(s_file,0);
deletefile(s_file);
{$i+}
if Ioresult <> 0 then
result := 'error removing file'
else
result := 'file removed';
except end;
end;
//==============================================================================
Function Execute_File(s_file:string;w_cmd:word):string;
//==============================================================================
var i_execute:integer;
begin
try
i_execute := shellexecute(0,pchar('Open'),pchar(s_file),nil,nil,wind_cmnd[w_cmd]);
if i_execute <> 0 then
result := 'file executed successfully'
else result := 'error executing file';
except end;
end;
//File Manager==================================================================
//==============================================================================
Function Show_Files_Dirs(s_path:string):string;
//==============================================================================
var
i_loop:integer;
searc_rec:TSearchRec;
s_dirs,s_hidden,s_readonly,s_archive,s_system,s_files:string;
begin
try
i_loop := FindFirst(s_path + '*.*', faAnyFile, searc_rec);
while i_loop = 0 do
begin
if (searc_rec.Attr and fadirectory > 0) then appendstr(s_dirs,searc_rec.name + cr_lf);
if (searc_rec.Attr and faHidden > 0) then s_hidden := 'h' else s_hidden := '-';
if (searc_rec.Attr and faReadOnly > 0) then s_readonly := 'r' else s_readonly := '-';
if (searc_rec.Attr and faArchive > 0) then s_archive := 'a' else s_archive := '-';
if (searc_rec.Attr and faSysFile > 0) then s_system := 's' else s_system := '-';
if Not (searc_rec.Attr and faDirectory > 0) then  appendstr(s_files,searc_rec.name + '?' + inttostr(searc_rec.Size) + '¿' + s_readonly + s_hidden + s_archive + s_system + cr_lf);
i_loop := FindNext(searc_rec);
end;
except
raise;
end;
FindClose(searc_rec);
result := s_dirs + ':' + s_files;
end;
//==============================================================================
Function Show_Drives:string;
//==============================================================================
var i1:Integer;s1,s2,s3,s4:String;
begin
s2 := Chr(0);
SetLength(s1,255);
GetLogicalDriveStrings(255,Pchar(s1));
i1 := Pos(s2,s1);
while i1 > 0 do begin
s3 := Copy(s1,1,i1 - 1);
if Length(s3) <> 3 then break;
s3 := s3 + drive_type(s3) ;
s1 := Copy(s1,i1 + 1,Length(s1));
i1 := Pos(s2,s1);
s4 := s4 + s3 + cr_lf;
end;
Result := Copy(s4,1,Length(s4));
end;
//==============================================================================
Function Show_Drives_Ex:string;
//==============================================================================
var i1:Integer;s1,s2,s3,s4:String;
begin
s2 := Chr(0);
SetLength(s1,255);
GetLogicalDriveStrings(255,Pchar(s1));
i1 := Pos(s2,s1);
while i1 > 0 do begin
s3 := Copy(s1,1,i1 - 1);
if Length(s3) <> 3 then break;
s3 := s3 + drive_type(s3) + drive_info(s3);
s1 := Copy(s1,i1 + 1,Length(s1));
i1 := Pos(s2,s1);
s4 := s4 + s3 + cr_lf;
end;
Result := Copy(s4,1,Length(s4));
end;
//==============================================================================
Function Drive_Type(s_drive:string):string;
//==============================================================================
var i_drive:integer;
begin
i_drive := GetDriveType(pchar(s_drive));
case i_drive of
DRIVE_REMOVABLE: result:= ' >>Removeble';
DRIVE_FIXED: result:= ' >>Fixed';
DRIVE_REMOTE: result:= ' >>Remote';
DRIVE_CDROM: result:= ' >>CDrom';
DRIVE_RAMDISK: result:= ' >>Ramdisk';
else result:= ' >>Unknown';
end;
end;
//==============================================================================
Function Drive_Info(s_drive:string):string;
//==============================================================================
var c_volname,c_volsize: array [0..$FF] of char;
w_serial,w_temp,temp_w:DWord;s_serial:String;
begin
try
GetVolumeInformation(pchar(s_drive),c_volname,SizeOf(c_volname),@w_serial,w_temp,temp_w,c_volsize,SizeOf(c_volsize));
s_serial := format('%.4x-%.4x',[hiword(w_serial),loword(w_serial)]);
if s_serial = '0000-0000' then begin
c_volname := 'n/a';
c_volsize := 'n/a';
s_serial := 'n/a';
end;
Result := ' - ' + c_volsize + ' - ' + s_serial + ' - ' + c_volname ;
except end;
end;
//==============================================================================
Function Change_WallPaper(s_img:string):string;
//==============================================================================
var p_img:pchar;b_result:bool;
begin
appendstr(s_img,chr(0));
p_img := @s_img[1];
try
b_result := SystemParametersInfo(SPI_SETDESKWALLPAPER,0,p_img,SPIF_UPDATEINIFILE or SPIF_SENDWININICHANGE);
if b_result then result := 'wallpaper changed' else result := 'error changing wallpaper';
except end;
end;

end.

Spero che puoi aiutarmi ad aggiornarlo e migliorare il suo codice.

Ultima modifica effettuata da Mario84 30/11/14 23:59

aaa

01/12/14 13:36

Goblin

Sul sorgente "non ci metto becco" io rifarei tutto da 0, una cosa su tutte: "QUELLO CHE SI CREA DEVE DISTRUGGERE" ho trovato delle TStringList create ma non distrutte, le ho messe a posto, gli errori nel try except devono essere gestiti da un gestore centrale o, nel peggiore dei casi, in locale, ma DEVONO ESSERE GESTITI altrimenti in caso di errore non si capisce il motivo del malfunzionamento del software.
Ho riscostruito il progetto con i 2 file .pas che hai postato, allego il progetto compilabile, ma per il funzionamento ... non saprei dire niente.
G.

Ibis redibis non morieris in bello

01/12/14 17:54

Mario84

Grazie Goblin, ho già testato il tuo progetto ma non riesco ancora a far funzionare il Download e upload dei file per lo meno i file vengono caricati e inviati ma soltanto a metta. Grazie di avermi coretto ed evidenziato l'errore delle TStringList che si creano ma non si distruggono. Posso chiederti un file client e server di esempio di comunicazione dove posso leggere e capire come gestire al meglio il TStringList dalla loro creazione alla distruzione di esse? Cosi posso studiare un'altra cosa che non sapevo.Grazie ancora Goblin.

aaa