Проблемы TPersistent и несколько полезных советов

Иногда можно обнаружить, что Delphi присваивает значение свойству компонента, используя метод read, а не write. Неосторожность при написании таких методов может привести к большим неприятностям! Джон и Эд поделятся своими соображениями о том, как избежать подобных бед и получить максимум пользы от работы с Delphi.

Свойства объектов Delphi просты и функциональны: они похожи на переменные, но весь процесс их чтения и записи находится под вашим контролем. Вы можете разрешить прямое считывание свойств, словно это обычные переменные, или же указать метод read, вызываемый при каждом чтении данного свойства. Можно разрешить прямую запись свойств или же указать метод write, который вызывается при задании значения этого свойства. 

Верно? 

Нет, неверно. 

Читаем, чтобы записывать? 

Разумеется, в большинстве случаев это несущественно — свойство все равно загружается и получает в режиме выполнения то же значение, что было задано в режиме конструирования. Тем не менее в некоторых ситуациях это все же может отразиться на вашей программе. 

Во-первых, метод read никогда не должен возвращать Nil. Мысль о том, чтобы отложить создание private-объекта до того момента, когда метод write предоставит копируемое значение, выглядит вполне разумно. К сожалению, код загрузки компонентов Delphi недостаточно умен — он просто не замечает, что у него нет объекта TPersistent, которому нужно дать команду загрузиться из потока. Поэтому если метод read возвращает Nil, то при загрузке компонента происходит GPF (General Protection Fault, ошибка защиты). Кстати, именно это обстоятельство привлекло мое внимание, хотя признаюсь, что я не сразу разобрался в сути происходящего. 

Во-вторых, не стоит использовать метод write для того, чтобы извлекать информацию из private-объекта свойства и сохранять ее в других runtime-полях вашего компонента. Метод write вызывается при непосредственном задании свойства в режиме конструирования или выполнения, но не при косвенном задании этого свойства, происходящем в момент загрузки компонента. Если воспользоваться методом write для обновления внутреннего состояния компонента, загрузка будет работать неверно. 

Разумные решения 

В случае GPF при полной загрузке обеспечить «совместимость с будущими версиями» оказывается несложно. Нам известно, что при загрузке объекта TPersistent из потока Delphi вызывает его метод read. Следовательно, как показано в листинге 9.1, конструктор Create объекта должен создать объект соответствующего типа и присвоить его private-полю данного свойства. Это выглядит несколько расточительным, если свойство не всегда должно задавать ся или сохраняться, но пара сотен лишних байт на диске или дополнитель ных команд кода Create несущественны для современных Pentium с 16 или 32 Мб памяти. 

{interface}
type DemoComponent =
  class(TComponent)

    private
      fGlyph:        TBitmap;
      fGlyphWritten: boolean;

      procedure SetGlyph(Glyph: TBitmap); 
      { снаружи не видно }

    protected
      constructor Create(Owner: TComponent); 
      override;
      procedure Loaded; override;

    public

    published
      property Glyph: TBitmap read fGlyph 
      write SetGlyph;

  end;

{implementation}

constructor DemoComponent.Create(Owner: 
TComponent);
begin
  inherited Create(Owner);
  fGlyph := TBitmap.Create;
  { Обязательно создайте для данного 
  поля пустой объект }
end;

procedure DemoComponent.SetGlyph(Glyph: TBitmap);
begin
  if fGlyph <> Glyph then    
  { fGlyph = Glyph, когда SetGlyph }
    begin                    
    { вызывается процедурой Loaded }
    fGlyph.Free;    
    { Assign может закончиться неудачно, }
{ если целевое поле не пусто: }
    fGlyph := TBitmap.Create; 
    { Free/Create/Assign намного надежнее }
    fGlyph.Assign(Glyph);
    end;
  { Извлекаем все необходимые данные и 
  устанавливаем флаг PropertyWritten}
  fGlyphWritten := True;
end;

procedure DemoComponent.Loaded;
begin
  inherited Loaded; { Не забывайте сделать это! }
  if (not fGlyphWritten) and (not fGlyph.Empty) 
  then
    SetGlyph(fGlyph); { Извлекаем все 
    необходимые данные }
end;

С частичной загрузкой дело обстоит несколько сложнее. К счастью, компоненты Delphi содержат метод Loaded, который можно переопределить для выполнения любых завершающих действий. С помощью метода Loaded и незначительных изменений в программе проблему частичной загрузки удается решить. 

Первое, что необходимо сделать, — добавить флаг fPropertyWritten для каждого свойства TPersistent, которое может сохраняться (см. листинг 9.1). При создании объекта флагу присваивается значение False, и лишь в методе write оно может измениться на True.

Затем следует переопределить (с помощью ключевого слова override) метод Loaded вашего компонента и добавить в него строку примерно такого вида: 

if not fPropertyWritten then
SetProperty(fProperty) 

чтобы метод write вызывался из Loaded в том (и только в том!) случае, если он не был вызван при загрузке компонента. 

Наконец, представьте себе, что произойдет при попытке присвоить свойству типа TPersistent тот же самый объект, который в нем уже содержится. Вы уничтожаете имеющееся значение (Free), создаете новый «пустой» экземпляр (Create) и затем присваиваете (Assign) ему новое значение, которое указывает на первоначальный (уже уничтоженный вами) экземпляр. Вряд ли это то, что вы хотели получить! Избежать такой ситуации можно, воспользовавшись фрагментом кода, приведенным в листинге 9.2. При этом private-объект уничтожается лишь в том случае, если новое значение не совпадает с существую щим. Дополнительная проверка гарантирует, что SetProperty(fProperty) больше не приведет к возникновению GPF и не станет причиной особых накладных расходов, если «чтение вместо записи» все же исчезнет из Delphi. 

