Создание компонента Slider для Delphi XE

LIONSMILE · #1 18.12.2018, 18:38

Доброго времени суток!

Возникла необходимость использования компонента типа "Слайдер" - переключатель на два положения. Поискав в интернете, нашел нечто подобное, которое меня устраивает вполне на Stackoverflow https://stackoverflow.com/questions/...imilar-to-ipad.
Нижеприведенный код, замечательно компилируется и работает в Delphi 7.

Код:

unit OnOffSwitch;

interface

uses
  Classes, Controls, Windows, Messages, Graphics, Themes;

type
  TOnOffSwitch = class(TCustomControl)
  private
    FMouseHover: Boolean;
    FOff: Boolean;
    FSliderRect: TRect;
    procedure SetMouseHover(Value: Boolean);
    procedure SetOff(Value: Boolean);
    procedure UpdateSliderRect;
    procedure WMWindowPosChanged(var Message: TWMWindowPosChanged);
      message WM_WINDOWPOSCHANGED;
    procedure CMEnabledChanged(var Message: TMessage);
      message CM_ENABLEDCHANGED;
    procedure CMFocusChanged(var Message: TCMFocusChanged);
      message CM_FOCUSCHANGED;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
  protected
    procedure KeyUp(var Key: Word; Shift: TShiftState); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property Anchors;
    property Constraints;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Font;
    property Off: Boolean read FOff write SetOff default True;
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDock;
    property OnStartDrag;
    property ParentFont default False;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop default True;
    property Visible;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Samples', [TOnOffSwitch]);
end;

{ TOnOffSwitch }

resourcestring
  SOff = 'OFF';
  SOn = 'ON';

procedure TOnOffSwitch.CMEnabledChanged(var Message: TMessage);
begin
  Invalidate;
  inherited;
end;

procedure TOnOffSwitch.CMFocusChanged(var Message: TCMFocusChanged);
begin
  Invalidate;
  inherited;
end;

procedure TOnOffSwitch.CMMouseLeave(var Message: TMessage);
begin
  SetMouseHover(False);
  inherited;
end;

constructor TOnOffSwitch.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := [csCaptureMouse, csClickEvents, csDoubleClicks, csOpaque];
  FOff := True;
  Caption := SOff;
  Width := 75;
  Height := 25;
  TabStop := True;
  Font.Name := 'Tahoma';
  Font.Style := [fsBold];
end;

procedure TOnOffSwitch.KeyUp(var Key: Word; Shift: TShiftState);
begin
  if Key = VK_SPACE then
    SetOff(not FOff);
  inherited KeyUp(Key, Shift);
end;

procedure TOnOffSwitch.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  if (Shift = [ssLeft]) and PtInRect(FSliderRect, Point(X, Y)) then
    SetOff(not FOff);
  inherited MouseDown(Button, Shift, X, Y);
end;

procedure TOnOffSwitch.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  if GetCaptureControl = nil then
    SetMouseHover(PtInRect(FSliderRect, Point(X, Y)));
  inherited MouseMove(Shift, X, Y);
end;

procedure TOnOffSwitch.Paint;
var
  Button: TThemedButton;
  PaintRect: TRect;
  Details: TThemedElementDetails;
begin
  if ThemeServices.ThemesAvailable then
  begin
    if not Enabled then
      Button := tbPushButtonDisabled
    else if not FOff then
      Button := tbPushButtonPressed
    else
      Button := tbPushButtonNormal;
    PaintRect := ClientRect;
    Details := ThemeServices.GetElementDetails(Button);
    ThemeServices.DrawElement(Canvas.Handle, Details, PaintRect);
    if FOff then
      Inc(PaintRect.Left, Round(2 / 5 * Width))
    else
      Dec(PaintRect.Right, Round(2 / 5 * Width));
    Canvas.Brush.Style := bsClear;
    Canvas.Font := Self.Font;
    if not Enabled then
      Canvas.Font.Color := $00A0A0A0
    else
      Canvas.Font.Color := $00555555;
    DrawText(Canvas.Handle, PChar(Caption), -1, PaintRect, DT_CENTER or
      DT_VCENTER or DT_SINGLELINE);
    if Enabled and not FOff then
    begin
      OffsetRect(PaintRect, 0, 1);
      Canvas.Font.Color := clWhite;
      DrawText(Canvas.Handle, PChar(Caption), -1, PaintRect, DT_CENTER or
        DT_VCENTER or DT_SINGLELINE);
    end;
    if not Enabled then
      Button := tbPushButtonDisabled
    else if Focused then
      Button := tbPushButtonDefaulted
    else if FMouseHover then
      Button := tbPushButtonHot
    else
      Button := tbPushButtonNormal;
    PaintRect := FSliderRect;
    Details := ThemeServices.GetElementDetails(Button);
    ThemeServices.DrawElement(Canvas.Handle, Details, PaintRect);
    if Focused then
    begin
      PaintRect := ThemeServices.ContentRect(Canvas.Handle, Details, PaintRect);
      SetTextColor(Canvas.Handle, clWhite);
      DrawFocusRect(Canvas.Handle, PaintRect);
    end;
  end;
end;

procedure TOnOffSwitch.SetMouseHover(Value: Boolean);
begin
  if FMouseHover <> Value then
  begin
    FMouseHover := Value;
    Invalidate;
  end;
end;

procedure TOnOffSwitch.SetOff(Value: Boolean);
begin
  if FOff <> Value then
  begin
    FOff := Value;
    if FOff then
      Caption := SOff
    else
      Caption := SOn;
    UpdateSliderRect;
    Invalidate;
  end;
end;

