Как отправить и обработать сообщение между родительским потоком TService и дочерним потоком?

Question

Я использую Delphi 2010 для создания службы Windows, которая будет отслеживать несколько разделов реестра и выполнять действия при изменении.Я использую RegMonitorThread от delphi.about.com, и моя проблема заключается в том, что мой основной служебный поток никогда не получает сообщение, отправленное из TRegMonitorThread.

type
  TMyService = class(TService)
    procedure ServiceExecute(Sender: TService);
    procedure ServiceShutdown(Sender: TService);
    procedure ServiceStart(Sender: TService; var Started: Boolean);
  private
    function main: boolean;
    { Private declarations }
  public
    function GetServiceController: TServiceController; override;
    procedure WMREGCHANGE(var Msg: TMessage); message WM_REGCHANGE;
    { Public declarations }
  end;

-

procedure TMyService.ServiceStart(Sender: TService; var Started: Boolean);
begin
    with TRegMonitorThread.Create do
    begin
        FreeOnTerminate := True;
        Wnd := ServiceThread.Handle;
        Key := 'SYSTEM\CurrentControlSet\Services\Tcpip\Parameters';
        RootKey := HKEY_LOCAL_MACHINE;
        WatchSub := True;
        Start;
    end;
end;

Здесь я пытаюсь обработать сообщение, отправленное из ветки уведомлений реестра ... но кажется, что это никогда не вызывается.

procedure TMyService.WMREGCHANGE(var Msg: TMessage);
begin
  OutputDebugString(PChar('Registry change at ' + DateTimeToStr(Now)));
end;

Я подтвердил, что сообщение обрабатываетсяотправлен и достигает этой точки кода в модуле RegMonitorThread.pas

procedure TRegMonitorThread.Execute;
begin
  InitThread;

  while not Terminated do
  begin
    if WaitForSingleObject(FEvent, INFINITE) = WAIT_OBJECT_0 then
    begin
      fChangeData.RootKey := RootKey;
      fChangeData.Key := Key;

      SendMessage(Wnd, WM_REGCHANGE, RootKey, longint(PChar(Key)));
      ResetEvent(FEvent);

      RegNotifyChangeKeyValue(FReg.CurrentKey, 1, Filter, FEvent, 1);
    end;
  end;
end;

Есть идеи о том, что мне здесь не хватает?Я упомяну это, потому что это может иметь отношение к проблеме, я на Windows 7.

Answer 1

TServiceThread.Handle - дескриптор потока, а не дескриптор окна. Вы не можете использовать его для получения сообщений Windows (он доступен для использования в функциях управления потоками), вам нужно настроить дескриптор окна. Вы можете найти пример здесь: http://delphi.about.com/od/windowsshellapi/l/aa093003a.htm

Answer 2

Я часто сталкиваюсь с той же проблемой. Я посмотрел на OmniThreadLibrary, и это выглядело как излишнее для моих целей. Я написал простую библиотеку, которую я называю TCommThread. Он позволяет передавать данные обратно в основной поток, не беспокоясь о любой сложности потоков или сообщений Windows.

Вот код, если вы хотите его попробовать.

Библиотека CommThread:

unit Threading.CommThread;

interface

uses
  Classes, SysUtils, ExtCtrls, SyncObjs, Generics.Collections, DateUtils;

const
  CTID_USER = 1000;
  PRM_USER = 1000;

  CTID_STATUS = 1;
  CTID_PROGRESS = 2;