if fProperty <> NewPropertyValue then
  begin
  fProperty.Free;                     
  { Assign 'через' TPersistent }
  fProperty := TPropertyType.Create;  
  { может и не пройти: }
  fProperty.Assign(NewPropertyValue); 
  { Free/Create/Assign надежнее }
  end;     

{ Извлекаем все необходимые данные из 
NewPropertyValue }
fPropertyWritten := True;

Перспективы 

Подозреваю, что «чтение вместо записи» возникло в результате слишком усердной оптимизации. На первый взгляд оправдать его довольно трудно, но каждый раз, когда в Delphi обнаруживается ошибка или неудачное решение, я спрашиваю себя — а часто ли мне приходилось создавать или использовать приложения, которые работали бы устойчивее Delphi или обладали лучшим соотношением удачных и неудачных решений? Ответ всегда один: крайне редко… если вообще приходилось. 

Наконец, следует помнить и о том, что метод write вызывается во время загрузки простых типов (например, целых, перечисляемых типов и строк), а проблема с объектами TPersistent и их потомками не представляет особых сложностей. 

Использование RDTSC для измерения временных интервалов на Pentium 

В наши дни появились хорошие компиляторы и быстрые процессоры, в результате чего стало довольно трудно написать какой-нибудь «предельно тупой» код, существенно замедляющий работу программы. Однако по иронии судьбы средство для измерения временных интервалов появилось лишь в процессоре Pentium. Команда RDTSC (Read Time Stamp Counter) возвращает количество тактов, прошедших с момента подачи напряжения или сброса процессора. Где была эта команда, когда мы действительно нуждались в ней? 

И все же лучше поздно, чем никогда. Команда RDTSC состоит из двух байтов: $0F 31. Она возвращает в регистрах EDX:EAX 64-битное значение счетчика. Поскольку сопроцессорный тип данных comp представляет собой 64-битное целое, мы можем прочитать текущее значение с помощью кода Delphi, приведенного в листинге 9.3. 

const
   D32 = $66;

function RDTSC: comp;
var
   TimeStamp: record
case byte of
   1: (Whole:  comp);
   2: (Lo, Hi: LongInt);
end;
begin
  asm
    db $0F; db $31;            
    // BASM не поддерживает команду RDTSC
{$ifdef Cpu386}
    mov    [TimeStamp.Lo],eax  
    // младшее двойное слово
    mov    [TimeStamp.Hi],edx  
    // старшее двойное слово
{$else}
    db D32
    mov    word ptr TimeStamp.Lo,AX
    {mov    [TimeStamp.Lo],eax 
    - младшее двойное слово}
    db D32
    mov    word ptr TimeStamp.Hi,DX
    {mov    [TimeStamp.Hi],edx 
    - старшее двойное слово}
{$endif}
    end;
    Result := TimeStamp.Whole;
end;

Одна из проблем, с которой вы столкнетесь при использовании команды RDTSC, заключается в том, что функции IntToStr и Format('%d') могут работать только со значениями типа LongInt, а не comp. Если этим функциям передается значение типа comp, оно не может превышать High(LongInt), то есть 2147483647. Возможно, эти цифры производят впечатление, если они определяют сумму в долларах, но на Pentium с тактовой частотой 133 МГц это соответствует всего лишь 16 секундам. Если вам потребуется сравнить время работы двух длительных процессов, разность между показаниями таймера в начале и конце работы легко может превысить High(LongInt). 

Проблема решается просто. Хотя тип comp соответствует 64-битному целому, на самом деле это тип данных сопроцессора 80х87. Чтобы отформатировать comp функцией Format(), необходимо воспользоваться форматами с плавающей точкой. Функция CompToStr в листинге 9.4 скрывает все хлопотные подробности, причем с ней сгенерированный компилятором объектный код получается более компактным, нежели при непосредственном использовании нескольких вызовов Format(). 

function CompToStr(N: comp): string;
begin
  Result := Format('%.0n', [N]);
end;

Напоследок скажу лишь следующее. Потребность в измерении временных интервалов сейчас возникает намного реже, чем в былые времена. В то же время с появлением команды RDTSC такое измерение становится удобным и надежным. 

На этом замечании я передаю повествование своему соавтору, Эду Джордану. Продолжай, Эд! 

Перетаскивание текста в списках 

Тем не менее вы можете придать пользователям еще больше уверенности в происходящем. Например, при перетаскивании одной из строк списка курсорможет выглядеть как прозрачное изображение текста, окруженное пунктирным прямоугольником. Оказывается, в Delphi 3 сделать это несложно.В листинге 9.5 приведен полный исходный текст компонента-списка, обладающего такой возможностью. 

В отличие от Delphi 1 версии Delphi 2 и Delphi 3 обладают встроенной поддержкой для перетаскивания графических элементов; все, что от вас требуется — предоставить нужное изображение. Для этого следует нарисовать его в растровом виде, поместить растр в компонент TImageList и передать этот объект Delphi. После этого за перерисовку изображения при перемещении мыши будет отвечать код Delphi из модуля Controls. 

Как видно из листинга 9.5, для хранения графики используется private-поле типа TImageList. Его следует создать как можно раньше, но не заносить в него изображение до начала перетаскивания. Чтобы обнаружить начало операции перетаскивания, мы переопределяем метод DoStartDrag. Кроме того, необходимо переопределить и метод GetDragImages, поскольку список изображе ний передается Delphi именно при вызове этого метода. 

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

unit TxtDrgBx;

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

type
  TTextDragListBox = class( TListBox )
  private
    FDragImage: TImageList;
  protected
    procedure CreateDragImage;
    procedure DoStartDrag( var DragObject: 
    TDragObject );
      override;
  public
    constructor Create( AnOwner: TComponent ); 
    override;
    destructor Destroy; override;
    function GetDragImages: TCustomImageList;
      override;
  end;

  procedure Register;

