Server im LAN finden mittels IdTCPClient

[DataCool]

Hi,

ich habe das ganze mal eben auf die Schnelle programmiert(ohne Test und gewährleistung):

Delphi-Quellcode:

unit Unit1;

interface

uses Classes, SyncObjs, IdTcpClient;

type

  TWorker = class(TThread)
    private
      client: TIdTCPClient;
    protected
      procedure Execute; override;
    public
      IP: string;
      Connected: boolean;
      Running: boolean;
  end;

  TWorkers = class(TObject)
    private
      {}
    protected
      {}
    public
      Threads: Array of TWorker;
  end;

  TJobList = class(TStringList)
    private
      FCS : TCriticalSection;
    protected
      {}
    public
      Constructor Create;
      Destructor Destroy;
      function GetNextJob: String;
      function isEmpty : boolean;
      procedure SaveAdd(sIP : String);
  end;

  TSearchThread = class(TThread)
  private
    NewItem: string;
    JobList: TJobList;
    Workers: TWorkers;
  protected
    procedure Execute; override;
    procedure AddTreeItem;
    procedure RunCheck(Index: integer);
  public
    IP: string;
    Connected: boolean;
  end;

implementation


procedure TSearchThread.Execute;
var
  i: Integer;
  bBreak : Boolean;
begin
  JobList := TJobList.Create;
  Workers := TWorkers.Create;
  for i := 0 to 255 do
  begin
    JobList.SaveAdd('192.168.1.'+IntToStr(i));
  end;

  for i := 0 to 5 do
  begin
    SetLength(Workers.Threads, Length(Workers.Threads)+1);
    Workers.Threads[i] := TWorker.Create(true);
    Workers.Threads[i].IP := JobList.GetNextJob;
    Workers.Threads[i].Resume;
  end;

  bBreak := false;
  while (not JobList.isEmpty) and (not bBreak) do
  begin
    for i := 0 to Length(Workers.Threads)-1 do
    begin
      if not Workers.Threads[i].Running then
      begin
        NewItem := 'Thread '+IntToStr(i)+' wurde beendet';
        Synchronize(AddTreeItem);
        Workers.Threads[i] := TWorker.Create(true);
        Workers.Threads[i].IP := JobList.GetNextJob;
        bBreak := Workers.Threads[i].IP <> '';
        if not bBreak then
          Workers.Threads[i].Resume;
      end;
      // Sleep(500);  <<<- unnötig
    end;
  end;
end;

procedure TSearchThread.AddTreeItem;
begin
  frmMain.treeContacts.Items.AddChild(nil, NewItem);
end;

procedure TWorker.Execute;
begin
  Running := true;
  client := TIdTCPClient.Create;
  client.Port := 60000;
  client.ConnectTimeout := 500;
  client.Host := IP;
  try
    client.Connect;
  except
  end;
  if client.Connected then
  begin
    Connected := true;
  end
  else
  begin
    Connected := false;
  end;
  client.Free;
  Running := false;
end;

constructor TJobList.Create;
begin
  FCS := TCriticalSection.Create;
end;

destructor TJobList.Destroy;
begin
  FreeAndNil(FCS);
end;

function TJobList.GetNextJob:string;
begin
  fCS.Enter;
  try
    if self.Count > 0 then begin
      Result := self.Get(0);
      self.Delete(0);
    end
    else
      result := '';
  finally
    FCS.Leave;
  end;
end;

function TJobList.isEmpty: boolean;
begin
  fCS.Enter;
  try
    Result := self.Count = 0;
  finally
    FCS.Leave;
  end;
end;

procedure TJobList.SaveAdd(sIP: String);
begin
  fCS.Enter;
  try
    self.Add(sIP);
  finally
    FCS.Leave;
  end;
end;

end.

Greetz DataCool