dm5314_usimpletcp.pas

DarkMoon v4.11 (远程控制) 国外收集的代码,控件下载: http://www.winio.cn/Blogs/jishuwenzhang/200712/20071208230135.

procedure TSimpleTCPServer.SetPort(Value: Word);
begin
  if not (csDesigning in ComponentState) then
   if FPort <> Value then
    if FListen then
     if FAllowChangeHostAndPortOnConnection then
      begin
       Listen := False;
       FPort := Value;
       Listen := True;
      end
     else
      raise Exception.Create('Can not change Port while listening')
    else FPort := Value
   else
  else FPort := Value;
end;

procedure TSimpleTCPServer.SetListen(Value: Boolean);
var
  I: Integer;
  tmpTCPClient: TSimpleTCPClient;
begin
  if not (csDesigning in ComponentState) then
   if FListen <> Value then
    begin
     if Value then
      begin
       FSocket := WinSock.Socket(PF_INET, SOCK_STREAM, IPPROTO_TCP);
       if FSocket = SOCKET_ERROR then
        begin
         SocketError(INVALID_SOCKET, WSAGetLastError);
         Exit;
        end;

       SockAddrIn.sin_family := AF_INET;
       SockAddrIn.sin_addr.s_addr := INADDR_ANY;
       SockAddrIn.sin_port := htons(FPort);
       if Bind(FSocket, SockAddrIn, SizeOf(SockAddrIn)) <> 0 then
        begin
         SocketError(FSocket, WSAGetLastError);
         Exit;
        end;

       if WinSock.Listen(FSocket, SOMAXCONN) <> 0 then
        begin
         SocketError(FSocket, WSAGetLastError);
         Exit;
        end;

       if WSAAsyncSelect(FSocket, WindowHandle, UM_TCPASYNCSELECT,
                         FD_READ or FD_ACCEPT or FD_CLOSE) <> 0 then
        begin
         SocketError(FSocket, WSAGetLastError);
         Exit;
        end;
      end
     else
      begin

      
       // Closing all connections first
       I := FConnections.Count;


       if I <> 0 then
        for I := I - 1 downto 0 do
         begin
          tmpTCPClient := FConnections[I];
          tmpTCPClient.Connected := False;
          FConnections.Delete(I);
          closesocket( tmpTCPClient.Socket);
         end;

       // Cancel listening
       WSAASyncSelect(FSocket, WindowHandle, UM_TCPASYNCSELECT, 0);
       Shutdown(FSocket, 2);

       if CloseSocket(FSocket) <> 0 then
        begin
         SocketError(FSocket, WSAGetLastError);
         Exit;
        end;

       FSocket := INVALID_SOCKET;
      end;
      FListen := Value;
    end
   else
  else
   FListen := Value;
end;

function TSimpleTCPServer.GetLocalHostName: String;
var
  HostName: Array[0..MAX_PATH] of Char;
begin
  if GetHostName(HostName, MAX_PATH) = 0 then
    Result := HostName
  else
    SocketError(FSocket, WSAGetLastError);
end;

function TSimpleTCPServer.GetLocalIP: String;
var
  SockAddrIn: TSockAddrIn;
  HostEnt: PHostEnt;
  HostName: Array[0..MAX_PATH] of Char;
begin
  if GetHostName(HostName, MAX_PATH) = 0 then
   begin
    HostEnt:= GetHostByName(HostName);
    if HostEnt = nil then
      Result := ''
    else
     begin
      SockAddrIn.sin_addr.S_addr := LongInt(PLongInt(HostEnt^.h_addr_list^)^);
      Result := inet_ntoa(SockAddrIn.sin_addr);
     end;
   end
  else
   SocketError(FSocket, WSAGetLastError);
end;

procedure TSimpleTCPServer.SetNoneStr(Value: String); begin end;
{------------------------------------------------------------}


{ TSimpleTCPClient }
destructor TSimpleTCPClient.Destroy;
begin
  Connected := False;
  inherited Destroy;
end;

{procedure TSimpleTCPClient.WndProc(var Message: TMessage);
begin
  inherited WndProc(Message);
end;}

procedure TSimpleTCPClient.SocketError(Socket: TSocket; ErrorCode: Integer);
begin
  Connected := False; // broke connection
  inherited;
end;

procedure TSimpleTCPClient.DoConnect;
begin
  FConnected := True; { definitely connected! }
  if Assigned(FOnConnected) then
    FOnConnected(Self);
end;

procedure TSimpleTCPClient.DoClose(Socket: TSocket);
begin
  Connected := False;
  if not (csDestroying in ComponentState) then
   begin
    if Assigned(FOnDisconnected) then
      FOnDisconnected(Self);

    if FAutoTryReconnect then
      Connected := True;
   end;   
end;

procedure TSimpleTCPClient.DoDataAvailable(Client: TSimpleTCPClient; DataSize: Integer; var Handled: Boolean);
begin
  Handled := Assigned(FOnDataAvailable);
  if Handled then
    FOnDataAvailable(Self, DataSize);