implementation

constructor TTextDragListBox.Create( AnOwner: 
TComponent );
begin
  inherited Create( AnOwner );
  ControlStyle := ControlStyle + 
  [ csDisplayDragImage ];
  FDragImage := TImageList.CreateSize
  ( 32, 32 );
end;

destructor TTextDragListBox.Destroy;
begin
  FDragImage.Free;
  inherited Destroy;
end;

procedure TTextDragListBox.CreateDragImage;
var
  Bitmap: TBitmap;          
  // Перетаскиваемое изображение
  AnItemRect: TRect;        
  // Прямоугольник, в котором находится
// элемент списка
  MousePt: TPoint;          
  // Положение курсора
begin
  // Очищаем список изображений 
  //и заканчиваем работу,
  // если в списке нет выделенных элементов
  FDragImage.Clear;
  if ItemIndex = -1 then Exit;

  // Создаем растр, масштабируем его 
  //до размеров
  // выделенного элемента и выводим 
  //в нем текст
  AnItemRect := ItemRect( ItemIndex );
  Bitmap := TBitmap.Create;
  try
    with Bitmap do
    begin
      Width := AnItemRect.Right - AnItemRect.Left;
      Height := AnItemRect.Bottom - 
      AnItemRect.Top;
      Canvas.Font := Font;
      Canvas.DrawFocusRect( Rect( 0, 0, 
      Width, Height ) );
      Canvas.Brush.Style := bsClear;
      Canvas.TextOut
      ( 1, 1, Items[ ItemIndex ] );

  // Задаем размер списка изображений, заносим 
  //в него
  // изображение и устанавливаем прозрачный цвет
      FDragImage.Width := Width;
      FDragImage.Height := Height;
      FDragImage.AddMasked( Bitmap, clWhite );

  // ... задаем положение активной точки
      GetCursorPos( MousePt );
      with ScreenToClient( MousePt ), 
      AnItemRect do
        FDragImage.SetDragImage
        ( 0, X - Left, Y - Top );
    end;
  finally
    Bitmap.Free;
  end;
end;

procedure TTextDragListBox.DoStartDrag
( var DragObject:
  TDragObject );
begin
  inherited DoStartDrag( DragObject );
  CreateDragImage;
end;

function TTextDragListBox.GetDragImages: 
TCustomImageList;
begin
  Result := nil;
  if FDragImage.Count > 0 then Result 
  := FDragImage;
end;

procedure Register;
begin
  RegisterComponents('HP Delphi 3', 
  [ TTextDragListBox ]);
end;

end.

Основную часть листинга 9.5 занимает процедура CreateDragImage для работы со списком изображений. После создания и прорисовки растра размер списка изображений приводится в соответствие с размером растра (не забывайте это делать!), после чего метод AddMasked заносит растр в список и назначает прозрачный цвет. 

Метод SetDragImage, вызываемый двумя строками ниже, задает положение активной точки (hotspot) перетаскиваемого изображения. Мышь «держит» перетаскиваемое изображение в активной точке. В нашем случае вызов SetDragImage гарантирует, что текстовый прямоугольник будет перетаскиваться за точку его первоначального «захвата». 

Конечно, запрограммировать этот прием в Delphi 2 и 3 оказывается сложнее, чем просто рисовать на экране, но зато перед вами открываются широкие возможности для организации визуального взаимодействия компонентов. Например, при перетаскивании изображения между списками второй список может скрыть перетаскиваемое изображение, выделить свой элемент-приемник и затем вернуть скрытое изображение на экран. 

Строковые коллекции и списки 

Но когда я потом попытался перенести приложение Delphi обратно на Turbo Vision, мне сразу захотелось, чтобы строковые коллекции стали похожими на строковые списки. 

Добавление и удаление строк в коллекциях по сравнению с удобными операциями списков выглядит как замешивание цемента — в основном из-за простоты и четкости нового синтаксиса Object Pascal. 

Сравните код для добавления нового объекта в коллекцию Turbo Vision 

AStringColl^.AtInsert(AStringColl^.Count, NewStr(S));
S := PString(AStringColl^.At(Index))^; 

с аналогичным кодом для строкового списка Delphi 

StringList.Add(S);
S := StringList[Index]; 

и вы поймете, что я имею в виду. Операции со строковыми коллекциями практически не читаются, а вторая строка приведенного выше фрагмента просто неверна. Если указатель PString равен NIL (то есть в коллекцию добавлена пустая строка), то в строковую переменную S попадет «мусор». 

К счастью, на основе TStringCollection можно создать новый объект, облегчающий работу со строковыми коллекциями. Мы добавляем (см. листинг 9.6) безопасный по отношению к указателям метод StrAt и простой метод Add. Теперь можно легко написать код следующего вида: 

StrList^.Add(S);
S := StrList^.StrAt(Index); 

Знакомый синтаксис облегчает переходы между старым и новым миром — до тех пор, пока с существованием старого мира DOS приходится считаться. 

{ Создание удобных строковых коллекций в 
стиле TStringList. }
unit StrList;
interface
uses Objects;
type
  PStrListCollection = ^TStrListCollection;
  TStrListCollection = object(TStringCollection)
    function StrAt(Index: Integer): string;
    procedure Add(const S: string);
  end;

implementation

{ PtrToStr преобразовывает указатель в строку 
с отдельной обработкой nil.}
function PtrToStr(P: Pointer): string;
begin
  if P = nil then PtrToStr := '' else PtrToStr 
  := PString(P)^;
end;

{ StrAt возвращает строку из 
строковой коллекции. }
function TStrListCollection.StrAt
(Index: Integer): string;
begin
  StrAt := PtrToStr(At(Index));
end;

