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_MinHeight: Integer = 50;  // Text part only
  QuestionDlgEx_ButtonAlignment: TAlignment = taCenter;
  QuestionDlgEx_TextAlignment: TAlignment = taLeftJustify;
  QuestionDlgEx_TextLayout: TTextLayout = tlCenter;
  QuestionDlgEx_FontName: String = '';    // the same as "default"
  QuestionDlgEx_FontSize: Integer = 0;
  QuestionDlgEx_GlyphShowMode: TGlyphShowMode = gsmApplication;
  
implementation

uses
  TypInfo, Math;

const
  DEFAULT_IMAGE_BORDER_X = 10;
  DEFAULT_IMAGE_BORDER_Y = 5;
  DEFAULT_TEXT_BORDER_X = 10;
  DEFAULT_TEXT_BORDER_Y = 10;
  
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: TCustomBitmap;
    FImageBorder: TSize;
    FInnerButtonPanel: TPanel;
    FText: String;
    FTextBorder: TSize;
    FTextAlignment: TAlignment;
    FTextLayout: TTextLayout;
    FTextPanel: TPanel;
    FXPos, FYPos: Integer;
    procedure SetDialogType(AValue: TMsgDlgType);
  protected         
    procedure Activate; override;
    procedure AdjustForm;
    procedure ApplyButtonAlignment;
    procedure CreateButtonPanel;
    procedure CreateInnerButtonPanel;
    procedure CreateTextPanel;
    procedure HelpClickHandler(Sender: TObject);
    procedure MeasureButtonPanel(var AWidth, AHeight: Integer);
    procedure MeasureText(var AWidth, AHeight: Integer);
    procedure MeasureTextPanel(Wrapped: Boolean; var AWidth, AHeight: Integer);
    procedure PaintTextPanelHandler(Sender: TObject);
    function PrepareButtons(const AButtons: array of const): TBtnParamsArray;
    procedure SetFormPosition(AX, AY: Integer);
  public
    constructor CreateNew(AOwner: TComponent; Num: Integer = 0); override;
    destructor Destroy; 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 FText write FText;
    property TextAlignment: TAlignment read FTextAlignment write FTextAlignment;
    property TextLayout: TTextLayout read FTextLayout write FTextLayout;
    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 gtk2, bsDialog "glues" the dialog to the calling form
  BorderIcons := [biSystemMenu];
  Color := clWindow;
  PopupMode := pmAuto;
  
  FImageBorder.CX := Scale96ToFont(DEFAULT_IMAGE_BORDER_X);
  FImageBorder.CY := Scale96ToFont(DEFAULT_IMAGE_BORDER_Y);
  FTextBorder.CX := Scale96ToFont(DEFAULT_TEXT_BORDER_X);
  FTextBorder.CY := Scale96ToFont(DEFAULT_TEXT_BORDER_Y);
  
  CreateTextPanel;
  CreateButtonPanel;
  CreateInnerButtonPanel;
end;
  
destructor TQForm.Destroy;
begin
  FImage.Free;
  inherited;
end;

