type
TMessageDlgCNInputCloseQueryEvent = procedure (Sender: TObject; const Values: array of string; var CanClose: Boolean; QueryForm: TForm) of object;
TMessageDlgCNInputCloseQueryFunc = reference to function (const Values: array of string; QueryForm: TForm): Boolean;
function DoFindWindow(Window: HWnd; Param: LPARAM): Bool; {$IFNDEF CLR}stdcall; {$ENDIF}
begin
if (Window <> TaskActiveWindow) and (Window <> Application.Handle) and IsWindowVisible(Window) and
IsWindowEnabled(Window) then
if GetWindowLong(Window, GWL_EXSTYLE) and WS_EX_TOPMOST = 0 then
begin
if TaskFirstWindow = 0 then
TaskFirstWindow := Window;
end
else
begin
if TaskFirstTopMost = 0 then
TaskFirstTopMost := Window;
end;
Result := True;
end;
function FindTopMostWindow(ActiveWindow: HWnd): HWnd;
var
EnumProc: TFNWndEnumProc; // keep a reference to the delegate!
begin
TaskActiveWindow := ActiveWindow;
TaskFirstWindow := 0;
TaskFirstTopMost := 0;
EnumProc := @DoFindWindow;
EnumThreadWindows(GetCurrentThreadID, EnumProc, 0);
if TaskFirstWindow <> 0 then
Result := TaskFirstWindow
else
Result := TaskFirstTopMost;
end;
function GetAveCharSize(Canvas: TCanvas): TPoint;
{$IF DEFINED(CLR)}
var
I: Integer;
Buffer: string;
Size: TSize;
begin
SetLength(Buffer, 52);
for I := 0 to 25 do
Buffer[I + 1] := Chr(I + Ord('A'));
for I := 0 to 25 do
Buffer[I + 27] := Chr(I + Ord('a'));
GetTextExtentPoint(Canvas.Handle, Buffer, 52, Size);
Result.X := Size.cx div 52;
Result.Y := Size.cy;
end;
{$ELSE}
var
I: Integer;
Buffer: array [0 .. 51] of Char;
begin
for I := 0 to 25 do
Buffer[I] := Chr(I + Ord('A'));
for I := 0 to 25 do
Buffer[I + 26] := Chr(I + Ord('a'));
GetTextExtentPoint(Canvas.Handle, Buffer, 52, TSize(Result));
Result.X := Result.X div 52;
end;
{$IFEND}
procedure TMessageForm.CreateParams(var Params: TCreateParams);
begin
inherited;
// SetWindowLong(Handle,GWL_EXSTYLE,
// GetWindowLong(Handle,GWL_EXSTYLE) or WS_EX_CONTROLPARENT);
Params.ExStyle := Params.ExStyle or WS_EX_CONTROLPARENT;
end;
procedure TMessageForm.WMSysCommand(var Message: TWMSysCommand);
begin
if (message.CmdType = SC_CLOSE) then
begin
if not isCanSysCDMClose then
begin
message.Result := 1;
exit;
end;
end;
inherited;
end;
procedure TMessageForm.DoShow;
var
i: Integer;
begin
for i := Low(Btns) to High(Btns) do
begin
with Btns do
begin
if Default then
begin
ActiveControl := Btns;
break;
end;
end;
end;
if Length(Btns) <= 1 then
begin
end
else if MessageDlgUseMessageBoxSysCMDColse then
begin
EnableMenuItem(GetSystemMenu(Handle, False), SC_CLOSE, MF_DISABLED or MF_GRAYED or MF_BYCOMMAND);
end;
if MessageDlgUseMessageBeep then
case DlgType of
TMsgDlgType.mtWarning:
MessageBeep(MB_ICONEXCLAMATION);
TMsgDlgType.mtError:
MessageBeep(MB_ICONHAND);
TMsgDlgType.mtInformation:
MessageBeep(MB_ICONASTERISK);
TMsgDlgType.mtConfirmation:
MessageBeep(MB_ICONQUESTION);
TMsgDlgType.mtCustom:
;
end;
try
SetFocus;
except
end;
inherited;
end;
procedure TMessageForm.DoClose;
begin
if (Application = nil) or Application.Terminated then
begin
ModalResult := mrCancel;
end;
inherited;
end;
procedure TMessageForm.HelpButtonClick(Sender: TObject);
begin
ModalResult := mrNone;
Application.HelpContext(HelpContext);
end;
procedure TMessageForm.ButtonClick(AOwner: TObject);
begin
IsSysCDMClose := False;
end;
procedure TMessageForm.CustomKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if (Shift = [ssCtrl]) and (Key = Word('C')) then
begin
System.SysUtils.Beep;
WriteToClipBoard(GetFormText);
end;
end;
procedure TMessageForm.WriteToClipBoard(Text: string);
var
Data: THandle;
{$IF DEFINED(CLR)}
DataPtr: IntPtr;
Buffer: TBytes;
{$ELSE}
DataPtr: Pointer;
{$IFEND}
begin
if OpenClipBoard(0) then
begin
try
//[UIPermission(SecurityAction.LinkDemand, Window = UIPermissionWindow.SafeSubWindows)]
function CreateMessageDialog(const Msg: string; const DlgType: TMsgDlgType; const Buttons: array of string;
const DefaultIndex, CancelIndex, HelpIndex: Integer; const AOwner: TComponent = nil): TForm;
const
mcHorzMargin = 8;
mcVertMargin = 8;
mcHorzSpacing = 10;
mcVertSpacing = 10;
mcButtonWidth = 50;
mcButtonHeight = 14;
mcButtonSpacing = 4;
var
DialogUnits: TPoint;
i, j, HorzMargin, VertMargin, HorzSpacing, VertSpacing, ButtonWidth, ButtonHeight, ButtonSpacing, ButtonCount,
ButtonGroupWidth, IconTextWidth, IconTextHeight, X, ALeft: Integer;
{$IF DEFINED(CLR)}
IconID: Integer;
{$ELSE}
IconID: PChar;
{$IFEND}
TextRect: TRect;
begin
if (AOwner <> nil) then
begin
Result := TMessageForm.CreateNew(AOwner);
end
else
begin
Result := TMessageForm.CreateNew(Application);
end;
TMessageForm(Result).DlgType := DlgType;
with TMessageForm(Result) do
begin
isCanSysCDMClose := False;
if CancelIndex > 0 then
begin
isCanSysCDMClose := True;
end;
if Length(Buttons) <= 1 then
begin
isCanSysCDMClose := True;
end;
if MessageDlgUseMessageBoxSysCMDColse then
begin
isCanSysCDMClose := False;
end;
Font := Screen.MessageFont;
if MessageDlgFormUseDefaultFont then
begin
Font.Name := MessageDlgDefaultFormFontName;
Font.Size := MessageDlgDefaultFormFontSize;
end;
Font.Charset := GetDefFontCharSet;
BiDiMode := Application.BiDiMode;
BorderStyle := bsDialog;
Canvas.Font := Font;
KeyPreview := True;
PopupMode := pmAuto;
Position := poDesigned;
OnKeyDown := TMessageForm(Result).CustomKeyDown;
// BorderIcons := [biSystemMenu];
// FormStyle := fsStayOnTop;
DialogUnits := GetAveCharSize(Canvas);
HorzMargin := MulDiv(mcHorzMargin, DialogUnits.X, 4);
VertMargin := MulDiv(mcVertMargin, DialogUnits.Y, 8);
HorzSpacing := MulDiv(mcHorzSpacing, DialogUnits.X, 4);
VertSpacing := MulDiv(mcVertSpacing, DialogUnits.Y, 8);
ButtonWidth := MulDiv(mcButtonWidth, DialogUnits.X, 4);
SetLength(ButtonWidths, Length(Buttons));
j := 0;
for i := Low(Buttons) to High(Buttons) do
begin
try
if ButtonWidths[j] = 0 then
begin
TextRect := Rect(0, 0, 0, 0);
Winapi.Windows.DrawText(canvas.handle, PChar(Buttons), -1, TextRect, DT_CALCRECT or DT_LEFT or
DT_SINGLELINE or DrawTextBiDiModeFlagsReadingOnly);
with TextRect do
ButtonWidths := Right - Left + 8;
end;
if ButtonWidths > ButtonWidth then
ButtonWidth := ButtonWidths;
finally
inc(j);
end;
end;
ButtonHeight := MulDiv(mcButtonHeight, DialogUnits.Y, 8);
ButtonSpacing := MulDiv(mcButtonSpacing, DialogUnits.X, 4);
SetRect(TextRect, 0, 0, Screen.Width div 2, 0);
DrawText(Canvas.Handle, Msg, Length(Msg) + 1, TextRect, DT_EXPANDTABS or DT_CALCRECT or DT_WORDBREAK or
DrawTextBiDiModeFlagsReadingOnly);
IconID := IconIDs[DlgType];
IconTextWidth := TextRect.Right;
IconTextHeight := TextRect.Bottom;
{$IF DEFINED(CLR)}
if DlgType <> mtCustom then
{$ELSE}
if IconID <> nil then
{$IFEND}
begin
Inc(IconTextWidth, 32 + HorzSpacing);
if IconTextHeight < 32 then
IconTextHeight := 32;
end;
ButtonCount := Length(Buttons);
ButtonGroupWidth := 0;
if ButtonCount <> 0 then
ButtonGroupWidth := ButtonWidth * ButtonCount + ButtonSpacing * (ButtonCount - 1);
ClientWidth := Max(IconTextWidth, ButtonGroupWidth) + HorzMargin * 2;
ClientHeight := IconTextHeight + ButtonHeight + VertSpacing + VertMargin * 2;
Left := (Screen.Width div 2) - (Width div 2);
Top := (Screen.Height div 2) - (Height div 2);
if DlgType <> mtCustom then
{$IF DEFINED(CLR)}
Caption := Captions[DlgType]
else
Caption := Application.Title;
if DlgType <> mtCustom then
{$ELSE}
Caption := LoadResString(Captions[DlgType])
else
Caption := Application.Title;
if IconID <> nil then
{$IFEND}
with TImage.Create(Result) do
begin
Name := 'Image';
Parent := Result;
Picture.Icon.Handle := LoadIcon(0, IconID);
SetBounds(HorzMargin, VertMargin, 32, 32);
end;
TMessageForm(Result).Message := TLabel.Create(Result);
with TMessageForm(Result).Message do
begin
Name := 'Message';
Parent := Result;
WordWrap := True;
Caption := Msg;
BoundsRect := TextRect;
BiDiMode := Result.BiDiMode;
ALeft := IconTextWidth - TextRect.Right + HorzMargin;
if UseRightToLeftAlignment then
ALeft := Result.ClientWidth - ALeft - Width;
SetBounds(ALeft, VertMargin, TextRect.Right, TextRect.Bottom);
end;
X := (ClientWidth - ButtonGroupWidth) div 2;
SetLength(Btns, Length(Buttons));
j := 0;
for i := Low(Buttons) to High(Buttons) do
begin
try
Btns := TButton.Create(Result);
with Btns do
begin
Name := 'Button_' + IntToStr(j + 1);
Parent := Result;
Caption := Buttons;
ModalResult := j + 1;
if j + 1 = DefaultIndex then
begin
Default := True;
ActiveControl := Btns;
end;
if j + 1 = CancelIndex then
Cancel := True;
SetBounds(X, IconTextHeight + VertMargin + VertSpacing, ButtonWidth, ButtonHeight);
Inc(X, ButtonWidth + ButtonSpacing);
if j + 1 = HelpIndex then
begin
ModalResult := mrNone;
// HelpFile := HelpFileName;
// HelpContext := HelpCtx;
Tag := 0;
OnClick := TMessageForm(Result).HelpButtonClick;
end
else
begin
OnClick := ButtonClick;
end;
end;
finally
inc(j);
end;
end;
end;
end;
//[UIPermission(SecurityAction.LinkDemand, Window = UIPermissionWindow.SafeSubWindows)]
function DoMessageDlgPosHelp(const Msg, MsgTitle: string; const DlgType: TMsgDlgType; const Buttons: array of string;
const DefaultIndex, CancelIndex, HelpIndex: Integer; HelpCtx: LongInt; const HelpFileName: string;
const X, Y: Integer; const AOwner: TComponent = nil): Integer;
var
Dialog: TMessageForm;
begin
// Dialog := TMessageDialog(CreateMessageDialogEx(Msg, DlgType, Buttons, DefaultIndex, CancelIndex, 80, 23, AOwner));
Dialog := TMessageForm(CreateMessageDialog(Msg, DlgType, Buttons, DefaultIndex, CancelIndex, HelpIndex, AOwner));
with Dialog do
begin
try
if MsgTitle <> '' then
begin
Caption := MsgTitle;
end;
HelpContext := HelpCtx;
HelpFile := HelpFileName;
if X >= 0 then
Left := X;
if Y >= 0 then
Top := Y;
if (X < 0) and (Y < 0) then
begin
if (AOwner <> nil) and (AOwner is TWinControl) and TWinControl(AOwner).Visible then
begin
Position := poOwnerFormCenter;
end
else
begin
if MessageDlgToMainFormCenter and (Application.MainForm <> nil) and Application.MainForm.Visible then
begin
Position := poMainFormCenter;
end
else
begin
Position := poScreenCenter;
end;
end;
end;
Application.NormalizeAllTopMosts;
try
Result := ShowModal;
if IsSysCDMClose then
begin
Result := CancelIndex;
if Result < 0 then
begin
Result := DefaultIndex;
end;
if Result < 0 then
begin
Result := High(Buttons);
end;
end;
finally
Application.RestoreTopMosts;
end;
finally
Free;
end;
end;
end;
{ TaskDialog based message dialog; requires Windows Vista or later }
type
TWndProcCB = function (hwnd: HWND; iMsg: UINT; wParam:WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
TaskMessageDialogList: TList<TTaskMessageDialog>;
procedure InitTaskMessageDialogList;
begin
if (TaskMessageDialogList = nil) then
begin
TaskMessageDialogList := TList<TTaskMessageDialog>.Create;
end;
TaskMessageDialogList.Clear;
end;
procedure UnInitTaskMessageDialogList;
begin
if (TaskMessageDialogList <> nil) then
begin
TaskMessageDialogList.Clear;
FreeAndNil(TaskMessageDialogList);
end;
end;
function WndProcForTaskForm(hwnd: HWND; iMsg: UINT; wParam:WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
i: Integer;
AForm: TTaskMessageDialog;
AWMsg: TMessage;
begin
for i := 0 to TaskMessageDialogList.Count - 1 do
begin
AForm := nil;
if (TaskMessageDialogList.Items <> nil) and (TaskMessageDialogList.Items is TTaskMessageDialog) then
begin
AForm := TaskMessageDialogList.Items;
end;
if (AForm <> nil) and (AForm.Handle = hwnd) and
Assigned(AForm.FOldWndProcCB) then
begin
if (iMsg = WM_COMMAND) then
begin
AWMsg.Msg := iMsg;
AWMsg.WParam := wParam;
AWMsg.LParam := lParam;
AWMsg.Result := Result;
if TWMCommand(AWMsg).ItemID = 2 then //和实体按钮无关，就是 ESC 按下了。
begin
iMsg := WM_NULL;
try
if (AForm.FCancelIndex > 0) and (AForm.FCancelIndex <= AForm.Buttons.Count) and
(AForm.Buttons[AForm.FCancelIndex - 1].Enabled) and (IsWindowVisible(hwnd))then
begin
AForm.Buttons[AForm.FCancelIndex - 1].Click;
end;
except
end;
end;
end;
Result := TWndProcCB(AForm.FOldWndProcCB)(hwnd, iMsg, wParam, lParam);
end;
end;
end;
function TTaskMessageDialog.CallbackProc(hwnd: HWND; msg: UINT; wParam: WPARAM;
lParam: LPARAM; lpRefData: LONG_PTR): HResult;
begin
if msg = TDN_DIALOG_CONSTRUCTED then
begin
TaskMessageDialogList.Add(Self);
FOldWndProcCB := Pointer(GetWindowLongW(hwnd, GWL_WNDPROC));
FWndProcCB := Addr(WndProcForTaskForm);
SetWindowLongW(hwnd, GWL_WNDPROC, IntPtr(FWndProcCB));
end;
if msg = TDN_DESTROYED then
begin
TaskMessageDialogList.Remove(Self);
if Assigned(FOldWndProcCB) then
begin
SetWindowLongW(hwnd, GWL_WNDPROC, IntPtr(FOldWndProcCB));
end;
end;
Result := inherited;
end;
const
tdbHelp = -1;
procedure TTaskMessageDialog.DoOnButtonClicked(AModalResult: Integer; var CanClose: Boolean);
begin
if AModalResult = tdbHelp then
begin
CanClose := False;
DoOnHelp;
end;
FButtonClicked := True;
end;
procedure TTaskMessageDialog.DoOnDialogCreated;
var
Rect: TRect;
LX, LY: Integer;
LHandle: HMONITOR;
LMonitorInfo: TMonitorInfo;
pt: TPoint;
begin
LX := Position.X;
LY := Position.Y;
LHandle := MonitorFromWindow(FParentWnd, MONITOR_DEFAULTTONEAREST);
LMonitorInfo.cbSize := SizeOf(LMonitorInfo);
if GetMonitorInfo(LHandle, {$IFNDEF CLR}@{$ENDIF}LMonitorInfo) then
with LMonitorInfo do
begin
GetWindowRect(Handle, Rect);
if LX < 0 then
LX := ((rcWork.Right - rcWork.Left) - (Rect.Right - Rect.Left)) div 2;
if LY < 0 then
LY := ((rcWork.Bottom - rcWork.Top) - (Rect.Bottom - Rect.Top)) div 2;
Inc(LX, rcWork.Left);
Inc(LY, rcWork.Top);
if (Position.X < 0) and (Position.Y < 0) then
begin
if (AOwner <> nil) and (AOwner is TWinControl) and TWinControl(AOwner).Visible then
begin
// Position := poOwnerFormCenter;
LX := ((TWinControl(AOwner).ClientRect.Right - TWinControl(AOwner).ClientRect.Left) -
(Rect.Right - Rect.Left)) div 2;
LY := ((TWinControl(AOwner).ClientRect.Bottom - TWinControl(AOwner).ClientRect.Top) -
(Rect.Bottom - Rect.Top)) div 2;
pt := TWinControl(AOwner).ClientToScreen(TPoint.Create(LX, LY));
LX := pt.X;
LY := pt.Y;
end
else
begin
if MessageDlgToMainFormCenter and (Application.MainForm <> nil) and Application.MainForm.Visible then
begin
// Position := poMainFormCenter;
LX := ((Application.MainForm.ClientRect.Right - Application.MainForm.ClientRect.Left) -
(Rect.Right - Rect.Left)) div 2;
LY := ((Application.MainForm.ClientRect.Bottom - Application.MainForm.ClientRect.Top) -
(Rect.Bottom - Rect.Top)) div 2;
pt := TWinControl(AOwner).ClientToScreen(TPoint.Create(LX, LY));
LX := pt.X;
LY := pt.Y;
end
else
begin
// Position := poScreenCenter;
end;
end;
end;
SetWindowPos(Handle, 0, LX, LY, 0, 0, SWP_NOACTIVATE or SWP_NOSIZE or SWP_NOZORDER);
end;
if MessageDlgUseMessageBoxSysCMDColse and (Buttons.Count > 1) then
EnableMenuItem(GetSystemMenu(Handle, False), SC_CLOSE, MF_DISABLED or MF_GRAYED or MF_BYCOMMAND);
end;
procedure TTaskMessageDialog.DoOnHelp;
var
LHelpFile: string;
LHelpSystem: IHelpSystem;
begin
if HelpContext <> 0 then
begin
if FHelpFile = '' then
LHelpFile := Application.HelpFile
else
LHelpFile := HelpFile;
if System.HelpIntfs.GetHelpSystem(LHelpSystem) then
try
LHelpSystem.Hook(Application.Handle, LHelpFile, HELP_CONTEXT, HelpContext);
except
on E: Exception do
ShowHelpException(E);
end;
end;
end;
function TTaskMessageDialog.Execute(ParentWnd: HWND): Boolean;
begin
FParentWnd := ParentWnd;
Result := inherited Execute(ParentWnd);
if (not FButtonClicked) and Result then
begin
ModalResult := FCancelIndex;
end;
end;
const
tdiConfirm = 32514;
tdiStop = tdiError;
function DoTaskMessageDlgPosHelp(const Instruction, Msg, MsgTitle: string; DlgType: TMsgDlgType;
const Buttons: array of string; const DefaultIndex, CancelIndex, HelpIndex: Integer; HelpCtx: LongInt;
const HelpFileName: string; const X, Y: Integer; const AOwner: TComponent = nil): Integer;
const
IconMap: array [TMsgDlgType] of TTaskDialogIcon =
// (tdiWarning, tdiError, tdiInformation, tdiConfirm, tdiStop, tdiNone);
(tdiWarning, tdiError, tdiInformation, tdiConfirm, tdiNone);
var
i: Integer;
LTaskDialog: TTaskMessageDialog;
begin
Application.ModalStarted;
LTaskDialog := TTaskMessageDialog.Create(nil);
try
LTaskDialog.FButtonClicked := False;
//为 TAST 对话框增加 ESC 按下的默认按钮。
//LTaskDialog.FCancelIndex := 2;
LTaskDialog.FCancelIndex := -1;
if CancelIndex > 0 then
begin
LTaskDialog.FCancelIndex := CancelIndex;
end;
// Assign buttons
for i := Low(Buttons) to High(Buttons) do
begin
with LTaskDialog.Buttons.Add do
begin
Caption := Buttons;
if i + 1 = DefaultIndex then
Default := True;
// if i + 1 = CancelIndex then
// Cancel := True;
ModalResult := i + 1;
end;
end;
LTaskDialog.AOwner := AOwner;
// Set dialog properties
with LTaskDialog do
begin
if DlgType <> mtCustom then
{$IF DEFINED(CLR)}
Caption := Captions[DlgType]
{$ELSE}
Caption := LoadResString(Captions[DlgType])
{$IFEND}
else
Caption := Application.Title;
if MsgTitle <> '' then
begin
Caption := MsgTitle;
end;
CommonButtons := [];
if Application.UseRightToLeftReading then
Flags := Flags + [tfRtlLayout];
HelpContext := HelpCtx;
HelpFile := HelpFileName;
MainIcon := IconMap[DlgType];
Position := Point(X, Y);
Text := Msg;
Title := Instruction;
end;
// Show dialog and return result
Result := mrNone;
if LTaskDialog.Execute then
Result := LTaskDialog.ModalResult;
finally
LTaskDialog.Free;
Application.ModalFinished;
end;
end;
//[UIPermission(SecurityAction.LinkDemand, Window = UIPermissionWindow.SafeSubWindows)]
function ShowMessageDlgPosHelp(const Msg, MsgTitle: string; const DlgType: TMsgDlgType; const Buttons: array of string;
const DefaultIndex, CancelIndex, HelpIndex: Integer; HelpCtx: LongInt; const HelpFileName: string;
const X, Y: Integer; const AOwner: TComponent = nil): Integer;
begin
if TOSVersion.Check(6) and UseLatestCommonDialogs and StyleServices.Enabled and StyleServices.IsSystemStyle then
Result := DoTaskMessageDlgPosHelp('', Msg, MsgTitle, DlgType, Buttons, DefaultIndex, CancelIndex, HelpIndex,
HelpCtx, HelpFileName, X, Y, AOwner)
else
Result := DoMessageDlgPosHelp(Msg, MsgTitle, DlgType, Buttons, DefaultIndex, CancelIndex, HelpIndex, HelpCtx,
HelpFileName, X, Y, AOwner)
end;
//[UIPermission(SecurityAction.LinkDemand, Window = UIPermissionWindow.SafeSubWindows)]
function MessageDlgPos(const Msg, MsgTitle: string; const DlgType: TMsgDlgType; const Buttons: array of string;
const DefaultIndex, CancelIndex: Integer; const X, Y: Integer; const AOwner: TComponent = nil): Integer;
begin
Result := ShowMessageDlgPosHelp(Msg, MsgTitle, DlgType, Buttons, DefaultIndex, CancelIndex, -1, 1, '', X, Y, AOwner);
end;
//[UIPermission(SecurityAction.LinkDemand, Window = UIPermissionWindow.SafeSubWindows)]
function MessageDialog(const Msg, MsgTitle: string; const DlgType: TMsgDlgType; const Buttons: array of string;
const DefaultIndex, CancelIndex: Integer; const AOwner: TComponent = nil): Integer;
begin
Result := MessageDlgPos(Msg, MsgTitle, DlgType, Buttons, DefaultIndex, CancelIndex, -1, -1, AOwner);
end;
//[UIPermission(SecurityAction.LinkDemand, Window = UIPermissionWindow.SafeSubWindows)]
function MessageDialog(const Msg, MsgTitle: string; const DlgType: TMsgDlgType; const Buttons: array of string;
const AOwner: TComponent = nil): Integer;
begin
Result := MessageDialog(Msg, MsgTitle, dlgType, Buttons, 1, -1, AOwner);
end;
//[UIPermission(SecurityAction.LinkDemand, Window = UIPermissionWindow.SafeSubWindows)]
function QuestionDialog(const Msg, MsgTitle: string; const AOwner: TComponent = nil; YesCaption: string = '';
NoCaption: string = ''): Boolean;
var
FYesCaption, FNoCaption: string;
begin
FYesCaption := YesCaption;
FNoCaption := NoCaption;
if FYesCaption = '' then
begin
FYesCaption := '是(&Y)';
end;
if FNoCaption = '' then
begin
FNoCaption := '否(&N)';
end;
Result := MessageDialog(Msg, MsgTitle, mtConfirmation, [FYesCaption, FNoCaption], 1, 2, AOwner) = 1;
end;
//[UIPermission(SecurityAction.LinkDemand, Window = UIPermissionWindow.SafeSubWindows)]
function QuestionCancelDialog(const Msg, MsgTitle: string; const AOwner: TComponent = nil; YesCaption: string = '';
NoCaption: string = ''; CancelCaption: string = ''): Integer;
var
FYesCaption, FNoCaption, FCancelCaption: string;
begin
FYesCaption := YesCaption;
FNoCaption := NoCaption;
FCancelCaption := CancelCaption;
if FYesCaption = '' then
begin
FYesCaption := '是(&Y)';
end;
if FNoCaption = '' then
begin
FNoCaption := '否(&N)';
end;
if FCancelCaption = '' then
begin
FCancelCaption := '取消(&C)';
end;
Result := MessageDialog(Msg, MsgTitle, mtConfirmation, [FYesCaption, FNoCaption, FCancelCaption], 1, 3, AOwner);
case Result of
1:
begin
Result := mrYes;
end;
2:
begin
Result := mrNo;
end;
else
begin
Result := mrCancel;
end;
end;
end;
//[UIPermission(SecurityAction.LinkDemand, Window = UIPermissionWindow.SafeSubWindows)]
procedure ShowMessagePos(const Msg, MsgTitle: string; const X, Y: Integer; const AOwner: TComponent = nil;
OKCaption: string = '');
var
FOKCaption: string;
begin
FOKCaption := OKCaption;
if FOKCaption = '' then
begin
FOKCaption := '确定(&O)';
end;
MessageDlgPos(Msg, MsgTitle, mtInformation, [FOKCaption], 1, -1, X, Y, AOwner);
end;
//[UIPermission(SecurityAction.LinkDemand, Window = UIPermissionWindow.SafeSubWindows)]
procedure ShowException(E: Exception; const AOwner: TComponent = nil; OKCaption: string = '');
var
Msg: string;
begin
Msg := E.Message;
if (Msg <> '') and (AnsiLastChar(Msg) > '.') then
Msg := Msg + '.';
ShowException(Msg, AOwner, OKCaption);
end;
//[UIPermission(SecurityAction.LinkDemand, Window = UIPermissionWindow.SafeSubWindows)]
procedure ShowException(E: string; const AOwner: TComponent = nil; OKCaption: string = '');
var
FOKCaption: string;
begin
FOKCaption := OKCaption;
if FOKCaption = '' then
begin
FOKCaption := '确定(&O)';
end;
MessageDlgPos(E, Application.Title, mtError, [FOKCaption], 1, -1, -1, -1, AOwner);
end;
//
type
TInputQueryForm = class(TForm)
public
FCloseQueryFunc: TFunc<Boolean>;
function CloseQuery: Boolean; override;
procedure DoShow; override;
end;
function TInputQueryForm.CloseQuery: Boolean;
begin
Result := (ModalResult = mrCancel) or (not Assigned(FCloseQueryFunc)) or FCloseQueryFunc();
end;
procedure TInputQueryForm.DoShow;
begin
if MessageDlgInputQueryDisableSysCMDClose then
begin
EnableMenuItem(GetSystemMenu(Handle, False), SC_CLOSE, MF_DISABLED or MF_GRAYED or MF_BYCOMMAND);
end;
inherited;
end;
{ Input dialog }
function GetTextBaseline(AControl: TControl; ACanvas: TCanvas): Integer;
var
tm: TTextMetric;
ClientRect: TRect;
Ascent: Integer;
begin
ClientRect := AControl.ClientRect;
GetTextMetrics(ACanvas.Handle, tm);
Ascent := tm.tmAscent + 1;
Result := ClientRect.Top + Ascent;
Result := AControl.Parent.ScreenToClient(AControl.ClientToScreen(TPoint.Create(0, Result))).Y - AControl.Top;
end;
function GetPromptCaption(const ACaption: string): string;
begin
if (Length(ACaption) > 1) and (ACaption[1] < #32) then
Result := Copy(ACaption, 2, MaxInt)
else
Result := ACaption;
end;
function GetMaxPromptWidth(Canvas: TCanvas): Integer;
var
I: Integer;
LLabel: TLabel;
begin
Result := 0;
// Use a TLabel rather than an API such as GetTextExtentPoint32 to
// avoid differences in handling characters such as line breaks.
LLabel := TLabel.Create(nil);
try
for I := 0 to PromptCount - 1 do
begin
LLabel.Caption := GetPromptCaption(APrompts[I]);
Result := Max(Result, LLabel.Width + DialogUnits.X);
end;
finally
LLabel.Free;
end;
end;
function GetPasswordChar(const ACaption: string): Char;
begin
if (Length(ACaption) > 1) and (ACaption[1] < #32) then
Result := '*'
else
Result := #0;
end;
begin
if Length(AValues) < Length(APrompts) then
raise EInvalidOperation.CreateRes(@SPromptArrayTooShort);
PromptCount := Length(APrompts);
if PromptCount < 1 then
raise EInvalidOperation.CreateRes(@SPromptArrayEmpty);
Result := False;
if (AOwner <> nil) then
begin
Form := TInputQueryForm.CreateNew(AOwner);
end
else
begin
Form := TInputQueryForm.CreateNew(Application);
end;
with Form do
begin
try
if MessageDlgFormUseDefaultFont then
begin
Font.Name := MessageDlgDefaultFormFontName;
Font.Size := MessageDlgDefaultFormFontSize;
end;
FCloseQueryFunc := function: Boolean
var
I, J: Integer;
LValues: array of string;
Control: TControl;
begin
Result := True;
if Assigned(CloseQueryFunc) then
begin
SetLength(LValues, PromptCount);
J := 0;
for I := 0 to Form.ControlCount - 1 do
begin
Control := Form.Controls[I];
if Control is TEdit then
begin
LValues[J] := TEdit(Control).Text;
Inc(J);
end;
end;
Result := CloseQueryFunc(LValues, Form);
Form.BringToFront;
end;
end;
Canvas.Font := Font;
Font.Charset := GetDefFontCharSet;
DialogUnits := GetAveCharSize(Canvas);
MaxPromptWidth := GetMaxPromptWidth(Canvas);
BorderStyle := bsDialog;
Caption := ACaption;
ClientWidth := MulDiv(180 + MaxPromptWidth, DialogUnits.X, 4);
PopupMode := pmAuto;
HelpContext := HelpCtx;
HelpFile := HelpFileName;
Position := poDefault;
if X >= 0 then
Left := X;
if Y >= 0 then
Top := Y;
if (X < 0) and (Y < 0) then
begin
if (AOwner <> nil) and (AOwner is TWinControl) and TWinControl(AOwner).Visible then
begin
Position := poOwnerFormCenter;
end
else
begin
if MessageDlgToMainFormCenter and (Application.MainForm <> nil) and Application.MainForm.Visible then
begin
Position := poMainFormCenter;
end
else
begin
Position := poScreenCenter;
end;
end;
end;
CurPrompt := MulDiv(8, DialogUnits.Y, 8);
Edit := nil;
for I := 0 to PromptCount - 1 do
begin
Prompt := TLabel.Create(Form);
with Prompt do
begin
Font.Name := MessageDlgDefaultFontName;
Font.Size := MessageDlgDefaultFontSize;
Parent := Form;
Caption := GetPromptCaption(APrompts[I]);
Left := MulDiv(8, DialogUnits.X, 4);
Top := CurPrompt;
Constraints.MaxWidth := MaxPromptWidth;
WordWrap := True;
end;
Edit := TEdit.Create(Form);
with Edit do
begin
Font.Name := MessageDlgDefaultFontName;
Font.Size := MessageDlgDefaultFontSize;
Parent := Form;
PasswordChar := GetPasswordChar(APrompts[I]);
Left := Prompt.Left + MaxPromptWidth;
Top := Prompt.Top + Prompt.Height - DialogUnits.Y -
(GetTextBaseline(Edit, Canvas) - GetTextBaseline(Prompt, Canvas));
Width := Form.ClientWidth - Left - MulDiv(8, DialogUnits.X, 4);
MaxLength := 255;
Text := AValues[I];
SelectAll;
Prompt.FocusControl := Edit;
end;
CurPrompt := Edit.Top + Edit.Height + 5;
end;
ButtonTop := Edit.Top + Edit.Height + 15;
ButtonWidth := MulDiv(50, DialogUnits.X, 4);
ButtonHeight := MulDiv(14, DialogUnits.Y, 8);
with TButton.Create(Form) do
begin
Parent := Form;
Caption := SMsgDlgOK;
Font.Name := MessageDlgDefaultFontName;
Font.Size := MessageDlgDefaultFontSize;
Caption := OKCaption;
if Caption = '' then
begin
Caption := '确定(&O)';
end;
ModalResult := mrOk;
Default := True;
SetBounds(Form.ClientWidth - (ButtonWidth + MulDiv(8, DialogUnits.X, 4)) * 2, ButtonTop, ButtonWidth,
ButtonHeight);
end;
with TButton.Create(Form) do
begin
Parent := Form;
Caption := SMsgDlgCancel;
Caption := CancelCaption;
if Caption = '' then
begin
Caption := '取消(&C)';
end;
ModalResult := mrCancel;
Cancel := True;
SetBounds(Form.ClientWidth - (ButtonWidth + MulDiv(8, DialogUnits.X, 4)), ButtonTop, ButtonWidth, ButtonHeight);
Form.ClientHeight := Top + Height + 13;
end;
Application.NormalizeAllTopMosts;
try
if ShowModal = mrOk then
begin
J := 0;
for I := 0 to ControlCount - 1 do
if Controls[I] is TEdit then
begin
Edit := TEdit(Controls[I]);
AValues[J] := Edit.Text;
Inc(J);
end;
Result := True;
end;
finally
Application.RestoreTopMosts;
end;
finally
Form.Free;
end;
end;
end;
//[UIPermission(SecurityAction.LinkDemand, Window = UIPermissionWindow.SafeSubWindows)]
function InputQueryPosHelp(const ACaption: string; const APrompts: array of string; var AValues: array of string;
const X, Y: Integer; HelpCtx: LongInt; const HelpFileName: string; CloseQueryEvent: TMessageDlgCNInputCloseQueryEvent;
Context: TObject = nil; const AOwner: TComponent = nil; OKCaption: string = ''; CancelCaption: string = ''): Boolean;
var
Func: TMessageDlgCNInputCloseQueryFunc;
begin
Func := function(const Values: array of string; QueryForm: TForm): Boolean // 注意本行最后不能有 ; 号
begin
Result := True;
CloseQueryEvent(Context, Values, Result, QueryForm);
end;
Result := InputQueryPosHelp(ACaption, APrompts, AValues, -1, -1, HelpCtx, HelpFileName, Func, AOwner, OKCaption,
CancelCaption);
end;
//[UIPermission(SecurityAction.LinkDemand, Window = UIPermissionWindow.SafeSubWindows)]
function InputQueryPos(const ACaption: string; const APrompts: array of string; var AValues: array of string;
const X, Y: Integer; CloseQueryFunc: TMessageDlgCNInputCloseQueryFunc = nil; const AOwner: TComponent = nil;
OKCaption: string = ''; CancelCaption: string = ''): Boolean;
begin
Result := InputQueryPosHelp(ACaption, APrompts, AValues, -1, -1, -1, '', CloseQueryFunc, AOwner, OKCaption,
CancelCaption);
end;
//[UIPermission(SecurityAction.LinkDemand, Window = UIPermissionWindow.SafeSubWindows)]
function InputQueryPos(const ACaption: string; const APrompts: array of string; var AValues: array of string;
const X, Y: Integer; CloseQueryEvent: TMessageDlgCNInputCloseQueryEvent; Context: TObject = nil; const AOwner: TComponent = nil;
OKCaption: string = ''; CancelCaption: string = ''): Boolean;
begin
Result := InputQueryPosHelp(ACaption, APrompts, AValues, X, Y, -1, '', CloseQueryEvent, Context, AOwner, OKCaption,
CancelCaption);
end;
//[UIPermission(SecurityAction.LinkDemand, Window = UIPermissionWindow.SafeSubWindows)]
function InputQuery(const ACaption: string; const APrompts: array of string; var AValues: array of string;
CloseQueryFunc: TMessageDlgCNInputCloseQueryFunc = nil; const AOwner: TComponent = nil; OKCaption: string = '';
CancelCaption: string = ''): Boolean;
begin
Result := InputQueryPos(ACaption, APrompts, AValues, -1, -1, CloseQueryFunc, AOwner, OKCaption, CancelCaption);
end;
//[UIPermission(SecurityAction.LinkDemand, Window = UIPermissionWindow.SafeSubWindows)]
function InputQuery(const ACaption: string; const APrompts: array of string; var AValues: array of string;
CloseQueryEvent: TMessageDlgCNInputCloseQueryEvent; Context: TObject = nil; const AOwner: TComponent = nil;
OKCaption: string = ''; CancelCaption: string = ''): Boolean;
begin
Result := InputQueryPos(ACaption, APrompts, AValues, -1, -1, CloseQueryEvent, Context, AOwner, OKCaption,
CancelCaption);
end;
//[UIPermission(SecurityAction.LinkDemand, Window = UIPermissionWindow.SafeSubWindows)]
function InputQuery(const ACaption, APrompt: string; var Value: string; const AOwner: TComponent = nil;
CloseQueryFunc: TMessageDlgCNInputCloseQueryFunc = nil;
OKCaption: string = ''; CancelCaption: string = ''): Boolean;
var
Values: array [0 .. 0] of string;
begin
Values[0] := Value;
Result := InputQuery(ACaption, [APrompt], Values, CloseQueryFunc, AOwner, OKCaption, CancelCaption);
if Result then
Value := Values[0];
end;
//[UIPermission(SecurityAction.LinkDemand, Window = UIPermissionWindow.SafeSubWindows)]
function InputQueryEx(const ACaption, APrompt: string; var Value: string; const AOwner: TComponent = nil;
OKCaption: string = ''; CancelCaption: string = ''): Boolean;
function GetAveCharSize(Canvas: TCanvas): TPoint;
var
I: Integer;
Buffer: array [0 .. 51] of Char;
begin
for I := 0 to 25 do
Buffer[I] := Chr(I + Ord('A'));
for I := 0 to 25 do
Buffer[I + 26] := Chr(I + Ord('a'));
GetTextExtentPoint(Canvas.Handle, Buffer, 52, TSize(Result));
Result.X := Result.X div 52;
end;
var
Form: TForm;
Prompt: TLabel;
Edit: TEdit;
DialogUnits: TPoint;
ButtonTop, ButtonWidth, ButtonHeight: Integer;
begin
Result := False;
if (AOwner <> nil) then
begin
Form := TForm.Create(AOwner);
end
else
begin
Form := TForm.Create(Application);
end;
with Form do
try
Font.Name := MessageDlgDefaultFormFontName;
Font.Size := MessageDlgDefaultFormFontSize;
Canvas.Font := Font;
DialogUnits := GetAveCharSize(Canvas);
BorderStyle := bsDialog;
Caption := ACaption;
ClientWidth := MulDiv(180, DialogUnits.X, 4);
Position := poDefault;
if (AOwner <> nil) and (AOwner is TWinControl) and TWinControl(AOwner).Visible then
begin
Position := poOwnerFormCenter;
end
else
begin
if MessageDlgToMainFormCenter and (Application.MainForm <> nil) and Application.MainForm.Visible then
begin
Position := poMainFormCenter;
end
else
begin
Position := poScreenCenter;
end;
end;
Prompt := TLabel.Create(Form);
with Prompt do
begin
Parent := Form;
Font.Name := MessageDlgDefaultFontName;
Font.Size := MessageDlgDefaultFontSize;
Caption := APrompt;
Left := MulDiv(8, DialogUnits.X, 4);
Top := MulDiv(8, DialogUnits.Y, 8);
Constraints.MaxWidth := MulDiv(164, DialogUnits.X, 4);
WordWrap := True;
end;
Edit := TEdit.Create(Form);
with Edit do
begin
Parent := Form;
Font.Name := MessageDlgDefaultFontName;
Font.Size := MessageDlgDefaultFontSize;
Left := Prompt.Left;
Top := Prompt.Top + Prompt.Height + 5;
Width := MulDiv(164, DialogUnits.X, 4);
MaxLength := 255;
Text := Value;
SelectAll;
end;
ButtonTop := Edit.Top + Edit.Height + 15;
ButtonWidth := MulDiv(50, DialogUnits.X, 4);
ButtonHeight := MulDiv(18, DialogUnits.Y, 8);
with TButton.Create(Form) do
begin
Parent := Form;
Font.Name := MessageDlgDefaultFontName;
Font.Size := MessageDlgDefaultFontSize;
Caption := OKCaption;
if Caption = '' then
begin
Caption := '确定(&O)';
end;
ModalResult := mrOk;
Default := True;
SetBounds(MulDiv(38, DialogUnits.X, 4), ButtonTop, ButtonWidth, ButtonHeight);
end;
with TButton.Create(Form) do
begin
Parent := Form;
Font.Name := MessageDlgDefaultFontName;
Font.Size := MessageDlgDefaultFontSize;
Caption := CancelCaption;
if Caption = '' then
begin
Caption := '取消(&C)';
end;
ModalResult := mrCancel;
Cancel := True;
SetBounds(MulDiv(92, DialogUnits.X, 4), Edit.Top + Edit.Height + 15, ButtonWidth, ButtonHeight);
Form.ClientHeight := Top + Height + 13;
end;
Application.NormalizeAllTopMosts;
try
if ShowModal = mrOk then
begin
Value := Edit.Text;
Result := True;
end;
finally
Application.RestoreTopMosts;
end;
finally
Form.Free;
end;
end;
initialization
InitTaskMessageDialogList;
finalization
UnInitTaskMessageDialogList
end.[/mw_shl_code]
看到这里是不是已经很晕了？
那么再晕点也没关系了吧？
给出调用的代码吧。
好像 MessageBox 都可以做到，那么下面这个呢？
[mw_shl_code=delphi,true]function ShowRewriteQuestion(MessageToShow, Title: String; AOwner: TComponent = nil): Integer;
begin
// Result := MessageDlg(MessageToShow, mtConfirmation, [mbYes, mbYesToAll, mbNo, mbNoToAll], 0);
// exit;
Result := MessageDlgCn.MessageDialog(MessageToShow, Title, mtConfirmation,
['是(&Y)', '全部是', '否(&N)', '全部否', '放弃'], 3, 5, AOwner);
case Result of
1:
begin
Result := mrYes;
end;
2:
begin
Result := mrYesToAll;
end;
3:
begin
Result := mrNo;
end;
4:
begin
Result := mrNoToAll;
end;
else
begin
Result := mrAbort;
end;
end;
end;[/mw_shl_code]
最后一个例子应该够大家使用了吧？
不过我这个单元还有一个好东西呢。
[mw_shl_code=delphi,true]function TFrm.InputQuery_Check_Name(const Values: array of string; QueryForm: TForm): Boolean;
begin
Result := False;
if Length(Values) > 0 then
begin
if Trim(Values[0]) = '' then
begin
CommUI.ShowError('名称不能为空！', QueryForm);
Exit;
end;
if find then //find 您自己替换
begin
CommUI.ShowError('名称不能重复！', QueryForm);
Exit;
end;
end;
Result := True;
end;
if not MessageDlgCN.InputQuery('输入名称','请输入新的名称：',New_Name, Self, InputQuery_Check_Name) then Exit;[/mw_shl_code]
