delphi – 类似于iPad的滑块(开/关)风格组件

任何人都知道开/关Delphi组件类似于iPad上的滑块控件？
TAdvSmoothSlider(http://www.tmssoftware.com/site/advsmoothslider.asp)是我迄今为止唯一找到的,但我不想购买/安装整个TMS Smooth Controls Pack.
有谁知道类似的组件？我已经有png格式的On / Off图像,因此基于png图像的组件也可以工作.
提前感谢任何回复/想法.
解决方法

你能用这样的东西吗？
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,Y)));
  inherited MouseMove(Shift,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,1);
      Canvas.Font.Color := clWhite;
      DrawText(Canvas.Handle,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,PaintRect);
    if Focused then
    begin
      PaintRect := ThemeServices.ContentRect(Canvas.Handle,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,Round(2 / 5 * Width),Height)
  else
    SetRect(FSliderRect,Round(3 / 5 * Width),Width,Height);
end;

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

end.
delphi – 类似于iPad的滑块(开/关)风格组件

解决方法

猜你在找的Delphi相关文章
