【Delphi】以高性能方式把线程信息显示在界面上的一个通用小框架【2023-08-05更新】

BlueStorm

已于 2023-08-05 22:25:44 修改

阅读量1.9k

点赞数 3

分类专栏： Delphi开发文章标签： Delphi 开发语言

于 2021-01-25 12:33:17 首次发布

本文链接：https://blog.csdn.net/BlueStorm/article/details/113107746

版权

Delphi开发专栏收录该内容

7 篇文章 5 订阅

订阅专栏

***2023-08-05更新了uInfoHub.pas。

Delphi通常使用TThread.Synclonize把线程信息显示到界面上，但由于此方法需与主界面同步，会拖慢线程的运行，如果显示的信息比较多或更新很快，对程序的性能会有比较大的影响。

此框架使用PostMessage异步方式，最大程度地提高了程序的性能，并保证了信息显示的顺序。

unit uMainForm; //示例

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
  Vcl.StdCtrls, Vcl.ExtCtrls,
  uDemoThread, Data.DB, Vcl.Grids, Vcl.DBGrids, Vcl.ComCtrls, Datasnap.DBClient;

type
  TMainForm = class(TForm)
    ButtonRun: TButton;
    Panel1: TPanel;
    Memo1: TMemo;
    Panel2: TPanel;
    Splitter1: TSplitter;
    ListView1: TListView;
    Splitter2: TSplitter;
    DBGrid1: TDBGrid;
    ClientDataSet1: TClientDataSet;
    DataSource1: TDataSource;
    ClientDataSet1id: TIntegerField;
    ClientDataSet1name: TStringField;
    procedure ButtonRunClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    LogInfoThread: TLogInofThread;
    DBGridInfoThread: TDBGridInfoThread;
    ListViewInfoThread: TListViewInfoThread;
  public
    { Public declarations }
  end;

var
  MainForm: TMainForm;

implementation

{$R *.dfm}

procedure TMainForm.FormCreate(Sender: TObject);
begin
  ReportMemoryLeaksOnShutDown := True;
  with ClientDataSet1 do
  begin
    CreateDataSet;
    LogChanges := False;
    Open;
  end;
  Position := poScreenCenter;
end;

procedure TMainForm.ButtonRunClick(Sender: TObject);
begin
  LogInfoThread := TLogInofThread.Create;
  DBGridInfoThread := TDBGridInfoThread.Create;
  ListViewInfoThread := TListViewInfoThread.Create;
  ButtonRun.Enabled := False;
end;

end.

object MainForm: TMainForm
  Left = 0
  Top = 0
  Anchors = [akLeft, akTop, akRight, akBottom]
  Caption = 'Demo'
  ClientHeight = 496
  ClientWidth = 565
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  Position = poScreenCenter
  OnCreate = FormCreate
  DesignSize = (
    565
    496)
  PixelsPerInch = 96
  TextHeight = 13
  object ButtonRun: TButton
    Left = 492
    Top = 462
    Width = 65
    Height = 25
    Anchors = [akRight, akBottom]
    Caption = 'Run'
    TabOrder = 0
    OnClick = ButtonRunClick
  end
  object Panel1: TPanel
    Left = 8
    Top = 8
    Width = 549
    Height = 448
    Anchors = [akLeft, akTop, akRight, akBottom]
    BevelInner = bvRaised
    BevelOuter = bvLowered
    TabOrder = 1
    object Splitter1: TSplitter
      Left = 2
      Top = 317
      Width = 545
      Height = 3
      Cursor = crVSplit
      Align = alBottom
      ExplicitTop = 2
      ExplicitWidth = 318
    end
    object Memo1: TMemo
      Left = 2
      Top = 320
      Width = 545
      Height = 126
      Align = alBottom
      TabOrder = 0
    end
    object Panel2: TPanel
      Left = 2
      Top = 2
      Width = 545
      Height = 315
      Align = alClient
      BevelInner = bvLowered
      BevelOuter = bvLowered
      TabOrder = 1
      object Splitter2: TSplitter
        Left = 257
        Top = 2
        Height = 311
        ExplicitLeft = 296
        ExplicitTop = 144
        ExplicitHeight = 100
      end
      object ListView1: TListView
        Left = 2
        Top = 2
        Width = 255
        Height = 311
        Align = alLeft
        Columns = <
          item
            Caption = 'Host'
          end
          item
            Caption = 'IP'
            Width = 100
          end>
        TabOrder = 0
        ViewStyle = vsReport
      end
      object DBGrid1: TDBGrid
        Left = 260
        Top = 2
        Width = 283
        Height = 311
        Align = alClient
        DataSource = DataSource1
        TabOrder = 1
        TitleFont.Charset = DEFAULT_CHARSET
        TitleFont.Color = clWindowText
        TitleFont.Height = -11
        TitleFont.Name = 'Tahoma'
        TitleFont.Style = []
      end
    end
  end
  object ClientDataSet1: TClientDataSet
    Aggregates = <>
    Params = <>
    Left = 384
    Top = 96
    object ClientDataSet1id: TIntegerField
      FieldName = 'id'
    end
    object ClientDataSet1name: TStringField
      FieldName = 'name'
      Size = 16
    end
  end
  object DataSource1: TDataSource
    DataSet = ClientDataSet1
    Left = 384
    Top = 177
  end
