lazarus-ccr/components/exctrls/source/exquestiondlg.pas

{
'*******************************************************************************
'
'   Michael Koecher/six1 & Werner Pamler/wp_xyz  https://www.lazarusforum.de/
'
'   LGPL2/Linking Exception
'   oder
'   http://creativecommons.org/licenses/by-sa/3.0/de/
'   
'   Based on post in the German Lazarus forum https://www.lazarusforum.de/
'
'*******************************************************************************
}
unit ExQuestionDlg;

{$mode ObjFPC}{$H+}

interface

uses
  LclIntf, LclType, Types,
  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, Buttons,
  ExtCtrls, Menus;


// AX, AY >= 0 absolute position
//
// AX= -ord(poXXXX) and AY = MaxInt
//   0 poDesigned,        // places form as if AX and AY were not specified (both MaxInt).
//  -1 poDefault,         // LCL decision (normally window manager decides) 
//  -2 poDefaultPosOnly,  // designed size and LCL position
//  -3 poDefaultSizeOnly, // designed position and LCL size
//  -4 poScreenCenter,    // center form on screen (depends on DefaultMonitor)
//  -5 poDesktopCenter,   // center form on desktop (total of all screens)
//  -6 poMainFormCenter,  // center form on main form (depends on DefaultMonitor)
//  -7 poOwnerFormCenter, // center form on owner form (depends on DefaultMonitor)
//  -8 poWorkAreaCenter
// NOTE: poDefaultXXXX are not working as expected 

function QuestionDlgEx(const ACaption, AMsg: string; ADlgType: TMsgDlgType;
  const AButtons: array of const; AX: Integer = MaxInt; AY: Integer = MaxInt): TModalResult; overload;

function QuestionDlgEx(const ACaption, AMsg: string; ADlgType: TMsgDlgType;
  const AButtons: array of const; AHelpCtx, AX, AY: Integer): TModalResult; overload;

function QuestionDlgEx(const ACaption, AMsg: string; ADlgType: TMsgDlgType;
  const AButtons: array of const; AHelpKeyword: String; 
  AX: Integer = MaxInt; AY: Integer= MaxInt): TModalResult; overload;

function CreateQuestionDlgEx(const ACaption, AMsg: string; ADlgType: TMsgDlgType;
  const AButtons: array of const; AX, AY: Integer ): TForm;

var
  QuestionDlgEx_MaxWidth: Integer = 500;
  QuestionDlgEx_MinWidth: Integer = 250;
  QuestionDlgEx_ButtonAlignment: TAlignment = taCenter;
  QuestionDlgEx_TextAlignment: TAlignment = taLeftJustify;
  QuestionDlgEx_FontName: String = '';
  QuestionDlgEx_FontSize: Integer = 0;
  QuestionDlgEx_GlyphShowMode: TGlyphShowMode = gsmApplication;
  
implementation

uses
  TypInfo, Math;

function GetBKType(str:string):TBitBtnKind;
var
  value: Integer;
begin
  value := GetEnumValue(TypeInfo(TBitBtnKind), 'bk' + str);
  if value > -1 then
    Result := TBitBtnKind(value)
  else
    Result := bkCancel;
end;

type
  TQForm = class(TForm)
  private
    type 
      TBtnParams = record
        Caption: string;
        Kind: integer;
        IsDefaultOrCancel: Byte;  // 1 = IsDefault, 2 = IsCancel
      end;
      TBtnParamsArray = array of TBtnParams;
  private
    FButtonAlignment: TAlignment;
    FButtons: array of TBitBtn;
    FButtonPanel: TPanel;
    FDialogType: TMsgDlgType;
    FImage: TImage;
    FInnerButtonPanel: TPanel;
    FLabel: TLabel;
    FTextAlignment: TAlignment;
    FTextPanel: TPanel;
    FXPos, FYPos: Integer;
    function GetMsg: String;
    procedure SetDialogType(AValue: TMsgDlgType);
    procedure SetMsg(const AValue: String);
  protected         
    procedure Activate; override;
    procedure AdjustFormSizeAndPosition(AX, AY: Integer);
    procedure ApplyButtonAlignment;
    procedure ApplyTextAlignment;
    procedure CreateButtonPanel;
    procedure CreateImage;
    procedure CreateLabel;
    procedure CreateInnerButtonPanel;
    procedure CreateTextPanel;
    procedure HelpClickHandler(Sender: TObject);
    function MeasureButtonPanel: Integer;
    function MeasureTextPanel: Integer;
    function PrepareButtons(const AButtons: array of const): TBtnParamsArray;
    procedure SetFormPosition(AX, AY: Integer);
  public
    constructor CreateNew(AOwner: TComponent; Num: Integer = 0); override;
    procedure AddButtons(const AButtons: array of const);
    property ButtonAlignment: TAlignment read FButtonAlignment write FButtonAlignment;
    property DialogType: TMsgDlgType read FDialogType write SetDialogType;
    property Msg: String read GetMsg write SetMsg;
    property TextAlignment: TAlignment read FTextAlignment write FTextAlignment;
    property XPos: Integer read FXPos write FXPos;
    property YPos: Integer read FYPos write FYPos;
  end;
  