type
  TThreadParams = class(TDictionary<String, Variant>);
  TThreadObjects = class(TDictionary<String, TObject>);

  TCommThreadParams = class(TObject)
  private
    FThreadParams: TThreadParams;
    FThreadObjects: TThreadObjects;
  public
    constructor Create;
    destructor Destroy; override;

    procedure Clear;

    function GetParam(const ParamName: String): Variant;
    function SetParam(const ParamName: String; ParamValue: Variant): TCommThreadParams;
    function GetObject(const ObjectName: String): TObject;
    function SetObject(const ObjectName: String; Obj: TObject): TCommThreadParams;
  end;

  TCommQueueItem = class(TObject)
  private
    FSender: TObject;
    FMessageId: Integer;
    FCommThreadParams: TCommThreadParams;
  public
    destructor Destroy; override;

    property Sender: TObject read FSender write FSender;
    property MessageId: Integer read FMessageId write FMessageId;
    property CommThreadParams: TCommThreadParams read FCommThreadParams write FCommThreadParams;
  end;

  TCommQueue = class(TQueue<TCommQueueItem>);

  ICommDispatchReceiver = interface
    ['{A4E2C9D1-E4E8-497D-A9BF-FAFE2D3A7C49}']
    procedure QueueMessage(Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams);
    procedure CommThreadTerminated(Sender: TObject);
    function Cancelled: Boolean;
  end;

  TCommThread = class(TThread)
  protected
    FCommThreadParams: TCommThreadParams;
    FCommDispatchReceiver: ICommDispatchReceiver;
    FName: String;
    FProgressFrequency: Integer;
    FNextSendTime: TDateTime;

    procedure SendStatusMessage(const StatusText: String; StatusType: Integer = 0); virtual;
    procedure SendProgressMessage(ProgressID: Int64; Progress, ProgressMax: Integer; AlwaysSend: Boolean = TRUE); virtual;
  public
    constructor Create(CommDispatchReceiver: TObject); reintroduce; virtual;
    destructor Destroy; override;

    function SetParam(const ParamName: String; ParamValue: Variant): TCommThread;
    function GetParam(const ParamName: String): Variant;
    function SetObject(const ObjectName: String; Obj: TObject): TCommThread;
    function GetObject(const ObjectName: String): TObject;
    procedure SendCommMessage(MessageId: Integer; CommThreadParams: TCommThreadParams); virtual;

    property Name: String read FName;
  end;

  TCommThreadClass = Class of TCommThread;

  TCommThreadQueue = class(TObjectList<TCommThread>);

  TCommThreadDispatchState = (
    ctsIdle,
    ctsActive,
    ctsTerminating
  );

  TOnReceiveThreadMessage = procedure(Source, Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams) of object;
  TOnStateChange = procedure(Sender: TObject; State: TCommThreadDispatchState) of object;
  TOnStatus = procedure(Source, Sender: TObject; const ID: String; StatusText: String; StatusType: Integer) of object;
  TOnProgress = procedure(Source, Sender: TObject; const ID: String; Progress, ProgressMax: Integer) of object;

  TBaseCommThreadDispatch = class(TComponent, ICommDispatchReceiver)
  private
    FProcessQueueTimer: TTimer;
    FCSReceiveMessage: TCriticalSection;
    FCSCommThreads: TCriticalSection;
    FCommQueue: TCommQueue;
    FActiveThreads: TList;
    FCommThreadClass: TCommThreadClass;
    FCommThreadDispatchState: TCommThreadDispatchState;

    function CreateThread(const ThreadName: String = ''): TCommThread;
    function GetActiveThreadCount: Integer;
    function GetStateText: String;
  protected
    FOnReceiveThreadMessage: TOnReceiveThreadMessage;
    FOnStateChange: TOnStateChange;
    FOnStatus: TOnStatus;
    FOnProgress: TOnProgress;
    FManualMessageQueue: Boolean;
    FProgressFrequency: Integer;

    procedure SetManualMessageQueue(const Value: Boolean);
    procedure SetProcessQueueTimerInterval(const Value: Integer);
    procedure SetCommThreadDispatchState(const Value: TCommThreadDispatchState);
    procedure QueueMessage(Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams);
    procedure OnProcessQueueTimer(Sender: TObject);
    function GetProcessQueueTimerInterval: Integer;

    procedure CommThreadTerminated(Sender: TObject); virtual;
    function Finished: Boolean; virtual;

    procedure DoOnReceiveThreadMessage(Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams); virtual;
    procedure DoOnStateChange; virtual;

    procedure TerminateActiveThreads;

    property OnReceiveThreadMessage: TOnReceiveThreadMessage read FOnReceiveThreadMessage write FOnReceiveThreadMessage;
    property OnStateChange: TOnStateChange read FOnStateChange write FOnStateChange;
    property OnStatus: TOnStatus read FOnStatus write FOnStatus;
    property OnProgress: TOnProgress read FOnProgress write FOnProgress;

    property ProgressFrequency: Integer read FProgressFrequency write FProgressFrequency;
    property ProcessQueueTimerInterval: Integer read GetProcessQueueTimerInterval write SetProcessQueueTimerInterval;
    property ManualMessageQueue: Boolean read FManualMessageQueue write SetManualMessageQueue;
    property CommThreadDispatchState: TCommThreadDispatchState read FCommThreadDispatchState write SetCommThreadDispatchState;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    function NewThread(const ThreadName: String = ''): TCommThread; virtual;
    procedure ProcessMessageQueue; virtual;
    procedure Stop; virtual;
    function State: TCommThreadDispatchState;
    function Cancelled: Boolean;

    property ActiveThreadCount: Integer read GetActiveThreadCount;
    property StateText: String read GetStateText;

    property CommThreadClass: TCommThreadClass read FCommThreadClass write FCommThreadClass;
  end;

  TCommThreadDispatch = class(TBaseCommThreadDispatch)
  published
    property OnReceiveThreadMessage: TOnReceiveThreadMessage read FOnReceiveThreadMessage write FOnReceiveThreadMessage;
    property OnStateChange: TOnStateChange read FOnStateChange write FOnStateChange;

    property ProgressFrequency: Integer read FProgressFrequency write FProgressFrequency;
    property ProcessQueueTimerInterval: Integer read GetProcessQueueTimerInterval write SetProcessQueueTimerInterval;
    property ManualMessageQueue: Boolean read FManualMessageQueue write SetManualMessageQueue;
  end;

  TBaseStatusCommThreadDispatch = class(TBaseCommThreadDispatch)
  protected
    FOnStatus: TOnStatus;
    FOnProgress: TOnProgress;

    procedure DoOnReceiveThreadMessage(Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams); override;

    procedure DoOnStatus(Sender: TObject;const ID: String; const StatusText: String; StatusType: Integer); virtual;
    procedure DoOnProgress(Sender: TObject; const ID: String; Progress, ProgressMax: Integer); virtual;

    property OnStatus: TOnStatus read FOnStatus write FOnStatus;
    property OnProgress: TOnProgress read FOnProgress write FOnProgress;
  end;

  TStatusCommThreadDispatch = class(TBaseStatusCommThreadDispatch)
  published
    property OnReceiveThreadMessage: TOnReceiveThreadMessage read FOnReceiveThreadMessage write FOnReceiveThreadMessage;
    property OnStateChange: TOnStateChange read FOnStateChange write FOnStateChange;
    property OnStatus: TOnStatus read FOnStatus write FOnStatus;
    property OnProgress: TOnProgress read FOnProgress write FOnProgress;

    property ProgressFrequency: Integer read FProgressFrequency write FProgressFrequency;
    property ProcessQueueTimerInterval: Integer read GetProcessQueueTimerInterval write SetProcessQueueTimerInterval;
    property ManualMessageQueue: Boolean read FManualMessageQueue write SetManualMessageQueue;
  end;

