Программирование Delphi

Класс позволяет вывести на экран псевдомодальное окно и обновлять сообщения в нем, не прерывая выполнения некоторой длительной операции в основном потоке приложения.

Класс используетмя примерно следующим образом

procedure TSomeForm.SomeActionExecute ;
begin
  try
    MessageForm.Show('Какое-то действие', 'Начало...');
     { ... }
    MessageForm.Text('В процессе...');
     { ... }
    MessageForm.Text('Конец операции...');
     { ... }
  finally
    MessageForm.Close ;
  end ;
end ;

Вызовы Show и Close могут быть вложенными, но должна соблюдаться парность. Это позволяет вызывать одну подпрограмму, использующую класс, из другой подпрограммы, также использующей класс.

При каждом вызове подпрограмм выполняется также Application.ProcessMessages. Существующие на момент первого (самого внешнего) вызова Show формы блокируются тем же механизмом, что и в случае TCustomForm.ShowModal; таким образом, несмотря на обработку сообщений, их кнопки и другие элементы управления остаются недоступными.

Вызов подпрограммы Close следует размещать в секции finally, так как в противном случае окно сообщений может остаться на экране, в то время как другие формы будут недоступны.

unit Splash ;

interface

uses Classes, SysUtils, Forms, Controls, ExtCtrls ;

type
  { Статический класс "окна сообщений" }
  MessageForm = class
  public
    class procedure Show ( const ACaption, AMessage : string ) ;
    class procedure Text ( const AMessage : string ) ;
    class procedure Close ;
  end ;

implementation

var
  { Окно и необходимые ему переменные }
  MsgForm  : TForm ;
  MsgPanel : TPanel ;
  MsgDepth : integer = 0 ;
  ListDisabled : pointer = nil ;

{ Инициализация окна }
procedure CreateMessageForm ;
begin
  MsgForm := TForm.Create ( nil ) ;
  with MsgForm do
  begin
    BorderIcons  := [] ;
    BorderStyle  := bsDialog ;
    Position     := poScreenCenter ;
    ClientHeight := 40 ;
    ClientWidth  := 350 ;
  end ;
  MsgPanel := TPanel.Create ( nil ) ;
  with MsgPanel do
  begin
    Align      := alClient ;
    BevelInner := bvLowered ;
    Parent     := MsgForm ;
  end ;
end ;

{ Запуск окна с сообщением }
class procedure MessageForm.Show ( const ACaption, AMessage : string ) ;
begin
  Text ( AMessage ) ;
  if MsgDepth > 0
    then Inc ( MsgDepth )
  else
    begin
      MsgForm.Caption := ACaption ;
      MsgForm.Show ;
      ListDisabled := DisableTaskWindows ( MsgForm.Handle ) ;
      MsgDepth := 1 ;
      Application.ProcessMessages ;
    end ;
end ;

{ Изменение текста в окне }
class procedure MessageForm.Text ( const AMessage : string ) ;
begin
  MsgPanel.Caption := AMessage ;
  Application.ProcessMessages ;
end ;

{ Закрытие формы }
class procedure MessageForm.Close ;
begin
  if MsgDepth > 1
    then Dec ( MsgDepth )
  else
    begin
      EnableTaskWindows ( ListDisabled ) ;
      ListDisabled := nil ;
      MsgForm.Close ;
      MsgDepth := 0 ;
    end ;
end ;

initialization
  CreateMessageForm ;

finalization
  FreeAndNil ( MsgForm ) ;

end.

Автор: http://www.softwarer.ru