Способы визуализации содержимого внутреннего буфера никак не зависят от того, что конкретно в нем хранится - изображение или текст. В связи с этим создан базовый класс TFarGraphic, в котором инкапсулированы все основные функциональные средства четырех компонентов (листинг 15.9).

Листинг 15.9. Модуль базового класса TFarGraphic unit FarAppearence;

Содержащийся в этом модуле класс TFarGraphic является родительским для компонентов XXXXAppearence. Свойство Picture предоставляет канву для хранения надписи или изображения. Метод Draw переносит эту канву на канву компонента. Способ переноса блоков определяет тот или иной эффект и задается значением свойства AppStyle: asNone - нет никаких эффектов; asJeftRight - изображение или текст перемещается в окне компонента слева направо; asRightLeft - перемещение справа налево; asTopBottom - перемещение сверху вниз; asBottomTop -перемещение снизу вверх; asToCenter - заполнение от краев к центру; asFromCenter - заполнение от центра к краям; asVJalousie - вертикальные жалюзи; asHJalousie -горизонтальные жалюзи; asRandom - случайное заполнение.

interface uses

Windows, SysUtils, Classes, Controls, StdCtrls, Graphics, Types, Forms;
type TAppStyle - (asNone, asLeftRight, asRightLeft, asTopBottom, asBottomTop, asToCenter, asFromCenter, asVJalousie, asHJalousie, asRandom);

TFarGraphic = class(TGraphicControl) private FBoxLength: Integer; // Длина блока переноски FDelay: Integer; // Задержка переноски

FAppStyle: TAppStyle; // Стиль переноски procedure SetAppStyle(Value: TAppStyle);
protected
FPicture: TPicture; // Хранилище изображения (надписи) Src, Dst: TCanvas; // Канва-источник и канва-приемник procedure Paint;
override; procedure Draw;
procedure SetCanvases;

property Picture: TPicture read FPicture write FPicture; public

constructor Create(AOwner: TComponent);
override;
destructor Destroy;
override;

продолжение

Листинг 15.9 (продолжение) published

property BoxLength: Integer read FBoxLength

write FBoxLength default 1; property AppStyle: TAppStyle read FAppStyle

write SetAppStyle default asNone; property Delay: Integer read FDelay

write FDelay default 0; property Color;
property DragCursor;
property DragMode;
property Enabled;
property ParentShowHint;
property ParentColor;
property PopupMenu;
property ShowHint;
property Visible;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
end;
PRect = ATrect;

TBoxes - class(TList) // Объект этого класса

// используется для хранения procedure Add(R: TRect); // прямоугольников при

procedure Delete(к: Integer); // реализации стиля asRandom

end;

implementation

{ TFarGraphic }
constructor TFarGraphic.Create(AOwner: TComponent); // Создает объект-хранилище и устанавливает // умалчиваемые значения свойств begin
inherited;
FPicture := TPicture.Create;
Width :- 100; Height := 100; FBoxLength := 1;
end;
destructor TFarGraphic.Destroy; // Уничтожает объект-хранилище begin
FPicture.Free;
inherited end;

procedure TFarGraphic.Draw; // Реализация эффектов var SRec, // Координаты блока на исходной канве

DRec: TRect; // Координаты блока на канве-приемнике

procedure DrawBox;
// Копирует блок и реализует задержку на FDelay миллисекунд var
D: Integer;
begin
Dst.CopyRect(DRec, Src, SRec);
D := GetTickCount + FDelay;
while GetTickCount <
D do;
Application.ProcessMessages end;
var
X, Y, D: Integers-Boxes: TBoxes;
P: PRect;
label Stop;

begin // Draw case AppStyle of asNone:

Stop: Dst.CopyRect(Rect(0, 0, Width, Height), Src, Rect(0, 0, Width, Height));
asLeftRight: // Перемещение слева направо begin
X :- 1;

repeat

if X * BoxLength Width then
goto Stop; // Завершение цикла DRec := Rect(0, О, X * BoxLength, Height);
SRec := Rect(Width - X * BoxLength, 0, Width, Height);
DrawBox;
inc(X); until False;
end;

asRightLeft: // Перемещение справа налево г г продолжение

Листинг 15.9 (продолжение) begin X : = 1; repeat

