unt_Thread

unit unt_Thread;

interface

uses
  { VCL }
  Classes,
  Windows,
  SysUtils,
  TlHelp32,
  { DevExpress }
  dxCore;

type
  /// <summary>
  /// Extender of TThread
  /// </summary>
  /// <example>
  /// <code>
  /// Thread1 := TThread.CreateAnonumoysThread(procedure()begin...end).NameThread('MyThread').Start;
  /// or
  /// TThread.NameExternalThreads;
  /// </code>
  /// </example>
  TThreadHelper = class helper for TThread
  strict private
    /// <summary>
    /// Holds a list of the already known (named) thread ids
    /// </summary>
    class var FKnownThreadIds: TArray<Cardinal>;
  public
    /// <summary>
    /// A wrapper of NameThreadForDebugging which
    /// 1. keeps track of the already named threads
    /// 2. can be used to do chained calls like TThread.CreateAnonumoysThread(procedure()begin...end).NameThread('MyThread').Start;
    /// 3. is shorter to type
    /// </summary>
    function NameThread(const ThreadName: AnsiString): TThread; overload;
    class procedure NameThread(const ThreadName: AnsiString; const ThreadId: Cardinal); overload;
    /// <summary>
    /// Give names to externally created threads such as the ones spawned by TWebBrowser.Navigate method
    /// URL : http://stackoverflow.com/questions/8222209/how-to-name-the-twebbrowser-threads
    /// </summary>
    class procedure NameExternalThreads;
  end;

implementation

{ TThreadHelper }

class procedure TThreadHelper.NameExternalThreads;
var
  ProcessId: Cardinal;
  hSnapshot: THandle;
  ThreadEnty: TThreadEntry32;
  i: Integer;
  IsAlreadyKnown: Boolean;
begin
  // Windows 2000 and above only
  if not dxCore.IsWin2KOrLater then
    Exit;
  // URL : http://msdn.microsoft.com/en-us/library/windows/desktop/ms682489(v=vs.85).aspx
  ProcessId := GetCurrentProcessId;
  hSnapshot := CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, 0 { ProcessId = Current, ignored for SNAPTHREAD });
  try
    if hSnapshot <> INVALID_HANDLE_VALUE then
    begin
      ThreadEnty.dwSize := SizeOf(TThreadEntry32);
      // URL : http://msdn.microsoft.com/en-us/library/windows/desktop/ms686852(v=vs.85).aspx
      if Thread32First(hSnapshot, ThreadEnty) then
      begin
        repeat
          if ThreadEnty.th32OwnerProcessID <> ProcessId then
            Continue;
          if ThreadEnty.th32ThreadID = MainThreadID then
            Continue;
          IsAlreadyKnown := false;
          for i := Low(FKnownThreadIds) to High(FKnownThreadIds) do
            if FKnownThreadIds[i] = ThreadEnty.th32ThreadID then
            begin
              IsAlreadyKnown := true;
              Break;
            end;
          if not IsAlreadyKnown then
            NameThread(AnsiString('External Thread - ' + IntToStr(ThreadEnty.th32ThreadID)), ThreadEnty.th32ThreadID);
        until not Thread32Next(hSnapshot, ThreadEnty);
      end;
    end;
  finally
    CloseHandle(hSnapshot);
  end;
end;

function TThreadHelper.NameThread(const ThreadName: AnsiString): TThread;
begin
  NameThread(ThreadName, Self.ThreadID);
  Result := Self;
end;

class procedure TThreadHelper.NameThread(const ThreadName: AnsiString; const ThreadId: Cardinal);
begin
  TThread.NameThreadForDebugging(ThreadName, ThreadId);
  SetLength(FKnownThreadIds, Succ(Length(FKnownThreadIds)));
  FKnownThreadIds[Pred(Length(FKnownThreadIds))] := ThreadId;
end;

end.