Статьи Королевства Дельфи


Внедрение и линковка компонентов. Пример.


Раздел Сокровищница рбань С.В.,
дата публикации 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)

Этот код является плодом обсуждения проблемы на Круглом столе между рем Шевченко.

Горбань С.В.
Специально для





Начало  Назад  Вперед



Книжный магазин