implementation

const
  PRM_STATUS_TEXT = 'Status';
  PRM_STATUS_TYPE = 'Type';
  PRM_PROGRESS_ID = 'ProgressID';
  PRM_PROGRESS = 'Progess';
  PRM_PROGRESS_MAX = 'ProgressMax';

resourcestring
  StrCommReceiverMustSupportInterface = 'CommDispatchReceiver must support ICommDispatchReceiver interface';
  StrSenderMustBeATCommThread = 'Sender must be a TCommThread';
  StrUnableToFindTerminatedThread = 'Unable to find the terminated thread';
  StrIdle = 'Idle';
  StrTerminating = 'Terminating';
  StrActive = 'Active';

{ TCommThread }

constructor TCommThread.Create(CommDispatchReceiver: TObject);
begin
  Assert(Supports(CommDispatchReceiver, ICommDispatchReceiver, FCommDispatchReceiver), StrCommReceiverMustSupportInterface);

  inherited Create(TRUE);

  FCommThreadParams := TCommThreadParams.Create;
end;

destructor TCommThread.Destroy;
begin
  FCommDispatchReceiver.CommThreadTerminated(Self);

  FreeAndNil(FCommThreadParams);

  inherited;
end;

function TCommThread.GetObject(const ObjectName: String): TObject;
begin
  Result := FCommThreadParams.GetObject(ObjectName);
end;

function TCommThread.GetParam(const ParamName: String): Variant;
begin
  Result := FCommThreadParams.GetParam(ParamName);
end;

procedure TCommThread.SendCommMessage(MessageId: Integer;
  CommThreadParams: TCommThreadParams);
begin
  FCommDispatchReceiver.QueueMessage(Self, MessageId, CommThreadParams);
end;

procedure TCommThread.SendProgressMessage(ProgressID: Int64; Progress,
  ProgressMax: Integer; AlwaysSend: Boolean);
begin
  if (AlwaysSend) or (now > FNextSendTime) then
  begin
    // Send a status message to the comm receiver
    SendCommMessage(CTID_PROGRESS, TCommThreadParams.Create
      .SetParam(PRM_PROGRESS_ID, ProgressID)
      .SetParam(PRM_PROGRESS, Progress)
      .SetParam(PRM_PROGRESS_MAX, ProgressMax));

    if not AlwaysSend then
      FNextSendTime := now + (FProgressFrequency * OneMillisecond);
  end;
end;

