Delphi World - Внедрение и линковка компонентов

Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...

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

Оформил: DeeCo

Модуль демонстрирует возможности по "Внедрению" и "Сцепке" компонентов. В основном все д/б понятно из подстрочных комментариев. Для чего нужно: Задача - содать специализированный 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 SetGeometry(const Index, Value: Integer);
    procedure SetColor(const Index: Integer; const Value: TColor);
    procedure SetValues(AMin, AMax, APosition: Integer);
    procedure RecalcGeometry;
    procedure SetMax(const Value: Integer);
    procedure SetMin(const Value: Integer);
    procedure SetPosition(const Index, Value: Integer);
    procedure SetGraphScrollKind(const Value: TGraphScrollKind);
    procedure SetGraphScrollLayout(const Value: TGraphScrollLayout);
  protected
    procedure Paint; override;
    procedure Resize; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure ConstrainedResize(var MinWidth, MinHeight, MaxWidth, MaxHeight:
      Integer); override;
    procedure RequestAlign; override;
    function CanAutoSize(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 CreateComponent;
    procedure SetComponent(const Value: TGraphScroll);
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation);
      override;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property Component: TGraphScroll read FComponent write SetComponent;
  end;

procedure Register;

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.

Скачать пример: AltChart.zip (11 K)