{ Add добавляет строку в 
конец строковой коллекции. }
procedure TStrListCollection.Add(const S: string);
begin
  AtInsert(Count, NewStr(S));
end;

end.

Установка приложений — дело рук самих приложений 

К счастью, я придумал, как предоставить установочной программе все ресурсы Delphi, обеспечив при этом минимальное увеличение объема пересылаемых файлов: главное приложение само выполняет функции установочной программы. Первоначально файл программы называется SETUP.EXE. При запуске под этим именем приложение устанавливает себя, хотя пользователю может показаться, что он имеет дело с отдельной установочной программой. После завершения установки программа переименовывает себя и перестает быть инсталлятором. 

Давайте посмотрим, как это делается. В листинге 9.7 показан основной блок файла проекта (DPR) типичного приложения Delphi. В листинге 9.8 показан тот же блок, но с изменениями, благодаря которым он начинает действовать как установочная программа. Обратите внимание на проверку имени EXE-файла приложения — если имя файла равно SETUP.EXE, мы запускаем форму (или серию форм), в которой пользователь задает каталог, программную группу и прочие параметры установки. 

{ Основной блок DPR-файла приложения 
до внесения изменений,
  предназначенных для работы в 
  установочном режиме. }
begin
  Application.Initialize;
  Application.CreateForm( TMainForm, MainForm );
  Application.Run;
end

{ Основной блок DPR-файла приложения после 
внесения изменений,
  предназначенных для работы в установочном 
  режиме. }

{ Обратите внимание, что в строку USES модуля 
  необходимо включить SYSUTILS.PAS. }
begin
  Application.Initialize;
  if UpperCase( ExtractFileName
  ( Application.ExeName ) ) =
     'SETUP.EXE' then
  begin
    Application.CreateForm
    ( TSetupForm, SetupForm );
  end
  else
    Application.CreateForm
    ( TMainForm, MainForm );
  Application.Run;
end.

Перед тем как архивировать свою программу (EXE-файл, справочные файлы и т. д.) для пересылки, я меняю имя EXE-файла на SETUP.EXE. После того как пользователь получит архив, раскроет его и запустит SETUP.EXE, приложение копирует себя и все вспомогательные файлы в указанный каталог и восстанавливает свое нормальное имя. При следующем запуске приложение обнаруживает, что его имя отличается от SETUP.EXE, и ведет себя нормально. 

Ценой незначительного увеличения объема программы и времени пересылки пользователь получает полезную установочную программу, а я (хочется верить) — несколько лишних проданных экземпляров. 

Использование inheritedс переопределенными свойствами 

Свойство ColCount определяет количество столбцов в сетке. Его значение, как и значение большинства свойств, хранится в private-поле (в нашем случае — FColCount) и изменяется private-методом (SetColCount). Следовательно, когда в программе встречается строка 

ColCount := AValue; 

или значение ColCount изменяется в инспекторе объектов в режиме конструи рования, вызывается метод SetColCount, который с помощью других private-методов изменяет значение переменной FColCount и вносит необходимые изменения в сетку. Все это инкапсулировано и недоступно для вмешательства извне. 

Однако разработчики исходной версии TDrawGrid предусмотрели, что при создании компонентов-потомков может потребоваться уведомление об изменении количества столбцов — поэтому после внесения изменений, но перед их отображением, вызывается метод SizeChanged. Метод SizeChanged является динамическим, то есть его можно переопределить, и после этого при каждом изменении количества столбцов (или строк) будет вызываться новая версия SizeChanged. См. листинг 9.9. 

{ Потомок TDrawGrid с переопределенным 
методом SizeChanged.
  Это позволяет компоненту-потомку узнавать 
  об изменении
  количества столбцов или строк. }

{ В секции interface... }

type
  TMyGrid = class(TDrawGrid)
  protected
    procedure SizeChanged(OldColCount, 
    OldRowCount: Longint);
      override;
  end;

{ В секции implementation... }

procedure TMyGrid.SizeChanged(OldColCount, 
OldRowCount: Longint);
begin
  { Выполняем любые необходимые действия }
end;

Переопределение SizeChanged позволит получать необходимые уведомления, но плохо подходит для контроля за количеством столбцов (скажем, если число столбцов в нашей сетке не должно превышать 3). К моменту вызова SizeChanged (обратите внимание на прошедшее время — Changed — в названии метода) изменения уже внесены. Лучшее, что мы можем сделать, если свойство ColCount стало равно 4, — заменить его на 3 и повторить весь процесс. 

Чтобы как можно раньше узнавать об изменениях, мы можем переопределить само свойствоColCount, задав для него новые методы доступа (см. объявление TMyGrid в листинге 9.10). Такое переопределение скрывает свойство ColCount предка. Если теперь в программе встретится строка: 

ColCount := AValue; 

будет вызван наш, невиртуальный метод SetColCount. Как видно из текста метода (см. листинг 9.10), мы сначала проверяем, не превышает ли новое количество столбцов 3, и если не превышает — вносим изменения. 

{ Потомок TDrawGrid, переопределяющий свойство ColCount 

с новыми методами доступа. Это позволяет компоненту-потомку 

управлять количеством столбцов. } 

{ В секции interface... } 

type
  TMyGrid = class(TDrawGrid)
  private
    function GetColCount: LongInt;
    procedure SetColCount(Value: LongInt);
  published
    property ColCount: LongInt read GetColCount 
      write SetColCount default 0;
  end;

{ В секции implementation... }

function TMyGrid.GetColCount: LongInt;
begin
  Result := inherited ColCount;
end;

procedure TMyGrid.SetColCount(Value: LongInt);
begin
  if Value <= 3 then inherited ColCount 
  := Value;
end;

