unit ServerTester;

interface

uses Windows, Classes, SysUtils, ScktComp;

type
TTestDoneEvent = procedure (Sender:TObject; Host:string; Port:Integer; ServiceIsOn:boolean) of object;

TSocketTester = class(TComponent)
private
SClient: TClientSocket;
FWhenDone: TTestDoneEvent;
procedure SocketError(Sender: TObject; Socket: TCustomWinSocket; ErrorEvent: TErrorEvent; var ErrorCode: Integer);
procedure SocketConnect(Sender: TObject; Socket: TCustomWinSocket);
protected
public
constructor Create(AOwner:TComponent; Host:string; Port:Integer; WhenDone: TTestDoneEvent); overload;
destructor Destroy; override;
end;

procedure CheckService(AOwner:TComponent; Host:string; Port:Integer=80; CBWhenDone: TTestDoneEvent=nil);

implementation

procedure CheckService(AOwner:TComponent; Host:string; Port:Integer=80; CBWhenDone: TTestDoneEvent=nil);
begin
TSocketTester.Create(AOwner, Host, Port, CBWhenDone);
end;

constructor TSocketTester.Create(AOwner:TComponent; Host:string; Port:Integer; WhenDone: TTestDoneEvent);
begin
inherited Create(AOwner);
FWhenDone := WhenDone;
SClient := TClientSocket.Create(Self);
SClient.OnError := SocketError;
SClient.OnConnect := SocketConnect;
SClient.Host := Host;
SClient.Port := Port;
SClient.Open;
end;

destructor TSocketTester.Destroy;
begin
if SClient.Active then SClient.Close;
FreeAndNil(SClient);
inherited;
end;

procedure TSocketTester.SocketConnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
if Assigned(FWhenDone) then FWhenDone(Owner, SClient.Host, SClient.Port, True);
Free;
end;

procedure TSocketTester.SocketError(Sender: TObject;
Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer);
begin
if ErrorEvent = eeConnect then begin
ErrorCode := 0;
if Assigned(FWhenDone) then FWhenDone(Owner, SClient.Host, SClient.Port, False);
Free;
end;
end;

end.

===================
Demo Unit :

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls;

TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure TesterDone (Sender:TObject; Host:string; Port:Integer; ServiceIsOn:boolean);
end;

implementation

{$R *.dfm}
uses ServerTester;

procedure TForm1.Button1Click(Sender: TObject);
begin
CheckService(Self, '192.168.2.253', 1433, TesterDone);
end;

procedure TForm1.TesterDone(Sender: TObject; Host: string; Port: Integer;
ServiceIsOn: boolean);
begin
if ServiceIsOn then
ShowMessage('On')
else ShowMessage('Off');
end;

編輯記錄

嗨，Mickey兄:

我按圖索驥試run了這支程式，發現它似乎是偵測指定的port是否開啟，如果這個port不存在或被防火牆攔下或未設定Virtual Server Settting(NAT)，即使server是正常的，也都會回應 off的狀況，然後我進一步測試，因為我有一套程式在客戶那邊會有一個現象，就是透過TCP/IP遠端連上(使用XP遠端桌面，SERVER使用Termail Server模式)，只要進入遠端桌面內的我的程式(使用InterBase/FireBird)，一段時間沒有進行資訊往來，會被Server端的InterBae給驅離，但這個狀況同時在其他不同客戶的電腦卻不曾發生(不同程式系統，但相同的寫法)，所以目前我是設定一個Timer定時去向主機開啟資料庫，告訴主機我還在，不要把我踢走。ok! 重點來了，我用您的程式去探測InterBae的Port3050，情況還是會發生，所以我猜程式的核心是探測此port是否可通，如果可以就回應，不知道是否有什麼辦法可以探測資料庫引擎的連線，因為畢竟定時開檔/關檔，一天下來還是會損耗不少的系統資源，不過話說回來，這支程式還是很好用，因為我之前是利用SocketServer/SocketClient方式來做雙方的探測行為，在Server端必須安裝SocketServer Serivce才能運作，謝謝!

Hi ! P.D. 兄您好:

沒錯...這只是測試 Port 是否是通的...因為當時的目的只是...

抓出我們公司防火牆...所有通道...誰叫他們要檔 MSN...

立志當駭客...哈哈

您的需求...這東西恐怕無法達到...因為您是要以 Session / Connection 為基準.

至於如何解....只有想法:

建立一個新連線...去取得 server 的 sessions 清單資訊...看看"原來的" session 是否還在

編輯記錄