procedure TCommThread.SendStatusMessage(const StatusText: String;
  StatusType: Integer);
begin
  // Send a status message to the comm receiver
  SendCommMessage(CTID_STATUS, TCommThreadParams.Create
    .SetParam(PRM_STATUS_TEXT, StatusText)
    .SetParam(PRM_STATUS_TYPE, StatusType));
end;

function TCommThread.SetObject(const ObjectName: String;
  Obj: TObject): TCommThread;
begin
  Result := Self;

  FCommThreadParams.SetObject(ObjectName, Obj);
end;

function TCommThread.SetParam(const ParamName: String;
  ParamValue: Variant): TCommThread;
begin
  Result := Self;

  FCommThreadParams.SetParam(ParamName, ParamValue);
end;


{ TCommThreadDispatch }

function TBaseCommThreadDispatch.Cancelled: Boolean;
begin
  Result := State = ctsTerminating;
end;

procedure TBaseCommThreadDispatch.CommThreadTerminated(Sender: TObject);
var
  idx: Integer;
begin
  FCSCommThreads.Enter;
  try
    Assert(Sender is TCommThread, StrSenderMustBeATCommThread);

    // Find the thread in the active thread list
    idx := FActiveThreads.IndexOf(Sender);

    Assert(idx <> -1, StrUnableToFindTerminatedThread);

    // if we find it, remove it (we should always find it)
    FActiveThreads.Delete(idx);
  finally
    FCSCommThreads.Leave;
  end;
end;

constructor TBaseCommThreadDispatch.Create(AOwner: TComponent);
begin
  inherited;

  FCommThreadClass := TCommThread;

  FProcessQueueTimer := TTimer.Create(nil);
  FProcessQueueTimer.Enabled := FALSE;
  FProcessQueueTimer.Interval := 5;
  FProcessQueueTimer.OnTimer := OnProcessQueueTimer;
  FProgressFrequency := 200;

  FCommQueue := TCommQueue.Create;

  FActiveThreads := TList.Create;

  FCSReceiveMessage := TCriticalSection.Create;
  FCSCommThreads := TCriticalSection.Create;
end;

destructor TBaseCommThreadDispatch.Destroy;
begin
  // Stop the queue timer
  FProcessQueueTimer.Enabled := FALSE;

  TerminateActiveThreads;

  // Pump the queue while there are active threads
  while CommThreadDispatchState <> ctsIdle do
  begin
    ProcessMessageQueue;

    sleep(10);
  end;

  // Free everything
  FreeAndNil(FProcessQueueTimer);
  FreeAndNil(FCommQueue);
  FreeAndNil(FCSReceiveMessage);
  FreeAndNil(FCSCommThreads);
  FreeAndNil(FActiveThreads);

  inherited;
end;

procedure TBaseCommThreadDispatch.DoOnReceiveThreadMessage(Sender: TObject;
  MessageId: Integer; CommThreadParams: TCommThreadParams);
begin
  // Don't send the messages if we're being destroyed
  if not (csDestroying in ComponentState) then
  begin
    if Assigned(FOnReceiveThreadMessage) then
      FOnReceiveThreadMessage(Self, Sender, MessageId, CommThreadParams);
  end;
end;

procedure TBaseCommThreadDispatch.DoOnStateChange;
begin
  if (Assigned(FOnStateChange)) and (not (csDestroying in ComponentState)) then
    FOnStateChange(Self, FCommThreadDispatchState);
end;

function TBaseCommThreadDispatch.GetActiveThreadCount: Integer;
begin
  Result := FActiveThreads.Count;
end;

function TBaseCommThreadDispatch.GetProcessQueueTimerInterval: Integer;
begin
  Result := FProcessQueueTimer.Interval;
end;


function TBaseCommThreadDispatch.GetStateText: String;
begin
  case State of
    ctsIdle: Result := StrIdle;
    ctsTerminating: Result := StrTerminating;
    ctsActive: Result := StrActive;
  end;
end;

function TBaseCommThreadDispatch.NewThread(const ThreadName: String): TCommThread;
begin
  if FCommThreadDispatchState = ctsTerminating then
    Result := nil
  else
  begin
    // Make sure we're active
    if CommThreadDispatchState = ctsIdle then
      CommThreadDispatchState := ctsActive;

    Result := CreateThread(ThreadName);

    FActiveThreads.Add(Result);

    if ThreadName = '' then
      Result.FName := IntToStr(Integer(Result))
    else
      Result.FName := ThreadName;

    Result.FProgressFrequency := FProgressFrequency;
  end;
end;