Но, вероятно, самое интересное в переопределяемых свойствах — способ их изменения. Мы не можем непосредственно модифицировать значение private-поля FColCount. Впрочем, прямая модификация привела бы к нежелательным эффектам из-за пропуска ряда необходимых действий, сопровожда ющих изменение числа столбцов. Мы не можем вызвать метод SetColCount предка, потому что он определен в разделе private. А попытка вставить в наш метод SelColCount строку вида 

ColCount := Value; 

приведет к бесконечной рекурсии и переполнению стека. 

Правильный ответ заключается в использовании ключевого слова inherited с именем свойства: 

inherited ColCount := Value; 

Возможность использования inherited с именем свойства предка не так хорошо документирована, как его применение к унаследованным public- и protected-методам. Для кого-то такая возможность станет приятной неожиданностью, но она вполне в духе Object Pascal. 

Копирование экрана 

К счастью, дело обстоит не настолько плохо. Совместное использование холстов (canvas) Delphi с несколькими функциями GDI превращает копирова ние экрана в совершенно тривиальную задачу. Функция CaptureScreenRect (см. листинг 9.11) показывает, как это делается. Сначала мы получаем для экрана контекст устройства (DC) функцией GetDC(0), а затем копируем прямоугольную область из DC на холст растрового изображения. Копирование выполняется функцией BitBlt. Чтобы воспользоваться в Delphi функцией BitBlt (или любой другой функцией GDI), необходимо лишь помнить о том, что логический номер (handle) холста — это и есть DC, необходимый для вызова функций Windows. 

{ Функции копирования экрана в Delphi }
unit ScrnCap;

interface
uses WinTypes, WinProcs, Forms, Classes, 
Graphics, Controls;

function CaptureScreenRect( ARect: TRect ): 
TBitmap;
function CaptureScreen: TBitmap;
function CaptureClientImage( Control: TControl )
: TBitmap;
function CaptureControlImage( Control: TControl )
: TBitmap;

implementation

{ Копирование прямоугольной области экрана... }
function CaptureScreenRect( ARect: TRect )
: TBitmap;
var
  ScreenDC: HDC;
begin
  Result := TBitmap.Create;
  with Result, ARect do
  begin
    Width := Right - Left;
    Height := Bottom - Top;

    ScreenDC := GetDC( 0 );
    try
      BitBlt( Canvas.Handle, 0, 0, Width, 
      Height, ScreenDC,
        Left, Top, SRCCOPY );
    finally
      ReleaseDC( 0, ScreenDC );
    end;
  end;
end;

{ Копирование всего экрана... }
function CaptureScreen: TBitmap;
begin
  with Screen do
    Result := CaptureScreenRect( Rect( 0, 0, 
    Width, Height ));
end;

{ Копирование клиентской области формы или 
элемента... }
function CaptureClientImage( Control: TControl )
: TBitmap;
begin
  with Control, Control.ClientOrigin do
    Result := CaptureScreenRect( Bounds( X, Y, 
    ClientWidth,
                ClientHeight ));
end;

{ Копирование всей формы или элемента... }
function CaptureControlImage( Control: TControl )
: TBitmap;
begin
  with Control do
    if Parent = nil then
      Result := CaptureScreenRect( Bounds( Left, 
      Top, Width,
                  Height ))
    else
      with Parent.ClientToScreen( Point( Left, 
      Top )) do
        Result := CaptureScreenRect( Bounds( X, 
        Y, Width,
                    Height ));
end;

end.

Остальные функции копирования экрана в листинге 9.11 лишь определяют нужные прямоугольники, а всю основную работу оставляют на долю CaptureScreenRect. Функция CaptureScreen определяет прямоугольник для всего экрана, а CaptureClientImage и CaptureControlImage — прямоугольники для клиентской области и всего элемента соответственно. 

С помощью этих четырех функций можно «сфотографировать» любую часть экрана — например, получить экранные изображения форм, кнопок, memo-полей, выпадающих списков и т. д. Только не забудьте сказать: «А сейчас вылетит птичка…» и уничтожить растры после того, как надобность в них отпадет. 

Группы переключателей с индивидуальной блокировкой 

Однако он не позволяет обращаться к отдельным переключателям группы — и наверняка для этого есть веские причины. Но я уверен в своей способности разумно блокировать тот или иной переключатель и поэтому написал улучшенный вариант TRadioGroup (см. листинг 9.12). Класс TRadioBtnGrp содержит новое свойство ItemEnabled, с помощью которого можно получать и задавать состояние блокировки для отдельных кнопок. 

{ Группа переключателей с возможностью 
блокировки отдельных кнопок }
unit RBtnGrps;
interface
uses StdCtrls, ExtCtrls, Classes;

type
  TRadioBtnGroup = class( TRadioGroup )
  private
    function GetItemEnabled( Index: Integer )
    : Boolean;
    procedure SetItemEnabled( Index: Integer; 
    Value: Boolean );
    function GetButtons( Index: Integer )
    : TRadioButton;
  protected
    function CheckAnyBut( NotThisIndex: 
    Integer ): Boolean;
    property Buttons[ Index: Integer ]
    : TRadioButton
      read GetButtons;
  public
    property ItemEnabled[ Index: Integer ]
    : Boolean
      read GetItemEnabled write SetItemEnabled;
  end;

  procedure Register;

implementation

function TRadioBtnGroup.CheckAnyBut;
var
  Index: Integer;
begin
  Result := True;
  for Index := NotThisIndex + 1 to Items.Count 
  - 1 do
    if Buttons[ Index ].Enabled then
    begin
      Buttons[ Index ].Checked := True;
      Exit;
    end;
  for Index := 0 to NotThisIndex - 1 do
    if Buttons[ Index ].Enabled then
    begin
      Buttons[ Index ].Checked := True;
      Exit;
    end;
  Result := False;
end;

