vrswitch.pas

作工控的好控件

    SetThumbTop(Value) else SetThumbLeft(Value);

  PaintThumb;
  inherited Paint;
end;

procedure TVrSwitch.PaintThumb;
var
  Index: Integer;
  SrcRect: TRect;
  TransColor: TColor;
begin
  Index := 0;
  if not Enabled then Index := 1;
  if FThumbDown then Index := 2;
  if (FThumbHasMouse) and (not FThumbDown) then Index := 3;
  if Index > ThumbStates - 1 then Index := 0;

  SrcRect := Bounds(Index * FThumbWidth, 0, FThumbWidth, FThumbHeight);
  with BitmapCanvas do
  begin
    TransColor := FThumbImage.TransparentColor;
    Brush.Color := TransColor;
    if soThumbOpaque in Options then Brush.Style := bsSolid
    else Brush.Style := bsClear;
    BrushCopy(FThumbRect, FThumbImage, SrcRect, TransColor);
  end;
end;

procedure TVrSwitch.AdjustControlSize;
var
  NewWidth, NewHeight: Integer;
begin
  if Orientation = voHorizontal then
  begin
    NewWidth := (FThumbWidth * FPositions) + (BorderWidth * 2);
    NewHeight := MaxIntVal(FThumbHeight + FBorderWidth * 2, Height);
  end
  else
  begin
    NewWidth := MaxIntVal(FThumbWidth + FBorderWidth * 2, Width);
    NewHeight := (FThumbHeight * FPositions) + (BorderWidth * 2);
  end;
  BoundsRect := Bounds(Left, Top, NewWidth, NewHeight);
end;

procedure TVrSwitch.WMSize(var Message: TWMSize);
begin
  inherited;
  AdjustControlSize;
  CenterThumb;
end;

procedure TVrSwitch.WMSetCursor(var Message: TWMSetCursor);
var
  P: TPoint;
begin
  GetCursorPos(P);
  if (not Designing) and PtInRect(FThumbRect, ScreenToClient(P)) then
  begin
    if (soHandPoint in Options) then
      Windows.SetCursor(Screen.Cursors[VrCursorHandPoint]);
  end else inherited;
end;

procedure TVrSwitch.WMGetDlgCode(var Msg: TWMGetDlgCode);
begin
  Msg.Result := DLGC_WANTARROWS;
end;

procedure TVrSwitch.CMFocusChanged(var Message: TCMFocusChanged);
var
  Active: Boolean;
begin
  with Message do Active := (Sender = Self);
  if Active <> FFocused then
  begin
    FFocused := Active;
    UpdateControlCanvas;
  end;
  inherited;
end;

procedure TVrSwitch.CMEnabledChanged(var Message: TMessage);
begin
  inherited;
  UpdateControlCanvas;
end;

procedure TVrSwitch.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) then
    if AComponent = BitmapList then BitmapList := nil;
end;

function TVrSwitch.GetBitmap(Index: Integer): TBitmap;
begin
  Result := nil;
  if Assigned(FBitmapList) then
    Result := FBitmapList.GetBitmap(Index);
end;

procedure TVrSwitch.Change;
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;

procedure TVrSwitch.SetThumbStates(Value: TVrNumGlyphs);
begin
  if FThumbStates <> Value then
  begin
    FThumbStates := Value;
    if not Loading then
      GetThumbImage;
    UpdateControlCanvas;
  end;
end;

procedure TVrSwitch.SetThumbIndent(Value: Integer);
begin
  if (FThumbIndent <> Value) and (Value >= 0) then
  begin
    FThumbIndent := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrSwitch.SetBackImageIndex(Value: Integer);
begin
  if FBackImageIndex <> Value then
  begin
    FBackImageIndex := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrSwitch.SetThumbImageIndex(Value: Integer);
begin
  if FThumbImageIndex <> Value then
  begin
    FThumbImageIndex := Value;
    GetThumbImage;
    UpdateControlCanvas;
  end;
end;

procedure TVrSwitch.SetBitmapList(Value: TVrBitmapList);
begin
  if FBitmapList <> nil then
    FBitmapList.RemoveLink(FBitmapListLink);
  FBitmapList := Value;
  if FBitmapList <> nil then
    FBitmapList.InsertLink(FBitmapListLink);

  GetThumbImage;
  UpdateControlCanvas;
end;

