Внедрение и линковка компонентов. Пример.
| Раздел Сокровищница | рбань С.В.,
дата публикации 18 марта 2002г. |
Модуль демонстрирует возможности по "Внедрению" и "Сцепке" компонентов. В основном все д/б понятно из подстрочных комментариев. Для чего нужно: Задача - содать специализированный LightWeight вариант TChart. Работа ведется несколькими программистами. ВСЕ элементы д/б объектами, а по возможности и самостоятельными компонентами. Например - полоса скроллинга по данным. Она должна быть либо "встроенной" (принадлежать базовому компоненту) либо внешней. Причем при работе (в приложении) различий быть не должно...
Первый маленький элемент - полоса скроллинга по данным и контейнер для нее. Компонент вполне самостоятельный и вполне может быть полезен Вне контекста задачи.
Примечания:
- 1. В первую очередь проект предназначен для обучения. В том числе и меня :-)) Поэтому "не стреляйте в пианиста...". Если есть лучшее решение - ДАВАЙТЕ ЕГО СЮДА!!!->>> Fox1225@Mail.ru
- 2. Весь код приведенный здесь может использоваться As Is и все такое... Я не силен в лицензионных соглашениях. Просто берите и пользуйтесь. На свой страх и риск, разумеется :-))
- 3. Все Ваши комментарии можно мылить по адресу: Fox1225@Mail.ru}
Глюкобаги:
- 1. Гляньте в конструктор. Там есть вопросик...
- 2. Есть БОЛЬШАЯ бяка - смотрите TModContainer.CreateComponent
unit AltChartMain;
interface {Заранее извиняюсь за цветовую гамму... Делайте как кому нравится :-)} {ВНИМАНИЕ!!!! Пример тестировался под D6, и меня предупредили, что в D5 нет SetSubComponent. Самому проверить негде, так что будте внимательны!}
uses Windows, Messages, SysUtils, Classes, Controls, StdCtrls, ExtCtrls, Graphics, Math, MyMath;
resourcestring SMinMaxError = 'Max ДОЛЖЕН быть больше Min. EMinMaxError.'+Chr(13)+Chr(13);
type EMinMaxError =
class(Exception); //Попытка задать Min > Max TGraphScrollKind = (skHorizontal, skVertical); TGraphScrollLayout = (slTop, slCenter, slBottom); //Полоса скроллинга по данным TGraphScroll =
class(TGraphicControl)
private FLineWidth: Integer; FLineColor: TColor; FSliderWidth: Integer; FSliderLength: Integer; FSliderColor: TColor; FHSC: Integer; //Horisontal Slider Center. Для ускорения отрисовки. FVSC: Integer; //Vertical Slider Center. Для ускорения отрисовки. FPosition: Integer; FSliderRect: TRect; //Это чтобы по быстрому определить, ткнули мы мышом по слайдеру или нет... FMin: Integer; FMax: Integer; FSliderCaptured: Boolean; FGraphScrollKind: TGraphScrollKind; //Слайдер зацепили мышом... FBegDragCoord: TPoint; //Коорд. мыша в момент "зацепа" FBegDragPos: Integer; //Position в момент "зацепа" FGraphScrollLayout: TGraphScrollLayout;
procedure (
const Index, Value: Integer);
procedure (
const Index: Integer;
const Value: TColor);
procedure (AMin, AMax, APosition: Integer);
procedure ;
procedure (
const Value: Integer);
procedure (
const Value: Integer);
procedure (
const Index, Value: Integer);
procedure (
const Value: TGraphScrollKind);
procedure (
const Value: TGraphScrollLayout);
protected procedure ;
override;
procedure ;
override;
procedure (Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
override;
procedure (Shift: TShiftState; X, Y: Integer);
override;
procedure (Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
override;
procedure (
var MinWidth, MinHeight, MaxWidth, MaxHeight: Integer);
override;
procedure ;
override;
function (
var NewWidth, NewHeight: Integer): Boolean;
override;
public constructor Create(AOwner: TComponent);
override;
published property Anchors;
property Align;
property AutoSize;
property LineColor: TColor
index 0
read FLineColor
write SetColor;
property SliderColor: TColor
index 1
read FSliderColor
write SetColor; property LineWidth: Integer
index 0
read FLineWidth
write SetGeometry;
property SliderWidth: Integer
index 1
read FSliderWidth
write SetGeometry;
property SliderLength: Integer
index 2
read FSliderLength
write SetGeometry;
property Position: Integer
index 0
read FPosition
write SetPosition;
property Min: Integer
read FMin
write SetMin;
property Max: Integer
read FMax
write SetMax;
property Kind: TGraphScrollKind
read FGraphScrollKind
write SetGraphScrollKind;
property Layout: TGraphScrollLayout
read FGraphScrollLayout
write SetGraphScrollLayout;
end; //Компонент - контейнер TModContainer =
class(TPanel)
private FComponent: TGraphScroll;
procedure ;
procedure (
const Value: TGraphScroll);
protected procedure (AComponent: TComponent; Operation: TOperation);
override;
public constructor Create(AOwner: TComponent);
override;
published property Component: TGraphScroll
read FComponent
write SetComponent;
end;
procedure ;
implementation procedure Register;
begin RegisterComponents('Samples', [TGraphScroll, TModContainer]);
end; { TGraphScroll }
constructor TGraphScroll.Create(AOwner: TComponent);
begin Inherited Create(AOwner); //"сетапим" компонент... FLineWidth:=3; FLineColor:=clNavy; FSliderWidth:=7; FSliderLength:=40; FSliderColor:=clTeal; FMax:=100; FPosition:=30; Width:=200; Height:=11; //Странно, но значения меньше 10 НЕ принимаются! Почему? Кто объяснит дремучему? Align:=alBottom; RecalcGeometry;
end;
procedure TGraphScroll.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin inherited; If InRect(X, Y, FSliderRect)
Then begin FSliderCaptured:=True; FBegDragCoord.X:=X; FBegDragCoord.Y:=Y; FBegDragPos:=Position;
end;
end;
procedure TGraphScroll.MouseMove(Shift: TShiftState; X, Y: Integer);
begin inherited;
If FSliderCaptured
Then If Kind = skHorizontal
Then Position:=FBegDragPos+Round((X-FBegDragCoord.X)*(Max-Min)/Width)
Else Position:=FBegDragPos+Round((Y-FBegDragCoord.Y)*(Max-Min)/Height);
end;
procedure TGraphScroll.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin inherited; FSliderCaptured:=False; Refresh;
end;
procedure TGraphScroll.RecalcGeometry;
Var WorkZone: Integer;
begin //Гммм... если кто-нибудь сможет упростить эти монструозные формулы - буду благодарен... //Однако будте внимательны! //If по Kind'у меня уже достал... Нужно как-то более гибко...
If Kind = skHorizontal
Then begin WorkZone:=Width - SliderLength - SliderWidth - 3; //Левый край FSliderRect.Left:=Round(WorkZone*(FPosition-FMin)/(FMax-FMin))+SliderWidth
div 2 + 2; //Правый край FSliderRect.Right:=FSliderRect.Left+SliderLength; //Горизонтальный центр слайдера (нужен для рисования риски) FHSC:=EnsureRange(FSliderRect.Left+Floor(SliderLength / 2), 0, Width-1); //"Вертикальные" параметры. Зависят от Layout.
Case Layout
of //ВНИМАНИЕ!!!! Может кому пригодится! У нас есть св-во Max, а нам нужна ф-ия Max из //модуля Math. Поэтому - Math.Max. Вроде-бы просто, но какую я шишку год назад набил на этом... slTop: FVSC:=Math.Max(SliderWidth, LineWidth)
div 2; slCenter: FVSC:=Height
div 2; slBottom: FVSC:=Height - Math.Max(SliderWidth, LineWidth)
div 2 - 2;
End; //Верх бегунка FSliderRect.Top:=FVSC - SliderWidth
div 2; //Низ бегунка FSliderRect.Bottom:=FSliderRect.Top+SliderWidth;
end Else begin WorkZone:=Height - SliderLength - SliderWidth - 3; //Верх бегунка FSliderRect.Top:=Round(WorkZone*(FPosition-FMin)/(FMax-FMin))+SliderLength
div 2 + 2; //Низ бегунка FSliderRect.Bottom:=FSliderRect.Top+SliderLength; //Горизонтальный центр (при skVertical становится Вертикальным Центром) слайдера (нужен для рисования риски) FHSC:=EnsureRange(FSliderRect.Top+Floor(SliderLength / 2), 0, Height-1); //"Вертикальные" параметры. Зависят от Layout.
Case Layout
of //ВНИМАНИЕ!!!! Может кому пригодится! У нас есть св-во Max, а нам нужна ф-ия Max из //модуля Math. Поэтому - Math.Max. Вроде-бы просто, но какую я шишку год назад набил на этом... slTop: FVSC:=Math.Max(SliderWidth, LineWidth)
div 2; slCenter: FVSC:=Width
div 2; slBottom: FVSC:=Width - Math.Max(SliderWidth, LineWidth)
div 2 - 2;
End; //Левый край бегунка FSliderRect.Left:=FVSC - SliderWidth
div 2; //Правый край бегунка FSliderRect.Right:=FSliderRect.Left+SliderWidth;
end;
end;
procedure TGraphScroll.Paint;
Var LWD2: Integer; //LineWidth div 2//
begin //Предложения по "украшательству" компонента принимаются с радостью, но только не в ущерб СКОРОСТИ //Предложения, как избавиться от мерцания, принимаются ВНЕ очереди! //С удовольствием выслушаю предложения, как избавиться от If'ов по Kind'у. Уж больно громоздко... LWD2:=LineWidth
div 2 + 1; //При рисовании толстой линии ее концы скругляются "наружу", чтобы их НЕ //подрезать (красиво выглядит), даем для них отступ... With Canvas
do begin //Рисуем линию. Без комментариев... Pen.Width:=LineWidth; Pen.Color:=LineColor;
If Kind = skHorizontal
Then begin MoveTo(LWD2, FVSC);//0 + ширина линии | Так получаются скругленные концы LineTo(Width-LWD2-1, FVSC); //ширина - ширина линии |
end Else begin MoveTo(FVSC, LWD2); //0 + ширина линии | Так получаются скругленные концы LineTo(FVSC, Height-LWD2-1); //ширина - ширина линии |
end; //Рисуем "слайдер" (бегунок, он же ползунок, по буржуйски - Slider). Без комментариев... Pen.Width:=SliderWidth; Pen.Color:=SliderColor;
If Kind = skHorizontal
Then begin MoveTo(FSliderRect.Left, FVSC); LineTo(FSliderRect.Right, FVSC);
end Else begin MoveTo(FVSC, FSliderRect.Top); LineTo(FVSC, FSliderRect.Bottom);
end; //Рисуем центральную риску на бегунке. Pen.Width:=1;
If FSliderCaptured
Then //Если бегунок "захвачен" (двигается мышом...) Pen.Color:=clRed //Рисуем красным цветом
Else Pen.Color:=clBlack; //Если нет - черным...
If Kind = skHorizontal
Then begin MoveTo(FHSC, FSliderRect.Top); LineTo(FHSC, FSliderRect.Bottom);
end Else begin MoveTo(FSliderRect.Left, FHSC); LineTo(FSliderRect.Right, FHSC);
end;
end;
end;
procedure TGraphScroll.Resize;
begin //При изменении размера надо пересчитать все переменные, используемы для отрисовки компонента...
inherited Resize; RecalcGeometry; Refresh;
end;
procedure TGraphScroll.SetColor(
const Index: Integer;
const Value: TColor);
begin //Все стандартно... Case
Index of 0: FLineColor := Value; 1: FSliderColor:=Value;
End; Refresh;
end;
procedure TGraphScroll.SetGeometry(
const Index, Value: Integer);
begin //Тоже стандартно... Case
Index of 0: FLineWidth:=Value; 1: FSliderWidth:=Value; 2: FSliderLength:=Value;
End; RecalcGeometry; Refresh;
end;
procedure TGraphScroll.SetGraphScrollKind(
const Value: TGraphScrollKind);
Var Tmp: Integer;
begin If FGraphScrollKind <> Value
then //Если НЕ текущее значение
begin FGraphScrollKind:=Value; //Присвоим новое...
If not (csLoading
in ComponentState) and //Если не в состоянии загрузки И //Выравнивание alNone или alCustom или alClient ((Align = alNone)
or (Align = alCustom)
or (Align = alClient))
then begin //"Переворачиваем" компонент (меняем местами высоту и ширину...) Tmp:=Height; Height:=Width; Width:=Tmp;
end; end; RecalcGeometry; Refresh;
end;
procedure TGraphScroll.SetGraphScrollLayout(
const Value: TGraphScrollLayout);
begin //Процедура смены Layout'а. Все просто... Что такое Layout - смотри TLabel FGraphScrollLayout:=Value; RecalcGeometry; Refresh;
end;
procedure TGraphScroll.SetMax(
const Value: Integer);
begin SetValues(FMin, Value, FPosition);
end;
procedure TGraphScroll.SetMin(
const Value: Integer);
begin SetValues(Value, FMax, FPosition);
end;
procedure TGraphScroll.SetPosition(
const Index, Value: Integer);
begin SetValues(FMin, FMax, Value);
end;
procedure TGraphScroll.SetValues(AMin, AMax, APosition: Integer);
begin If AMax < AMin
then //Максимум ДОЛЖЕН быть больше минимума
raise EMinMaxError.Create(SMinMaxError+'TGraphScroll.SetValues'); FMin:=AMin; FMax:=AMax; FPosition:=EnsureRange(APosition, FMin, FMax); RecalcGeometry; Refresh;
end;
procedure TGraphScroll.ConstrainedResize(
var MinWidth, MinHeight, MaxWidth, MaxHeight: Integer); //Перекрыв этот метод TControl можно задать мин и макс. р-ры компонента. //В нашем случае - компонент не может быть ниже ширины Math.Max(LineWidth, SliderWidth); //И уже MinWidth:=SliderLength+2*LineWidth+2*SliderWidth; //ЕСЛИ вертикально расположенный - наоборот...
begin If Kind = skHorizontal
Then begin MinWidth:=SliderLength+2*LineWidth+2*SliderWidth; MinHeight:=Math.Max(LineWidth, SliderWidth);
end Else begin MinWidth:=Math.Max(LineWidth, SliderWidth); MinHeight:=SliderLength+2*LineWidth+2*SliderWidth;
end;
end;
procedure TGraphScroll.RequestAlign;
begin Inherited; //Меняем тип Kind'а при изменении выравнивания.
If ((Align = alTop)
or (Align = alBottom))
and (Kind <> skHorizontal)
Then Kind:=skHorizontal;
If ((Align = alLeft)
or (Align = alRight))
and (Kind <> skVertical)
Then Kind:=skVertical;
end;
function TGraphScroll.CanAutoSize(
var NewWidth, NewHeight: Integer): Boolean;
begin //Перекрываем унаследованную "автосайзилку". Код слизан с TImage и поэтому работает :-) Result:=True;
if not (csDesigning
in ComponentState)
or (LineWidth > 0)
and (SliderWidth > 0)
then begin if (Align
in [alNone, alLeft, alRight])
and (Kind = skVertical)
then NewWidth:=Math.Max(LineWidth, SliderWidth);
if (Align
in [alNone, alTop, alBottom])
and (Kind <> skVertical)
then NewHeight:=Math.Max(LineWidth, SliderWidth);
end;
end; { TModContainer }
constructor TModContainer.Create(AOwner: TComponent);
begin inherited Create(AOwner); //Ну, это святое... Width:=400; Height:=150; CreateComponent; //Создание к-та собрано в процедуру, так как используется еще и в SetComponent
end;
procedure TModContainer.CreateComponent;
begin FComponent:=TGraphScroll.Create(Self); //Создаем к-т FComponent.
Name:='IntCnt'; //Даем ему имя (необязательно...) FComponent.SetSubComponent(True); //Устанавливаем флаг "SubComponent" FComponent.FreeNotification(Self); //Хотим получать уведомление об уничтожении FComponent.Parent:=Self; //ВАЖНО!!!! Ставим себя "Родителем" FComponent.Width:=Width-20; //Располагаем и образмериваем... FComponent.Top:=Height-20; // ------//------- FComponent.Left:=10; // ------//------- // FComponent.Anchors:=[akBottom, akLeft, akRight]; //А вот с якорями пока решения нету. //Ставим "ручками" в DesignTime //Суть прикола такова - "якоря" цепляются раньше, чем загружаются размеры контейнерного компонента //из файла формы. (ВСЕ креэйты отрабатваю раньше загрузки). Как я понял: контейнерный компонент создается //с размерами Width:=400; Height:=150; , на нем создается FComponent, который цепляется якорями, а затем //читаются данные из файла формы, например Width:=800; - Результат - внедренные к-ты с установленными akLeft+akRight или //akTop+akBottom растягиваются (сжимаются) при КАЖДОЙ загрузке формы в Design Time. //В Ран тайм все нормально... но...
end;
procedure TModContainer.Notification(AComponent: TComponent; Operation: TOperation); //*Fox* Процедура отслеживающая удаление встроенных объектов //См. справку "Creating properties for subcomponents"
begin inherited Notification(AComponent, Operation); //Ну, это святое... //Если "наш" компонент и его удаляют
If (AComponent = FComponent)
and (Operation = opRemove)
Then FComponent:=nil; //Обнулим линк на него...
end;
procedure TModContainer.SetComponent(
const Value: TGraphScroll); //*Fox* Процедура ответственная за "линковку" FComponent //Если линкуем внешний скроллер - внутренний высвобождается //Если удаляем внешний (присваиваем nil) - создается внутрений //См. справку "Creating properties for subcomponents"
begin If Value <> FComponent
Then //Если предлагают НЕ то, что уже есть... begin If Value <>
nil Then //Если линкуем внешний begin If (FComponent <>
nil)
and (FComponent.Owner = Self)
Then //Если сейчас НЕ пустой и Свой FComponent.Free; //Удалим его FComponent:=Value; //Прицепим то, что предлагают... FComponent.FreeNotification(Self); //Хотим получать уведомление об уничтожении
end Else //Если удаляем внешний (присв. nil) begin If FComponent.Owner <> Self Then //Если убрали внешний - создадим внутренний CreateComponent;
end;
end;
end;
end.
Скачать пример: (11 K)
Этот код является плодом обсуждения проблемы на Круглом столе между рем Шевченко.
Горбань С.В.
Специально для
Содержание Назад Вперед