function TRadioBtnGroup.GetItemEnabled;
begin
  Result := Buttons[ Index ].Enabled;
end;

procedure TRadioBtnGroup.SetItemEnabled;
begin
  if ( not Value ) and ( Index = ItemIndex ) and
      Buttons[ Index ].Checked and ( not 
      CheckAnyBut( Index )) then
    ItemIndex := -1;
  Buttons[ Index ].Enabled := Value;
end;

function TRadioBtnGroup.GetButtons;
begin
  Result := Components[ Index ] as TRadioButton;
end;

procedure Register;
begin
  RegisterComponents('HP Delphi 3', 
  [ TRadioBtnGroup ]);
end;

end.

Во внутренней реализации TRadioBtnGroup метод GetButtons используется для получения доступа к отдельным переключателям. GetButtons использует тот факт, что входящие в группу переключатели хранятся в массиве Components. Все, что требуется от GetButtons — индексировать массив Components и выполнить безопасное преобразование типа для результата. 

Новый элемент стремится работать как можно разумнее. При блокировке установленного переключателя он пытается установить другой переключатель; если заблокированы все переключатели, он ничего не устанавливает. Если такое поведение вас не устраивает, его можно изменить. 

Захват системной палитры 

Дело в том, что при копировании экрана в видеорежиме, использующем палитру, полученные цвета пикселей на самом деле представляют собой лишь индексы в цветовой таблице; они останутся правильными лишь в том случае, если не изменилась системная палитра. 

Следовательно, после копирования экрана мы должны создать новую палитру с системными цветами и назначить ее свойству Palette растра. При сохранении растрового изображения значения цветов будут сохранены вместе с ним. Функция GetSystemPalette из листинга 9.13 создает такую палитру и возвращает ее логический номер. Функция CaptureScreenRect из того же листинга показывает, как использовать GetSystemPalette со скопированным изображением. 

function GetSystemPalette: HPalette;
var
  PaletteSize: Integer;
  LogSize: Integer;
  LogPalette: PLogPalette;
  DC: HDC;
  Focus: HWND;
begin
  Result := 0;
  Focus := GetFocus;    { ...это необходимо 
  для GetDC }
  DC := GetDC( Focus ); { ...это необходимо для 
  GetDeviceCaps }
  try
    PaletteSize := GetDeviceCaps( DC, 
    SIZEPALETTE );
    LogSize := SizeOf( TLogPalette ) + 
    ( PaletteSize - 1 ) *
               SizeOf( TPaletteEntry );
    GetMem( LogPalette, LogSize );
    try
      with LogPalette^ do
      begin
        palVersion := $0300;
        palNumEntries := PaletteSize;
GetSystemPaletteEntries( DC, 0, PaletteSize,
          palPalEntry );
      end;
      Result := CreatePalette( LogPalette^ );
    finally
      FreeMem( LogPalette, LogSize );
    end;
  finally
    ReleaseDC( Focus, DC );
  end;
end;

{ Воспользуемся GetSystemPalette для 
копирования прямоугольника... }
function CaptureScreenRect( ARect: TRect )
: TBitmap;
var
  ScreenDC: HDC;

begin
  Result := TBitmap.Create;
  with Result, ARect do
  begin
    Width := Right - Left;
    Height := Bottom - Top;

    ScreenDC := GetDC( 0 );
    try
      BitBlt( Canvas.Handle, 0, 0, Width, 
      Height, ScreenDC,
        Left, Top, SRCCOPY );
    finally
      ReleaseDC( 0, ScreenDC );
    end;

    { Также сохраним системную палитру... }
    Palette := GetSystemPalette;
  end;
end;

Палитра создается функцией API CreatePalette. Функция CreatePalette получает один параметр-запись, в котором указываются версия палитры, количество цветов и массив значений, определяющих каждый цвет. 

В типе записи для этой «логической палитры» хватает места для хранения лишь одного элемента палитры. Сначала это может показаться странным, но на самом деле все логично — количество элементов палитры зависит от видеорежима. Следовательно, прежде всего необходимо определить размер палитры для текущего видеорежима. Затем мы используем указатель типа PLogPalette и выделяем область памяти, достаточную для хранения записи и всех элементов. Как видно из листинга 9.13, количество элементов палитры определяется функцией GetDeviceCaps. 

Выделение памяти под логическую палитру — дело хлопотное, но зато дальше все просто. Мы получаем сами цветовые значения функцией GetSystem PaletteEntries, а затем передаем информацию о логической палитре функции CreatePalette и получаем необходимый логический номер (handle) палитры. 

Работа с буфером как с потоком 

А вот и другая причина — если объект умеет записываться в поток, он способен перенести себя на любое устройство, представленное в виде потока. Такой объект с одинаковой легкостью записывается как в память (через TMemoryStream), так и на диск. 

Создавая поток для нового устройства, вы делаете свой код более гибким и универсальным — и зачастую упрощаете работу с данным устройством. Например, обмен информацией с буфером (clipboard) — занятие на любителя. Конечно, объект Delphi TClipboard вам поможет, но для копирования и вставки нестандартных форматов или больших объемов данных все равно придется вызывать загадочные функции API, имена которых начинаются с Global. Поток из листинга 9.14, напротив, позволяет работать с буфером с помощью знакомых методов Write и Read. 

unit ClipStrm;

interface
uses Classes, Clipbrd, Consts, WinProcs, WinTypes;

type
  TClipboardMode = ( cmRead, cmWrite );
  TClipboardStream = class( TMemoryStream )
  private
    FMode: TClipboardMode;
    FFormat: Word;

  public
    constructor Create( Format: Word; Mode: 
    TClipboardMode );
    destructor Destroy; override;
  end;

implementation

constructor TClipboardStream.Create;
var
  Handle: THandle;
  MemPtr: Pointer;