procedure TVrSwitch.SetOrientation(Value: TVrOrientation);
begin
  if FOrientation <> Value then
  begin
    FOrientation := Value;
    GetThumbImage;
    if not Loading then
    begin
      BoundsRect := Bounds(Left, Top, Height, Width);
      AdjustControlSize;
    end;
    UpdateControlCanvas;
  end;
end;

procedure TVrSwitch.SetStyle(Value: TVrProgressStyle);
begin
  if FStyle <> Value then
  begin
    FStyle := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrSwitch.SetOffset(Value: Integer);
begin
  if Value < 0 then Value := 0;
  if Value > Positions - 1 then Value := Positions - 1;
  if FOffset <> Value then
  begin
    FOffset := Value;
    UpdateControlCanvas;
    Change;
  end;
end;

procedure TVrSwitch.SetPositions(Value: Integer);
begin
  if FPositions <> Value then
  begin
    FPositions := Value;
    AdjustControlSize;
  end;
end;

procedure TVrSwitch.SetOptions(Value: TVrSwitchOptions);
begin
  if FOptions <> Value then
  begin
    FOptions := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrSwitch.SetBorderColor(Value: TColor);
begin
  if FBorderColor <> Value then
  begin
    FBorderColor := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrSwitch.SetBorderWidth(Value: Integer);
begin
  if (FBorderWidth <> Value) and (Value >= 0) then
  begin
    FBorderWidth := Value;
    AdjustControlSize;
    UpdateControlCanvas;
  end;
end;

procedure TVrSwitch.SetFocusColor(Value: TColor);
begin
  if FFocusColor <> Value then
  begin
    FFocusColor := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrSwitch.SetBevel(Value: TVrBevel);
begin
  FBevel.Assign(Value);
end;

procedure TVrSwitch.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  R: TRect;
  P: TPoint;
begin
  inherited MouseDown(Button, Shift, X, Y);
  if (Button = mbLeft) then
  begin
    if TabStop then SetFocus;
    P := Point(X, Y);
    if PtInRect(FThumbRect, P) then
    begin
      FThumbDown := True;
      if Orientation = voHorizontal then FHit := X - FThumbRect.Left
      else FHit := Y - FThumbRect.Top;
      if (soMouseClip in Options) then
      begin
        R := Bounds(ClientOrigin.X, ClientOrigin.Y,
          ClientWidth, ClientHeight);
        ClipCursor(@R);
        FClipOn := True;
      end;
      UpdateControlCanvas;
    end
    else
    if (soActiveClick in Options) then
    begin
      if Orientation = voHorizontal then
        FHit := X - FThumbWidth div 2
      else FHit := Y - FThumbHeight div 2;
      SetThumbOffset(FHit);
    end;
  end;
end;

procedure TVrSwitch.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  OldValue: Boolean;
begin
  if FThumbDown then
  begin
    if FOrientation = voVertical then
      SetThumbOffset(Y - FHit)
    else
      SetThumbOffset(X - FHit);
  end
  else
  begin
    OldValue := FThumbHasMouse;
    FThumbHasMouse := PtInRect(FThumbRect, Point(X, Y));
    if OldValue <> FThumbHasMouse then UpdateControlCanvas;
  end;
  inherited MouseMove(Shift, X, Y);
end;

procedure TVrSwitch.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  if FThumbDown then
  begin
    FThumbDown := false;
    UpdateControlCanvas;
  end;

  if FClipOn then
  begin
    ClipCursor(nil);
    FClipOn := false;
  end;

  inherited MouseUp(Button, Shift, X, Y);
end;

procedure TVrSwitch.KeyDown(var Key: Word; Shift: TShiftState);

  function Adjust(Value: Integer): Integer;
  begin
    Result := Value;
    if Style = psTopRight then Result := -Result;
  end;

begin
  if Shift = [] then
  begin
    if Key = VK_HOME then Offset := 0
    else if Key = VK_END then Offset := Positions - 1;
    if Orientation = voHorizontal then
    begin
      if Key = VK_LEFT then Offset := Offset + Adjust(-1)
      else if Key = VK_RIGHT then Offset := Offset + Adjust(1);
    end
    else
    begin
      if Key = VK_UP then Offset := Offset + Adjust(1)
      else if Key = VK_DOWN then Offset := Offset + Adjust(-1);
    end;
  end;
  inherited KeyDown(Key, Shift);
end;


end.