可以中文化的自定义对话框单元。
首先，代码原本是 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[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} 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[i] do begin if Default then begin ActiveControl := Btns[i]; 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 {$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[I] is TButton then ButtonCaptions := ButtonCaptions + TButton(Components[I]).Caption + StringOfChar(' ', 3); ButtonCaptions := StringReplace(ButtonCaptions, '&', '', [rfReplaceAll]); 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 [TMsgDlgType] of string = ( SMsgDlgWarning_CN, SMsgDlgError_CN, SMsgDlgInformation_CN, SMsgDlgConfirm_CN, // SMsgDlgStop_CN, '' ); IconIDs: array [TMsgDlgType] of Integer = ( IDI_EXCLAMATION, IDI_HAND, IDI_ASTERISK, IDI_QUESTION, // IDI_HAND, -1 ); {$ELSE} Captions: array [TMsgDlgType] of Pointer = ( @SMsgDlgWarning_CN, @SMsgDlgError_CN, @SMsgDlgInformation_CN, @SMsgDlgConfirm_CN, // @SMsgDlgStop_CN, nil ); IconIDs: array [TMsgDlgType] of PChar = ( IDI_EXCLAMATION, IDI_HAND, IDI_ASTERISK, IDI_QUESTION, // IDI_HAND, nil ); {$IFEND} var ButtonWidths: array of Integer; //[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[i]), -1, TextRect, DT_CALCRECT or DT_LEFT or DT_SINGLELINE or DrawTextBiDiModeFlagsReadingOnly); with TextRect do ButtonWidths[i] := Right - Left + 8; end; if ButtonWidths[i] > ButtonWidth then ButtonWidth := ButtonWidths[i]; 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[i] := TButton.Create(Result); with Btns[i] do begin Name := 'Button_' + IntToStr(j + 1); Parent := Result; Caption := Buttons[i]; ModalResult := j + 1; if j + 1 = DefaultIndex then begin Default := True; ActiveControl := Btns[i]; 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; 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[i] <> nil) and (TaskMessageDialogList.Items[i] is TTaskMessageDialog) then begin AForm := TaskMessageDialogList.Items[i]; 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[i]; 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 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; //[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 ShowMessage(const Msg, MsgTitle: string; const AOwner: TComponent = nil; OKCaption: string = ''); begin ShowMessagePos(Msg, MsgTitle, -1, -1, AOwner, OKCaption); end; //[UIPermission(SecurityAction.LinkDemand, Window = UIPermissionWindow.SafeSubWindows)] procedure ShowMessage(const Msg: string; const AOwner: TComponent = nil; OKCaption: string = ''); begin ShowMessage(Msg, Application.Title, AOwner, OKCaption); end; //[UIPermission(SecurityAction.LinkDemand, Window = UIPermissionWindow.SafeSubWindows)] 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, [FOKCaption], 1, -1, -1, -1, AOwner); end; //[UIPermission(SecurityAction.LinkDemand, Window = UIPermissionWindow.SafeSubWindows)] procedure ShowWarning(const Msg: string; const AOwner: TComponent = nil; OKCaption: string = ''); begin ShowWarning(Msg, Application.Title, AOwner, OKCaption); end; //[UIPermission(SecurityAction.LinkDemand, Window = UIPermissionWindow.SafeSubWindows)] 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, [FOKCaption], 1, -1, -1, -1, AOwner); end; //[UIPermission(SecurityAction.LinkDemand, Window = UIPermissionWindow.SafeSubWindows)] procedure ShowError(const Msg: string; const AOwner: TComponent = nil; OKCaption: string = ''); begin ShowMessage(Msg, Application.Title, AOwner, OKCaption); 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; //[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; 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[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 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; //[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.
看到这里是不是已经很晕了？
那么再晕点也没关系了吧？
给出调用的代码吧。
var /// <summary> /// 使用 MessageBox 对话框模式。否则使用 MessageDlg 对话框模式。 /// </summary> DlgUseMessageBoxAPI: Boolean = True; procedure ShowInformation(MessageToShow, Title: String; AOwner: TComponent = nil); begin // MessageBox 比 自定义对话框兼容性好，但在 6.0 以上系统中不够好看。 if DlgUseMessageBoxAPI then begin if (AOwner <> nil) and (AOwner is TWinControl) then begin MessageBoxW(TWinControl(AOwner).Handle, PWideChar(MessageToShow), PWideChar(Title), MB_ICONINFORMATION or MB_TOPMOST); end else begin MessageBoxW(Application.Handle, PWideChar(MessageToShow), PWideChar(Title), MB_ICONINFORMATION or MB_TOPMOST); end; end else begin MessageDlgCn.ShowMessage(MessageToShow, Title, AOwner); end; end;
好像 MessageBox 都可以做到，那么下面这个呢？
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;
最后一个例子应该够大家使用了吧？
不过我这个单元还有一个好东西呢。
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;
例子也写完了，希望大家帮忙测试下。
大家也可以不用我这个，用 DELPHI 自带的，但是要改 DELPHI 的 CONST.PAS ，才能显示中文，而且也不是很自由。