begin
  inherited Create;
  FMode := Mode;
  FFormat := Format;

{ В "режиме чтения" немедленно 
читаем данные буфера в поток... }
  if ( FMode = cmRead ) and Clipboard.HasFormat
  ( FFormat ) then
  begin
    Clipboard.Open;
    try
      Handle := Clipboard.GetAsHandle( FFormat );
      MemPtr := GlobalLock( Handle );
      try
        Write( MemPtr^, GlobalSize( Handle ));
      finally
        GlobalUnlock( Handle );
      end;
      Position := 0;
    finally
      Clipboard.Close;
    end;
  end;
end;

destructor TClipboardStream.Destroy;
var
  P: PChar;
begin
  { В "режиме записи" копируем в буфер 
  все содержимое потока... }
  if FMode = cmWrite then
  begin
    P := GlobalAllocPtr( HeapAllocFlags, Size );
    try
      Position := 0;
      Read( P^, Size );
      Clipboard.SetAsHandle( FFormat, 
      GlobalHandle( P ));
    except
      GlobalFreePtr( P );
    end;
  end;
  inherited Destroy;
end;

end.

Поток TClipboardStream работает чрезвычайно просто. При его создании необходимо указать формат, а также выполняемую операцию — чтение или запись. Поток, созданный в «режиме чтения», немедленно загружает все содержимое буфера, чтобы данные можно было получить методом Read. Поток, созданный в «режиме записи», ожидает своего уничтожения, а дождавшись, копирует в буфер все, что мы успели в него занести. 

В результате получается, что объект может с помощью одного и того же кода сохранить себя на диске (TFileStream), в памяти (TMemoryStream) или в буфере; код для его последующей загрузки из разных источников тоже будет одинаковым. 

Оперативное изменение подсказок 

К сожалению, стандартный механизм подсказок такой возможности не дает. Приложение определяет, какую подсказку следует выводить, лишь при перемещении курсора к другому элементу. 

Однако объект Application обладает public-методом CancelHint, который убирает с экрана текущую подсказку и заново запускает таймер. Если изменить свойство Hint после вызова CancelHint, но перед повторным появлением окна подсказки, мы сможем изменить текст подсказки, не перемещаясь за границу элемента. 

В листинге 9.15 приведен пример обработчика OnMouseMove для объекта TStringGrid; вы можете использовать эту модель в своих программах. Обработ чик вызывается при каждом перемещении мыши над сеткой, но лишь при переходе к другой ячейке мы убираем окно подсказки и изменяем ее текст. 

{ Пример изменения подсказок в объекте 
TStringGrid }
procedure TForm1.StringGrid1MouseMove
( Sender: TObject;
  Shift: TShiftState; X, Y: Integer );
const
  LastMCol: LongInt = -2;
  LastMRow: LongInt = -2;
var
  MCol, MRow: LongInt;  // Столбец и строка, 
  где находится курсор
  NewHintText: string;
  Grid: TStringGrid;
begin
  Grid := Sender as TStringGrid;
  Grid.MouseToCell( X, Y, MCol, MRow );
  if ( MCol <> LastMCol ) or 
  ( MRow <> LastMRow ) then
  begin
    Application.CancelHint;
    if ( MCol = -1 ) or ( MRow = -1 ) then
      NewHintText := 'Not over cell'
    else
      NewHintText := Format( 'Col %d, Row %d', 
      [ MCol, MRow ]);
    Grid.Hint := NewHintText;
  end;
  LastMCol := MCol;
  LastMRow := MRow;
end;

Этот код можно использовать во всех трех версиях Delphi, хотя поведение окна подсказки в них несколько отличается. В Delphi 1 и 2 окно подсказки остается в нижней части сетки, независимо от положения курсора. В Delphi 3 окно подсказки следует за курсором и располагается рядом с текущей ячейкой или поверх нее — именно на это вы и рассчитывали. 

Использование макросов в редакторе Delphi 

Во время редактирования текста программы можно записать последовательность нажатий клавиш в виде макроса и потом воспроизвести ее. Чтобы начать запись макроса, нажмите Ctrl+Shift+R и введите нужную последовательность клавиш. Запись прекращается повторным нажатием Ctrl+Shift+R. Макрос воспроизводится клавишами Ctrl+Shift+P. 

Редактор Delphi — не WinWord и не WordPerfect, и поддержка макросов в нем ограничена: запоминается лишь один набор клавиш. Кроме того, нажатие во время записи макроса любых клавиш, вызывающих переход к другому окну, отменяет процесс записи. Например, если последняя операция Find представляла собой простой поиск, то при нажатии F3 диалоговое окно не выводится (при успешном поиске) и клавиша F3 включается в макрос. Но если ранее выполнялся поиск с заменой, F3 выведет диалоговое окно с запросом подтверждения, и запись макроса прервется. 

Даже при таких ограничениях макросы могут принести немалую пользу — вы можете определять закладки и переходить к ним, выполнять поиск с изменением критерия, копировать и вставлять фрагменты текста. 

Например, после ввода заголовка метода в объявлении класса мне часто приходится копировать этот заголовок в секцию implementation модуля, вставлять перед ним имя класса с точкой и вводить пару begin..end. Если тщательно продумать последовательность операций, все эти действия можно записать в одном универсальном макросе. В листинге 9.16 приведен возможный набор клавиш, которые выполняют эту задачу при условии, что текстовый курсор находится в строке с заголовком метода. 

Кстати, в моем примере использованы стандартные (Default) настройки клавиатурных комбинаций редактора. Если у вас установлен другой режим, возможно, макрос придется изменить.

{ Ниже приведена последовательность нажатий клавиш для вставки заголовка 

метода в секцию implementation модуля и добавления пары begin..end. 

Управляющие сочетания клавиш заключены в фигурные скобки. 

После двойного символа "косая черта" следует комментарий. 

Предполагается, что модуль заканчивается ключевым словом "end."}

