Delphi -> BCB4

Alexander Sulfrian

Hi,
könnte jemand das hier mal für den BCB übersetzten (Ich weiß auch das der BCB Delphi unterstützt, aber hier findet er WSocket und WSocketS nicht):

unit NetFind;

interface

uses
  Windows, Classes, SysUtils, ExtCtrls, WSocket, WSocketS, WinSock;

type

  TFoundEvent  = Procedure(Sender:TObject;Client:TWSocket;FromIP,FromPCName,Data:String) of object;
  TRequestEvent  = Procedure(Sender:TObject;Client:TWSocket;FromIP,FromPCName,Data:String;
                 var Answer: string) of object;
  TFoundDoneEvent = Procedure(Sender:TObject) of object;

  RClients = Record
    IP    :String;
    Name  :String;
    Answer:String;
  end;

  TNetFind = class(TComponent)
  private
    { Private-Deklarationen }
  protected
    FActive:Boolean;
    FPort:String;
    FLocalPCName:String;
    FTimeout:DWord;
    FTimer:TTimer;
    FTagStr:String;
    SocketServer:TWSocketServer;
    FOnClientFound : TFoundEvent;
    FOnRequest: TRequestEvent;
    FFoundDoneEvent: TFoundDoneEvent;
    procedure SocketServerDataAvailable(Sender: TObject; Error: Word);
    procedure SetActive(Value:Boolean);
    procedure SetPCName(Default:String);
    function ExtractPCName(var Source:String):String;
    procedure TimerTimeout(Sender: TObject);
  public
    ClientList: Array of RClients;
    procedure Find(InitMessage:String);
  published
    constructor Create(AOwner:TComponent); override;
    destructor Destroy; override;
    property TagStr:String read FTagStr write FTagStr;
    property Active:Boolean read FActive write SetActive;
    property Port:String read FPort write FPort;
    property LocalPCName:String read FLocalPCName;
    property FindTimeout: DWord read FTimeout write FTimeout default 3000;
    property OnClientFound:TFoundEvent read FOnClientFound
                                       write FOnClientFound;
    property OnRequest: TRequestEvent read FOnRequest
                                      write FOnRequest;
    property OnFoundDone: TFoundDoneEvent read FFoundDoneEvent
                                          write FFoundDoneEvent;
  end;

procedure Register;

implementation

const
  IsRequest = #17;
  IsAnswer  = #20;
  Delimiter = '|';

procedure Register;
begin
  RegisterComponents('FPiette', [TNetFind]);
end;

constructor TNetFind.Create(AOwner:TComponent);
begin
  inherited Create(AOwner);
  if not (csDesigning in ComponentState) then begin
    SocketServer := TWSocketServer.Create(self);
    SocketServer.Proto := 'udp';
    SocketServer.OnDataAvailable := SocketServerDataAvailable;
    FTimer := TTimer.Create(Self);
    FTimer.Enabled := false;
    FTimer.OnTimer := TimerTimeout;
  end;
  FPort       := '2899';
  FindTimeout := 3000;
  SetPCName('netfindpc');
  SetLength(ClientList,0);
end;

destructor TNetFind.Destroy;
begin
  Try
    If Assigned(SocketServer) then SocketServer.Free;
    If Assigned(FTimer) then FTimer.Free;
    SetLength(ClientList,0);
  Except
  End;
  inherited destroy;
end;

procedure TNetFind.SetPCName(Default:String);
  var
    ComputerName : PChar;
    NameSize : DWORD;
begin
  Try
    If Default<>'' then FLocalPCName := Default;
    ComputerName := #0;
    NameSize := MAX_COMPUTERNAME_LENGTH + 1;
    try
      GetMem(ComputerName, NameSize);
      Windows.GetComputerName(ComputerName, NameSize);
      If Trim(StrPas(ComputerName))<>'' then
        FLocalPCName:= StrPas(ComputerName);
    finally
      FreeMem(ComputerName);
    end;
  Except
  End;
end;

function TNetFind.ExtractPCName(var Source:String):String;
begin
  Result := '';
  If Source='' then exit;
  Result := Copy(Source,0,Pos(Delimiter,Source)-1);
  Source := Copy(Source,Pos(Delimiter,Source)+1,Length(Source));
end;

procedure TNetFind.TimerTimeout(Sender: TObject);
begin
  FTimer.Enabled := false;
  If Assigned(FFoundDoneEvent) then FFoundDoneEvent(Self);