constructor TQForm.CreateNew(AOwner: TComponent; Num: Integer = 0);
begin
  inherited;
  BorderStyle := bsSingle;  // In gth2, bsDialog "glues" the dialog to the calling form
  BorderIcons := [biSystemMenu];
  Color := clWindow;
  PopupMode := pmAuto;
  
  CreateTextPanel;
  CreateImage;
  CreateLabel;

  CreateButtonPanel;
  CreateInnerButtonPanel;
end;
  
procedure TQForm.Activate;
begin
  AdjustFormSizeAndPosition(FXPos, FYPos);
  inherited;
end;

procedure TQForm.AddButtons(const AButtons: array of const);
const
  MsgDlgBtnStr : array [0..11] of string = (
    'Yes', 'No', 'OK', 'Cancel', 'Abort', 'Retry', 'Ignore',
    'All', 'NoToAll', 'YesToAll', 'Help', 'Close'
  );
var
  btnParams: TBtnParamsArray;
  i: Integer;
  btn: TBitBtn;
begin
  // Translate given Buttons into array of button parameters.
  btnParams := PrepareButtons(AButtons);
  
  // Create BitBtn's
  SetLength(FButtons, Length(btnParams));
  for i := 0 to high(btnParams) do
  begin
    btn := TBitBtn.Create(Self);
    btn.Parent := FInnerButtonPanel;
    btn.GlyphShowMode := QuestionDlgEx_GlyphShowMode;
    btn.Kind := GetBKType(MsgDlgBtnStr[btnParams[i].Kind]);
    if btn.Kind = bkHelp then
      btn.OnClick := @HelpClickHandler;
    if trim(btnParams[i].Caption) <> '' then
      btn.Caption := btnParams[i].Caption;   
    btn.Constraints.MinWidth := 75;
    btn.Cancel := (btnParams[i].IsDefaultOrCancel = 2);
    btn.Default := (btnParams[i].IsDefaultOrCancel = 1);
    if btn.Default then ActiveControl := btn;
    btn.AutoSize := true;
    btn.BorderSpacing.Around := 6;
    if i = 0 then
      btn.AnchorSideLeft.Control := FInnerButtonPanel
    else
    begin
      btn.AnchorSideLeft.Control := FButtons[i-1];
      btn.AnchorSideLeft.Side := asrBottom;
    end;
    btn.AnchorSideTop.Control := FInnerButtonPanel;
    FButtons[i] := btn;
  end;
  
//  MeasureButtonPanel;
end;

procedure TQForm.AdjustFormSizeAndPosition(AX, AY: Integer);
var
  buttonPanelWidth, textPanelWidth: Integer;
  w, h: Integer;
begin
  if (FTextPanel = nil) or (FLabel = nil) or (FButtonPanel = nil) then
  begin
    inherited;
    exit;
  end;
  
  FTextPanel.Anchors := [akLeft, akTop];
  FLabel.Anchors := [akLeft, akTop];
  FButtonPanel.Anchors := [akLeft, akTop];
  
  buttonPanelWidth := MeasureButtonPanel;
  textPanelWidth := MeasureTextPanel;
  
  if buttonPanelWidth > textPanelWidth then
  begin
    Constraints.MinWidth := buttonPanelWidth;
    Constraints.MaxWidth := buttonPanelWidth;
    Width := buttonPanelWidth;
  end else
  begin
    if textPanelWidth > QuestionDlgEx_MaxWidth then
    begin
      if buttonPanelWidth > QuestionDlgEx_Maxwidth then
        textPanelWidth := buttonPanelWidth
      else
        textPanelWidth := QuestionDlgEx_MaxWidth;
    end;
    Constraints.MinWidth := textPanelWidth;
    Constraints.MaxWidth := textPanelWidth;
    Width := textPanelWidth;
  end;
             
  HandleNeeded;
  AutoSize := true;
              
  FTextPanel.Anchors := [akLeft, akRight, akTop];
  FLabel.Anchors := [akLeft, akRight, akTop];
  FButtonPanel.Anchors := [akLeft, akRight, akTop];
                     
  ApplyButtonAlignment;
  ApplyTextAlignment;
  
  SetFormPosition(AX, AY);