function TBaseCommThreadDispatch.CreateThread(
  const ThreadName: String): TCommThread;
begin
  Result := FCommThreadClass.Create(Self);

  Result.FreeOnTerminate := TRUE;
end;

procedure TBaseCommThreadDispatch.OnProcessQueueTimer(Sender: TObject);
begin
  ProcessMessageQueue;
end;

procedure TBaseCommThreadDispatch.ProcessMessageQueue;
var
  CommQueueItem: TCommQueueItem;
begin
  if FCommThreadDispatchState in [ctsActive, ctsTerminating] then
  begin
    if FCommQueue.Count > 0 then
    begin
      FCSReceiveMessage.Enter;
      try
        CommQueueItem := FCommQueue.Dequeue;

        while Assigned(CommQueueItem) do
        begin
          try
            DoOnReceiveThreadMessage(CommQueueItem.Sender, CommQueueItem.MessageId, CommQueueItem.CommThreadParams);
          finally
            FreeAndNil(CommQueueItem);
          end;

          if FCommQueue.Count > 0 then
            CommQueueItem := FCommQueue.Dequeue;
        end;
      finally
        FCSReceiveMessage.Leave
      end;
    end;

    if Finished then
    begin
      FCommThreadDispatchState := ctsIdle;

      DoOnStateChange;
    end;
  end;
end;

function TBaseCommThreadDispatch.Finished: Boolean;
begin
  Result := FActiveThreads.Count = 0;
end;

procedure TBaseCommThreadDispatch.QueueMessage(Sender: TObject; MessageId: Integer;
  CommThreadParams: TCommThreadParams);
var
  CommQueueItem: TCommQueueItem;
begin
  FCSReceiveMessage.Enter;
  try
    CommQueueItem := TCommQueueItem.Create;
    CommQueueItem.Sender := Sender;
    CommQueueItem.MessageId := MessageId;
    CommQueueItem.CommThreadParams := CommThreadParams;

    FCommQueue.Enqueue(CommQueueItem);
  finally
    FCSReceiveMessage.Leave
  end;
end;

procedure TBaseCommThreadDispatch.SetCommThreadDispatchState(
  const Value: TCommThreadDispatchState);
begin
  if FCommThreadDispatchState <> ctsTerminating then
  begin
    if Value = ctsActive then
    begin
      if not FManualMessageQueue then
        FProcessQueueTimer.Enabled := TRUE;
    end
    else
      TerminateActiveThreads;
  end;

  FCommThreadDispatchState := Value;

  DoOnStateChange;
end;

procedure TBaseCommThreadDispatch.SetManualMessageQueue(const Value: Boolean);
begin
  FManualMessageQueue := Value;
end;

procedure TBaseCommThreadDispatch.SetProcessQueueTimerInterval(const Value: Integer);
begin
  FProcessQueueTimer.Interval := Value;
end;

function TBaseCommThreadDispatch.State: TCommThreadDispatchState;
begin
  Result := FCommThreadDispatchState;
end;

procedure TBaseCommThreadDispatch.Stop;
begin
  if CommThreadDispatchState = ctsActive then
    TerminateActiveThreads;
end;

procedure TBaseCommThreadDispatch.TerminateActiveThreads;
var
  i: Integer;
begin
  if FCommThreadDispatchState = ctsActive then
  begin
    // Lock threads
    FCSCommThreads.Acquire;
    try
      FCommThreadDispatchState := ctsTerminating;

      DoOnStateChange;

      // Terminate each thread in turn
      for i := 0 to pred(FActiveThreads.Count) do
        TCommThread(FActiveThreads[i]).Terminate;
    finally
      FCSCommThreads.Release;
    end;
  end;
end;


{ TCommThreadParams }

procedure TCommThreadParams.Clear;
begin
  FThreadParams.Clear;
  FThreadObjects.Clear;
end;

constructor TCommThreadParams.Create;
begin
  FThreadParams := TThreadParams.Create;
  FThreadObjects := TThreadObjects.Create;
end;

destructor TCommThreadParams.Destroy;
begin
  FreeAndNil(FThreadParams);
  FreeAndNil(FThreadObjects);

  inherited;
end;

function TCommThreadParams.GetObject(const ObjectName: String): TObject;
begin
  Result := FThreadObjects.Items[ObjectName];
end;

function TCommThreadParams.GetParam(const ParamName: String): Variant;
begin
  Result := FThreadParams.Items[ParamName];
end;

function TCommThreadParams.SetObject(const ObjectName: String;
  Obj: TObject): TCommThreadParams;
begin
  FThreadObjects.AddOrSetValue(ObjectName, Obj);

  Result := Self;
