vrtrackbar.pas

来自「作工控的好控件」· PAS 代码 · 共 874 行 · 第 1/2 页

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 toThumbOpaque in Options then Brush.Style := bsSolid
    else Brush.Style := bsClear;
    BrushCopy(FThumbRect, FThumbImage, SrcRect, TransColor);
  end;
end;

procedure TVrTrackBar.DrawScale(Canvas: TCanvas; Offset, ThumbOffset,
  RulerLength, PointsStep, PointsHeight, ExtremePointsHeight: Integer);
const
  MinInterval = 3;
var
  Interval, Scale, Cnt, I, Value: Integer;
  X, H, X1, X2, Y1, Y2, Tmp: Integer;
  Range: Double;
begin
  Scale := 0;
  Range := FMaxValue - FMinValue;
  repeat
    Inc(Scale);
    Cnt := Round(Range / (Scale * PointsStep)) + 1;
    if Cnt > 1 then
      Interval := RulerLength div (Cnt - 1)
    else Interval := RulerLength;
  until (Interval >= MinInterval + 1) or (Interval >= RulerLength);
  Value := FMinValue;
  for I := 1 to Cnt do
  begin
    H := PointsHeight;
    if I = Cnt then Value := FMaxValue;
    if (Value = FMaxValue) or (Value = FMinValue) then H := ExtremePointsHeight;
    X := GetOffsetByValue(Value);
    if Orientation = voHorizontal then
    begin
      X1 := X + ThumbOffset;
      Y1 := Offset;
      X2 := X1;
      Y2 := Y1 + H;
      if Y1 > Y2 then
      begin
        Tmp := Y1;
        Y1 := Y2;
        Y2 := Tmp;
      end;
    end
    else
    begin
      X1 := Offset;
      Y1 := X + ThumbOffset;
      X2 := X1 + H;
      Y2 := Y1;
      if X1 > X2 then
      begin
        Tmp := X1;
        X1 := X2;
        X2 := Tmp;
      end;
    end;
    Canvas.MoveTo(X1, Y1);
    Canvas.LineTo(X2, Y2);
    Inc(Value, Scale * PointsStep);
  end;
end;

procedure TVrTrackBar.WMSize(var Message: TWMSize);
begin
  inherited;
  CenterThumb;
  UpdateControlCanvas;
end;

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

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

procedure TVrTrackBar.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 TVrTrackBar.CMEnabledChanged(var Message: TMessage);
begin
  inherited;
  UpdateControlCanvas;
end;

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

procedure TVrTrackBar.GutterBevelChanged(Sender: TObject);
begin
  UpdateControlCanvas;
end;

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

procedure TVrTrackBar.BitmapListChanged(Sender: TObject);
begin
  GetThumbImage;
  UpdateControlCanvas;
end;

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

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

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

procedure TVrTrackBar.SetMaxValue(Value: Integer);
begin
  if FMaxValue <> Value then
  begin
    FMaxValue := Value;
    if FPosition > FMaxValue then Position := FMaxValue
    else UpdateControlCanvas;
  end;
end;

procedure TVrTrackBar.SetMinValue(Value: Integer);
begin
  if FMinValue <> Value then
  begin
    FMinValue := Value;
    if FPosition < FMinValue then Position := FMinValue
    else UpdateControlCanvas;
  end;
end;

procedure TVrTrackBar.SetPosition(Value: Integer);
begin
  if Value < FMinValue then Value := FMinValue;
  if Value > FMaxValue then Value := FMaxValue;
  if FPosition <> Value then
  begin
    FPosition := Value;
    UpdateControlCanvas;
    Change;
  end;
end;

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

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

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

procedure TVrTrackBar.SetFrequency(Value: Integer);
begin
  if FFrequency <> Value then
  begin
    FFrequency := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrTrackBar.SetBorderWidth(Value: Integer);
begin
  if FBorderWidth <> Value then
  begin
    FBorderWidth := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrTrackBar.SetGutterWidth(Value: Integer);
begin
  if FGutterWidth <> Value then
  begin
    FGutterWidth := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrTrackBar.SetGutterColor(Value: TColor);
begin
  if FGutterColor <> Value then
  begin
    FGutterColor := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrTrackBar.SetGutterBevel(Value: TVrBevel);
begin
  FGutterBevel.Assign(Value);
end;

procedure TVrTrackBar.SetTickMarks(Value: TVrTickMarks);
begin
  if FTickMarks <> Value then
  begin
    FTickMarks := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrTrackBar.SetTickColor(Value: TColor);
begin
  if FTickColor <> Value then
  begin
    FTickColor := Value;
    UpdateControlCanvas;
  end;
end;

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

procedure TVrTrackBar.SetScaleOffset(Value: Integer);
begin
  if FScaleOffset <> Value then
  begin
    FScaleOffset := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrTrackBar.SetFocusOffset(Value: Integer);
begin
  if FFocusOffset <> Value then
  begin
    FFocusOffset := Value;
    UpdateControlCanvas;
  end;
end;

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

procedure TVrTrackBar.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 (toMouseClip in Options) then
      begin
        R := Bounds(ClientOrigin.X, ClientOrigin.Y,
          ClientWidth, ClientHeight);
        ClipCursor(@R);
        FClipOn := True;
      end;
      UpdateControlCanvas;
    end
    else
    if (toActiveClick 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 TVrTrackBar.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 TVrTrackBar.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 TVrTrackBar.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 Position := FMaxValue
    else if Key = VK_END then Position := FMinValue;
    if Orientation = voHorizontal then
    begin
      if Key = VK_LEFT then Position := Position + Adjust(-Frequency)
      else if Key = VK_RIGHT then Position := Position + Adjust(Frequency);
    end
    else
    begin
      if Key = VK_UP then Position := Position + Adjust(Frequency)
      else if Key = VK_DOWN then Position := Position + Adjust(-Frequency);
    end;
  end;
  inherited KeyDown(Key, Shift);
end;



end.