end

unit uDemoThread; //示例

interface

uses System.Classes, Winapi.Windows, Winapi.Messages, Vcl.Forms, System.SysUtils,
     uInfoDef, uBaseThread;

type
  TLogInofThread = class(TBaseThread)
  protected
    procedure Execute; override;
  end;

  TDBGridInfoThread = class(TBaseThread)
  protected
    procedure Execute; override;
  end;

  TListViewInfoThread = class(TBaseThread)
  protected
    procedure Execute; override;
  end;

implementation

uses uInfoShow;

procedure TLogInofThread.Execute;
var
  I: Integer;
  LogInfo: TLogInfo;
begin
  Sleep(666);
  while not Terminated do
  begin
    LogInfo := 'Showing Log Infomation....';
    ShowInfo(LogInfo);

    for I := 1 to 40 do
    begin
      Sleep(25);
      if Terminated then
        Break;
    end;
  end;
end;

procedure TDBGridInfoThread.Execute;
var
  I, Id: Integer;
  DBGridInfo: TDBGridInfo;
begin
  Id := 0;
  Sleep(333);
  while not Terminated do
  begin
    DBGridInfo.Assign(Id, 'Name_' + Id.ToString);
    ShowInfo(DBGridInfo);
    Inc(Id);

    for I := 1 to 40 do
    begin
      Sleep(25);
      if Terminated then
        Break;
    end;
  end;
end;

procedure TListViewInfoThread.Execute;
var
  I, J: Integer;
  ListViewInfo: TListViewInfo;
begin
  J := 0;
  while not Terminated do
  begin
    ListViewInfo.Assign('Host_' + J.ToString, '192.168.1.' + J.ToString);
    ShowInfo(ListViewInfo);
    Inc(J);
    if J > 255 then J := 0;

    for I := 1 to 40 do
    begin
      Sleep(25);
      if Terminated then
        Break;
    end;
  end;
end;

end.

unit uBaseThread;  //此单元为通用单元，不需要修改

//实现主Form关闭时，程序自动先关闭继承于此类的全部线程, 然后才关闭主Form
//注意：此单元中，线程数>0时重载了主Form的OnCloseQuery事件

interface

uses System.Classes, Generics.Collections, System.SysUtils,
     Winapi.Windows, Vcl.Forms, Winapi.Messages, System.SyncObjs;

type
  TBaseThread = class(TThread)
  private
    class procedure NewCloseQuery(Sender: TObject; var CanClose: Boolean);
  public
    constructor Create(aCreateSuspended: Boolean = False); overload;
    constructor Create(aForm: TForm; aCreateSuspended: Boolean = False); overload;
    destructor Destroy; override;
  end;