if X * BoxLength >= Width then goto Stop;
DRec := Rect(Width - X * BoxLength, 0, Width, Height);
SRec := Rect(0, О, X * FBoxLength, Height);
DrawBox;
inc(X); until False;
end;
asBottomTop: // Перемещение сверху вниз begin
Y : = 1;

repeat t

if Y * BoxLength Height then goto Stop;
DRec := Rect(0, 0, Width, Y * BoxLength);
SRec := Rect(0, Height - Y * BoxLength, Width, Height );
DrawBox;
inc(Y); until False;
end;

asTopBottom: // Перемещение снизу вверх begin Y := 1; repeat

if Y * BoxLength >= Height then
goto Stop;
DRec := Rect(0, Height - у * BoxLength, Width, Height);
SRec := Rect(0, 0, Width, Y * BoxLength);
DrawBox;
inc(Y) until False end;
asToCenter: // Заполнение от краев к центру begin X := 1;

for У := 1 to Width div 2 do begin if X * 2 * BoxLength >= Width then goto Stop; // Верхний блок

SRec := Rect((X - 1) * BoxLength, (Y - 1) * BoxLength, Width - (X - 1) * BoxLength, Y * BoxLength);
DRec := SRec;
DrawBox;

// Нижний блок

SRec := Rect((X - 1) * BoxLength, Height - Y * BoxLength, Width - (X - 1) * BoxLength, Height - (Y - 1) * BoxLength);
DRec := SRec;
DrawBox;

// Левый блок

SRec := Rect((X - 1) * BoxLength, Y * BoxLength, X * BoxLength, Height - Y * BoxLength); DRec := SRec; DrawBox; // Правый блок

SRec := Rect(Width - X * BoxLength, Y * BoxLength, Width - (X - 1) * BoxLength, Height - Y * BoxLength);
DRec := SRec;
DrawBox; inc(X) end end;
asFromCenter: // Заполнение от центра к краям begin
X := (Width - BoxLength) div 2; Y := (Height - BoxLength) div 2;
SRec :=Rect(X, Y, X + 2 * BoxLength, Y + 2 * BoxLength);
DRec := SRec;
repeat DrawBox;
if SRec.Left 0 then begin
SRec.Left := SRec.Left - BoxLength;
SRec.Right *:= SRec.Right + BoxLength;
DRec.Left := DRec.Left - BoxLength;
DRec.Right : = DRec.Right + BoxLength;
end;
if SRec.Top >= 0 then begin
SRec.Top SRec.Top - BoxLength;
SRec.Bottom := SRec.Bottom + BoxLength;
DRec.Top := DRec.Top - BoxLength;
DRec.Bottom := DRec.Bottom + BoxLength end;
until (SRec.Left < 0) and (SRec.Top < 0) end;

asVJalousie: // Вертикальные жалюзи begin D :~ Width div 10; // Ширина полос

for X := 1 to D do // Цикл по ширине полосы продолжение^