End;

procedure TNetFind.SetActive(Value:Boolean);
begin
  If not Assigned(SocketServer) then exit;
  If Value<>FActive then begin

    If Value then begin
      SocketServer.Addr := '0.0.0.0';
      SocketServer.Port := FPort;
    end;

    If Value then SocketServer.Listen
    Else SocketServer.Close;
    FActive := Value;
  end;
end;

procedure TNetFind.Find(InitMessage:String);
  var TempSocket:TWSocket;
begin
  SetLength(ClientList,0);
  If not Assigned(SocketServer) then exit;
  Try
    If (FLocalPCName='') then SetPCName('netfindpc');
    TempSocket := TWSocket.Create(Self);
    TempSocket.Proto := 'udp';
    TempSocket.Addr := '255.255.255.255';
    TempSocket.Port := FPort;
    TempSocket.LocalAddr := '0.0.0.0';
    TempSocket.Connect;
    TempSocket.SendStr(IsRequest+FLocalPCName+Delimiter+InitMessage);
    TempSocket.Close;
    TempSocket.Free;
    If FTimeout>0 then begin
      FTimer.Interval := FTimeout;
      FTimer.Enabled  := true;
    End else FTimer.Enabled := false;
  Except
  end;
end;

procedure TNetFind.SocketServerDataAvailable(Sender: TObject; Error: Word);
  var
    Buffer : array [0..1023] of char;
    Len    : Integer;
    Src    : TSockAddrIn;
    SrcLen : Integer;
    Client : TWSocket;
    FromIP, FromPCName, Data, DataToSend:String;
    TempSocket:TWSocket;
    DoAnswer:Boolean;
begin
  If Error<>0 then exit;
  Try
    Client := TWSocket(Sender);
    SrcLen := SizeOf(Src);
    Len    := Client.ReceiveFrom(@Buffer, SizeOf(Buffer), Src, SrcLen);
    If (Len>0) then begin
      FromIP := StrPas(inet_ntoa(Src.sin_addr));
      Data   := Copy(StrPas(Buffer),1,Len);
      DoAnswer := (Data[1]=IsRequest);
      Data := Copy(Data,2,Length(Data));
      If Pos(Delimiter,Data)>0 then FromPCName := ExtractPCName(Data)
      else FromPCName := '';
      DataToSend := 'Hello to '+FromIP;
      { It's an answer to our request ... }
      If not DoAnswer then begin
    SetLength(ClientList,Length(ClientList)+1);
        ClientList[Length(ClientList)-1].IP    := FromIP;
        ClientList[Length(ClientList)-1].Name  := FromPCName;
        ClientList[Length(ClientList)-1].Answer:= Data;
        If Assigned(FOnClientFound) then
          FOnClientFound(Self,Client,FromIP,FromPCName,Data);
      { We received a request, answer ... }
      end else If ((DataToSend<>'') and (FromPCName<>FLocalPCName)) then begin
        DataToSend := '';
        If Assigned(FOnRequest) then
          FOnRequest(Self,Client,FromIP,FromPCName,Data,DataToSend);
        TempSocket := TWSocket.Create(Self);
        TempSocket.Proto := 'udp';
        TempSocket.Addr := FromIP;
    TempSocket.Port := FPort;
        TempSocket.LocalAddr := '0.0.0.0';
        TempSocket.Connect;
        TempSocket.SendStr(IsAnswer+FLocalPCName+Delimiter+DataToSend);
        TempSocket.Close;
        TempSocket.Free;
      End;
    End;
  Except
  End;
end;

end.

Danke

Alexander Sulfrian

hallo,

für 100 euro übersetz ichs dir...

murph

Jansen

Hey, keine Dumpingpreise!

Ab jetzt aber bitte nur noch "ernstgemeinte Zuschriften". Dass die Bitte von A.S. reichlich unverschämt ist weiss er sicher selbst. Zumal es ja im Grunde noch nicht mal eine Bitte ist ...

Alexander Sulfrian

Hi,
ja irgenwie wusste ich selber, dass das keiner macht (naja versuchen kann man's ja mal)! Naja jedenfalls hab ich mir die mühe gamacht und in den unendlichen weiten des Internets nach WSocket und WSocketS gesucht und siehe da, hab sie auch in einer Komponentensammlung gefunden! (hier)

Trotzdem danke!

Alexander Sulfrian

PS: Is 100€ nich ein weinig viel?