vrslider.pas

作工控的好控件

    if Style = ssBottomLeft then
    begin
      Y := Rect.Bottom - TickWidth;
      OffsetValue := -(TickWidth + Spacing);
    end else
    begin
      Y := Rect.Top;
      OffsetValue := TickWidth + Spacing;
    end;

    Brush.Color := Self.Color;
    FillRect(Rect);

    Bm := nil;
    if not SolidFill then
      Bm := CreateLCDImage(W, TickWidth, Color, Self.Color)
    else Brush.Color := Color;

    for I := 0 to Cnt do
    begin
      R := Bounds(X, Y, W, TickWidth);
      if SolidFill then FillRect(R)
      else CopyRect(R, Bm.Canvas, BitmapRect(Bm));
      Inc(Y, OffsetValue);
    end;
    if Bm <> nil then Bm.Free;
  end;
end;

procedure TVrSlider.DrawHorz(Canvas: TCanvas; Rect: TRect;
  Color: TColor);
var
  R: TRect;
  X, Y, I, H, Cnt: Integer;
  OffsetValue: Integer;
  Bm: TBitmap;
begin
  with Canvas do
  begin
    H := HeightOf(Rect);
    Cnt := (WidthOf(Rect) div (TickWidth + Spacing)) + 1;
    Y := Rect.Top;
    if FStyle = ssBottomLeft then
    begin
      X := Rect.Left;
      OffsetValue := (TickWidth + Spacing);
    end
    else
    begin
      X := Rect.Right - TickWidth;
      OffsetValue := -(TickWidth + Spacing);
    end;

    Brush.Color := Self.Color;
    FillRect(Rect);

    Bm := nil;
    if not SolidFill then
      Bm := CreateLCDImage(TickWidth, H, Color, Self.Color)
    else Brush.Color := Color;

    for I := 0 to Cnt do
    begin
      R := Bounds(X, Y, TickWidth, H);
      if SolidFill then FillRect(R)
      else CopyRect(R, Bm.Canvas, BitmapRect(Bm));
      Inc(X, OffsetValue);
    end;
    if Bm <> nil then Bm.Free;
  end;
end;

procedure TVrSlider.CreateBackImages;
var
  W, H: Integer;
  PaintRect: TRect;
begin
  PaintRect := GetSliderRect;
  InflateRect(PaintRect, ThumbIndent, ThumbIndent);
  Bevel.GetVisibleArea(PaintRect);
  W := WidthOf(PaintRect);
  H := HeightOf(PaintRect);
  with FBackImageOrg do
  begin
    Width := W;
    Height := H;
  end;
  with FBackImageNew do
  begin
    Width := W;
    Height := H;
  end;
  if Orientation = voVertical then
  begin
    DrawVert(FBackImageOrg.Canvas, BitmapRect(FBackImageOrg), Palette[0]);
    DrawVert(FBackImageNew.Canvas, BitmapRect(FBackImageNew), Palette[1]);
  end else
  begin
    DrawHorz(FBackImageOrg.Canvas, BitmapRect(FBackImageOrg), Palette[0]);
    DrawHorz(FBackImageNew.Canvas, BitmapRect(FBackImageNew), Palette[1]);
  end;
end;

procedure TVrSlider.Changed;
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;

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

procedure TVrSlider.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 TVrSlider.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 TVrSlider.WMGetDlgCode(var Msg: TWMGetDlgCode);
begin
  Msg.Result := DLGC_WANTARROWS;
end;

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

procedure TVrSlider.CMColorChanged(var Message: TMessage);
begin
  inherited;
  if (HandleAllocated) then
  begin
    CreateBackImages;
    UpdateControlCanvas;
  end;
end;

procedure TVrSlider.BevelChanged(Sender: TObject);
begin
  if not Loading then
    CreateBackImages;
  UpdateControlCanvas;
end;

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

procedure TVrSlider.PaletteModified(Sender: TObject);
begin
  if not Loading then CreateBackImages;
  UpdateControlCanvas;
end;

procedure TVrSlider.SetPalette(Value: TVrPalette);
begin
  FPalette.Assign(Value);
end;

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

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

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

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

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

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

procedure TVrSlider.SetSpacing(Value: Integer);
begin
  if (FSpacing <> Value) and (Value > -1) then
  begin
    FSpacing := Value;
    if not Loading then
      CreateBackImages;
    UpdateControlCanvas;
  end;
end;

procedure TVrSlider.SetTickWidth(Value: Integer);
begin
  if (FTickWidth <> Value) and (Value > 0) then
  begin
    FTickWidth := Value;
    if not Loading then
      CreateBackImages;
    UpdateControlCanvas;
  end;
end;

procedure TVrSlider.SetSolidFill(Value: Boolean);
begin
  if FSolidFill <> Value then
  begin
    FSolidFill := Value;
    if not Loading then
      CreateBackImages;
    UpdateControlCanvas;
  end;
end;

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

procedure TVrSlider.SetStyle(Value: TVrSliderStyle);
begin
  if FStyle <> Value then
  begin
    FStyle := Value;
    if not Loading then
      CreateBackImages;
    UpdateControlCanvas;
  end;
end;

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

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

procedure TVrSlider.SetBorderWidth(Value: Integer);
begin
  if (FBorderWidth <> Value) and (Value >= 0) then
  begin
    FBorderWidth := Value;
    if not Loading then
      CreateBackImages;
    UpdateControlCanvas;
  end;
end;

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

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

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

procedure TVrSlider.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 TVrSlider.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 TVrSlider.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 TVrSlider.KeyDown(var Key: Word; Shift: TShiftState);

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

begin
  if Shift = [] then
  begin
    if Key = VK_HOME then Position := MinValue
    else if Key = VK_END then Position := MaxValue;
    if Orientation = voHorizontal then
    begin
      if Key = VK_LEFT then Position := Position + Adjust(-FKeyIncrement)
      else if Key = VK_RIGHT then Position := Position + Adjust(FKeyIncrement);
    end
    else
    begin
      if Key = VK_UP then Position := Position + Adjust(FKeyIncrement)
      else if Key = VK_DOWN then Position := Position + Adjust(-FKeyIncrement);
    end;
  end;
  inherited KeyDown(Key, Shift);
end;



end.