【Delphi Frame 使用示范】

77 阅读 0 评论 51 点赞

我是靠谱客的博主精明画板，最近开发中收集的这篇文章主要介绍【Delphi Frame 使用示范】，觉得挺不错的，现在分享给大家，希望可以做个参考。

概述

说明:此程序是在Delphi 10.3.3上编写和测试.

unit uMain;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
  RzButton, RzTabs, uBaseFrame;

type
  TRzTabSheet = class(RzTabs.TRzTabSheet)
  public
    FrameClassName: String;
    Frame: TBaseFrame;
  end;

  TMainForm = class(TForm)
    PageControl: TRzPageControl;
    TabSheet1: TRzTabSheet;
    TabSheet2: TRzTabSheet;
    TabSheet3: TRzTabSheet;
    ButtonRun: TRzButton;
    procedure FormCreate(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure PageControlChange(Sender: TObject);
    procedure ButtonRunClick(Sender: TObject);
    procedure PageControlPaintCardBackground(Sender: TObject; ACanvas: TCanvas;
      ARow: Integer; const ARect: TRect; var Handled: Boolean);
    procedure PageControlPaintTabBackground(Sender: TObject; ACanvas: TCanvas;
      ATabIndex: Integer; const ARect: TRect; var Handled: Boolean);
  private
    procedure WmAfterShow(var Msg: TMessage); message WM_USER;
  public
    { Public declarations }
  end;

var
  MainForm: TMainForm;

implementation

{$R *.dfm}

procedure TMainForm.FormCreate(Sender: TObject);
begin
  ReportMemoryLeaksOnShutDown := True;
  TabSheet1.FrameClassName := 'TFrame1';
  TabSheet2.FrameClassName := 'TFrame2';
  TabSheet3.FrameClassName := 'TFrame3';
end;

procedure TMainForm.FormShow(Sender: TObject);
begin
  OnShow := nil;
  PostMessage(Handle, WM_USER, 0, 0);
end;

procedure TMainForm.WmAfterShow(var Msg:TMessage);
begin
  PageControlChange(nil);
end;

procedure TMainForm.PageControlChange(Sender: TObject);
var
  Frame: TBaseFrame;
  FrameClass: TBaseFrameClass;
  TabSheet: TRzTabSheet;
begin
  TabSheet := TRzTabSheet(PageControl.ActivePage);
  Frame := TabSheet.Frame;

  if not Assigned(Frame) then
  begin
    FrameClass := TBaseFrame.GetFrameClass(TabSheet.FrameClassName);
    Frame := FrameClass.Create(TabSheet);
    Frame.Parent := TabSheet;
    TabSheet.Frame := Frame;
  end;

  if Frame.RunCount = 0 then
     Frame.Run;
end;

procedure TMainForm.ButtonRunClick(Sender: TObject);
begin
  TRzTabSheet(PageControl.ActivePage).Frame.Run;
end;

procedure TMainForm.PageControlPaintCardBackground(Sender: TObject;
  ACanvas: TCanvas; ARow: Integer; const ARect: TRect; var Handled: Boolean);
begin
  ACanvas.Brush.Color := clRed;
  ACanvas.FillRect(ARect);
  Handled := True;
end;

procedure TMainForm.PageControlPaintTabBackground(Sender: TObject;
  ACanvas: TCanvas; ATabIndex: Integer; const ARect: TRect;
  var Handled: Boolean);
begin
  if ATabIndex = PageControl.ActivePage.TabIndex then
  begin
    ACanvas.Brush.Color := clAqua;
    ACanvas.FillRect(ARect);
    Handled := True;
  end;
end;

end.

object MainForm: TMainForm
  Left = 0
  Top = 0
  Caption = 'MainForm'
  ClientHeight = 273
  ClientWidth = 489
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  Position = poScreenCenter
  OnCreate = FormCreate
  OnShow = FormShow
  DesignSize = (
    489
    273)
  PixelsPerInch = 96
  TextHeight = 13
  object PageControl: TRzPageControl
    Left = 8
    Top = 8
    Width = 476
    Height = 260
    Hint = ''
    ActivePage = TabSheet1
    Anchors = [akLeft, akTop, akRight, akBottom]
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -13
    Font.Name = #24494#36719#38597#40657
    Font.Style = []
    ParentFont = False
    TabIndex = 0
    TabOrder = 0
    TabStyle = tsDoubleSlant
    OnChange = PageControlChange
    OnPaintCardBackground = PageControlPaintCardBackground
    OnPaintTabBackground = PageControlPaintTabBackground
    ExplicitWidth = 804
    ExplicitHeight = 438
    FixedDimension = 25
    object TabSheet1: TRzTabSheet
      Caption = 'TabSheet1'
      ExplicitWidth = 669
      ExplicitHeight = 353
    end
    object TabSheet2: TRzTabSheet
      ImageIndex = 1
      Caption = 'TabSheet2'
      ExplicitWidth = 992
      ExplicitHeight = 562
    end
    object TabSheet3: TRzTabSheet
      ImageIndex = 2
      Caption = 'TabSheet3'
      ExplicitWidth = 992
      ExplicitHeight = 562
    end
  end
  object ButtonRun: TRzButton
    Left = 339
    Top = 5
    Caption = 'Run'
    HotTrack = True
    TabOrder = 1
    OnClick = ButtonRunClick
  end
end

unit uBaseFrame;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs;

type
  TBaseFrameClass = class of TBaseFrame;

  TBaseFrame = class(TFrame)
  public class
    function GetFrameClass(aClassName: String): TBaseFrameClass;
  public
    RunCount: Integer;
    procedure Run; virtual;
    constructor Create(aComponent : TComponent); override;
  end;

implementation

{$R *.dfm}

constructor TBaseFrame.Create;
begin
  inherited;
  RunCount := 0;
end;

procedure TBaseFrame.Run;
begin
  Inc(RunCount);
end;

class function TBaseFrame.GetFrameClass(aClassName: String): TBaseFrameClass;
var
  MetaClass: TClass;
begin
  Result := nil;
  MetaClass := FindClass(aClassName);
  if MetaClass.InheritsFrom(TBaseFrame) then
    Result := TBaseFrameClass(MetaClass)
  else
    Exception.Create(aClassName + '不是TBaseFrame的子类');
end;

end.

object BaseFrame: TBaseFrame
  Left = 0
  Top = 0
  Width = 320
  Height = 240
  Align = alClient
  TabOrder = 0
end

unit uFrame1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
  uBaseFrame, Vcl.StdCtrls;

type
  TFrame1 = class(TBaseFrame)
    Label1: TLabel;
  private
    { Private declarations }
  public
    procedure Run; override;
  end;

var
  Frame1: TFrame1;

implementation

{$R *.dfm}

procedure TFrame1.Run;
begin
  inherited;
  ShowMessage('Frame1的工作任务已运行' + RunCount.ToString + '次');
end;

initialization

RegisterClass(TFrame1);

end.

inherited Frame1: TFrame1
  object Label1: TLabel
    Left = 128
    Top = 112
    Width = 67
    Height = 24
    Caption = 'Frame1'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -20
    Font.Name = 'Tahoma'
    Font.Style = []
    ParentFont = False
  end
end

unit uFrame2;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
  uBaseFrame, Vcl.StdCtrls;

type
  TFrame2 = class(TBaseFrame)
    Label1: TLabel;
  private
    { Private declarations }
  public
    procedure Run; override;
  end;

var
  Frame2: TFrame2;

implementation

{$R *.dfm}

procedure TFrame2.Run;
begin
  inherited;
  ShowMessage('Frame2的工作任务已运行' + RunCount.ToString + '次');
end;

initialization

RegisterClass(TFrame2);

end.

inherited Frame2: TFrame2
  object Label1: TLabel
    Left = 128
    Top = 112
    Width = 67
    Height = 24
    Caption = 'Frame2'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -20
    Font.Name = 'Tahoma'
    Font.Style = []
    ParentFont = False
  end
end

unit uFrame3;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
  uBaseFrame, Vcl.StdCtrls;

type
  TFrame3 = class(TBaseFrame)
    Label1: TLabel;
  private
    { Private declarations }
  public
    procedure Run; override;
  end;

var
  Frame3: TFrame3;

implementation

{$R *.dfm}

procedure TFrame3.Run;
begin
  inherited;
  ShowMessage('Frame3的工作任务已运行' + RunCount.ToString + '次');
end;

initialization

RegisterClass(TFrame3);

end.

inherited Frame3: TFrame3
  object Label1: TLabel
    Left = 128
    Top = 112
    Width = 67
    Height = 24
    Caption = 'Frame3'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -20
    Font.Name = 'Tahoma'
    Font.Style = []
    ParentFont = False
  end
end