Data.Write(I, SizeOf(Integer));
  end else
    WriteVariant(V, Data);
  Data.Signature := ResultSig or asCreateObject;
  FSendDataBlock.Send(Data, False);
end;

procedure TDataBlockInterpreter.DoFreeObject(const Data: IDataBlock);
var
  VarFlags: TVarFlags;
begin
  try
    ReleaseObject(ReadVariant(VarFlags, Data));
  except
    { Don't return any exceptions }
  end;
end;

procedure TDataBlockInterpreter.DoGetIDsOfNames(const Data: IDataBlock);
var
  ObjID, RetVal, DispID: Integer;
  Disp: IDispatch;
  W: WideString;
  VarFlags: TVarFlags;
begin
  ObjID := ReadVariant(VarFlags, Data);
  Disp := LockObject(ObjID);
  try
    W := ReadVariant(VarFlags, Data);
    Data.Clear;
    RetVal := Disp.GetIDsOfNames(GUID_NULL, @W, 1, 0, @DispID);
  finally
    UnlockObject(ObjID, Disp);
  end;
  WriteVariant(RetVal, Data);
  if RetVal = S_OK then
    WriteVariant(DispID, Data);
  Data.Signature := ResultSig or asGetID;
  FSendDataBlock.Send(Data, False);
end;

procedure TDataBlockInterpreter.DoInvoke(const Data: IDataBlock);
var
  ExcepInfo: TExcepInfo;
  DispParams: TDispParams;
  ObjID, DispID, Flags, i: Integer;
  RetVal: HRESULT;
  ExpectResult: Boolean;
  VarFlags: TVarFlags;
  Disp: IDispatch;
  VarList: PVariantArray;
  V: OleVariant;
begin  //
  VarList := nil;  //參數列表
  FillChar(ExcepInfo, SizeOf(ExcepInfo), 0);//異常信息
  FillChar(DispParams, SizeOf(DispParams), 0);//參數
  ObjID := ReadVariant(VarFlags, Data);  //讀取對象ID
  Disp := LockObject(ObjID); // 找到對象
  try
    DispID := ReadVariant(VarFlags, Data);//讀取調度ID
    Flags := ReadVariant(VarFlags, Data);//讀取數據標識
    ExpectResult := ReadVariant(VarFlags, Data);//讀取異常標識
    DispParams.cArgs := ReadVariant(VarFlags, Data);//讀取調度參數
    DispParams.cNamedArgs := ReadVariant(VarFlags, Data);//讀取調度參數名稱
    try
      DispParams.rgdispidNamedArgs := nil;//
      if DispParams.cNamedArgs > 0 then //名字參數
      begin
        GetMem(DispParams.rgdispidNamedArgs, DispParams.cNamedArgs * SizeOf(Integer));
        for i := 0 to DispParams.cNamedArgs - 1 do
          DispParams.rgdispidNamedArgs[i] := ReadVariant(VarFlags, Data);
      end;
      if DispParams.cArgs > 0 then  //參數個數
      begin
        GetMem(DispParams.rgvarg, DispParams.cArgs * SizeOf(TVariantArg));//分配參數空間
        GetMem(VarList, DispParams.cArgs * SizeOf(OleVariant));//分配參數空間
        Initialize(VarList^, DispParams.cArgs); //分配列表空間
        for i := 0 to DispParams.cArgs - 1 do
        begin
          VarList[i] := ReadVariant(VarFlags, Data); //依次讀取參數
          if vfByRef in VarFlags then //類型參考
          begin
            if vfVariant in VarFlags then //如果是變體
            begin
              DispParams.rgvarg[i].vt := varVariant or varByRef;
              TVarData(DispParams.rgvarg[i]).VPointer := @VarList[i];
            end else
            begin
              DispParams.rgvarg[i].vt := VarType(VarList[i]) or varByRef; //如果是具體類型
              TVarData(DispParams.rgvarg[i]).VPointer := GetVariantPointer(VarList[i]);//存正確指針
            end;
          end else
            DispParams.rgvarg[i] := TVariantArg(VarList[i]);//無類型
        end;
      end;
      Data.Clear; //清空數據包
      RetVal := Disp.Invoke(DispID, GUID_NULL, 0, Flags, DispParams, @V, @ExcepInfo, nil);//AuotObject調用
      WriteVariant(RetVal, Data);//寫入返回結果
      if RetVal = DISP_E_EXCEPTION then //如果調用異常
      begin
        WriteVariant(ExcepInfo.scode, Data); //返回異常碼
        WriteVariant(ExcepInfo.bstrDescription, Data);//返回異常描述
      end;
      if DispParams.rgvarg <> nil then //如果休要返回參數
      begin
        for i := 0 to DispParams.cArgs - 1 do //填寫返回參數
          if DispParams.rgvarg[i].vt and varByRef = varByRef then
            WriteVariant(OleVariant(DispParams.rgvarg[i]), Data);
      end;
      if ExpectResult then WriteVariant(V, Data); //如果有返回值，寫返回值
      Data.Signature := ResultSig or asInvoke;//標識為調用返回
      FSendDataBlock.Send(Data, False);//發送數據包
    finally
      if DispParams.rgdispidNamedArgs <> nil then //參數名稱
        FreeMem(DispParams.rgdispidNamedArgs);    //釋放參數名稱
      if VarList <> nil then                      //釋放值表
      begin
        Finalize(VarList^, DispParams.cArgs);
        FreeMem(VarList);
      end;
      if DispParams.rgvarg <> nil then
        FreeMem(DispParams.rgvarg);
    end;
  finally
    UnlockObject(ObjID, Disp);
  end;
end;

function TDataBlockInterpreter.DoCustomAction(Action: Integer;
  const Data: IDataBlock): Boolean;
begin
  Result := False;
end;

{ TDataDispatch }

constructor TDataDispatch.Create(Interpreter: TCustomDataBlockInterpreter; DispatchIndex: Integer);
begin
  inherited Create;
  FDispatchIndex := DispatchIndex;
  FInterpreter := Interpreter;
  Interpreter.AddDispatch(Self);
end;

destructor TDataDispatch.Destroy;
begin
  if Assigned(FInterpreter) then
  begin
    FInterpreter.CallFreeObject(FDispatchIndex);
    FInterpreter.RemoveDispatch(Self);
  end;
  inherited Destroy;
end;

{ TDataDispatch.IDispatch }

function TDataDispatch.GetTypeInfoCount(out Count: Integer): HResult; stdcall;
begin
  Count := 0;
  Result := S_OK;
end;

function TDataDispatch.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
begin
  Result := E_NOTIMPL;
end;

function TDataDispatch.GetIDsOfNames(const IID: TGUID; Names: Pointer;
  NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
begin
  Result := FInterpreter.CallGetIDsOfNames(FDispatchIndex, IID, Names, NameCount,
    LocaleID, DispIDs);
end;

function TDataDispatch.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
begin
  Result := FInterpreter.CallInvoke(FDispatchIndex, DispID, IID, LocaleID, Flags,
    Params, VarResult, ExcepInfo, ArgErr);
end;


{ TTransportThread }

constructor TTransportThread.Create(AHandle: THandle; Transport: ITransport);
begin
  FParentHandle := AHandle;
  FTransport := Transport;
  FreeOnTerminate := True;
  FSemaphore := CreateSemaphore(nil, 0, 1, nil);
  inherited Create(False);
end;

destructor TTransportThread.Destroy;
begin
  CloseHandle(FSemaphore);
  inherited Destroy;
end;

procedure TTransportThread.Execute;

  procedure SynchronizeException;
  var
    SendException: TObject;
  begin
    SendException := AcquireExceptionObject;
    if Assigned(FTransport) and (SendException is ESocketConnectionError) then
      FTransport.Connected := False;
    PostMessage(FParentHandle, THREAD_EXCEPTION, 0, Integer(Pointer(SendException)));
  end;

var
  msg: TMsg;
  Data: IDataBlock;
  Event: THandle;
  Context: Integer;
begin
  CoInitialize(nil);
  try
    PeekMessage(msg, 0, WM_USER, WM_USER, PM_NOREMOVE);
    ReleaseSemaphore(FSemaphore, 1, nil);
    try
      FTransport.Connected := True;
      try
        Event := FTransport.GetWaitEvent;
        while not Terminated and FTransport.Connected do
        try
          case MsgWaitForMultipleObjects(1, Event, False, INFINITE, QS_ALLINPUT) of
            WAIT_OBJECT_0:
            begin
              WSAResetEvent(Event);
              Data := FTransport.Receive(False, 0);
              if Assigned(Data) then
              begin
                Data._AddRef;
                PostMessage(FParentHandle, THREAD_RECEIVEDSTREAM, 0, Integer(Pointer(Data)));
                Data := nil;
              end;
            end;
            WAIT_OBJECT_0 + 1:
            begin
              while PeekMessage(msg, 0, 0, 0, PM_REMOVE) do
              begin
                if (msg.hwnd = 0) then
                  case msg.message of
                    THREAD_SENDSTREAM:
                    begin
                      Data := IDataBlock(msg.lParam);
                      Data._Release;
                      Context := FTransport.Send(Data);
                      if msg.wParam = 1 then
                      begin
                        Data := FTransport.Receive(True, Context);
                        Data._AddRef;
                        PostMessage(FParentHandle, THREAD_RECEIVEDSTREAM, 0, Integer(Pointer(Data)));
                        Data := nil;
                      end else
                        PostMessage(FParentHandle, THREAD_SENDNOTIFY, 0, 0);
                    end;
                    THREAD_REPLACETRANSPORT:
                    begin
                      FTransport := ITransport(msg.lParam);
                      FTransport._Release;
                    end;
                  else
                    DispatchMessage(msg);
                  end
                else
                  DispatchMessage(msg);
              end;
            end;
          end;
        except
          SynchronizeException;
        end;
      finally
        Data := nil;
        FTransport.Connected := False;
      end;
    except
      SynchronizeException;
    end;
  finally
    FTransport := nil;
    CoUninitialize();
  end;
end;

{ TStreamedConnection }

constructor TStreamedConnection.Create(AOwner: TComponent);
var
  Obj: ISendDataBlock;
begin
  inherited Create(AOwner);
  GetInterface(ISendDataBlock, Obj);
//  FInterpreter := TDataBlockInterpreter.Create(Self, SSockets);
  FSupportCallbacks := True;
end;
procedure TStreamedConnection.SetConnected(Value: Boolean);
begin
  if (csReading in ComponentState) and Value then
    FStreamedConnected := True else
  begin
    if Value = GetConnected then Exit;
    if Value then
    begin
      if Assigned(BeforeConnect) then BeforeConnect(Self);
      DoConnect;
//      SendConnectEvent(True);
      if Assigned(AfterConnect) then AfterConnect(Self);
    end else
    begin
      if Assigned(BeforeDisconnect) then BeforeDisconnect(Self);
//      SendConnectEvent(False);
      DoDisconnect;
      if Assigned(AfterDisconnect) then AfterDisconnect(Self);
    end;
  end;
end;


destructor TStreamedConnection.Destroy;
begin
  SetConnected(False);
  FInterpreter.Free;
  if FHandle <> 0 then DeallocateHWnd(FHandle);
  if Assigned(FTransport) then FTransport.OnTerminate := nil;
  FTransIntf := nil;
  inherited Destroy;
end;

function TStreamedConnection.GetInterceptGUID: string;
begin
  if (FInterceptGUID.D1 <> 0) or (FInterceptGUID.D2 <> 0) or (FInterceptGUID.D3 <> 0) then
    Result := GUIDToString(FInterceptGUID) else
    Result := '';
end;

procedure TStreamedConnection.SetInterceptGUID(const Value: string);
var
  InterceptName: PWideChar;
begin
  if not (csLoading in ComponentState) then
    SetConnected(False);
  if Value = '' then
    FillChar(FInterceptGUID, SizeOf(FInterceptGUID), 0)
  else
  begin
    FInterceptGUID := StringToGUID(Value);
    if ProgIDFromCLSID(FInterceptGUID, InterceptName) = 0 then
    begin
      FInterceptName := InterceptName;
      CoTaskMemFree(InterceptName);
    end;
  end;
end;

procedure TStreamedConnection.SetInterceptName(const Value: string);
begin
  if Value <> FInterceptName then
  begin
    if not (csLoading in ComponentState) then
    begin
      SetConnected(False);
      if CLSIDFromProgID(PWideChar(WideString(Value)), FInterceptGUID) <> 0 then
        FillChar(FInterceptGUID, SizeOf(FInterceptGUID), 0);
    end;
    FInterceptName := Value;
  end;
end;

procedure TStreamedConnection.SetSupportCallbacks(Value: Boolean);
begin
  if Connected then Connected := False;
  FSupportCallbacks := Value;
end;

procedure TStreamedConnection.InternalOpen;
begin
  if FSupportCallbacks then
  begin
    FTransport := TTransportThread.Create(Handle, CreateTransport);
    FTransport.OnTerminate := TransportTerminated;
    WaitForSingleObject(FTransport.Semaphore, INFINITE);
  end else
  begin
    FTransIntf := CreateTransport;
    FTransIntf.SetConnected(True);
  end;
end;

procedure TStreamedConnection.InternalClose;
begin
  if Assigned(FTransport) then
  begin
    FTransport.OnTerminate := nil;
    FTransport.Terminate;
    PostThreadMessage(FTransport.ThreadID, WM_USER, 0, 0);
    WaitForSingleObject(FTransport.Handle, 180000);
    FTransport := nil;
  end else
  if Assigned(FTransIntf) then
  begin
    FTransIntf.Connected := False;
    FTransIntf := nil;
  end;
end;

function TStreamedConnection.GetInterceptorList: OleVariant;
var
  List: TStringList;
  i: Integer;
begin
  Result := NULL;
  List := TStringList.Create;
  try
    GetPacketInterceptorList(List);
    if List.Count > 0 then
    begin
      Result := VarArrayCreate([0, List.Count - 1], varOleStr);
      for i := 0 to List.Count - 1 do
        Result[i] := List[i];
    end;
  finally