Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

ВИДЕОКУРС ВЗЛОМ
выпущен 12 ноября!


УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ FAQ ПО DELPHI



TServerSocket и TClientSocket без scktsrvr.exe отказываются работать

Встpечаются девушка и молодой человек, знакомые лишь виртуально. Молодой человек, смотpя на девушку:
- Так вот почему с тобой было так интеpесно говоpить - все остальное с тобой делать пpосто беcполезно.

Вопрос: У меня ни TServerSocket, ни TClientSocket без scktsrvr.exe отказываются работать! Слышал, что для решения проблемы можно что-то откуда-то вырезать и вклеить в программу.

Установите этот компонент:


 unit Sck;
 
 interface
 
 uses
   Classes, SysUtils, Windows, Messages,
   ScktComp, SConnect, ActiveX, MidConst;
 
 type
   TNotifyClient = procedure (Sender: TObject; Thread: TServerClientThread) of
 object;
 
 { TSocketDispatcher }
   TSocketDispatcher = class;
 
 { TSocketDispatcherThread }
   TSocketDispatcherThread = class(TServerClientThread, ISendDataBlock)
   private
     FRefCount: Integer;
     FInterpreter: TDataBlockInterpreter;
     FTransport: ITransport;
     FInterceptGUID: string;
     FLastActivity: TDateTime;
     FTimeout: TDateTime;
     FRegisteredOnly: Boolean;
   protected
     SocketDispatcher: TSocketDispatcher;
     function CreateServerTransport: ITransport; virtual;
     procedure AddClient;
     procedure RemoveClient;
     { IUnknown }
     function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
     function _AddRef: Integer; stdcall;
     function _Release: Integer; stdcall;
     { ISendDataBlock }
     function Send(const Data: IDataBlock; WaitForResult: Boolean): IDataBlock;
 stdcall;
   public
     constructor Create(AOwner: TSocketDispatcher; CreateSuspended: Boolean;
       ASocket: TServerClientWinSocket; const InterceptGUID: string;
       Timeout: Integer; RegisteredOnly: Boolean);
     procedure ClientExecute; override;
     property LastActivity: TDateTime read FLastActivity;
   end;
 
 { TSocketDispatcher }
   TSocketDispatcher = class(TServerSocket)
   private
     FInterceptGUID: string;
     FTimeout: Integer;
     FRegisteredOnly: Boolean;
     FOnRemoveClient: TNotifyClient;
     FOnAddClient: TNotifyClient;
     procedure GetThread(Sender: TObject; ClientSocket: TServerClientWinSocket;
       var SocketThread: TServerClientThread);
   published
     constructor Create(AOwner: TComponent); override;
     property InterceptGUID: string read FInterceptGUID write FInterceptGUID;
     property Timeout: Integer read FTimeout write FTimeout;
     property RegisteredOnly: Boolean read FRegisteredOnly write
 FRegisteredOnly;
     property OnAddClient: TNotifyClient read FOnAddClient write FOnAddClient;
     property OnRemoveClient: TNotifyClient read FOnRemoveClient write
 FOnRemoveClient;
   end;
 
 procedure Register;
 
 implementation
 
 procedure Register;
 begin
   RegisterComponents('Midas', [TSocketDispatcher]);
 end;
 
 { TSocketDispatcherThread }
 
 constructor TSocketDispatcherThread.Create(AOwner: TSocketDispatcher;
   CreateSuspended: Boolean; ASocket: TServerClientWinSocket;
   const InterceptGUID: string; Timeout: Integer; RegisteredOnly: Boolean);
 begin
   SocketDispatcher := AOwner;
   FInterceptGUID := InterceptGUID;
   FTimeout := EncodeTime(Timeout div 60, Timeout mod 60, 0, 0);
   FLastActivity := Now;
   FRegisteredOnly := RegisteredOnly;
   inherited Create(CreateSuspended, ASocket);
 end;
 
 function TSocketDispatcherThread.CreateServerTransport: ITransport;
 var
   SocketTransport: TSocketTransport;
 begin
   SocketTransport := TSocketTransport.Create;
   SocketTransport.Socket := ClientSocket;
   SocketTransport.InterceptGUID := FInterceptGUID;
   Result := SocketTransport as ITransport;
 end;
 
 procedure TSocketDispatcherThread.AddClient;
 begin
   with SocketDispatcher do
     if Assigned(OnAddClient) then OnAddClient(SocketDispatcher, Self);
 end;
 
 procedure TSocketDispatcherThread.RemoveClient;
 begin
   with SocketDispatcher do
     if Assigned(OnRemoveClient) then OnRemoveClient(SocketDispatcher, Self);
 end;
 
 { TSocketDispatcherThread.IUnknown }
 
 function TSocketDispatcherThread.QueryInterface(const IID: TGUID;
   out Obj): HResult;
 begin
   if GetInterface(IID, Obj) then Result := 0 else Result := E_NOINTERFACE;
 end;
 
 function TSocketDispatcherThread._AddRef: Integer;
 begin
   Inc(FRefCount);
   Result := FRefCount;
 end;
 
 function TSocketDispatcherThread._Release: Integer;
 begin
   Dec(FRefCount);
   Result := FRefCount;
 end;
 
 { TSocketDispatcherThread.ISendDataBlock }
 
 function TSocketDispatcherThread.Send(const Data: IDataBlock;
   WaitForResult: Boolean): IDataBlock;
 begin
   FTransport.Send(Data);
   if WaitForResult then
     while True do
     begin
       Result := FTransport.Receive(True, 0);
       if Result = nil then break;
       if (Result.Signature and ResultSig) = ResultSig then
         break else
         FInterpreter.InterpretData(Result);
     end;
 end;
 
 procedure TSocketDispatcherThread.ClientExecute;
 var
   Data: IDataBlock;
   msg: TMsg;
   Obj: ISendDataBlock;
   Event: THandle;
   WaitTime: DWord;
 begin
   CoInitialize(nil);
   try
     Synchronize(AddClient);
     FTransport := CreateServerTransport;
     try
       Event := FTransport.GetWaitEvent;
       PeekMessage(msg, 0, WM_USER, WM_USER, PM_NOREMOVE);
       GetInterface(ISendDataBlock, Obj);
       if FRegisteredOnly then
         FInterpreter := TDataBlockInterpreter.Create(Obj, SSockets) else
         FInterpreter := TDataBlockInterpreter.Create(Obj, '');
       try
         Obj := nil;
         if FTimeout = 0 then
           WaitTime := INFINITE else
           WaitTime := 60000;
         while not Terminated and FTransport.Connected do
         try
           case MsgWaitForMultipleObjects(1, Event, False, WaitTime,
            QS_ALLEVENTS) of
             WAIT_OBJECT_0:
             begin
               WSAResetEvent(Event);
               Data := FTransport.Receive(False, 0);
               if Assigned(Data) then
               begin
                 FLastActivity := Now;
                 FInterpreter.InterpretData(Data);
                 Data := nil;
                 FLastActivity := Now;
               end;
             end;
             WAIT_OBJECT_0 + 1:
               while PeekMessage(msg, 0, 0, 0, PM_REMOVE) do
                 DispatchMessage(msg);
             WAIT_TIMEOUT:
               if (FTimeout > 0) and ((Now - FLastActivity) > FTimeout) then
                 FTransport.Connected := False;
           end;
         except
           FTransport.Connected := False;
         end;
       finally
         FInterpreter.Free;
         FInterpreter := nil;
       end;
     finally
       FTransport := nil;
     end;
   finally
     CoUninitialize;
     Synchronize(RemoveClient);
   end;
 end;
 
 
 { TSocketDispatcher }
 
 constructor TSocketDispatcher.Create(AOwner: TComponent);
 begin
   inherited Create(AOwner);
   ServerType := stThreadBlocking;
   OnGetThread := GetThread;
 end;
 
 procedure TSocketDispatcher.GetThread(Sender: TObject;
   ClientSocket: TServerClientWinSocket;
   var SocketThread: TServerClientThread);
 begin
   SocketThread := TSocketDispatcherThread.Create(Self, False, ClientSocket,
     InterceptGUID, Timeout, RegisteredOnly);
 end;
 
 end.
 
 




<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS