如何在TService父线程和子线程之间发送和处理消息?

发布于 2024-09-30 12:27:56 字数 1880 浏览 7 评论 0原文

我正在使用 Delphi 2010 创建一个 Windows 服务,该服务将监视多个注册表项,并在发生更改时执行操作。我正在使用来自 delphi.about.com 的 RegMonitorThread ,我的问题是我的主服务线程永远不会接收从 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。

I am using Delphi 2010 to create a Windows service that will monitor several registry keys, and perform an action when a change occurs. I am using RegMonitorThread from delphi.about.com, and my issue is that my main service thread never receives the message that is sent from the 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;

Here is where I attempt to handle the message sent from the registry notification thread...but this never seems to be called.

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

I have confirmed that the message is being sent, and is reaching this point of code in the RegMonitorThread.pas unit

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;

Any ideas on what I'm missing here? I'll mention it because it may be relevant to the problem, I am on Windows 7.

如果你对这篇内容有疑问,欢迎到本站社区发帖提问 参与讨论,获取更多帮助,或者扫码二维码加入 Web 技术交流群。

扫码二维码加入Web技术交流群

发布评论

需要 登录 才能够评论, 你可以免费 注册 一个本站的账号。

评论(4

海未深 2024-10-07 12:27:56

TServiceThread.Handle 是线程句柄,而不是窗口句柄。你不能用它来接收窗口消息(它可以在线程管理函数中使用),你必须设置一个窗口句柄。您可以在此处找到示例: http://delphi.about.com/od/ windowsshellapi/l/aa093003a.htm

TServiceThread.Handle is a thread handle, not a window handle. You can't use it to receive windows messages (it is available to be used in thread management functions), you have to setup a window handle. You can find an example here: http://delphi.about.com/od/windowsshellapi/l/aa093003a.htm

薄暮涼年 2024-10-07 12:27:56

我经常遇到同样的问题。我查看了 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 线程派生您的线程并覆盖执行过程:

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。计时器将在第一个线程创建时启动。当最后一个线程完成时它将停止。如果您需要控制计时器何时停止,您可以覆盖已完成过程。您还可以通过重写 DoOnStateChange 过程来根据线程的状态执行操作。

看一下 TCommThread 后代 TStatusCommThreadDispatch。它实现了将简单的状态和进度消息发送回主线程。

我希望这对您有所帮助,并且我已经解释得很好。

I have often run into the same problem. I took a look at OmniThreadLibrary and it looked like overkill for my purposes. I wrote a simple library I call TCommThread. It allows you to pass data back to the main thread without worrying about any of the complexities of threads or Windows messages.

Here's the code if you'd like to try it.

CommThread Library:

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.

To use the library, simply descend your thread from the TCommThread thread and override the Execute procedure:

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

Next, create a descendant of the TStatusCommThreadDispatch component and set it's events.

  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;

Make sure you set the CommThreadClass to your TCommThread descendant.

Now all you need to do is create the threads via MyCommThreadComponent:

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

Add as many parameters and objects as you like. In your threads Execute method you can retrieve the parameters and objects.

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

Parameters will be automatically freed. You need to manage objects yourself.

To send a message back to the main thread from the threads execute method:

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

Again, parameters will be destroyed automatically, objects you have to manage yourself.

To receive messages in the main thread either attach the OnReceiveThreadMessage event or override the DoOnReceiveThreadMessage procedure:

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

Use the overridden procedure to process the messages sent back to your main thread:

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;

The messages are pumped in the ProcessMessageQueue procedure. This procedure is called via a TTimer. If you use the component in a console app you will need to call ProcessMessageQueue manually. The timer will start when the first thread is created. It will stop when the last thread has finished. If you need to control when the timer stops you can override the Finished procedure. You can also perform actions depending on the state of the threads by overriding the DoOnStateChange procedure.

Take a look at the TCommThread descendant TStatusCommThreadDispatch. It implements the sending of simple Status and Progress messages back to the main thread.

I hope this helps and that I've explained it OK.

離人涙 2024-10-07 12:27:56

嗯,我不知道 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服务窗口更安全。

Hm I don't know about ServiceThread.Handle and how it behaves on Windows 7, but a safer way would probably be to just create a new window handle via "AllocateHwnd". Then just use a WndProc for it. Something like this (by the way did you check that the handle to the windows is a valid value?):

FWinHandle := AllocateHWND(WndProc);

Deallocate it like this

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;

The WndProc procedure

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;

This works on Windows 7 in threads and services. I use it in couple of places. It think it is safer to use that some internal VCL service windows.

谁的新欢旧爱 2024-10-07 12:27:56

这和我之前的回答有关,但我限制在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

This is related to my previous answer, but I was limited to 30000 characters.

Here's the code for a test app that uses TCommThread:

Test App (.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.

Test app (.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
~没有更多了~
我们使用 Cookies 和其他技术来定制您的体验包括您的登录状态等。通过阅读我们的 隐私政策 了解更多相关信息。 单击 接受 或继续使用网站,即表示您同意使用 Cookies 和您的相关数据。
原文