Delphi World - TServerSocket и TClientSocket без scktsrvr.exe отказываются работать
Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
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.


Проект Delphi World © Выпуск 2002 - 2017
Автор проекта: Эксклюзивные курсы программирования