implementation //=============================================================

type
  TThreadList = TList<TThread>;
  TFormInfo = record
    Form: TForm;
    Closing: Boolean;
    ThreadList: TThreadList;
    OriginalCloseQuery: procedure(Sender: TObject; var CanClose: Boolean) of Object;
  end;
  TFormList = TList<TFormInfo>;

var
  FormList: TFormList;
  FCritSect: TCriticalSection;


function GetFormIndex(aForm: TForm): Integer; overload;
var
  I: Integer;
begin
  Result := -1;
  for I := 0 to FormList.Count-1 do
  begin
    if FormList[I].Form = aForm then
    begin
      Result := I;
      Break;
    end;
  end;
end;

function GetFormIndex(aThread: TThread): Integer; overload;
var
  I, J: Integer;
  ThreadList: TThreadList;
begin
  Result := -1;
  begin
    for I := 0 to FormList.Count - 1 do
    begin
      ThreadList := FormList[I].ThreadList;
      for J := 0 to ThreadList.Count - 1 do
      begin
        if ThreadList[J] = aThread then
        begin
          Result := I;
          Break;
        end;
      end;
    end;
  end;
end;

//============================================================================

class procedure TBaseThread.NewCloseQuery(Sender: TObject; var CanClose: Boolean);
var
  Index: Integer;
  Thread: TThread;
  FormInfo: TFormInfo;
begin
  FCritSect.Enter;
    Index := GetFormIndex(TForm(Sender));
    if Index <> -1 then
    begin
      FormInfo := FormList[Index];
      if FormInfo.ThreadList.Count > 0 then
      begin
        CanClose := False; //还有线程没释放的情况下，暂时不关闭主Form
        FormInfo.Closing := True;
        FormList[Index] := FormInfo;
        for Thread in FormInfo.ThreadList do
        begin
          Thread.Terminate;
        end;
      end;
    end;
  FCritSect.Leave;
end;

//============================================================================

constructor TBaseThread.Create(aCreateSuspended: Boolean);
begin
  Create(Application.MainForm, aCreateSuspended);
end;

constructor TBaseThread.Create(aForm: TForm; aCreateSuspended: Boolean);
var
  FormIndex: Integer;
  FormInfo : TFormInfo;
begin
  FCritSect.Enter;
    if aForm = nil then aForm := Application.MainForm;
    FormIndex := GetFormIndex(aForm);
    if FormIndex = -1 then
    begin
      with FormInfo do
      begin
        Form := aForm;
        Closing := False;
        OriginalCloseQuery := Form.OnCloseQuery;
        Form.OnCloseQuery  := NewCloseQuery;
        ThreadList := TThreadList.Create;
        ThreadList.Add(Self);
      end;
      FormList.Add(FormInfo);
    end
    else
    begin
      FormList[FormIndex].ThreadList.Add(Self);
    end;
  FCritSect.Leave;

  inherited Create(aCreateSuspended);
  FreeOnTerminate := True;
end;

destructor TBaseThread.Destroy;
var
  FormIndex: Integer;
  FormInfo : TFormInfo;
begin
  //在FreeOnTerminate := True的情况下，Destroy的执行实际上是在线程里面进行的
  FCritSect.Enter;  //对ThreadList的操作需要在临界保护区里完成
    FormIndex := GetFormIndex(Self);
    if FormIndex <> -1 then
    begin
      FormInfo := FormList[FormIndex];
      with FormInfo do
      begin
        ThreadList.Remove(Self);
        if ThreadList.Count = 0 then
        begin
          //一旦线程释放完毕，主Form的OnCloseQuery恢复使用原来定义的FormCloseQuery
          Form.OnCloseQuery := OriginalCloseQuery;
          ThreadList.Free;
          FormList.Delete(FormIndex);
          if Closing then   //线程已经释放完毕，发消息关闭主Form
            PostMessage(Form.Handle, WM_CLOSE, 0, 0);
        end;
      end;
    end;
  FCritSect.Leave;
  inherited;