end;

function TCommThreadParams.SetParam(const ParamName: String;
  ParamValue: Variant): TCommThreadParams;
begin
  FThreadParams.AddOrSetValue(ParamName, ParamValue);

  Result := Self;
end;

{ TCommQueueItem }

destructor TCommQueueItem.Destroy;
begin
  if Assigned(FCommThreadParams) then
    FreeAndNil(FCommThreadParams);

  inherited;
end;


{ TBaseStatusCommThreadDispatch }

procedure TBaseStatusCommThreadDispatch.DoOnReceiveThreadMessage(
  Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams);
begin
  inherited;

  case MessageId of
    // Status Message
    CTID_STATUS: DoOnStatus(Sender,
                            Name,
                            CommThreadParams.GetParam(PRM_STATUS_TEXT),
                            CommThreadParams.GetParam(PRM_STATUS_TYPE));
    // Progress Message
    CTID_PROGRESS: DoOnProgress(Sender,
                                CommThreadParams.GetParam(PRM_PROGRESS_ID),
                                CommThreadParams.GetParam(PRM_PROGRESS),
                                CommThreadParams.GetParam(PRM_PROGRESS_MAX));
  end;
end;

procedure TBaseStatusCommThreadDispatch.DoOnStatus(Sender: TObject; const ID,
  StatusText: String; StatusType: Integer);
begin
  if (not (csDestroying in ComponentState)) and (Assigned(FOnStatus)) then
    FOnStatus(Self, Sender, ID, StatusText, StatusType);
end;

procedure TBaseStatusCommThreadDispatch.DoOnProgress(Sender: TObject;
  const ID: String; Progress, ProgressMax: Integer);
begin
  if not (csDestroying in ComponentState) and (Assigned(FOnProgress)) then
    FOnProgress(Self, Sender, ID, Progress, ProgressMax);
end;

end.

Чтобы использовать библиотеку, просто спустите ваш поток из потока TCommThread и переопределите процедуру Execute:

MyCommThreadObject = class(TCommThread)
public
  procedure Execute; override;
end;

Затем создайте потомок компонента TStatusCommThreadDispatch и установите его события.

  MyCommThreadComponent := TStatusCommThreadDispatch.Create(Self);

  // Add the event handlers
  MyCommThreadComponent.OnStateChange := OnStateChange;
  MyCommThreadComponent.OnReceiveThreadMessage := OnReceiveThreadMessage;
  MyCommThreadComponent.OnStatus := OnStatus;
  MyCommThreadComponent.OnProgress := OnProgress;

  // Set the thread class
  MyCommThreadComponent.CommThreadClass := TMyCommThread;

Убедитесь, что вы установили CommThreadClass на своего потомка TCommThread.

Теперь все, что вам нужно сделать, это создать темы с помощью MyCommThreadComponent:

  FCommThreadComponent.NewThread
    .SetParam('MyThreadInputParameter', '12345')
    .SetObject('MyThreadInputObject', MyObject)
    .Start;

Добавьте столько параметров и объектов, сколько захотите. В ваших потоках метод Execute вы можете получить параметры и объекты.

MyThreadParameter := GetParam('MyThreadInputParameter'); // 12345
MyThreadObject := GetObject('MyThreadInputObject'); // MyObject

Параметры будут автоматически освобождены. Вам нужно управлять объектами самостоятельно.

Чтобы отправить сообщение обратно в основной поток из потоков, выполните метод:

FCommDispatchReceiver.QueueMessage(Self, CTID_MY_MESSAGE_ID, TCommThreadParams.Create
  .SetObject('MyThreadObject', MyThreadObject)
  .SetParam('MyThreadOutputParameter', MyThreadParameter));

Опять же, параметры будут уничтожаться автоматически, объекты, которыми вы должны управлять сами.

Чтобы получать сообщения в основном потоке, либо присоедините событие OnReceiveThreadMessage, либо переопределите процедуру DoOnReceiveThreadMessage:

procedure DoOnReceiveThreadMessage(Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams); override;

Используйте переопределенную процедуру для обработки сообщений, отправленных обратно в ваш главный поток:

procedure THostDiscovery.DoOnReceiveThreadMessage(Sender: TObject;
  MessageId: Integer; CommThreadParams: TCommThreadParams);
begin
  inherited;

  case MessageId of

    CTID_MY_MESSAGE_ID:
      begin
        // Process the CTID_MY_MESSAGE_ID message
        DoSomethingWithTheMessage(CommThreadParams.GetParam('MyThreadOutputParameter'),
                                  CommThreadParams.GeObject('MyThreadObject'));
      end;
  end;
