实现Time Out功能的MessageDlg

最近有个项目需要用到Timeout的MessageBox，在网上查找资料推荐使用未公开API函数MessageBoxTimeout，但是我在win2000下没有调用成功，只有自己动手，参照MessageDlg改造为Timeout功能的 MessageDlg

unit UMessageTimeOutDlg;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;

const
  mrTimeOut = mrYesToAll + 1;  // Message Dialog的Time out 返回值

function MessageTimeOutDlgTimeOutDefaultValue(const Msg: string; DlgType: TMsgDlgType;
  Buttons: TMsgDlgButtons; ATimeOut: Integer; HelpCtx: Longint; ADefValue: Integer): Integer;
function MessageTimeOutDlg(const Msg: string; DlgType: TMsgDlgType;
  Buttons: TMsgDlgButtons; ATimeOut: Integer; HelpCtx: Longint): Integer;
function MessageTimeOutDlgPos(const Msg: string; DlgType: TMsgDlgType;
  Buttons: TMsgDlgButtons; ATimeOut: Integer; HelpCtx: Longint; X, Y: Integer): Integer;
function MessageTimeOutDlgPosHelp(const Msg: string; DlgType: TMsgDlgType;
  Buttons: TMsgDlgButtons; ATimeOut: Integer; HelpCtx: Longint; X, Y: Integer;
  const HelpFileName: string): Integer;

implementation

uses
  Consts, Math;

type
  TMessageTimeOutForm = class(TForm)
  private
    FDlgType: TMsgDlgType;
    FTimer: TTimer;    // 定时器，检查Time Out
    Message: TLabel;
    FTimeOutValue: Integer;
    procedure HelpButtonClick(Sender: TObject);
    procedure OnTimer(Sender: TObject);
    function GetFormCaption(const ADlgType: TMsgDlgType;
      const ATimeOut: Integer): string;
  protected
    procedure CustomKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure WriteToClipBoard(Text: String);
    function GetFormText: String;
  public
    constructor CreateNew(AOwner: TComponent); reintroduce;
    destructor Destroy; override;
  end;

constructor TMessageTimeOutForm.CreateNew(AOwner: TComponent);
var
  NonClientMetrics: TNonClientMetrics;
begin
  inherited CreateNew(AOwner);
  FTimer := TTimer.Create(AOwner);
  FTimer.Interval := 1000;
  FTimer.Enabled := False;
  FTimer.OnTimer := OnTimer;
  NonClientMetrics.cbSize := sizeof(NonClientMetrics);
  if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NonClientMetrics, 0) then
    Font.Handle := CreateFontIndirect(NonClientMetrics.lfMessageFont);
end;

procedure TMessageTimeOutForm.HelpButtonClick(Sender: TObject);
begin
  Application.HelpContext(HelpContext);
end;

procedure TMessageTimeOutForm.CustomKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  if (Shift = [ssCtrl]) and (Key = Word('C')) then
  begin
    Beep;
    WriteToClipBoard(GetFormText);
  end;
end;

procedure TMessageTimeOutForm.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.CreateRes(@SCannotOpenClipboard);
end;

function TMessageTimeOutForm.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;

var
  Captions: array[TMsgDlgType] of Pointer = (@SMsgDlgWarning, @SMsgDlgError,
    @SMsgDlgInformation, @SMsgDlgConfirm, nil);
  IconIDs: array[TMsgDlgType] of PChar = (IDI_EXCLAMATION, IDI_HAND,
    IDI_ASTERISK, IDI_QUESTION, nil);
  ButtonNames: array[TMsgDlgBtn] of string = (
    'Yes', 'No', 'OK', 'Cancel', 'Abort', 'Retry', 'Ignore', 'All', 'NoToAll',
    'YesToAll', 'Help');
  ButtonCaptions: array[TMsgDlgBtn] of Pointer = (
    @SMsgDlgYes, @SMsgDlgNo, @SMsgDlgOK, @SMsgDlgCancel, @SMsgDlgAbort,
    @SMsgDlgRetry, @SMsgDlgIgnore, @SMsgDlgAll, @SMsgDlgNoToAll, @SMsgDlgYesToAll,
    @SMsgDlgHelp);
  ModalResults: array[TMsgDlgBtn] of Integer = (
    mrYes, mrNo, mrOk, mrCancel, mrAbort, mrRetry, mrIgnore, mrAll, mrNoToAll,
    mrYesToAll, 0);
var
  ButtonWidths : array[TMsgDlgBtn] of integer;  // initialized to zero

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;

function CreateMessageTimeOutDialog(const Msg: string; DlgType: TMsgDlgType;
  Buttons: TMsgDlgButtons; const ATimeOut: Integer): 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: TMsgDlgBtn;
  IconID: PChar;
  TextRect: TRect;
  CaptionAddWidth: Integer;