end;

initialization
  FormList  := TFormList.Create;
  FCritSect := TCriticalSection.Create;

finalization
  FormList.Free;
  FCritSect.Free;

end.

unit uInfoDef;   //此单元需要根据实际情况做修改
                 //发送的信息全部在这里定义

interface

uses Generics.Collections;

type
  TLogInfo = String;

  TDBGridInfo = record
    Id  : Cardinal;
    Name: String;
    procedure Assign(const aId: Cardinal; const aName: String);
  end;
  TDBGridInfoList = TList<TDBGridInfo>;

  TListViewInfo = record
    Host, IP: String;
    procedure Assign(const aHost, aIP: String);
  end;

implementation

procedure TDBGridInfo.Assign(const aId: Cardinal; const aName: String);
begin
  Id   := aId;
  Name := aName;
end;

procedure TListViewInfo.Assign(const aHost, aIP: String);
begin
  Host := aHost;
  IP   := aIP;
end;

end.

unit uInfoShow;  //此单元需要根据实际情况做修改

//值 -> Object -> ShowInfo->Enqueue -> PostMessage -> Dequeue -> uInfoHub.ShowInfo

interface

uses uInfoDef;

procedure ShowInfo(const aValue: TLogInfo); overload;
procedure ShowInfo(const aValue: TDBGridInfo); overload;
procedure ShowInfo(const aValue: TListViewInfo); overload;

implementation

uses uInfoClass, uInfoImpl, uInfoHub;

//Show Value -> Show Object
//将信息、信息类和处理方法关联在一切
//这里Create的对象会在TInfoHub里面自动Free掉；

procedure ShowInfo(const aValue: TLogInfo);
begin
  InfoHub_ShowInfo(TInfoClass<TLogInfo>.Create(aValue, ShowLogInfo));
end;

procedure ShowInfo(const aValue: TDBGridInfo);
begin
  InfoHub_ShowInfo(TInfoClass<TDBGridInfo>.Create(aValue, ShowDBGridInfo));
end;

procedure ShowInfo(const aValue: TListViewInfo);
begin
  InfoHub_ShowInfo(TInfoClass<TListViewInfo>.Create(aValue, ShowListViewInfo));
end;

end.

unit uInfoImpl;  //此单元需要根据实际情况做修改

//把线程信息处理相关的代码放在此单元，避免和MainForm的其它代码混在一起。

interface

procedure ShowLogInfo(var aInfo); //aInfo是无类型参数
procedure ShowDBGridInfo(var aInfo);
procedure ShowListViewInfo(var aInfo);

implementation

uses Vcl.Forms, Vcl.StdCtrls, System.SysUtils,
     uMainForm, uInfoDef;

procedure ShowLogInfo(var aInfo);
var
  Info: TLogInfo absolute aInfo; //无类型转换为有类型
begin
  Info := '[' + FormatDateTime('yyyy/mm/dd hh:nn:ss', Now)+ '] ' + Info;
  MainForm.Memo1.Lines.Add(Info);
end;

procedure ShowDBGridInfo(var aInfo);
var
  Info: TDBgridInfo absolute aInfo;
begin
  MainForm.ClientDataSet1.AppendRecord([Info.Id, Info.Name]);
end;

procedure ShowListViewInfo(var aInfo);
var
  Info: TListViewInfo absolute aInfo;
begin
  with MainForm.ListView1.Items.Add do
  begin
    Caption := Info.Host;
    SubItems.Add(Info.IP);
  end;
end;

end.

unit uInfoClass;   //此单元为通用单元，不需要修改

//线程信息以对象的方式传递，对象的类在这里定义

interface