procedure TQForm.Activate;
begin
  AdjustForm;
  SetFormPosition(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.AdjustForm;
var
  buttonPanelWidth: Integer = 0;
  buttonPanelHeight: Integer = 0;
  textPanelWidth: Integer = 0;
  textPanelHeight: Integer = 0;
begin
  if (FTextPanel = nil) or (FButtonPanel = nil) then
    exit;
  
  MeasureButtonPanel(buttonPanelWidth, buttonPanelHeight);
  MeasureTextPanel(false, textPanelWidth, textPanelHeight);
  
  if buttonPanelWidth > textPanelWidth then
  begin
    textPanelWidth := buttonPanelWidth;
  end else
  begin
    MeasureTextPanel(true, textPanelWidth, textPanelHeight);
    if textPanelWidth > QuestionDlgEx_MaxWidth then
    begin
      if buttonPanelWidth > QuestionDlgEx_Maxwidth then
        textPanelWidth := buttonPanelWidth
      else
        textPanelWidth := QuestionDlgEx_MaxWidth;
      MeasureTextPanel(true, textPanelWidth, textPanelheight);
    end;
  end;
  
  FTextPanel.SetBounds(0, 0, textPanelWidth, textPanelHeight);
  FButtonPanel.SetBounds(0, textPanelHeight, textPanelWidth, buttonPanelHeight);
  
  Width := textPanelWidth;
  Height := textPanelHeight + buttonPanelHeight;

  ApplyButtonAlignment;
end;

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

procedure TQForm.CreateButtonPanel;
begin
  FButtonPanel := TPanel.Create(Self);
  with FButtonPanel do
  begin
    BevelOuter := bvNone;
    Caption := '';
    Color := clBtnFace;
    Parent := Self;
  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
    BevelOuter := bvNone;
    Caption := '';
    Color := clWindow;
    Parent := Self;
    OnPaint := @PaintTextPanelHandler;
  end;
end;
  
procedure TQForm.HelpClickHandler(Sender: TObject);
begin
  ShowHelp;
end;

procedure TQForm.MeasureButtonPanel(var AWidth, AHeight: Integer);
begin
  AWidth := 0;
  AHeight := 0;
  FButtonPanel.HandleNeeded;
  FButtonPanel.GetPreferredSize(AWidth, AHeight);
  if QuestionDlgEx_MinWidth > AWidth then AWidth := QuestionDlgEx_MinWidth;
end;

procedure TQForm.MeasureText(var AWidth, AHeight: Integer);
var
  R: TRect;
  flags: integer;
begin
  R := Rect(0, 0, AWidth, AHeight);
  flags := DT_CALCRECT or DT_WORDBREAK;
  DrawText(Canvas.Handle, PChar(FText), Length(FText), R, flags);
  AWidth := R.Right;
  AHeight := R.Bottom;
end;
  
procedure TQForm.MeasureTextPanel(Wrapped: Boolean; var AWidth, AHeight: Integer);
var
  R: TRect;
  x: Integer;
  flags: Integer;
  imgHeight: Integer;
begin
  x := FImageBorder.CX;
  if Assigned(FImage) then
    inc(x, FImage.Width + Max(FImageBorder.CX, FTextBorder.CX));
  if not Wrapped then AWidth := 9999;
  R := Rect(x, FTextBorder.CY, AWidth, 9999);
  flags := DT_CALCRECT;
  if Wrapped then flags := flags or DT_WORDBREAK;
  HandleNeeded;
  DrawText(Canvas.Handle, PChar(FText), Length(FText), R, flags);
  inc(R.Bottom, FTextBorder.CY);
  AWidth := R.Right;
  if AWidth < QuestionDlgEx_MinWidth then
    AWidth := QuestionDlgEx_MinWidth;
  AHeight := R.Bottom;
  if Assigned(FImage) then
    imgHeight := FImage.Height
  else
    imgHeight := 32;
  if (AHeight < 2*FImageBorder.CY + imgHeight) then
    AHeight := 2*FImageBorder.CY + imgHeight;
  if AHeight < QuestionDlgEx_MinHeight then
    AHeight := QuestionDlgEx_MinHeight;
end;

procedure TQForm.PaintTextPanelHandler(Sender: TObject);
var
  x, y: Integer;
  R: TRect;
  flags: Integer;
  w, h: Integer;
begin
  with FTextPanel do begin
    Canvas.Brush.Color := Color;
    Canvas.FillRect(0, 0, Width, Height);
    x := FImageBorder.CX;
    if Assigned(FImage) then
    begin
      Canvas.Draw(x, FImageBorder.CY, FImage);
      inc(x, FImage.Width + Max(FImageBorder.CX, FTextBorder.CX));
    end;
    if FText <> '' then
    begin
      R := Rect(x, FTextBorder.CY, Width - FTextBorder.CX, Height - FTextBorder.CY);
      w := R.Right - x;
      h := R.Bottom - FTextBorder.CY;
      MeasureText(w, h);
      flags := DT_WORDBREAK;
      case FTextAlignment of
        taLeftJustify: flags := flags or DT_LEFT;
        taCenter: flags := flags or DT_CENTER;
        taRightJustify: flags := flags or DT_RIGHT;
      end;
      case FTextLayout of
        tlTop: ;
        tlCenter: R.Top := (R.Top + R.Bottom - h) div 2;
        tlBottom: R.Top := R.Bottom - h;
      end;
      DrawText(Canvas.Handle, PChar(FText), Length(FText), R, flags);
    end;
  end;
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;
begin
  FDialogType := AValue;
  iconKind := idDialogBase + 1 + ord(FDialogType);
  FImage.Free;
  FImage := GetDialogIcon(iconKind);
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;


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.TextLayout := QuestionDlgEx_TextLayout;
  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.