begin
  Result := TMessageTimeOutForm.CreateNew(Application);
  with Result do
  begin
    BiDiMode := Application.BiDiMode;
    BorderStyle := bsDialog;
    Canvas.Font := Font;
    KeyPreview := True;
    OnKeyDown := TMessageTimeOutForm(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(TMsgDlgBtn) to High(TMsgDlgBtn) 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(LoadResString(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];
    // 时间信息显示在Form的Caption中,所以计算多加的Caption宽度
    CaptionAddWidth := ((Length(TMessageTimeOutForm(Result).GetFormCaption(DlgType, ATimeOut)) - 1) div Length(Msg)) * (TextRect.Right - TextRect.Left);
    if CaptionAddWidth < 0 then
      CaptionAddWidth := 0;
    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(TMsgDlgBtn) to High(TMsgDlgBtn) 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 + CaptionAddWidth;
    ClientHeight := IconTextHeight + ButtonHeight + VertSpacing +
      VertMargin * 2;
    Left := (Screen.Width div 2) - (Width div 2);
    Top := (Screen.Height div 2) - (Height div 2);
    TMessageTimeOutForm(Result).FDlgType := DlgType;
    Caption := TMessageTimeOutForm(Result).GetFormCaption(DlgType, ATimeOut);
//    if DlgType <> mtCustom then
//      Caption := LoadResString(Captions[DlgType]) else
//      Caption := Application.Title;
    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;
    TMessageTimeOutForm(Result).Message := TLabel.Create(Result);
    with TMessageTimeOutForm(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 mbOk in Buttons then DefaultButton := mbOk else
      if mbYes in Buttons then DefaultButton := mbYes else
        DefaultButton := mbRetry;
    if mbCancel in Buttons then CancelButton := mbCancel else
      if mbNo in Buttons then CancelButton := mbNo else
        CancelButton := mbOk;
    X := (ClientWidth - ButtonGroupWidth) div 2;
    for B := Low(TMsgDlgBtn) to High(TMsgDlgBtn) do
      if B in Buttons then
        with TButton.Create(Result) do
        begin
          Name := ButtonNames[B];
          Parent := Result;
          Caption := LoadResString(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 = mbHelp then
            OnClick := TMessageTimeOutForm(Result).HelpButtonClick;
        end;
  end;
end;

function MessageTimeOutDlgTimeOutDefaultValue(const Msg: string; DlgType: TMsgDlgType;
  Buttons: TMsgDlgButtons; ATimeOut: Integer; HelpCtx: Longint; ADefValue: Integer): Integer;
begin
  Result := MessageTimeOutDlg(Msg, DlgType, Buttons, ATimeOut, HelpCtx);
  if Result = mrTimeOut then
    Result := ADefValue;
end;

function MessageTimeOutDlg(const Msg: string; DlgType: TMsgDlgType;
  Buttons: TMsgDlgButtons; ATimeOut: Integer; HelpCtx: Longint): Integer;
begin
  Result := MessageTimeOutDlgPosHelp(Msg, DlgType, Buttons, ATimeOut, HelpCtx, -1, -1, '');
end;

function MessageTimeOutDlgPos(const Msg: string; DlgType: TMsgDlgType;
  Buttons: TMsgDlgButtons; ATimeOut: Integer; HelpCtx: Longint; X, Y: Integer): Integer;
begin
  Result := MessageTimeOutDlgPosHelp(Msg, DlgType, Buttons, ATimeOut, HelpCtx, X, Y, '');
end;

function MessageTimeOutDlgPosHelp(const Msg: string; DlgType: TMsgDlgType;
  Buttons: TMsgDlgButtons; ATimeOut: Integer; HelpCtx: Longint; X, Y: Integer;
  const HelpFileName: string): Integer;
begin
  with (CreateMessageTimeOutDialog(Msg, DlgType, Buttons, ATimeOut) as TMessageTimeOutForm) do
    try
      HelpContext := HelpCtx;
      HelpFile := HelpFileName;
      if X >= 0 then Left := X;
      if Y >= 0 then Top := Y;
      if (Y < 0) and (X < 0) then Position := poScreenCenter;
      FTimeOutValue := ATimeOut;
      FTimer.Enabled := True;
      Result := ShowModal;
    finally
      Free;
    end;
end;

destructor TMessageTimeOutForm.Destroy;
begin
  FreeAndNil(FTimer);
  inherited;
end;

// 得到Form的Caption值
function TMessageTimeOutForm.GetFormCaption(const ADlgType: TMsgDlgType; const ATimeOut: Integer): string;
var
  Str: string;
begin
  if ADlgType <> mtCustom then
    Str := LoadResString(Captions[ADlgType])
  else
    Str := Application.Title;
  Result := Format('%s   Left Time: %dSec', [Str, ATimeOut]);
end;

procedure TMessageTimeOutForm.OnTimer(Sender: TObject);
begin
  Dec(FTimeOutValue);
  Caption := GetFormCaption(FDlgType, FTimeOutValue);
  // 如果时间到，将返回mrTimeOut
  if FTimeOutValue < 1 then
  begin
    ModalResult := mrTimeOut;
  end;
end;

end.