Delphi 7 自定义消息框MessageMyDlg

      在之前的文章《深入了解Delphi 7中的四种消息框》了解到MessageDlg消息框不够强大，而Application.MessageBox、MessageBox实质都是Windows API函数MessageBox，无法根据自己需要所修改。于是，从MessageDlg入手，定制自己所需要的消息框。有时候我们需要在消息框上弹出的按钮不是“确定”、“是”、“否”等等，而需要“继续”、“退出”等按钮文本；有时候我们不需要消息框上还出现了标题栏的关闭按钮，给用户逃避选择的机会，于是去掉标题栏关闭按钮也是根据实际可能需要的。

自定义消息框MessageMyDlg函数原型：

{------------------------------------------------------------------------------- 
  过程名:    MessageMyDlg 
  功能:      自定义的消息框 
  参数:      Msg: string;                  消息内容 
               MsgTitle: string;             消息标题 
               DlgType: TMsgDlgType;         消息显示图标 
               Buttons: TMyMsgDlgButtons;    消息按钮集合 
               ShowClose: Boolean            消息框标题栏关闭按钮的显示 
  返回值:    Integer 
-------------------------------------------------------------------------------} 
function MessageMyDlg( const Msg, MsgTitle:  string; DlgType: TMsgDlgType; Buttons: TMyMsgDlgButtons; ShowClose: Boolean): Integer; 

自定义消息框源码：（展开即可显示）

