***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.