You've already forked lazarus-ccr
extctrls: Add extended question dialog.
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@8150 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
540
components/exctrls/source/exquestiondlg.pas
Normal file
540
components/exctrls/source/exquestiondlg.pas
Normal file
@@ -0,0 +1,540 @@
|
||||
{
|
||||
'*******************************************************************************
|
||||
'
|
||||
' 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 := bsDialog;
|
||||
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.
|
||||
|
||||
Reference in New Issue
Block a user