可以中文化的自定义对话框单元。MessageDlgCN
首先，代码原本是 DELPHI7的，而且不是我写的。原作者大概是我公司的一个高管，要么就是网络上的高手。
我修改的是 XE2 版本，自然支持 Unicode ，支持 TaskDialog。
整个单元都给大家，请不要使用复制代码按钮
/// <summary>
/// 中文版对话框单元。
/// </summary>
unit MessageDlgCN;
{ -------------------------------------------------------------------------------
单元: MessageDlgCN.pas
说明: 提供了Message Dialog 函数
****************************************************************************
注意：所有的按钮 index 都是从 1 开始的。默认返回 2。
****************************************************************************
修改：爱吃猪头肉
------------------------------------------------------------------------------- }
interface
uses
System.SysUtils, Winapi.Windows, Messages, Classes, Consts, Dialogs, Forms,
System.Generics.Collections,
Winapi.MultiMon, System.HelpIntfs, Vcl.Themes,
Winapi.CommCtrl,
Controls, Graphics, StdCtrls, ExtCtrls, ShellApi;
// type
// TMsgDlgTypeEx = (mtWarning, mtError, mtInformation, mtConfirmation, mtStop, mtCustom);
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;
//CancelIndex 在 6.0 以上系统中没有使用。
// Create Message Dialog
function CreateMessageDialog(const Msg: string; const DlgType: TMsgDlgType; const Buttons: array of string;
const DefaultIndex, CancelIndex, HelpIndex: Integer; const AOwner: TComponent = nil): TForm;
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;
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;
function MessageDlgHelp(const Msg, MsgTitle: string; const DlgType: TMsgDlgType; const Buttons: array of string;
const DefaultIndex, CancelIndex, HelpIndex: Integer; HelpCtx: LongInt; const HelpFileName: string;
const AOwner: TComponent = nil): Integer;
function MessageDialog(const Msg, MsgTitle: string; const DlgType: TMsgDlgType; const Buttons: array of string;
const DefaultIndex, CancelIndex: Integer; const AOwner: TComponent = nil): Integer; overload;
function MessageDialog(const Msg, MsgTitle: string; const DlgType: TMsgDlgType; const Buttons: array of string;
const AOwner: TComponent = nil): Integer; overload;
function QuestionDialog(const Msg, MsgTitle: string; const AOwner: TComponent = nil; YesCaption: string = '';
NoCaption: string = ''): Boolean;
function QuestionCancelDialog(const Msg, MsgTitle: string; const AOwner: TComponent = nil; YesCaption: string = '';
NoCaption: string = ''; CancelCaption: string = ''): Integer;
procedure ShowMessagePos(const Msg, MsgTitle: string; const X, Y: Integer; const AOwner: TComponent = nil;
OKCaption: string = '');
procedure ShowMessage(const Msg, MsgTitle: string; const AOwner: TComponent = nil; OKCaption: string = ''); overload;
procedure ShowMessage(const Msg: string; const AOwner: TComponent = nil; OKCaption: string = ''); overload;
procedure ShowWarning(const Msg, MsgTitle: string; const AOwner: TComponent = nil; OKCaption: string = ''); overload;
procedure ShowWarning(const Msg: string; const AOwner: TComponent = nil; OKCaption: string = ''); overload;
procedure ShowError(const Msg, MsgTitle: string; const AOwner: TComponent = nil; OKCaption: string = ''); overload;
procedure ShowError(const Msg: string; const AOwner: TComponent = nil; OKCaption: string = ''); overload;
procedure ShowException(E: Exception; const AOwner: TComponent = nil; OKCaption: string = ''); overload;
procedure ShowException(E: string; const AOwner: TComponent = nil; OKCaption: string = ''); overload;
function InputBox(const ACaption, APrompt, ADefault: string; const AOwner: TComponent = nil;
CloseQueryFunc: TMessageDlgCNInputCloseQueryFunc = nil;
OKCaption: string = ''; CancelCaption: string = ''): string;
function InputQuery(const ACaption, APrompt: string; var Value: string; const AOwner: TComponent = nil;
CloseQueryFunc: TMessageDlgCNInputCloseQueryFunc = nil;
OKCaption: string = ''; CancelCaption: string = ''): Boolean; overload;
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; overload;
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; overload;
function InputQueryPosHelp(const ACaption: string; const APrompts: array of string; var AValues: array of string;
const X, Y: Integer; HelpCtx: LongInt; const HelpFileName: string; CloseQueryFunc: TMessageDlgCNInputCloseQueryFunc = nil;
const AOwner: TComponent = nil; OKCaption: string = ''; CancelCaption: string = ''): Boolean; overload;
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; overload;
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; overload;
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; overload;
function InputQueryEx(const ACaption, APrompt: string; var Value: string; const AOwner: TComponent = nil;
OKCaption: string = ''; CancelCaption: string = ''): Boolean;
var
// 字体设置在 6.0 以上系统中没有使用。
MessageDlgDefaultFontName: string = '宋体';
MessageDlgDefaultFontSize: Integer = 9;
MessageDlgDefaultFormFontName: string = '宋体';
MessageDlgDefaultFormFontSize: Integer = 9;
/// <summary>
/// 将对话框显示在主窗体的中心，前提是没有 AOwner 。
/// </summary>
MessageDlgToMainFormCenter: Boolean = False;
/// <summary>
/// 在 4.x 5.x 系统中，对话框窗体标题使用字体。
/// </summary>
MessageDlgFormUseDefaultFont: Boolean = False;
/// <summary>
/// 对话框有 MessageBox 样式的 关闭按钮。
/// </summary>
MessageDlgUseMessageBoxSysCMDColse: Boolean = True;
/// <summary>
/// 对话框显示时发出对应类型的 Beep 。
/// </summary>
MessageDlgUseMessageBeep: Boolean = True;
/// <summary>
/// 对话框有 MessageBox 样式的 关闭按钮。
/// </summary>
MessageDlgInputQueryDisableSysCMDClose: Boolean = False;
//没办法代码是抄来的。虽然有改动，但还是得尊重下原作者。
//resourcestring
const
Coderinfo = 'MsessageDlgCn By 爱吃猪头肉';
//请不要删除，请确保本代码存在，否则请不要使用，resourcestring 和 const 都可以。
//EMB 官方，如果您用了，这是可以删除的。
implementation
uses Math;
var
TaskActiveWindow: HWnd = 0;
TaskFirstWindow: HWnd = 0;
TaskFirstTopMost: HWnd = 0;
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 := Chr(I + Ord('A'));
for I := 0 to 25 do
Buffer := 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 of Char;
begin
for I := 0 to 25 do
Buffer := Chr(I + Ord('A'));
for I := 0 to 25 do
Buffer := Chr(I + Ord('a'));
GetTextExtentPoint(Canvas.Handle, Buffer, 52, TSize(Result));
Result.X := Result.X div 52;
end;
{$IFEND}
type
TMessageForm = class(TForm)
private
DlgType: TMsgDlgType;
Message: TLabel;
Btns: array of TButton;
procedure HelpButtonClick(Sender: TObject);
procedure ButtonClick(AOwner: TObject);
protected
procedure CustomKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure WriteToClipBoard(Text: string);
function GetFormText: string;
procedure DoShow; override;
procedure DoClose(var Action: TCloseAction); override;
procedure WMSysCommand(var Message: TWMSysCommand); message WM_SYSCOMMAND;
procedure CreateParams(var Params: TCreateParams); override;
public
isCanSysCDMClose: Boolean;
IsSysCDMClose: Boolean;
constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;
end;
constructor TMessageForm.CreateNew(AOwner: TComponent; Dummy: Integer = 0);
begin
inherited CreateNew(AOwner, Dummy);
Font.Assign(Screen.MessageFont);
isCanSysCDMClose := False;
IsSysCDMClose := True;
end;
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 = ) 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
{$IF DEFINED(CLR)}
Buffer := PlatformBytesOf(Text);
SetLength(Buffer, Length(Buffer) + Marshal.SystemDefaultCharSize);
Data := GlobalAlloc(GMEM_MOVEABLE + GMEM_DDESHARE, Length(Buffer));
{$ELSE}
Data := GlobalAlloc(GMEM_MOVEABLE + GMEM_DDESHARE, ByteLength(Text) + SizeOf(Char));
{$IFEND}
try
DataPtr := GlobalLock(Data);
try
{$IF DEFINED(CLR)}
Marshal.Copy(Buffer, 0, DataPtr, Length(Buffer));
{$ELSE}
Move(PChar(Text)^, DataPtr^, ByteLength(Text) + SizeOf(Char));
EmptyClipBoard;
SetClipboardData(CF_UNICODETEXT, Data);
{$IFEND}
finally
GlobalUnlock(Data);
end;
{$IF DEFINED(CLR)}
EmptyClipBoard;
if Marshal.SystemDefaultCharSize > 1 then
SetClipboardData(CF_UNICODETEXT, Data)
else
SetClipboardData(CF_TEXT, Data)
{$IFEND}
except
GlobalFree(Data);
raise;
end;
finally
CloseClipBoard;
end;
end
else
raise Exception.CreateRes({$IFNDEF CLR}@{$ENDIF}SCannotOpenClipboard);
end;
function TMessageForm.GetFormText: string;
var
DividerLine, ButtonCaptions: string;
I: integer;
begin
DividerLine := StringOfChar('-', 27) + sLineBreak;
for I := 0 to ComponentCount - 1 do
if Components is TButton then
ButtonCaptions := ButtonCaptions + TButton(Components).Caption + StringOfChar(' ', 3);
ButtonCaptions := StringReplace(ButtonCaptions, '&', '', );
Result := Format('%s%s%s%s%s%s%s%s%s%s', [DividerLine, Caption, sLineBreak, DividerLine, message.Caption, sLineBreak,
DividerLine, ButtonCaptions, sLineBreak, DividerLine]);
end;
resourcestring
SMsgDlgStop = 'Stop';
SMsgDlgStop_CN = '停止';
SMsgDlgWarning_CN = '警告';
SMsgDlgError_CN = '错误';
SMsgDlgInformation_CN = '信息';
SMsgDlgConfirm_CN = '确认';
var
{$IF DEFINED(CLR)}
Captions: array of string = (
SMsgDlgWarning_CN,
SMsgDlgError_CN,
SMsgDlgInformation_CN,
SMsgDlgConfirm_CN,
// SMsgDlgStop_CN,
''
);
IconIDs: array of Integer = (
IDI_EXCLAMATION,
IDI_HAND,
IDI_ASTERISK,
IDI_QUESTION,
// IDI_HAND,
-1
);
{$ELSE}
Captions: array of Pointer = (
@SMsgDlgWarning_CN,
@SMsgDlgError_CN,
@SMsgDlgInformation_CN,
@SMsgDlgConfirm_CN,
// @SMsgDlgStop_CN,
nil
);
IconIDs: array of PChar = (
IDI_EXCLAMATION,
IDI_HAND,
IDI_ASTERISK,
IDI_QUESTION,
// IDI_HAND,
nil
);
{$IFEND}
var
ButtonWidths: array of Integer;
//
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 := ;
// 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 = 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;
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
else
Caption := Application.Title;
if DlgType <> mtCustom then
{$ELSE}
Caption := LoadResString(Captions)
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;
//
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;
TTaskMessageDialog = class(TCustomTaskDialog)
private
FHelpFile: string;
FParentWnd: HWND;
FPosition: TPoint;
FCanceled: Boolean;
FCancelIndex: Integer;
FButtonClicked: Boolean;
FWndProcCB: Pointer;
FOldWndProcCB: Pointer;
strict protected
procedure DoOnButtonClicked(AModalResult: Integer; var CanClose: Boolean); override;
procedure DoOnDialogCreated; override;
procedure DoOnHelp; override;
protected
function CallbackProc(hwnd: HWND; msg: UINT; wParam: WPARAM;
lParam: LPARAM; lpRefData: LONG_PTR): HResult; override;
public
AOwner: TComponent;
function Execute(ParentWnd: HWND): Boolean; overload; override;
property HelpFile: string read FHelpFile write FHelpFile;
property Position: TPoint read FPosition write FPosition;
property Canceled: Boolean read FCanceled;
end;
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.Enabled) and (IsWindowVisible(hwnd))then
begin
AForm.Buttons.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 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
{$ELSE}
Caption := LoadResString(Captions)
{$IFEND}
else
Caption := Application.Title;
if MsgTitle <> '' then
begin
Caption := MsgTitle;
end;
CommonButtons := [];
if Application.UseRightToLeftReading then
Flags := Flags + ;
HelpContext := HelpCtx;
HelpFile := HelpFileName;
MainIcon := IconMap;
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;
//
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;
//
function MessageDlgHelp(const Msg, MsgTitle: string; const DlgType: TMsgDlgType; const Buttons: array of string;
const DefaultIndex, CancelIndex, HelpIndex: Integer; HelpCtx: LongInt; const HelpFileName: string;
const AOwner: TComponent = nil): Integer;
begin
Result := ShowMessageDlgPosHelp(Msg, MsgTitle, DlgType, Buttons, DefaultIndex, CancelIndex, HelpIndex, HelpCtx,
HelpFileName, -1, -1, AOwner);
end;
//
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;
//
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;
//
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;
//
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, , 1, 2, AOwner) = 1;
end;
//
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, , 1, 3, AOwner);
case Result of
1:
begin
Result := mrYes;
end;
2:
begin
Result := mrNo;
end;
else
begin
Result := mrCancel;
end;
end;
end;
//
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, , 1, -1, X, Y, AOwner);
end;
//
procedure ShowMessage(const Msg, MsgTitle: string; const AOwner: TComponent = nil; OKCaption: string = '');
begin
ShowMessagePos(Msg, MsgTitle, -1, -1, AOwner, OKCaption);
end;
//
procedure ShowMessage(const Msg: string; const AOwner: TComponent = nil; OKCaption: string = '');
begin
ShowMessage(Msg, Application.Title, AOwner, OKCaption);
end;
//
procedure ShowWarning(const Msg, MsgTitle: string; const AOwner: TComponent = nil; OKCaption: string = '');
var
FOKCaption: string;
begin
FOKCaption := OKCaption;
if FOKCaption = '' then
begin
FOKCaption := '确定(&O)';
end;
MessageDlgPos(Msg, MsgTitle, mtWarning, , 1, -1, -1, -1, AOwner);
end;
//
procedure ShowWarning(const Msg: string; const AOwner: TComponent = nil; OKCaption: string = '');
begin
ShowWarning(Msg, Application.Title, AOwner, OKCaption);
end;
//
procedure ShowError(const Msg, MsgTitle: string; const AOwner: TComponent = nil; OKCaption: string = '');
var
FOKCaption: string;
begin
FOKCaption := OKCaption;
if FOKCaption = '' then
begin
FOKCaption := '确定(&O)';
end;
MessageDlgPos(Msg, MsgTitle, mtError, , 1, -1, -1, -1, AOwner);
end;
//
procedure ShowError(const Msg: string; const AOwner: TComponent = nil; OKCaption: string = '');
begin
ShowMessage(Msg, Application.Title, AOwner, OKCaption);
end;
//
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;
//
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, , 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 InputQueryPosHelp(const ACaption: string; const APrompts: array of string; var AValues: array of string;
const X, Y: Integer; HelpCtx: LongInt; const HelpFileName: string; CloseQueryFunc: TMessageDlgCNInputCloseQueryFunc = nil;
const AOwner: TComponent = nil; OKCaption: string = ''; CancelCaption: string = ''): Boolean;
var
I, J: Integer;
Form: TInputQueryForm;
Prompt: TLabel;
Edit: TEdit;
DialogUnits: TPoint;
PromptCount, CurPrompt: Integer;
MaxPromptWidth: Integer;
ButtonTop, ButtonWidth, ButtonHeight: Integer;
function GetPromptCaption(const ACaption: string): string;
begin
if (Length(ACaption) > 1) and (ACaption < #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);
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 < #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;
if Control is TEdit then
begin
LValues := 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);
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);
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;
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 is TEdit then
begin
Edit := TEdit(Controls);
AValues := Edit.Text;
Inc(J);
end;
Result := True;
end;
finally
Application.RestoreTopMosts;
end;
finally
Form.Free;
end;
end;
end;
//
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;
//
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;
//
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;
//
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;
//
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;
//
function InputQuery(const ACaption, APrompt: string; var Value: string; const AOwner: TComponent = nil;
CloseQueryFunc: TMessageDlgCNInputCloseQueryFunc = nil;
OKCaption: string = ''; CancelCaption: string = ''): Boolean;
var
Values: array of string;
begin
Values := Value;
Result := InputQuery(ACaption, , Values, CloseQueryFunc, AOwner, OKCaption, CancelCaption);
if Result then
Value := Values;
end;
//
function InputBox(const ACaption, APrompt, ADefault: string; const AOwner: TComponent = nil;
CloseQueryFunc: TMessageDlgCNInputCloseQueryFunc = nil;
OKCaption: string = ''; CancelCaption: string = ''): string;
begin
Result := ADefault;
InputQuery(ACaption, APrompt, Result, AOwner, CloseQueryFunc, OKCaption, CancelCaption);
end;
//
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 of Char;
begin
for I := 0 to 25 do
Buffer := Chr(I + Ord('A'));
for I := 0 to 25 do
Buffer := 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.
看到这里是不是已经很晕了？
那么再晕点也没关系了吧？
给出调用的代码吧。
**** Hidden Message *****
好像 MessageBox 都可以做到，那么下面这个呢？
function ShowRewriteQuestion(MessageToShow, Title: String; AOwner: TComponent = nil): Integer;
begin
// Result := MessageDlg(MessageToShow, mtConfirmation, , 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;
最后一个例子应该够大家使用了吧？
不过我这个单元还有一个好东西呢。
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) = '' 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;
大家也可以不用我这个，用 DELPHI 自带的，但是要改 DELPHI 的 CONST.PAS ，才能显示中文，而且也不是很自由。
面对 FMX 如果您只想显示系统对话框，那么修改 FMX.Consts 是最简单有效的办法。
如果您打算显示自定义对话框。
那么可以使用 FMX.DialogHelper 里的 TDialogHelper 对象。但是 按钮依然是指定的哪几种。
如果想显示自定义的文字按钮对话框。
可以试试，下面的开源项目。
**** Hidden Message *****
其中的 DEMO Test CHS TDialogBuilder 支持按钮文字自定义。
特别声明
禁止 win2003 (楚凡) QQ635887 使用本人修改的内容
禁止 qiuyan81 (苦恋树) QQ46494153 使用本人修改的内容。
禁止 gfuchaoQQ82715485 使用本人修改的内容。
禁止 supersk QQ未知，使用本人修改的内容。
禁止 yesin119 QQ未知，使用本人修改的内容。
禁止 263378440 使用本人修改的内容。
禁止 yanse 使用本人修改的内容。
禁止 ltshdp、ltsh、(禁卫军) 使用本人修改的内容
禁止 www123 使用本人修改的内容
禁止 eliyh 使用本人修改的内容
禁止 zwjchinazwj (蒲石) 使用本人修改的内容
禁止 zhipu QQ:2001972使用本人修改的内容
禁止 jackalan (nVicen) QQ:875271757使用本人修改的内容
禁止 kencc2016 (小宇) QQ:2601759381 使用本人修改的内容
以上用户名均为 2CCC 的
禁止 QQ:191909837 使用本人修改的内容
禁止 QQ 81604691 使用本人修改的版内容
禁止 QQ:122742470(菜根) 使用本人修改或建立的代码或工具。
当然，如果你们脸皮比较厚，就偷偷的用吧。
凡是想要骂我的，都可以偷偷的用，反正我是控制不了。
只要你们不鄙视自己就行。 感谢分享，先收藏了！:lol 谢谢................. 难得查看地一一下代码 我来了。。。 GGGGGGGGGGGGGGGGG 厉害，但是看不懂！菜鸟一枚 感谢！！！！！！！！！！！！！！！！！！！ 学习下学习下学习下 感谢分享，收藏了！
页:
[1]
2