با سلام
من برنامه ای دارم که یک سرور در آن هست و میخواهم با اتصال هر کلاینت به این سرور لیست باکس موجود در فرم ریفرش شود و کلاینت ها را نمایش دهد.
اگر بصورت مستقیم از درون ترد اتصال به سرور دستور ریفرش را بزنم مشکل بوجود میآید.
طاهرا باید از دستور Sysnchronize استفاده کنم ولی درست نمیدونم چطور استفاده کنم.
من کدم رو در زیر آوردم. اگر دوستان میتونند راهنمایی کنند ممنون میشم.
در حقیقت میخوام روال UpdateList انجام بشه.
unit U_Server;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
uSockets,WinSock, IdStack,DateUtils,IniFiles,
Dialogs, StdCtrls, VCLBase, BmpCtrls, Spin, ExtCtrls, ComCtrls;
type
TMy_Server = class(TForm)
MyActiveCheckBox: TCheckBox;
Label31: TLabel;
PearIP: TEdit;
MyPort: TSpinEdit;
Pear_Connected: TepBMPCheckBox;
ListBox11: TListBox;
Button9: TButton;
Label33: TLabel;
FTimer: TTimer;
lbIPs: TListBox;
Label1: TLabel;
AutoActive: TCheckBox;
Button1: TButton;
StartMeHide: TCheckBox;
Button4: TButton;
StatusBar1: TStatusBar;
procedure MyServerActiveCheckBoxClick(Sender: TObject);
Procedure ActivateServer;
Procedure DeactivateServer;
procedure Button9Click(Sender: TObject);
procedure PopulateIPAddresses;
procedure FTimerTimer(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure Button1Click(Sender: TObject);
procedure PearIPChange(Sender: TObject);
private
{ Private declarations }
Server: TTCPServer;
ClientCounter: Integer;
FirstMinute : Boolean;
MyClientsList : TStringList;
procedure ServerDisconnect(Client: TTCPConnection);
procedure ServerConnect(Client: TTCPConnection);
procedure ServerExecute(Thread: TTCPConnectionThread);
procedure ServerError(Socket: TTCPSocket);
procedure UpdateList;
public
{ Public }
end;
var
My_Server: TMy_Server;
Pear_IP : string;
type
TMyClientData = class
Name , IP : String;
end;
implementation
{$R *.dfm}
procedure TMy_Server.PopulateIPAddresses;
begin
try
lbIPs.Items.Clear;
GStack := GStackClass.Create;
lbIPs.Items := TStringlist(GStack.LocalAddresses);
if lbIPs.Items.IndexOf('127.0.0.1') < 0 then
lbIPs.Items.Insert(0,'127.0.0.1');
FreeAndNil(GStack);
except
FreeAndNil(GStack);
end;
end;
Procedure TMy_Server.ActivateServer;
var i : integer;
begin
ClientCounter := 0;
Server := TTCPServer.Create;
with Server do
begin
OnConnect := Server1Connect;
OnDisconnect := Server1Disconnect;
OnExecute := Server1Execute;
OnError := Server1Error;
end;
try
for i := 0 to lbIPs.Items.Count-1 do
Server.AddBinding(TTCPBinding.Create(lbIPs.Items.S trings[i]+':'+ MyPort.Text));
except
end;
Server.Listen := True;
PearIP.Enabled := False;
MyPort.Enabled := false;
end;
Procedure TMy_Server.DeactivateServer;
begin
try
Server.Listen := False;
MyPort.Enabled := True;
PearIP.Enabled := True;
Server1.Free;
MyClientsList.Clear;
except
end;
end;
Function UptimeInSeconds: double;
//const
// SecondsInAMinute = 86400;
var
cnt, freq: Int64;
begin
QueryPerformanceCounter(cnt);
QueryPerformanceFrequency(freq);
Result := (cnt / freq);
end;
procedure TMy_Server.MyActiveCheckBoxClick(Sender: TObject);
begin
MyActiveCheckBox.Enabled := False;
if FirstMinute then
begin
FTimer.Enabled := true;
exit;
end;
MyActiveCheckBox.Enabled := True;
if MyActiveCheckBox.Checked
then
ActivateServer
else
DeactivateServer;
MyActiveCheckBox.Checked := Server.Listen = True;
end;
procedure TMy_Server.UpdateList;
begin
TMy_Server.ListBox11.Items := MyClientsList;
end;
procedure TMy_Server.ServerConnect(Client: TTCPConnection);
begin
ClientCounter := 1;
Client.Data := TMyClientData.Create;
with TMyClientData(Client.Data) do
begin
Name := Client.PeerIP;
if MyClientsList.IndexOf(Name) >= 0
then
begin
ClientCounter := 1;
Name := Client.PeerIP + '_'+ InttoStr(ClientCounter);
while MyClientsList.IndexOf(Name) >= 0 do
begin
Inc(ClientCounter);
Name := Client.PeerIP + '_'+ InttoStr(ClientCounter);
end;
end;
if Pear_IP = Client.PeerIP then
begin
Pear_Connected.Checked := True;
PearIP.Enabled := False;
end
else
begin
MyClientsList.AddObject(Name, Client);
end;
end;
Client.Detach;
{ Synchronize }(UpdateList);
// ListBox11.Items := MyClientsList;
end;
procedure TMy_Server.ServerDisconnect(Client: TTCPConnection);
begin
try
with TMyClientData(Client.Data) do
begin
if Name = pear_IP then
begin
pear_Connected.Checked := False;
end
else
begin
MyClientsList.Delete(MyClientsList.IndexOf(Name));
end;
Free;
end;
except end;
UpdateList;
// ListBox11.Items := MyClientsList;
end;
procedure TMy_Server.ServerExecute(Thread: TTCPConnectionThread);
var s: String;
Procedure SendToAllOthers( S : String);
var i : integer;
begin
if s <> '' then
for i := 0 to MyClientsList.Count -1 do
try
TTCPConnection(MyClientsList.Objects[i]).WriteLn(s);
except
try TTCPConnection(MyClientsList.Objects[i]).Disconnect;
except
MyClientsList.Delete(i);
end;
end;
end;
begin
s := Thread.Connection.ReadLn();
if Thread.Connection.PeerIP <> pear_IP then Exit;
if Thread.Connection.Connected then
begin
Thread.Lock;
with TMyClientData(Thread.Connection.Data) do
try
SendToAllOthers(S);
finally
Thread.Unlock;
end;
end;
end;
procedure TMy_Server.ServerError(Socket: TTCPSocket);
begin
{ if Socket.LastError <> WSAECONNRESET then
begin
///n main.MylogEvent(True , IntToStr(Socket.LastError) + ' '+ Socket.LastErrorMessage);
end; }
end;
procedure TMy_Server.Button9Click(Sender: TObject);
begin
ListBox11.Items := MyClientsList;
end;
procedure TMy_Server.FTimerTimer(Sender: TObject);
begin
if (UptimeInSeconds < 150)
then
exit;
FTimer.Enabled := False;
FirstMinute := False;
if AutoActive.Checked then
MyActiveCheckBox.Checked := True
else
begin
MyActiveCheckBox.Enabled := True;
if AutoActive.Checked
then
ActivateServer
else
DeactivateServer;
end;
end;
procedure TMy_Server.FormCreate(Sender: TObject);
begin
MyClientsList := TStringList.Create;
PopulateIPAddresses;
end;
procedure TMy_Server.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
MyActiveCheckBox.Checked := False;
end;
procedure TMy_Server.PearIPChange(Sender: TObject);
begin
Pear_IP := PearIP.Text;
end;
end.
پاسخ با نقل قول