procedure TOnOffSwitch.UpdateSliderRect;
begin
  if FOff then
    SetRect(FSliderRect, 0, 0, Round(2 / 5 * Width), Height)
  else
    SetRect(FSliderRect, Round(3 / 5 * Width), 0, Width, Height);
end;

procedure TOnOffSwitch.WMWindowPosChanged(var Message: TWMWindowPosChanged);
begin
  inherited;
  UpdateSliderRect;
  Font.Size := Round(Height div 3) + 1;
end;

end.

LNcWd.png
Но мне нужно его использовать в Delphi XE7, но он выкидывает кучу ошибок и не работает. Просто не вижу смысла из-за одного компонента ставить целый pack от TMS, в котором подобный компонент присутствует, тем более что еще и pack этот Trial.
Помогите пожалуйста переделать компонент для Delphi XE7, если Вам не трудно.
Проект прикрепляю Slider_XE.7z. Исходник брал отсюда - https://svn.apada.nl/svn/NLDelphi-op...LDOnOffSwitch/
Заранее огромное спасибо!

lmikle · #2 18.12.2018, 20:36

Ошибки какие?
Если не ошибаюсь, компилил ээтот компонент в D10 какой-то, все работалло. Только я его не ставил, создавал динамически.

LIONSMILE · #3 19.12.2018, 03:00

Была проблема с ThemeServices, которые в версиях Delphi XE идут как StyleServices, это я поправил, везде вроде бы

Код:

procedure TNLDOnOffSwitch.Paint;
var
  Button: TThemedButton;
  PaintRect: TRect;
  Details: TThemedElementDetails;
begin
  if StyleServices.Available then
  begin
    if not Enabled then
      Button := tbPushButtonDisabled
    else if not FOff then
      Button := tbPushButtonPressed
    else
      Button := tbPushButtonNormal;
    PaintRect := ClientRect;
    Details := StyleServices.GetElementDetails(Button);
StyleServices.DrawElement(Canvas.Handle, Details, PaintRect);
    if FOff then
      Inc(PaintRect.Left, Round(2 / 5 * Width))
    else
      Dec(PaintRect.Right, Round(2 / 5 * Width));
    Canvas.Brush.Style := bsClear;
    Canvas.Font := Self.Font;
    if not Enabled then
      Canvas.Font.Color := $00A0A0A0
    else
      Canvas.Font.Color := $00555555;
    DrawText(Canvas.Handle, PChar(Caption), -1, PaintRect, DT_CENTER or
      DT_VCENTER or DT_SINGLELINE);
    if Enabled and not FOff then
    begin
      OffsetRect(PaintRect, 0, 1);
      Canvas.Font.Color := clWhite;
      DrawText(Canvas.Handle, PChar(Caption), -1, PaintRect, DT_CENTER or
        DT_VCENTER or DT_SINGLELINE);
    end;
    if not Enabled then
      Button := tbPushButtonDisabled
    else if Focused then
      Button := tbPushButtonDefaulted
    else if FMouseHover then
      Button := tbPushButtonHot
    else
      Button := tbPushButtonNormal;
    PaintRect := FSliderRect;
    Details := StyleServices.GetElementDetails(Button);
    StyleServices.DrawElement(Canvas.Handle, Details, PaintRect);
    if Focused then
    begin
      PaintRect := StyleServices.GetElementContentRect(Canvas.Handle, Details, PaintRect);
      SetTextColor(Canvas.Handle, clWhite);
      DrawFocusRect(Canvas.Handle, PaintRect);
    end;
  end;
end;

Теперь ругается на вот эту строку

Код:

      PaintRect := StyleServices.GetElementContentRect(Canvas.Handle, Details, PaintRect);

Пишет - [dcc32 Error] NLDOnOffSwitch.pas(177): E2250 There is no overloaded version of 'GetElementContentRect' that can be called with these arguments - как говорит кривой переводчик гугл - Не существует перегруженной версии GetElementContentRect, которую можно вызывать с этими аргументами.

lmikle · #4 19.12.2018, 04:51

Ага, сигнатура метода, видимо, отличается. Нажми Ctrl+Space на имени метода, должна появиться подсказка. Там смотри типы параметров.

LIONSMILE · #5 20.12.2018, 08:59

Вот что он мне нарисовал
Ф1.JPG

lmikle · #6 20.12.2018, 20:24

Ну тут похоже порядок параметров другой.
В исходнике: Details, Canvas.Handle, PaintRect
А библиотечная функция ожидает: Canvas.Handle, Details, PaintRect
(еще там может быть четвертый - тот же PaintRect, если этот метод описан как procedure,а не как function.

LIONSMILE · #7 22.12.2018, 05:41

Оказывается все было куда проще, нужно было просто поменять классы, что я и сделал ранее, и просто пересоздать заново файл DPK. В итоге все получилось и работает.
ScreenXE7.png

Опции темы	Поиск в этой теме
Версия для печати Отправить на Email	Поиск в этой теме: Расширенный поиск
Опции просмотра
Линейный вид Комбинированный вид Древовидный вид

	Сайт	Форум	FAQ	RSS лента	Прочее
	Новости Исходники Компоненты Статьи Добавить исходник Поиск	Правила Поиск Сообщения за сегодня Пользователи Кто на форуме?	Delphi FAQ - 5000 статей DRKB - 4500 статей (ZIP-архив) Справочник функций и процедур Delphi Delphi Programming Guide Indy in Depth. Глубины Indy	Новости сайта Новости форума	Ссылки и Баннеры Donate О сайте Реклама Контакты

Этот пользователь сказал Спасибо lmikle за это полезное сообщение:
LIONSMILE (22.12.2018)