{Ctrl+Shift+R}       // Начало записи
{HOME}               // Перейти к началу строки
{Shift+DOWN}         // Выделить строку
{Ctrl+C}             // Скопировать выделенную 
строку
{Ctrl+END}           // Перейти в конец модуля
{Ctrl+LEFT}          // Перейти в позицию слева 
от "end."
{Ctrl+V}             // Вставить скопированную 
строку
{UP}                 // Перейти к началу 
вставленной строки
{Ctrl+T}             // Удалить отступ
{Ctrl+RIGHT}         // Перейти к имени метода
TMyClass.            // Ввести имя класса с точкой
{END}                // Перейти к концу строки
{ENTER}              // Вставить новую строку
begin                // Ввести "begin"
{ENTER}{ENTER}       // Вставить две новые строки 
после "begin"
end;                 // Ввести "end;"
{ENTER}              // Вставить новую строку 
после метода
{UP}{UP}             // Вернуться к телу метода
{RIGHT}{RIGHT}       // Создать отступ в два 
пробела 
                     // и приготовиться к вводу
{Ctrl+Shift+R}       // Остановить запись

Потоки и TPersistent 

Потоки Delphi умеют работать с классом TPersistent, так что чтение и запись объектов происходит почти автоматически. Однако не все объекты TPersistent равноценны. Компоненты , являющиеся потомками TPersistent, можно сохранять и загружать удобными методами TStream.WriteComponent и ReadComponent. Но другие потомки TPersistent сохраняются в потоках лишь в том случае, если они представляют собой published-свойства компонентов — то есть теряют самостоятельность. 

Это становится неудобным, если мы захотим сохранить в потоке, например, шрифтовой объект. Сначала придется объявить новый тип компонента с published-свойством TFont, затем создать экземпляр этого компонента, присвоить шрифтовому свойству наш объект и записать компонент в поток. 

Но если все, что вам нужно — это «рабочая лошадка», которая возит на себе TPersistent, необязательно каждый раз объявлять новый класс. Необходим всего один класс для компонента с published-свойством TPersistent; полиморфизм позволяет назначить этому свойству объект любого класса-потомка TPersistent, и он будет сохраняться и загружаться вместе с компонентом. 

Компонент TCarrier (см. листинг 9.17) как раз и является таким «вьючным животным». Он спрятан в секции implementation модуля StrmPers, а процедуры WritePersistent и ReadPersistent занимаются созданием, использованием и уничтожением временных экземпляров его объектов. Не забудьте создать свой TPersistent перед тем, как использовать его при вызове ReadPersistent; к этому моменту объект уже должен существовать. 

unit StrmPers;

interface
uses Classes;

procedure WritePersistent( Stream: TStream;
  Persistent: TPersistent );

{ ЗАМЕЧАНИЕ: Объект TPersistent должен быть 
создан до 
  его передачи этой процедуре... }

procedure ReadPersistent( Stream: TStream;
  Persistent: TPersistent );

implementation

type
  TCarrier = class( TComponent )
  private
    FPersistent: TPersistent;
  published
    property Persistent: TPersistent
      read FPersistent write FPersistent;
  end;

procedure WritePersistent( Stream: TStream;
  Persistent: TPersistent );
var
  Carrier: TCarrier;
begin
  Carrier := TCarrier.Create( nil );
  try
    Carrier.Persistent := Persistent;
    Stream.WriteComponent( Carrier );
  finally
    Carrier.Free;
  end;
end;

procedure ReadPersistent( Stream: TStream;
  Persistent: TPersistent );
var
  Carrier: TCarrier;
begin
  Carrier := TCarrier.Create( nil );
  try
    Carrier.Persistent := Persistent;
    Stream.ReadComponent( Carrier );
  finally
    Carrier.Free;
  end;
end;

end.

Отображение перетаскиваемого объекта
в Delphi 2 и 3 

Почему это происходит? В число факторов, определяющих поведение элемента, входит свойство ControlStyle. В Delphi версий 2 и 3 появился новый стандартный флаг csDisplayDragImage. Если csDisplayDragImage входит в ControlStyle, перетаскиваемое изображение выводится над элементом. В противном случае оно исчезает до тех пор, пока курсор не доберется до более «дружественной» территории. К сожалению, для большинства элементов значение ControlStyle, принятое по умолчанию, не включает флага csDisplayDragImage. Следовательно, если вы хотите, чтобы изображение не пропадало при перемещении, придется настроить все формы вашего проекта и все элементы, находящиеся на них, чтобы в их свойстве ControlStyle присутствовал флаг csDisplayDragImage. 

В листинге 9.18 приведена процедура EnableDisplayDragImage, исправляющая значение ControlStyle самого элемента, его дочерних элементов, «внуков» и т. д. 

Чтобы каждый элемент формы поддерживал отображение перетаскиваемого объекта, включите в обработчик FormCreate формы следующую строку: 

EnableDisplayDragImage( Self, True ); 

Если ваша программа создает элементы динамически, не забудьте вызвать EnableDisplayDragImage и для них. 

unit EnabDisp;

interface
uses Controls;

procedure EnableDisplayDragImage( Control: 
TControl;
  ChildrenToo: Boolean );

implementation

procedure EnableDisplayDragImage( Control: 
TControl;
  ChildrenToo: Boolean );
var
  Index: Integer;
begin
  with Control do
    ControlStyle := ControlStyle + 
    [ csDisplayDragImage ];

  if ChildrenToo and ( Control is TWinControl ) 
  then
    with TWinControl( Control ) do
      for Index := 0 to ControlCount - 1 do
      begin
        EnableDisplayDragImage( Controls[ Index ],
          ChildrenToo );
      end;
end;

end.