ventana de mensaje por un tiempo determinado

[delphi.com.ar]

100% Api, como hablamos fuera de los foros:

Código Delphi [-]
procedure WaitDialog(const AText: PChar; ATimeOut: Cardinal = 5000);
var
  wcClass: Windows.TWndClass;
  hHandle: HWND;
  Msg: TMsg;
  hCanvas: HDC;
  hFnt, hOldFont: HFONT;
  hTimer: UINT;
  R: TRect;
  L: Cardinal;
begin
  L := StrLen(AText);
  ZeroMemory(@wcClass, SizeOf(TWndClass));
  with wcClass do
  begin
    Style := CS_CLASSDC;
    hInstance := SysInit.HInstance;
    lpszClassName := 'WaitDlg';
    lpfnWndProc := @DefWindowProc;
    hbrBackGround := CTLCOLOR_MSGBOX+1;
  end;
  Windows.RegisterClass(wcClass);

  { Crea la ventana }
  hHandle := Windows.CreateWindowEx(WS_EX_TOOLWINDOW, wcClass.lpszClassName,
               nil, WS_POPUP or WS_BORDER, 0, 0, 100, 100, 0, 0,
               wcClass.hInstance, nil);

  if hHandle = 0 then
    RaiseLastOSError
  else
    try
      hCanvas := GetWindowDc(hHandle);
      { Crea la fuente }
      hFnt := CreateFont(-1, 0, 0, 0, 400, 0, 0, 0, DEFAULT_CHARSET,
                     OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY,
                     DEFAULT_PITCH + FF_DONTCARE, 'MS Sans Serif');
      hOldFont := SelectObject(hCanvas, hFnt);
      try
        { Calcula el tamaño del texto }
        SetRectEmpty(R);
        R.Right := GetSystemMetrics(SM_CXSCREEN);
        DrawText(hCanvas, AText, L, R, DT_CALCRECT + DT_CENTER + DT_WORDBREAK);

        { Para que no escriba sobre el Borde }
        InflateRect(R, 2, 2);

        SetBkMode(hCanvas, TRANSPARENT);

        SetWindowPos(hHandle, 0,
                     (GetSystemMetrics(SM_CXSCREEN) - R.Right) div 2,
                     (GetSystemMetrics(SM_CYSCREEN) - R.Bottom) div 2,
                     R.Right, R.Bottom, 0);

        { Crea el timer que disparará el evento WM_TIMER cada ATimeOut milisegundos }
        hTimer := SetTimer(hHandle, 1, ATimeOut, nil);
        try
          ShowWindow(hHandle, SW_SHOW);
          while GetMessage(Msg, hHandle, 0, 0) do
          begin
            TranslateMessage(Msg);
            case Msg.message of
              WM_PAINT:
              begin
                GetClientRect(Msg.hwnd, R);
                OffsetRect(R, 1, 1);
                DrawText(hCanvas, PChar(AText), Length(AText), R, DT_WORDBREAK + DT_CENTER + DT_NOCLIP);
                DispatchMessage(Msg);
              end;
              WM_CLOSE, WM_DESTROY, WM_KEYDOWN, WM_TIMER, WM_RBUTTONDOWN:
              begin
                KillTimer(hHandle, hTimer);
                hTimer := 0;
                Break; {WM_QUIT}
              end;
              else
                DispatchMessage(Msg);
              end;
          end;
        finally
          if hTimer <> 0 then
            KillTimer(hHandle, hTimer);
        end;
      finally
        SelectObject(hCanvas, hOldFont);
        DeleteObject(hFnt);
      end;
    finally
      DestroyWindow(hHandle);
    end;
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
  WaitDialog(PChar(Memo1.Lines.Text));
end;