Оформил: DeeCo

Автор: Горбань С.В.

Первый маленький элемент - полоса скроллинга по данным и контейнер для нее. Компонент вполне самостоятельный и вполне может быть полезен Вне контекста задачи.

• 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)