type
  TShowInfoProc = Reference to procedure(var Info); //Info是无类型参数

  TInfoBase = class(TObject)
  public
    PInfo: Pointer;
    ShowInfo: TShowInfoProc;
  end;

  TInfoClass<T> = class(TInfoBase)
  public
    Info: T; //消息只有一个变量，但可以是任何类型，包括String、record或class等
    constructor Create(const aInfo: T; aShowInfo: TShowInfoProc);
    destructor Destroy; Override;
  end;

implementation

uses System.TypInfo;

constructor TInfoClass<T>.Create(const aInfo: T; aShowInfo: TShowInfoProc);
begin
  inherited Create;
  Info := aInfo;
  PInfo:= @Info;
  ShowInfo := aShowInfo;;
end;

destructor TInfoClass<T>.Destroy;
begin  //如果线程信息的值是对象的话，则自动释放内存
  if PTypeInfo(TypeInfo(T)).Kind = tkClass then
    TObject(PInfo^).Free;   //TObject(Value).Free会报Invalid typecast
  inherited;
end;

end.

unit uInfoHub;  //此单元为通用单元，不需要修改

  //InfoObj -> Enqueue -> PostMessage -> Dequeue -> InfoObj.ShowInfo
  //实现高性能的线程信息处理，采用PostMessage异步方式
  //Delphi提供的Synclonize采用与主线程同步的方法，会拖慢程线程运行，所以不使用此方法

interface

uses System.SysUtils, uInfoClass;

var
  InfoHub_ShowInfo: TProc<TInfoBase>; //用于在线程里面向程序界面显示信息

implementation //--------------------------------------------------------

uses System.Classes, Winapi.Messages, System.SyncObjs, System.TypInfo,
     Winapi.Windows, Generics.Collections;

type
  TInfoHub = class(TObject)
  private
    FHandle: HWND;
    FCritSect: TCriticalSection;
    FInfoQueue: TQueue<TInfoBase>;
    procedure WndProc(var aMsg: TMessage);
    procedure ShowInfo(aInfoObj: TInfoBase);
  public
    constructor Create;
    destructor Destroy; override;
  end;

var
  InfoHub: TInfoHub;

constructor TInfoHub.Create;
begin
  inherited;
  InfoHub_ShowInfo := ShowInfo;
  FHandle   := AllocateHWnd(WndProc);
  FCritSect := TCriticalSection.Create;
  FInfoQueue:= TQueue<TInfoBase>.Create;
end;

destructor TInfoHub.Destroy;
var
  InfoObj: TInfoBase;
begin
  for InfoObj in FInfoQueue do InfoObj.Free;
  FInfoQueue.Free;
  FCritSect.Free;
  DeallocateHWnd(FHandle);
  inherited;
end;

procedure TInfoHub.ShowInfo(aInfoObj: TInfoBase);
begin
  FCritSect.Enter;
    FInfoQueue.Enqueue(aInfoObj);  //仅在临界保护区内操作FInfoQueue
  FCritSect.Leave;

  while not PostMessage(FHandle, WM_User, 0, 0) do
  begin
    if GetCurrentThreadID = MainThreadID then
      Application.ProcessMessages  //在主线程发送消息
    else
      Sleep(20); //在子线程发送消息
  end;
end;

procedure TInfoHub.WndProc(var aMsg: TMessage);
var  //上面发送的消息在这里处理
  InfoObj: TInfoBase;
begin
  if aMsg.Msg = WM_User then
  begin
    FCritSect.Enter;
      InfoObj := FInfoQueue.Dequeue; //仅在临界保护区内操作FInfoQueue
    FCritSect.Leave;

    InfoObj.ShowInfo(InfoObj.PInfo^);
    InfoObj.Free;  //释放InfoObj
  end
  else
  begin
    DefWindowProc(FHandle, aMsg.Msg, aMsg.wParam, aMsg.lParam);
  end;
end;

initialization
  InfoHub := TInfoHub.Create;

finalization
  InfoHub.Free;

end.