end;

Сообщения обрабатываются в процедуре ProcessMessageQueue . Эта процедура вызывается через TTimer. Если вы используете компонент в консольном приложении, вам нужно будет вызвать ProcessMessageQueue вручную. Таймер запустится, когда будет создан первый поток. Он остановится, когда закончится последний поток. Если вам нужно контролировать, когда таймер останавливается, вы можете отменить процедуру Finished . Вы также можете выполнять действия в зависимости от состояния потоков, переопределяя процедуру DoOnStateChange .

Посмотрите на потомок TCommThread TStatusCommThreadDispatch. Он реализует отправку простых сообщений о состоянии и ходе выполнения обратно в главный поток.

Надеюсь, это поможет, и я все объяснил.

Answer 3

Хм. Я не знаю о ServiceThread.Handle и о том, как он ведет себя в Windows 7, но, возможно, более безопасный способ - просто создать новый дескриптор окна через «AllocateHwnd». Тогда просто используйте WndProc для этого. Примерно так (кстати, вы проверили, что дескриптор окна является допустимым значением?):

FWinHandle := AllocateHWND(WndProc);

Распределите это так

procedure TMyService.DeallocateHWnd(Wnd: HWND);
var
  Instance: Pointer;
begin
  Instance := Pointer(GetWindowLong(Wnd, GWL_WNDPROC));

  if Instance <> @DefWindowProc then
  begin
    { make sure we restore the default
      windows procedure before freeing memory }
    SetWindowLong(Wnd, GWL_WNDPROC, Longint(@DefWindowProc));
    FreeObjectInstance(Instance);
  end;

  DestroyWindow(Wnd);
end;

Процедура WndProc

procedure TMyService.WndProc(var msg: TMessage);
begin
  if Msg.Msg = WM_REGCHANGE then
  begin
    {
     if the message id is WM_ON_SCHEDULE
     do our own processing
    }
  end
  else
    {
     for all other messages call
     the default window procedure
    }
    Msg.Result := DefWindowProc(FWinHandle, Msg.Msg, Msg.wParam, Msg.lParam);
end;

Это работает на Windows 7 в потоках и службах. Я использую это в нескольких местах. Думаю, безопаснее использовать некоторые внутренние окна службы VCL.

Answer 4

Это связано с моим предыдущим ответом, но я был ограничен 30000 символами.

Вот код для тестового приложения, использующего TCommThread:

Тестовое приложение (.pas)

unit frmMainU;

interface

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

  Threading.CommThread;