{*******************************************************} { } { 系统名称 自定义消息框 } { 版权所有 (C) http://blog.csdn.net/akof1314 } { 单元名称 MyMessagebox.pas } { 单元功能 实现比MessageDlg强大的消息框 } { } {*******************************************************} unit MyMessagebox; interface uses Classes, Windows, Controls, Forms, Dialogs, StdCtrls, SysUtils, Graphics, Math, ExtCtrls; type TMyMsgDlgBtn = (mcYes, mcNo, mcOK, mcCancel, mcAbort, mcRetry, mcIgnore, mcAll, mcNoToAll, mcYesToAll, mcHelp, mcForceClose, mcContinute, mcExit); TMyMsgDlgButtons = set of TMyMsgDlgBtn; const mcYesNoCancel = [mcYes, mcNo, mcCancel]; mcYesAllNoAllCancel = [mcYes, mcYesToAll, mcNo, mcNoToAll, mcCancel]; mcOKCancel = [mcOK, mcCancel]; mcAbortRetryIgnore = [mcAbort, mcRetry, mcIgnore]; mcAbortIgnore = [mcAbort, mcIgnore]; const mrForceClose= mrYesToAll + 1; mrContinute = mrForceClose + 1; mrExit = mrContinute + 1; function CreateMyMessageDialog(const Msg,MsgTitle: string; DlgType: TMsgDlgType; Buttons: TMyMsgDlgButtons): TForm; function MessageMyDlg(const Msg,MsgTitle: string; DlgType: TMsgDlgType; Buttons: TMyMsgDlgButtons; ShowClose: Boolean = True): Integer; implementation type TMessageForm = class(TForm) private Message: TLabel; procedure HelpButtonClick(Sender: TObject); protected procedure CustomKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); procedure WriteToClipBoard(Text: String); function GetFormText: String; public constructor CreateNew(AOwner: TComponent); reintroduce; end; procedure Beep; begin MessageBeep(0); end; constructor TMessageForm.CreateNew(AOwner: TComponent); var NonClientMetrics: TNonClientMetrics; begin inherited CreateNew(AOwner); NonClientMetrics.cbSize := sizeof(NonClientMetrics); if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NonClientMetrics, 0) then Font.Handle := CreateFontIndirect(NonClientMetrics.lfMessageFont); end; procedure TMessageForm.HelpButtonClick(Sender: TObject); begin Application.HelpContext(HelpContext); end; procedure TMessageForm.CustomKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin if (Shift = [ssCtrl]) and (Key = Word('C')) then begin Beep; WriteToClipBoard(GetFormText); end; end; procedure TMessageForm.WriteToClipBoard(Text: String); var Data: THandle; DataPtr: Pointer; begin if OpenClipBoard(0) then begin try Data := GlobalAlloc(GMEM_MOVEABLE+GMEM_DDESHARE, Length(Text) + 1); try DataPtr := GlobalLock(Data); try Move(PChar(Text)^, DataPtr^, Length(Text) + 1); EmptyClipBoard; SetClipboardData(CF_TEXT, Data); finally GlobalUnlock(Data); end; except GlobalFree(Data); raise; end; finally CloseClipBoard; end; end else raise Exception.Create('Cannot open clipboard'); 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; 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 IconIDs: array[TMsgDlgType] of PChar = (IDI_EXCLAMATION, IDI_HAND, IDI_ASTERISK, IDI_QUESTION, nil); ButtonNames: array[TMyMsgDlgBtn] of string = ( 'Yes', 'No', 'OK', 'Cancel', 'Abort', 'Retry', 'Ignore', 'All', 'NoToAll', 'YesToAll', 'Help', 'ForceClose', 'Continute', 'Exit'); ButtonCaptions: array[TMyMsgDlgBtn] of string = ( '是(&Y)', '否(&N)', '确定', '取消', '终止(&A)', '重试(&R)', '忽略(&I)', '全部(&A)', '全否(&O)', '全是(&A)', '帮助(&H)', '强制关闭', '继续', '退出'); ModalResults: array[TMyMsgDlgBtn] of Integer = ( mrYes, mrNo, mrOk, mrCancel, mrAbort, mrRetry, mrIgnore, mrAll, mrNoToAll, mrYesToAll, 0, mrForceClose, mrContinute, mrExit); var ButtonWidths : array[TMyMsgDlgBtn] of integer; function CreateMyMessageDialog(const Msg,MsgTitle: string; DlgType: TMsgDlgType; Buttons: TMyMsgDlgButtons): TForm; const mcHorzMargin = 8; mcVertMargin = 8; mcHorzSpacing = 10; mcVertSpacing = 10; mcButtonWidth = 50; mcButtonHeight = 14; mcButtonSpacing = 4; var DialogUnits: TPoint; HorzMargin, VertMargin, HorzSpacing, VertSpacing, ButtonWidth, ButtonHeight, ButtonSpacing, ButtonCount, ButtonGroupWidth, IconTextWidth, IconTextHeight, X, ALeft: Integer; B, DefaultButton, CancelButton: TMyMsgDlgBtn; IconID: PChar; TextRect: TRect; begin Result := TMessageForm.CreateNew(Application); with Result do begin BiDiMode := Application.BiDiMode; BorderStyle := bsDialog; Canvas.Font := Font; KeyPreview := True; OnKeyDown := TMessageForm(Result).CustomKeyDown; 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); for B := Low(TMyMsgDlgBtn) to High(TMyMsgDlgBtn) do begin if B in Buttons then begin if ButtonWidths[B] = 0 then begin TextRect := Rect(0,0,0,0); Windows.DrawText( canvas.handle, PChar(ButtonCaptions[B]), -1, TextRect, DT_CALCRECT or DT_LEFT or DT_SINGLELINE or DrawTextBiDiModeFlagsReadingOnly); with TextRect do ButtonWidths[B] := Right - Left + 8; end; if ButtonWidths[B] > ButtonWidth then ButtonWidth := ButtonWidths[B]; 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, PChar(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 IconID <> nil then begin Inc(IconTextWidth, 32 + HorzSpacing); if IconTextHeight < 32 then IconTextHeight := 32; end; ButtonCount := 0; for B := Low(TMyMsgDlgBtn) to High(TMyMsgDlgBtn) do if B in Buttons then Inc(ButtonCount); 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); Caption := MsgTitle ; if IconID <> nil then 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; if mcOk in Buttons then DefaultButton := mcOk else if mcYes in Buttons then DefaultButton := mcYes else DefaultButton := mcRetry; if mcCancel in Buttons then CancelButton := mcCancel else if mcNo in Buttons then CancelButton := mcNo else CancelButton := mcOk; X := (ClientWidth - ButtonGroupWidth) div 2; for B := Low(TMyMsgDlgBtn) to High(TMyMsgDlgBtn) do if B in Buttons then with TButton.Create(Result) do begin Name := ButtonNames[B]; Parent := Result; Caption := ButtonCaptions[B]; ModalResult := ModalResults[B]; if B = DefaultButton then Default := True; if B = CancelButton then Cancel := True; SetBounds(X, IconTextHeight + VertMargin + VertSpacing, ButtonWidth, ButtonHeight); Inc(X, ButtonWidth + ButtonSpacing); if B = mcHelp then OnClick := TMessageForm(Result).HelpButtonClick; end; end; end; {------------------------------------------------------------------------------- 过程名: MessageMyDlg 功能: 自定义的消息框 参数: Msg: string; 消息内容 MsgTitle: string; 消息标题 DlgType: TMsgDlgType; 消息显示图标 Buttons: TMyMsgDlgButtons; 消息按钮集合 ShowClose: Boolean 消息框标题栏关闭按钮的显示 返回值: Integer -------------------------------------------------------------------------------} function MessageMyDlg(const Msg,MsgTitle: string; DlgType: TMsgDlgType; Buttons: TMyMsgDlgButtons; ShowClose: Boolean): Integer; begin with CreateMyMessageDialog(Msg, MsgTitle, DlgType, Buttons) do try if ShowClose then BorderIcons := BorderIcons + [biSystemMenu] else BorderIcons := BorderIcons - [biSystemMenu]; Position := poScreenCenter; Result := ShowModal; finally Free; end; end; end.

使用示例：

unit Unit1; 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
  Dialogs, StdCtrls, XPMan; 
 
type 
  TForm1 =  class(TForm) 
    btn1: TButton; 
    xpmnfst1: TXPManifest; 
     procedure btn1Click(Sender: TObject); 
   private 
     { Private declarations } 
   public 
     { Public declarations } 
   end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
uses MyMessagebox; 
 
{$R *.dfm} 
 
procedure TForm1.btn1Click(Sender: TObject); 
begin 
  MessageDlg( '这是MessageDlg弹出消息框',mtError,mbYesNoCancel, 0);      //全英文 
  MessageMyDlg( '这是MessageMyDlg弹出消息框', '自定义标题',mtError,mcYesNoCancel,False);  //全中文 
 
   case MessageMyDlg( '您的操作还未完成？' + # 13# 13 +  '请点击“继续”按钮继续完成操作，如果您想终止操作，' + # 13 +  '请点击“退出”按钮。',  '提示', mtInformation,  [mcContinute, mcExit])  of 
    mrContinute: ShowMessage( '按了继续按钮'); 
    mrExit: ShowMessage( '按了退出按钮'); 
   else ShowMessage( '按了标题栏的关闭按钮'); 
   end; 
end; 
 
end. 
 

结果如下图所示：