lazarus模拟MDI Form-526互联

从delphi转到lazarus，发现lazarus不支持MDI窗体，我们可以用PageContorl实现，不过发现使用ATTabs component更简单方便。
关键在ATTabs添加:

    procedure ATTabs1TabClick(Sender: TObject);
    procedure ATTabs1TabClose(Sender: TObject; ATabIndex: integer;

直接上代码：
form：

object MainForm: TMainForm
  Left = -12
  Height = 1628
  Top = -12
  Width = 1363
  Caption = 'lazarus MDI Form Demo'
  ClientHeight = 1564
  ClientWidth = 1363
  Color = clBtnFace
  DesignTimePPI = 168
  Font.Color = clWindowText
  Font.Height = -19
  Font.Name = 'MS Sans Serif'
  FormStyle = fsMDIForm
  HelpFile = 'acs.hlp'
  Menu = MainMenu1
  OnClose = FormClose
  OnCloseQuery = FormCloseQuery
  OnCreate = FormCreate
  OnResize = FormResize
  OnShow = FormShow
  WindowState = wsMaximized
  object Panel4: TPanel
    Left = 0
    Height = 47
    Top = 1517
    Width = 1363
    Align = alBottom
    BevelOuter = bvLowered
    ClientHeight = 47
    ClientWidth = 1363
    Font.CharSet = ANSI_CHARSET
    Font.Color = clWindowText
    Font.Height = -21
    Font.Name = '宋体'
    ParentBackground = False
    ParentFont = False
    TabOrder = 0
    object Panel2: TPanel
      Left = 1
      Height = 45
      Top = 1
      Width = 712
      Align = alLeft
      BevelOuter = bvSpace
      Font.CharSet = ANSI_CHARSET
      Font.Color = clWindowText
      Font.Height = -21
      Font.Name = '宋体'
      ParentBackground = False
      ParentFont = False
      TabOrder = 0
    end
    object ShowM: TPanel
      Left = 713
      Height = 45
      Top = 1
      Width = 649
      Align = alClient
      ClientHeight = 45
      ClientWidth = 649
      Font.CharSet = ANSI_CHARSET
      Font.Color = clBlue
      Font.Height = -21
      Font.Name = '宋体'
      ParentBackground = False
      ParentFont = False
      TabOrder = 1
      object Label6: TLabel
        Left = 574
        Height = 1
        Top = 9
        Width = 1
        Anchors = [akTop, akRight]
        ParentColor = False
      end
    end
  end
  object ATTabs1: TATTabs
    AnchorSideBottom.Control = Panel1
    Left = 0
    Height = 30
    Top = 0
    Width = 1363
    Align = alTop
    Anchors = [akTop, akLeft, akRight, akBottom]
    Font.CharSet = ANSI_CHARSET
    Font.Color = clBlack
    Font.Height = -21
    Font.Name = 'MS Sans Serif'
    Font.Pitch = fpVariable
    Font.Quality = fqDraft
    ParentColor = False
    ParentFont = False
    Tabs = <>
    DoubleBuffered = True
    TabIndex = -1
    OptButtonLayout = '<>,v'
    OptVarWidth = True
    OptTruncateCaption = acsmNone
    OptTabWidthMaximal = 500
    OptShowXRounded = False
    OptShowXButtons = atbxShowActive
    OptShowPlusTab = False
    OptShowPinnedText = '!'
    OptHintForX = 'Close tab'
    OptHintForPlus = 'Add tab'
    OptHintForArrowLeft = 'Scroll tabs left'
    OptHintForArrowRight = 'Scroll tabs right'
    OptHintForArrowMenu = 'Show tabs list'
    OptHintForUser0 = '0'
    OptHintForUser1 = '1'
    OptHintForUser2 = '2'
    OptHintForUser3 = '3'
    OptHintForUser4 = '4'
    OnTabClick = ATTabs1TabClick
    OnTabClose = ATTabs1TabClose
  end
  object Panel1: TPanel
    Left = 0
    Height = 1487
    Top = 30
    Width = 1363
    Align = alClient
    ParentBackground = False
    TabOrder = 2
  end
  object MainMenu1: TMainMenu
    Left = 744
    Top = 160
    object N12: TMenuItem
      Caption = '数据处理'
      object N142: TMenuItem
        Caption = '回弹法检测砼强度'
        OnClick = N142Click
      end
      object N169: TMenuItem
        Caption = '新回弹法检测砼强度'
        Visible = False
      end
      object N199: TMenuItem
        Caption = '砂浆强度(回弹法检测)'
        Visible = False
      end
    end
    object N15: TMenuItem
      Caption = '系统管理'
      object N5: TMenuItem
        Caption = '权限设置'
      end
      object N48: TMenuItem
        Caption = '技术指标'
      end
      object N62: TMenuItem
        Caption = '系统参数设置'
        OnClick = N62Click
      end
      object MenuItem1: TMenuItem
        Caption = '报告模板管理'
      end
      object N78: TMenuItem
        Caption = '报告编号样式管理'
      end
    end
    object N16: TMenuItem
      Caption = '帮助'
      object N58: TMenuItem
        Caption = '使用说明'
      end
      object N10: TMenuItem
        Caption = '软件注册'
        Visible = False
      end
      object N187: TMenuItem
        Caption = '公司名称及地址设置'
      end
      object N8: TMenuItem
        Caption = '-'
      end
      object N108: TMenuItem
        Caption = '软件版权声明'
      end
      object Separator1: TMenuItem
        Caption = '-'
      end
      object MenuItem2: TMenuItem
        Caption = '退出'
        OnClick = MenuItem2Click
      end
    end
  end
end

unit main;

{$mode objfpc}
{$H+}

interface

uses
  LCLIntf, LCLType, LMessages, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, Menus,

  ExtCtrls,
  ComCtrls, inifiles, StdCtrls
 {$ifdef LINUX}
  , FileUtil
  , process
  , BaseUnix
 {$endif LINUX}
  ,attabs;

type

  { TMainForm }

  TMainForm = class(TForm)
    ATTabs1: TATTabs;
    Label6: TLabel;
    MainMenu1: TMainMenu;
    MenuItem1: TMenuItem;
    MenuItem2: TMenuItem;
    Panel1: TPanel;
    Separator1: TMenuItem;
    N12: TMenuItem;
    N15: TMenuItem;
    N62: TMenuItem;
    N16: TMenuItem;
    N58: TMenuItem;
    N108: TMenuItem;
    N8: TMenuItem;
    N10: TMenuItem;
    N5: TMenuItem;
    N48: TMenuItem;
    N78: TMenuItem;
    N142: TMenuItem;
    N169: TMenuItem;
    N187: TMenuItem;
    N199: TMenuItem;
    Panel4: TPanel;
    Panel2: TPanel;
    ShowM: TPanel;
    procedure ATTabs1TabClick(Sender: TObject);
    procedure ATTabs1TabClose(Sender: TObject; ATabIndex: integer;
      var ACanClose, ACanContinue: boolean);
    procedure FormCreate(Sender: TObject);
    procedure MenuItem2Click(Sender: TObject);
    procedure RxSpeedButton1Click(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: boolean);
    procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
    procedure N62Click(Sender: TObject);
    procedure N142Click(Sender: TObject);
    procedure DateMenuDrawItem(Sender: TObject; ACanvas: TCanvas;
      ARect: TRect; Selected: boolean);
    procedure FormResize(Sender: TObject);
    function findChildwindow(s: TForm): boolean;
    procedure FormShow(Sender: TObject);
  private
    { Private declarations }
    //    procedure formmaximum(var msg: Tmessage); message wm_getminmaxinfo;
  public
    { Public declarations }
    start: integer;
  end;

var
  MainForm: TMainForm;

implementation

uses SetSys, HTCS_pas;

{$R *.lfm}

function TMainForm.findChildwindow(s: TForm): boolean;
var
  i: integer;
begin
  i := 0;
  findChildwindow := False;
  while i <= MDIChildCount - 1 do
  begin
    if MDIChildren[i].Caption = s.Caption then
    begin
      findChildwindow := True;
      break;
    end;
    Inc(i);
  end;
end;

procedure TMainForm.FormCreate(Sender: TObject);
begin
  WindowState:=wsMaximized;
end;

procedure TMainForm.MenuItem2Click(Sender: TObject);
begin
  close;
end;

procedure TMainForm.ATTabs1TabClick(Sender: TObject);
var
  d: TATTabData;
begin
  d := ATTabs1.GetTabData(ATTabs1.TabIndex);
  (d.TabObject as TForm).Show;
end;

procedure TMainForm.ATTabs1TabClose(Sender: TObject; ATabIndex: integer;
  var ACanClose, ACanContinue: boolean);
var
  d: TATTabData;
begin
  if ATTabs1.TabIndex=ATabIndex Then
  begin
  d := ATTabs1.GetTabData(ATabIndex);
  (d.TabObject as tform).close;
  end
  ELSE
  Begin
     ACanClose:=False;
  end;
end;

procedure TMainForm.RxSpeedButton1Click(Sender: TObject);
begin
  Close;
end;

procedure TMainForm.FormCloseQuery(Sender: TObject; var CanClose: boolean);
var
  i:Integer;
begin
  if ATTabs1.TabCount>0 Then
  begin
    if application.messagebox(
      '有项目已打开！是否退出？',
      '讯息', MB_YESNO) = idNo then canclose := False
    else
    Begin
      if ATTabs1.TabCount>-1 then
      begin
        for  i:=ATTabs1.TabCount-1 downto 0 do
        begin
          tform(ATTabs1.GetTabData(i).TabObject).close;
        end;
      end;
    end;
  end;
end;

procedure TMainForm.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
  if SetSysFrm<>nil Then
    (SetSysFrm):=nil;
  if htcsform<>nil Then
    (htcsform):=nil;
end;

procedure TMainForm.N62Click(Sender: TObject);
var
  NIndex: integer;
  d: TATTabData;
begin
    if ATTabs1.FindTabByObject(SetSysFrm)=-1 Then
    begin
      SetSysFrm := TSetSysFrm.Create(self);
      if ATTabs1.TabIndex > -1 then
        NIndex := ATTabs1.TabIndex + 1;
      Dec(NIndex);
      ATTabs1.AddTab(NIndex,//标签编号
        SetSysFrm.Caption,  //标签名称
        SetSysFrm,          //标签对象
        False
        );
      SetSysFrm.Parent := Panel1;
      SetSysFrm.Align := alClient;
    end
    else
    begin
      ATTabs1.TabIndex:=ATTabs1.FindTabByObject(SetSysFrm);
      d := ATTabs1.GetTabData(ATTabs1.TabIndex);
      (d.TabObject as TForm).show;
    end;
end;

procedure TMainForm.N142Click(Sender: TObject);
var
  NIndex: integer;
  d: TATTabData;
begin
    if ATTabs1.FindTabByObject(htcsform)=-1 Then
    begin
      htcsform := ThtcsForm.Create(self);
      if ATTabs1.TabIndex > -1 then
        NIndex := ATTabs1.TabIndex + 1;
      Dec(NIndex);
      ATTabs1.AddTab(NIndex,
        htcsform.Caption,
        htcsform,
        False
        );
      htcsForm.Parent := Panel1;
      htcsForm.Align := alClient;
    end
    else
    begin
      ATTabs1.TabIndex:=ATTabs1.FindTabByObject(htcsform);
      d := ATTabs1.GetTabData(ATTabs1.TabIndex);
      (d.TabObject as TForm).show;
    end;
end;

procedure TMainForm.DateMenuDrawItem(Sender: TObject; ACanvas: TCanvas;
  ARect: TRect; Selected: boolean);
begin
  Acanvas.brush.Color := clblue;
  Acanvas.Font.size := 11;
  Acanvas.Font.Color := clyellow;
  Acanvas.TextOut(arect.left + 5, arect.top, tmenuitem(Sender).Caption);
end;

procedure TMainForm.FormResize(Sender: TObject);
var
  ye, mo, day: word;
begin
  DecodeDate(Now, ye, mo, day);
end;

procedure TMainForm.FormShow(Sender: TObject);
var
  ye, mo, day: word;
begin
  DecodeDate(Now, ye, mo, day);
end;

end.

编译后的效果：

窗体winform-mdi winform mdi

lazarus

窗体winform-mdi roadeshi winform

窗体winform mdi

lazarus_loongarch

lazarus_loongarch loongarch lazarus版本

lazarus v10