end;

procedure TQForm.ApplyButtonAlignment;
begin
  // Set button and text alignments
  case FButtonAlignment of
    taLeftJustify: ;
    taCenter: 
      FInnerButtonPanel.AnchorSideLeft.Side := asrCenter;
    taRightJustify: 
      begin
        FInnerButtonPanel.Anchors := [akTop, akRight];
        FInnerButtonPanel.AnchorSideRight.Control := FButtonPanel;
        FInnerButtonPanel.AnchorSideRight.Side := asrRight;
      end;
  end;
end;

procedure TQForm.ApplyTextAlignment;
begin
  FLabel.Alignment := FTextAlignment;  
end;
  
procedure TQForm.CreateButtonPanel;
begin
  FButtonPanel := TPanel.Create(Self);
  with FButtonPanel do
  begin
    BevelOuter := bvNone;
    Caption := '';
    Color := clBtnFace;
    AutoSize := true;
    AnchorSideTop.Control := FTextPanel;
    AnchorSideTop.Side := asrBottom;
    AnchorSideLeft.Control := Self;
    AnchorSideRight.Control := Self;
    AnchorSideRight.Side := asrBottom;
    Parent := Self;
  end;
end;
  
procedure TQForm.CreateImage;
var
  lSize: TSize;
begin
  lSize.cx := GetSystemMetrics(SM_CXICON);
  lSize.cy := GetSystemMetrics(SM_CYICON);
  
  FImage := TImage.Create(Self);
  with FImage do
  begin
    Parent := FTextPanel;
    AnchorSideTop.Control := FTextPanel;
    BorderSpacing.Left := 10;
    BorderSpacing.Top := 5;
    BorderSpacing.Bottom := 10;
    Width:= Min(32, lSize.CY);
    Height:= Min(32, lSize.CY);
    Transparent := true;
    Proportional := true;
    AntialiasingMode := amON;
    Center := true;
    if lSize.CX > Width then
      Stretch := true;
  end;
end;

procedure TQForm.CreateLabel;
begin
  FLabel := TLabel.Create(Self);
  with FLabel do
  begin
    Parent := FTextPanel;
    AnchorSideLeft.Control := FImage;
    AnchorSideLeft.Side := asrBottom;
    AnchorSideTop.Control := FTextPanel;
    AnchorSideTop.Side := asrTop;
    AnchorSideRight.Control := FTextPanel;
    AnchorSideRight.Side := asrBottom;
    BorderSpacing.Around := 10;
    WordWrap := true;
    Transparent := true;
    AutoSize := true;
  end;
end;

procedure TQForm.CreateInnerButtonPanel;
begin
  FInnerButtonPanel := TPanel.Create(Self);
  with FInnerButtonPanel do 
  begin
    AnchorSideLeft.Control := FButtonPanel;
    AnchorSideTop.Control := FButtonPanel;
    AnchorSideRight.Control := FButtonPanel;
    AnchorSideRight.Side := asrBottom;
    BevelOuter := bvNone;
    Caption := '';
    AutoSize := true;
    Parent := FButtonPanel;
  end;
end;
    
procedure TQForm.CreateTextPanel;
begin
  FTextPanel := TPanel.Create(Self);
  with FTextPanel do
  begin
    AnchorSideLeft.Control := Self;
    AnchorSideTop.Control := Self;
    AnchorSideRight.Control := Self;
    AnchorSideRight.Side := asrBottom;
    BevelOuter := bvNone;
    Caption := '';
    Color := clWindow;
    AutoSize := true;
    Parent := Self;
  end;
end;
  
function TQForm.GetMsg: String;
begin
  Result := FLabel.Caption;
end;

procedure TQForm.HelpClickHandler(Sender: TObject);
begin
  ShowHelp;
end;

function TQForm.MeasureButtonPanel: Integer;
var
  h: Integer = 0;
begin
  Result := 0;
  FButtonPanel.HandleNeeded;
  FButtonPanel.GetPreferredSize(Result, h);
  Result := Max(QuestionDlgEx_MinWidth, result);
end;

function TQForm.MeasureTextPanel: Integer;
var
  h: Integer = 0;
  savedAutoSize: Boolean;
begin
  Result := 0;
  savedAutoSize := FTextPanel.AutoSize;
  FTextPanel.AutoSize := true;
  FTextPanel.HandleNeeded;
  FTextPanel.GetPreferredSize(Result, h);
  Result := Max(QuestionDlgEx_MinWidth, Result);
  FTextPanel.AutoSize := savedAutoSize;
end;

function TQForm.PrepareButtons(const AButtons: array of const): TBtnParamsArray; 
var
  i, n: Integer;