Листинг 15.9 (продолжение)
for Y 1 to 10 do // Цикл по каждой полосе . begin
SRec Rect((X - 1) * BoxLength + (Y - 1) * D, 0, X * BoxLength + (Y - 1) * D, Height);
DRec : = SRec;
DrawBox end end;
asHJalousie: // Вертикальные жалюзи begin
D Height div 10;
for Y 1 to D do
for X := 1 to 10 do
begin
SRec Rect(0, (Y - 1) * BoxLength + (X - 1) * D, Width, Y * BoxLength + (X - If * D);
DRec := SRec;
DrawBox end end;

asRandom: // Случайное заполнение begin Boxes := TBoxes.Create; // Хранилище координат блоков for X := 1 to Width div BoxLength do // Заполняем его for Y := 1 to Height div BoxLength do Boxes.Add(Rect((X - 1) * BoxLength, (Y - 1) * BoxLength, X * BoxLength, Y * BoxLength)); while Boxes.Count > 0 do // Пока хранилище не пусто begin D := Random (Boxes .Count) ; // Выбираем случайный номер блока Р := Boxes. Items [D] ; // Получаем указатель на блок

SRec :« РА; // Координаты блока

DRec : = SRec;
DrawBox;

Boxes.Delete(D); // Уничтожаем отрисованный блок

end;

Boxes.Free // Удаляем пустое хранилище

end;
end;
end;

procedure TFarGraphic.Paint; begin if csDesigning in ComponentState then with Dst do begin Pen.Style := psDash; // Отрисовка пунктира

Brush.Style := bsClear; // вокруг компонента

Rectangle(0f 0, Width, Height); // на этапе конструирования end;
if FPicture.Graphic.Empty then Exit;

Dst.Brush.Style := bsSolid; // Очищаем прямоугольник

Dst.Brush.Color Color; // перед отрисовкой

Dst.FillRect(Rect(0, 0, Width, Height));
Draw;
end;
procedure TFarGraphic.SetAppStyle(Value: TAppStyle);
begin
if Value <>
FAppStyle then begin
FAppStyle := Values-invalidate end ends-procedure TFarGraphic.SetCanvases;
begin
Src := FPicture.Bitmap.Canvas;
Dst := Canvas;
end;
{ TBoxes }
procedure TBoxes.Add(R: TRect);
// Помещает координаты прямоугольника в память и в хранилище var
Р: PRect;
begin
New(P) ;
РА := R;
inherited Add(P) ends-procedure TBoxes.Delete(k: Integer); // Уничтожает блок после его использования var
Р: PRect;
begin
Р :*= Items [к] ;

Dispose(Р); // Сначала освобождаем память

inherited Delete(к) endsend.

Класс TFarGraphic является наследником TGraphicControl и, таким образом, получает свойство Canvas для своей отрисовки. В классе определено свойство Picture, которое служит внутренним хранилищем изображения или текста. Поскольку это свойство не должно публиковаться у наследников TFarLabelAppearence и TFarDBTextAppearence, оно объявляется в секции ptotected. Для формирования анимационных эффектов канва хранилища разбивается на множество блоков, характерный размер которых (высота или ширина) задается свойством BoxLength.

Метод Draw вызывается из метода Paint и, в зависимости от значения свойства AppStyle, реализует нужный алгоритм формирования и копирования блоков. Скорость отрисовки компонентов зависит от производительности компьютера, размеров изображения и выбранного стиля. Оно определяется свойствами BoxLength и Delay: чем больше характерный размер блока, тем меньше общее количество копируемых блоков и тем быстрее отрисовка^.свойство Delay определяет задержку в миллисекундах между двумя последовательными отрисовка-ми блоков; чем оно больше, тем медленнее формируется изображение. Комбинация значений этих свойств позволяет установить нужное время отрисовки на любом компьютере. Замечу, что задержка реализуется с помощью API-функции GetTickCount, которая возвращает количество миллисекунд, прошедших с момента включения компьютера.

При реализации эффектов, связанных с перемещением изображении, используется «бесконечный» цикл repeat...until (в таком цикле условие выхода всегда равно False). Выход из такого цикла возможен либо с помощью процедуры Break, либо оператором перехода goto на метку вне тела цикла. Поскольку количество блоков определяется целочисленным делением ширины (высоты) изображения на величину значения BoxLength, самый последний копируемый блок может оказаться несколько больше нужного. Чтобы исключить связанные с этим возможные искажения изображения, вместо последнего блока копируется хранилище целиком (метка Stop).

Простой вспомогательный класс TBoxes предназначен для удобного хранения в памяти множества координат квадратных блоков с размерами BoxLength на BoxLength, на которые разбивается все изображение при случайном заполнении. После того как объект Boxes этого класса создан и наполнен, реализуется выбор случайного блока, его копирование и уничтожение. Таким образом, после каждого копирования значение свойства Boxes. Count уменьшается на единицу. Цикл повторяется до тех пор, пока не будет скопирован последний блок. Замечу, что при малых значениях BoxLength и значительных размерах изображения первоначально в Boxes будут храниться десятки тысяч блоков, что приведет к значительному времени отрисовки. В этом случае следует нужным образом увеличить значение BoxLength.

Четыре специализированных класса - TFarLabeAppearence, TFarlmage-Appearence, TFarDBTextAppearence и TFarDBImageAppearence - наследуют от TFarGraphic и конкретизируют его функциональность для отображения однострочных надписей или растровых изображений. Все они реализованы в отдельных модулях, хотя Delphi позволяет размещать в одном модуле сколько угодно компонентов.

Модуль компонента FarLabelAppearence представлен в листинге 15.10.

Листинг 15.10. Модуль компонента FarLabelAppearence unit FarLabelApp;

Модуль содержит компонент FarLabelAppearence, обеспечивающий мультимедийные эффекты при отображении однострочных надписей. Он наследует от TFarGraphic и вводит свойство Caption для хранения надписи. ...........--.««..„......-^^^

interface uses

Classes, FarAppearence; type TFarLabelAppearence = class(TFarGraphic) private FC apt ion: Strings-protected procedure SetCaption(const Value: String); procedure Paint; override; public

constructor Create(AOwner: TComponent); override; published

property Caption: String read FCaption write SetCaption;
property Fonts-end;

procedure Registers-implementation

procedure Register;
begin
RegisterComponents(1 Far', [TFarLabelAppearence]);
end;
{ TFarLabelApp }
constructor TFarLabelAppearence.Create(AOwner: TComponent);
продолжение &
Листинг 15.10 (продолжение) begin
inherited;
FCaption := Name;
SetCanvases;
end;
procedure TFarLabelAppearence.Paint;
begin
FPicture.Bitmap.Width := Src.TextWidth(FCaption);
FPicture.Bitmap.Height Src.TextHeight(FCaption); Width := FPicture.Bitmap.Width;
Height := FPicture.Bitmap.Height;
Src.Font := Font;
Src.Brush.Color :- Color;
Src.TextOut(0, 0f FCaption);
inherited;
end;
procedure TFarLabelAppearence.SetCaption(const Value: String);
begin
if Value <>
FCaption then begin
FCaption := Value;
Paint end end;

end.

В класс добавлено свойство Caption, опубликовано свойство Font и перекрыт метод Paint, в котором перед отрисовкой вычисляются размеры компонента и в канву-источник помещается текст из поля FCaption.

Модуль компонента FarDBTextAppearence представлен в листинге 15.11.

Листинг 15.11. Модуль компонента FarDBTextAppearence unit FarDBTextApp;

Модуль содержит класс TFarDBTextAppearence, отличающийся от родительского класса TFapLabelAppearence только тем, что предназначен для работы с базами данных.

interface uses

Classes, FarLabelApp, DBCtrls, DB;

type TFarDbTextAppearence = class(TFarLabelAppearence) private FDataLink: TFieldDataLink; protected procedure SetDataSource(Value: TDataSource); function GetDataSource: TDataSource; procedure SetDataField(const Value: String); function GetDataField: Strings-procedure DataChange(Sender: TObject); public

constructor Create(AOwner: TComponent); override; destructor Destroy; override; published

property DataSource: TDataSource read GetDataSource

write SetDataSource; property DataField: String read GetDataField

write SetDataField;

ends-procedure Registers-implementation

procedure Registers-begin
RegisterComponents(' Far', [TFarDBTextAppearence]);
end;
{ TFarDbTextAppearence } »
constructor TFarDbTextAppearence.Create(AOwner: TComponent);

// Создает канал связи с данными

begin
inherited;
FDataLink :- TFieldDataLink.Create;

FDataLink.OnDataChange := DataChange; ends-procedure TFarDbTextAppearence.DataChange(Sender: TObject); // Реакция на изменение данных begin if FDataLink.Field - NIL then Caption := ' ' else Caption := FDataLink.Field.DisplayText

end; л продолжение &
Листинг 15.11 (продолжение)
destructor TFarDbTextAppearence.Destroy;

// Разрушает канал связи

begin
FDataLink.Free;
inherited;
end;
function TFarDbTextAppearence.GetDataField: String;

// Возвращает имя поля данных

begin
Result := FDataLink.FieldName end;
function TFarDbTextAppearence.GetDataSource: TDataSource;

// Возвращает источник данных

begin
Result := FDataLink.DataSource end;

procedure TFarDbTextAppearence.SetDataField(

const Value: String); // Устанавливает имя поля данных begin
FDataLink.FieldName := Value end;

procedure TFarDbTextAppearence.SetDataSource(

Value: TDataSource); // Устанавливает источник данных begin
FDataLink.DataSource := Value;
if Value <>
NIL then
Value.FreeNotification(Self);

end; end.

Этот модуль является классической иллюстрацией компонента для работы с базами данных (см. главу 12). Его поле FDataLink представляет собой канал связи с данными. В конструкторе этот канал создается, в деструкторе уничтожается. Настройка канала заключается в том, что создаются компонентные свойства DataSource и DataField для настройки соответствующих свойств канала и определяется обработчик его события OnDataChange.

Модуль компонента FarlmageAppearence представлен в листинге 15.12.

Листинг 15.12. Модуль компонента FarlmageAppearence unit FarlmageApp;

Компонент наследует от TFarGraphic основную функциональность. Он вводит дополнительное свойство AutoSize и публикует свойство Picture, которое у родителя объявлено в секции protected.

interface uses

Classes, FarAppearence; type TFarlmageAppearence = class(TFarGraphic) private FAutoSize: Boolean; protected procedure SetAutoSize(Value: Boolean); procedure PictureChanged(Sender: TObject); public

constructor Create(AOwner: TComponent); override; published

property AutoSize: Boolean read FAutoSize

write SetAutoSize default True;
property Picture;
end;

procedure Registers-implementation .*

procedure Registers-begin
RegisterComponents('Far', [TFarlmageAppearence]);
end;
{ TFarlmageAppearence }
constructor TFarImageAppearence.Create(AOwner: TComponent); // Устанавливает обработчик события OnChange хранилища // изображения и умалчиваемые значения свойств begin
inherited;
Picture.OnChange := PictureChanged;
FAutoSize := True;
Height :- 105;
продолжение &
Листинг 15.12 (продолжение)
Width := 105; SetCanvases;
end;
procedure TFarlmageAppearence.PictureChanged(Sender: TObject);

// Реакция на изменение изображения

begin
if AutoSize and (Picture.Width > 0) and (Picture.Height > 0) then
SetBounds(Left, Top, Picture.Width, Picture.Height);
SetCanvases;
Invalidate;
end;

t*

procedure TFarlmageAppearence.SetAutoSize(Value: Boolean);
begin
if Value <>
FAutoSize then begin
FAutoSize :~ Value;
PictureChanged(Self) end end;

end.

В обработчике PictureChanged проверяется свойство AutoSize и корректируются размеры компонента с помощью вызова унаследованного метода SetBounds.

Модуль компонента FarDBImageAppearence представлен в листинге 15.13.

Листинг 15.13. Модуль компонента FarDBImageAppearence unit FarDBImageApp;

Компонент наследует от TFarlmageAppearence и предназначен для работы с базами данных.

interface

uses

Classes, FarlmageApp, DBCtrls, DB; type TFarDblmageAppearence = class(TFarlmageAppearence) private FDataLink: TFieldDataLink; protected procedure SetDataSource(Value: TDataSource); function GetDataSource: TDataSource; procedure SetDataField(Const Value: String); function GetDataField: String; procedure DataChange(Sender: TObject); public

constructor Create(AOwner: TComponent); override; destructor Destroy; override; published

property DataSource: TDataSource read GetDataSource

write SetDataSource; property DataField: String read GetDataField

write SetDataField;

ends-procedure Registers-implementation

procedure Registers-begin
RegisterComponents(' Far1, [TFarDBImageAppearence]);
end;
{ TFarDblmageAppearence }
constructor TFarDblmageAppearence.Create(AOwner: TComponent);

// Создает канал связи

begin inherited; *

FDataLink := TFieldDataLink.Create;
FDataLink.OnDataChange := DataChange;
ends-procedure TFarDblmageAppearence.DataChange(Sender: TObj ect); // Реакция на смену изображения begin
if FDataLink.Field = NIL then
Picture := NIL else
Picture.Assign(FDataLink.Field)
endsdestructor TFarDblmageAppearence.Destroy; // Уничтожает канал связи продолжение &
Листинг 15.13 (продолжение) begin
FDataLink.Free;
inherited;
end;
function TFarDblmageAppearence.GetDataField: String;

// Возвращает имя поля с данными

begin
Result := FDataLink.FieldName end;
function TFarDblmageAppearence.GetDataSource: TDataSource;

// Возвращает источник данных

begin
Result : = FDataLink. DataSource <■
end;

procedure TFarDblmageAppearence.SetDataField(

const Value: String); // Устанавливает имя поля данных begin
FDataLink.FieldName := Value end;

procedure TFarDblmageAppearence.SetDataSource(

Value: TDataSource); // Устанавливает источник данных begin
FDataLink.DataSource := Value if Value о NIL then
Value.FreeNotification(Self);

end; end.

Замечу, что все рассмотренные в этом разделе компоненты при желании можно оснастить редакторами, подобными описанному в 14.4.3.

15.6. Компоненты ХХХХАрреаrеnсе || Оглавление || Компоненты независимых разработчиков


Искусство создания компонентов Delphi



Новости за месяц

  • Май
    2019
  • Пн
  • Вт
  • Ср
  • Чт
  • Пт
  • Сб
  • Вс