type
  TMyCommThread = class(TCommThread)
  public
    procedure Execute; override;
  end;

  TfrmMain = class(TForm)
    Panel1: TPanel;
    lvLog: TListView;
    btnStop: TButton;
    btnNewThread: TButton;
    StatusBar1: TStatusBar;
    btn30NewThreads: TButton;
    tmrUpdateStatusBar: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure btnStopClick(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure tmrUpdateStatusBarTimer(Sender: TObject);
  private
    FCommThreadComponent: TStatusCommThreadDispatch;

    procedure OnReceiveThreadMessage(Source, Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams);
    procedure OnStateChange(Sender: TObject; State: TCommThreadDispatchState);
    procedure UpdateStatusBar;
    procedure OnStatus(Source, Sender: TObject; const ID: String; StatusText: String; StatusType: Integer);
    procedure OnProgress(Source, Sender: TObject; const ID: String; Progress,  ProgressMax: Integer);
  public

  end;

var
  frmMain: TfrmMain;

implementation

resourcestring
  StrStatusIDDProgre = 'StatusID: %s, Progress: %d, ProgressMax: %d';
  StrActiveThreadsD = 'Active Threads: %d, State: %s';
  StrIdle = 'Idle';
  StrActive = 'Active';
  StrTerminating = 'Terminating';

{$R *.dfm}

{ TMyCommThread }

procedure TMyCommThread.Execute;
var
  i: Integer;
begin
  SendCommMessage(0, TCommThreadParams.Create.SetParam('status', 'started'));

  for i := 0 to 40 do
  begin
    sleep(50);

    SendStatusMessage(format('Thread: %s, i = %d', [Name, i]), 1);

    if Terminated then
      Break;

    sleep(50);

    SendProgressMessage(Integer(Self), i, 40, FALSE);
  end;

  if Terminated then
    SendCommMessage(0, TCommThreadParams.Create.SetParam('status', 'terminated'))
  else
    SendCommMessage(0, TCommThreadParams.Create.SetParam('status', 'finished'));
end;


{ TfrmMain }

procedure TfrmMain.btnStopClick(Sender: TObject);
begin
  FCommThreadComponent.Stop;
end;

procedure TfrmMain.Button3Click(Sender: TObject);
var
  i: Integer;
begin
  for i := 0 to 29 do
    FCommThreadComponent.NewThread
      .SetParam('input_param1', 'test_value')
      .Start;
end;

procedure TfrmMain.Button4Click(Sender: TObject);
begin
  FCommThreadComponent.NewThread
    .SetParam('input_param1', 'test_value')
    .Start;
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  FCommThreadComponent := TStatusCommThreadDispatch.Create(Self);

  // Add the event handlers
  FCommThreadComponent.OnStateChange := OnStateChange;
  FCommThreadComponent.OnReceiveThreadMessage := OnReceiveThreadMessage;
  FCommThreadComponent.OnStatus := OnStatus;
  FCommThreadComponent.OnProgress := OnProgress;

  // Set the thread class
  FCommThreadComponent.CommThreadClass := TMyCommThread;
end;

procedure TfrmMain.OnProgress(Source, Sender: TObject; const ID: String; Progress, ProgressMax: Integer);
begin
  With lvLog.Items.Add do
  begin
    Caption := '-';

    SubItems.Add(format(StrStatusIDDProgre, [Id, Progress, ProgressMax]));
  end;
end;

procedure TfrmMain.OnReceiveThreadMessage(Source, Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams);
begin
  if MessageID = 0 then
    With lvLog.Items.Add do
    begin
      Caption := IntToStr(MessageId);

      SubItems.Add(CommThreadParams.GetParam('status'));
    end;
end;

procedure TfrmMain.UpdateStatusBar;
begin
  StatusBar1.SimpleText := format(StrActiveThreadsD, [FCommThreadComponent.ActiveThreadCount, FCommThreadComponent.StateText]);
end;

procedure TfrmMain.OnStateChange(Sender: TObject; State: TCommThreadDispatchState);
begin
  With lvLog.Items.Add do
  begin
    case State of
      ctsIdle: Caption := StrIdle;
      ctsActive: Caption := StrActive;
      ctsTerminating: Caption := StrTerminating;
    end;
  end;
end;

procedure TfrmMain.OnStatus(Source, Sender: TObject; const ID: String; StatusText: String; StatusType: Integer);
begin
  With lvLog.Items.Add do
  begin
    Caption := IntToStr(StatusType);

    SubItems.Add(StatusText);
  end;
end;

procedure TfrmMain.tmrUpdateStatusBarTimer(Sender: TObject);
begin
  UpdateStatusBar;
end;

end.

Тестовое приложение (.dfm)

object frmMain: TfrmMain
  Left = 0
  Top = 0
  Caption = 'CommThread Test'
  ClientHeight = 290
  ClientWidth = 557
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object Panel1: TPanel
    AlignWithMargins = True
    Left = 3
    Top = 3
    Width = 97
    Height = 265
    Margins.Right = 0
    Align = alLeft
    BevelOuter = bvNone
    TabOrder = 0
    object btnStop: TButton
      AlignWithMargins = True
      Left = 0
      Top = 60
      Width = 97
      Height = 25
      Margins.Left = 0
      Margins.Top = 10
      Margins.Right = 0
      Margins.Bottom = 0
      Align = alTop
      Caption = 'Stop'
      TabOrder = 2
      OnClick = btnStopClick
    end
    object btnNewThread: TButton
      Left = 0
      Top = 0
      Width = 97
      Height = 25
      Align = alTop
      Caption = 'New Thread'
      TabOrder = 0
      OnClick = Button4Click
    end
    object btn30NewThreads: TButton
      Left = 0
      Top = 25
      Width = 97
      Height = 25
      Align = alTop
      Caption = '30 New Threads'
      TabOrder = 1
      OnClick = Button3Click
    end
  end
  object lvLog: TListView
    AlignWithMargins = True
    Left = 103
    Top = 3
    Width = 451
    Height = 265
    Align = alClient
    Columns = <
      item
        Caption = 'Message ID'
        Width = 70
      end
      item
        AutoSize = True
        Caption = 'Info'
      end>
    ReadOnly = True
    RowSelect = True
    TabOrder = 1
    ViewStyle = vsReport
  end
  object StatusBar1: TStatusBar
    Left = 0
    Top = 271
    Width = 557
    Height = 19
    Panels = <>
    SimplePanel = True
  end
  object tmrUpdateStatusBar: TTimer
    Interval = 200
    OnTimer = tmrUpdateStatusBarTimer
    Left = 272
    Top = 152
  end
end