begin
  Result := nil;
  SetLength(Result, Length(AButtons));
  n := -1;
  for i := 0 to high(AButtons) do
  begin
    if AButtons[i].VType = vtAnsiString then //text
    begin
      if SameText(AButtons[i].VPChar, 'IsDefault') then
        Result[n].IsDefaultOrCancel := 1
      else if SameText(AButtons[i].VPChar, 'IsCancel') then
        Result[n].IsDefaultOrCancel := 2
      else
        Result[n].Caption := AButtons[i].VPChar
    end else
    if AButtons[i].VType = vtInteger then
    begin
      inc(n);
      Result[n].Kind := AButtons[i].VInteger;
    end;
  end;
  SetLength(Result, n+1);
end;

procedure TQForm.SetDialogType(AValue: TMsgDlgType);
var
  iconKind: Integer;
  bmp: TCustomBitmap;
begin
  FDialogType := AValue;
  iconKind := idDialogBase + 1 + ord(FDialogType);
  bmp := GetDialogIcon(iconKind);
  try
    FImage.Picture.Assign(bmp);
  finally
    bmp.Free;
  end;
end;
  
procedure TQForm.SetFormPosition(AX, AY: Integer);
const
  NOT_USED = MaxInt;
var
  R: TRect;
begin
  if (AX < 0) and (AY = MaxInt) then
  begin
     Position := TPosition(-AX);
  end else
  begin
    R := Monitor.WorkAreaRect;
    Position := poDesigned;
    if AY = NOT_USED then // Screen Center  Y
      Top := (R.Top + R.Bottom - Height) div 2
    else
    if (AY + Height) <= (Monitor.WorkareaRect.Bottom - 30) then
      Top := AY
    else // prevent displaying outside bottom screen border
      Top := R.Bottom - Height - 30;

    if AX = NOT_USED then // Screen Center  X
      Left := (R.Left + R.Right - Width) div 2
    else
    if (AX + Width) <= Monitor.WorkareaRect.Right then
      Left := AX
    else // prevent displaying outside right screen border
      Left := R.Right - Width;
  end;
end;

procedure TQForm.SetMsg(const AValue: String);
begin
  FLabel.Caption := AValue;
//  MeasureTextPanel;
end;
  

function CreateQuestionDlgEx(const ACaption, AMsg: string; ADlgType: TMsgDlgType;
  const AButtons: array of const; AX, AY: Integer): TForm;
var
  QForm: TQForm;
begin
  QForm := TQForm.CreateNew(Screen.ActiveCustomForm);
  QForm.Font.Name := QuestionDlgEx_FontName;
  QForm.Font.Size := QuestionDlgEx_FontSize;
  QForm.ButtonAlignment := QuestionDlgEx_ButtonAlignment;
  QForm.TextAlignment := QuestionDlgEx_TextAlignment;
  QForm.Caption := ACaption;
  QForm.DialogType := ADlgtype;
  QForm.Msg := AMsg;
  QForm.AddButtons(AButtons);
  QForm.XPos := AX;
  QForm.YPos := AY;
  Result := QForm;
end;

function QuestionDlgEx(const ACaption, AMsg: string; ADlgType: TMsgDlgType;
  const AButtons: array of const; AX: Integer = MaxInt; AY: Integer = MaxInt): TModalResult; 
var
  QForm: TForm;
begin
  QForm := CreateQuestionDlgEx( ACaption, AMsg, ADlgType, AButtons, AX, AY);
  try
    result := QForm.ShowModal;
  finally
    FreeAndNil(QForm);
  end;
end;

function QuestionDlgEx(const ACaption, AMsg: string; ADlgType: TMsgDlgType;
  const AButtons: array of const; AHelpCtx, AX, AY: Integer): TModalResult; 
var
  QForm: TForm;
begin
  QForm := CreateQuestionDlgEx( ACaption, AMsg, ADlgType, AButtons, AX, AY);
  try
    QForm.HelpContext := AHelpCtx;
    result := QForm.ShowModal;
  finally
    FreeAndNil(QForm);
  end;
end;

function QuestionDlgEx(const ACaption, AMsg: string; ADlgType: TMsgDlgType;
  const AButtons: array of const; AHelpKeyword: String; 
  AX: Integer = MaxInt; AY: Integer= MaxInt): TModalResult; overload;
var
  QForm: TForm;
begin
  QForm:=CreateQuestionDlgEx( ACaption, AMsg, ADlgType, AButtons, AX, AY);
  try
    QForm.HelpKeyword := AHelpKeyword;
    result := QForm.ShowModal;
  finally
    FreeAndNil(QForm);
  end;
end;


end.