end;

procedure TSimpleTCPClient.DoRead(Client: TSimpleTCPClient; Stream: TStream);
begin
  if Assigned(FOnRead) then
    FOnRead(Self, Stream);
end;

function TSimpleTCPClient.Send(Buffer: PChar; BufLength: Integer): Integer; // bytes sent
begin
  Result := SendBufferTo(FSocket, Buffer, BufLength);
end;

function TSimpleTCPClient.SendStream(Stream: TStream): Integer; // returns N of bytes sent
begin
  Result := SendStreamTo(FSocket, Stream);
end;

function TSimpleTCPClient.Receive(Buffer: PChar; BufLength: Integer; ReceiveCompletely: Boolean): Integer;
begin
  Result := ReceiveFrom(FSocket, Buffer, BufLength, ReceiveCompletely);
end;

function TSimpleTCPClient.ReceiveStream(Stream: TStream; DataSize: Integer; ReceiveCompletely: Boolean): Integer;
begin
  Result := ReceiveStreamFrom(FSocket, Stream, DataSize, ReceiveCompletely);
end;

procedure TSimpleTCPClient.SetConnected(Value: Boolean);
var
  lin: TLinger;
  linx: Array[0..3] of Char absolute lin;
  ErrorCode: Integer;
begin
  if not (csDesigning in ComponentState) then
   if FConditionallyConnected <> Value then
    begin
     FConditionallyConnected := Value;
     if Value then
      begin
       SockAddrIn.sin_family := AF_INET;
       SockAddrIn.sin_port := htons(FPort);
       SockAddrIn.sin_addr.s_addr := inet_addr(PChar(Host));
       if SockAddrIn.sin_addr.s_addr = -1 then
        begin
         HostEnt := GetHostByName(PChar(Host));
         if HostEnt = nil then
          begin
           SocketError(INVALID_SOCKET, WSAEFAULT);
           Exit;
          end;
         SockAddrIn.sin_addr.S_addr := LongInt(PLongInt(HostEnt^.h_addr_list^)^);
        end;
       FSocket := WinSock.Socket(PF_INET, SOCK_STREAM, IPPROTO_TCP);
       if FSocket = SOCKET_ERROR then
        begin
         SocketError(INVALID_SOCKET, WSAGetLastError);
         Exit;
        end;

       ErrorCode := WSAASyncSelect(FSocket, WindowHandle, UM_TCPASYNCSELECT,
                                   FD_READ or FD_CONNECT or FD_CLOSE);
       if ErrorCode <> 0 then
        begin
         SocketError(FSocket, WSAGetLastError);
         Exit;
        end;

       ErrorCode := WinSock.Connect(FSocket, SockAddrIn, SizeOf(SockAddrIn));
       if ErrorCode <> 0 then
        begin
         ErrorCode := WSAGetLastError;
         if ErrorCode <> WSAEWOULDBLOCK then
          begin
           SocketError(FSocket, WSAGetLastError);
           Exit;
          end;
        end;
      end
     else
      begin
       WSAASyncSelect(FSocket, WindowHandle, UM_TCPASYNCSELECT, 0);
       Shutdown(FSocket, 2);
       lin.l_onoff := 1;
       lin.l_linger := 0;
       SetSockOpt(FSocket, SOL_SOCKET, SO_LINGER, linx, SizeOf(Lin));

       ErrorCode := CloseSocket(FSocket);
       if ErrorCode <> 0 then
        begin
         SocketError(FSocket, WSAGetLastError);
         Exit;
        end;

       FSocket := INVALID_SOCKET;
       FConnected := False;
       if Assigned(FOnDisconnected) and not (csDestroying in ComponentState) then
         FOnDisconnected(Self);
      end;
    end
   else
  else
   if Value then
    raise Exception.Create('Can not connect at design-time');
end;

procedure TSimpleTCPClient.SetHost(Value: String);
begin
  if not (csDesigning in ComponentState) then
   if FHost <> Value then
    if FConnected then
     if FAllowChangeHostAndPortOnConnection then
      begin
       Connected := False;
       FHost := Value;
       Connected := True;
      end
     else
      raise Exception.Create('Can not change Host while connected')
    else
     FHost := Value
   else
  else FHost := Value;   
end;

procedure TSimpleTCPClient.SetPort(Value: Word);
begin
  if not (csDesigning in ComponentState) then
   if FPort <> Value then
    if FConnected then
     if FAllowChangeHostAndPortOnConnection then
      begin
       Connected := False;
       FPort := Value;
       Connected := True;
      end
     else
      raise Exception.Create('Can not change Port while connected')
    else
     FPort := Value
   else
  else
   FPort := Value;
end;

function  TSimpleTCPClient.GetIP: LongInt;
begin
  Result := StrToIP(Host);
end;

procedure TSimpleTCPClient.SetIP(Value: LongInt);
begin
  Host := IPToStr(Value);
end;

procedure Register;
begin
  RegisterComponents('UtilMind', [TSimpleTCPServer, TSimpleTCPClient]);
end;

end.