cdibslider.pas

Delphi控件

  FPointerOpacityHigh := 255;
  FPointerOpacityLow := 196;
  FSmallChange := 1;
  FLargeChange := 5;
  FPageSize := 5;
  AutoSize := True;
  MouseRepeat := True;
  FPointerOffset := 0;
  FOverlayBorderX := 0;
  FOverlayBorderY := 0;
  FOverlayOpacity := 64;
  FStretchBackground := True;

  AddTemplateProperty('AutoSize');
  AddTemplateProperty('LargeChange');
  AddTemplateProperty('Min');
  AddTemplateProperty('Max');
  AddTemplateProperty('Opacity');
  AddTemplateProperty('OverlayBorderX');
  AddTemplateProperty('OverlayBorderY');
  AddTemplateProperty('OverlayOpacity');
  AddTemplateProperty('PageSize');
  AddTemplateProperty('PointerOffset');
  AddTemplateProperty('PointerOpacityHigh');
  AddTemplateProperty('PointerOpacityLow');
  AddTemplateProperty('Position');
  AddTemplateProperty('SliderType');
  AddTemplateProperty('SmallChange');
  AddTemplateProperty('StretchBackground');
end;

destructor TCustomDIBSlider.Destroy;
begin
  FIndexEnd1.Free;
  FIndexEnd2.Free;
  FIndexMain.Free;
  FIndexOverlay.Free;
  FIndexPointer.Free;
  inherited;
end;

procedure TCustomDIBSlider.DoEnter;
begin
  inherited;
  Invalidate;
end;

procedure TCustomDIBSlider.DoExit;
begin
  inherited;
  Invalidate;
end;

procedure TCustomDIBSlider.ImageChanged(Index: Integer; Operation: TDIBOperation);
begin
  if AutoSize then
    AdjustSize
  else
    CalcRects;
end;

procedure TCustomDIBSlider.KeyDown(var Key: Word;
  Shift: TShiftState);
begin
  inherited;
  case SliderType of
    stHorizontal:
      begin
        case Key of
          VK_LEFT: Position := Position - SmallChange;
          VK_RIGHT: Position := Position + SmallChange;
        end;
      end;

    stVertical:
      begin
        case Key of
          VK_UP: Position := Position - SmallChange;
          VK_DOWN: Position := Position + SmallChange;
        end;
      end;
  end;

  case Key of
    VK_PRIOR: Position := Position - PageSize;
    VK_NEXT: Position := Position + PageSize;
  end;
end;

procedure TCustomDIBSlider.Loaded;
begin
  inherited;
  FLastPosition := Position;
  if AutoSize then AdjustSize;
  FPointerPosition := CalcPointerFromPosition(FPosition);
  CalcRects;
end;


procedure TCustomDIBSlider.MouseDown(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  MaxAllowedRange, Range: Integer;
  ShouldCapture: Boolean;
begin
  inherited;
  if not IndexPointer.Valid then exit;

  ShouldCapture := False;
  //If the X,Y is within the rect, then we capture
  if PtInRect(FRectPointer, Point(X, Y)) then
    ShouldCapture := True
  else //If MouseRepeating, we should capture if X/Y is within the Left & Right/ Top & Botton
  //range, this is because PointerOffset may cause the pointer to be inline with the
  //cursor but not actually beneath it (Or the cursor may not be within the slider)
  if IsMouseRepeating then
    case SliderType of
      stHorizontal:
        if (X >= FRectPointer.Left) and (X <= FRectPointer.Right) then
          ShouldCapture := True;
      stVertical:
        if (Y >= FRectPointer.Top) and (Y <= FRectPointer.Bottom) then
          ShouldCapture := True;
    end;

  if ShouldCapture then
  begin
    StopRepeating;
    FCapturePointer := True;
    FCapturePosition := Point(X - FRectPointer.Left, Y - FRectPointer.Top);
    Invalidate;
  end 
  else if PtInRect(FRectEnd1, Point(X, Y)) then
    Position := Position - SmallChange
  else if PtInRect(FRectEnd2, Point(X, Y)) then
    Position := Position + SmallChange
  else 
  begin
    Range := 0;
    case SliderType of
      stHorizontal:
        begin
          Range := X - FRectPointer.Left - ((FRectPointer.Right - FRectPointer.Left) div 2);
        end;

      stVertical:
        begin
          Range := Y - FRectPointer.Top - ((FRectPointer.Bottom - FRectPointer.Top) div 2);
        end;
    end;

    MaxAllowedRange := CalcPositionFromPointer(Abs(Range));
    if MaxAllowedRange > LargeChange then
      MaxAllowedRange := LargeChange;

    if Range < 0 then
      Position := Position - MaxAllowedRange
    else
      Position := Position + MaxAllowedRange;
  end;
end;

procedure TCustomDIBSlider.MouseMove(Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
  if FCapturePointer then 
  begin
    case SliderType of
      stHorizontal: PointerPosition := X - FRectMain.Left - FCapturePosition.X;
      stVertical: PointerPosition := Y - FRectMain.Top - FCapturePosition.Y;
    end;
  end;
end;

procedure TCustomDIBSlider.MouseUp(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if FCapturePointer then Invalidate;
  FCapturePointer := False;
  inherited;
end;

procedure TCustomDIBSlider.Paint;
var
  TheDIB: TMemoryDIB;
  TempDIB: TMemoryDIB;
  NewClip, OrigClip: TRect;
  Position, FinalPosition, IncPosition, OverlayWidth, OverlayHeight: Integer;
begin
  if IndexMain.GetImage(TheDIB) then
  begin
    if FStretchBackground then 
    begin
      TempDIB :=
        TMemoryDIB.Create(FRectMain.Right - (FRectMain.Left - 1),
        FRectMain.Bottom - (FRectMain.Top - 1));
      try
        TempDIB.StretchCopyPicture(TheDIB);
        TheDIB.AssignHeaderTo(TempDIB);
        TempDIB.Draw(FRectMain.Left, FRectMain.Top,
          FRectMain.Right - (FRectMain.Left - 1), FRectMain.Bottom - (FRectMain.Top - 1),
          ControlDIB, 0, 0);
      finally
        TempDIB.Free;
      end;
    end 
    else 
    begin
      OrigClip := ControlDIB.ClipRect;
      try
        IntersectRect(NewClip, OrigClip, FRectMain);
        ControlDIB.ClipRect := NewClip;

        if SliderType = stHorizontal then 
        begin
          Position := FRectMain.Left;
          FinalPosition := FRectMain.Right;
          IncPosition := TheDIB.Width;
        end 
        else 
        begin
          Position := FRectMain.Top;
          FinalPosition := FRectMain.Bottom;
          IncPosition := TheDIB.Height;
        end;

        while (Position < FinalPosition) do 
        begin
          if SliderType = stHorizontal then
            TheDIB.Draw(Position, FRectMain.Top, TheDIB.Width, TheDIB.Height,
              ControlDIB, 0, 0)
          else
            TheDIB.Draw(FRectMain.Left, Position, TheDIB.Width, TheDIB.Height,
              ControlDIB, 0, 0);

          Inc(Position, IncPosition);
        end;
      finally
        ControlDIB.ClipRect := OrigClip;
      end;
    end;
  end;

  if IndexOverlay.GetImage(TheDIB) then 
  begin
    TempDIB :=
      TMemoryDIB.Create(FRectOverlay.Right - (FRectOverlay.Left - 1),
      FRectOverlay.Bottom - (FRectOverlay.Top - 1));
    try
      TempDIB.StretchCopyPicture(TheDIB);
      TheDIB.AssignHeaderTo(TempDIB);
      TempDIB.Opacity := OverlayOpacity;

      OverlayWidth := 0;
      OverlayHeight := 0;

      //Now, we only draw as far as the pointer position
      case SliderType of
        stHorizontal:
          begin
            if csDesigning in ComponentState then
              OverlayWidth := FRectOverlay.Right - (FRectOverlay.Left - 1)
            else
              OverlayWidth := FPointerPosition - OverlayBorderX;
            OverlayHeight := FRectOverlay.Bottom - (FRectOverlay.Top - 1);
          end;

        stVertical:
          begin
            OverlayWidth := FRectOverlay.Left - (FRectOverlay.Right - 1);
            if csDesigning in ComponentState then
              OverlayHeight := FRectOverlay.Bottom - (FRectOverlay.Top - 1)
            else
              OverlayHeight := FPointerPosition - OverlayBorderY;
          end;
      end;


      TempDIB.Draw(FRectOverlay.Left, FRectOverlay.Top, OverlayWidth, OverlayHeight,
        ControlDIB, 0, 0);
    finally
      TempDIB.Free;
    end;
  end;

  if IndexEnd1.GetImage(TheDIB) then
    TheDIB.Draw(FRectEnd1.Left, FRectEnd1.Top, TheDIB.Width, TheDIB.Height,
      ControlDIB, 0, 0);
  if IndexEnd2.GetImage(TheDIB) then
    TheDIB.Draw(FRectEnd2.Left, FRectEnd2.Top, TheDIB.Width, TheDIB.Height,
      ControlDIB, 0, 0);
  if IndexPointer.GetImage(TheDIB) then
  begin
    if FCapturePointer then
      TheDIB.Opacity := PointerOpacityHigh
    else
      TheDIB.Opacity := PointerOpacityLow;
    TheDIB.Draw(FRectPointer.Left, FRectPointer.Top, TheDIB.Width,
      TheDIB.Height, ControlDIB, 0, 0);
  end;
end;

procedure TCustomDIBSlider.SetBounds(ALeft, ATop, AWidth,
  AHeight: Integer);
var
  MinSize: TPoint;
begin
  MinSize := CalcMinimumSize;
  if aWidth < MinSize.x then aWidth := MinSize.x;
  if aHeight < MinSize.y then aHeight := MinSize.y;
  inherited;
  if not Creating then
  begin
    FPointerPosition := CalcPointerFromPosition(FPosition);
    CalcRects;
    Invalidate;
  end;
end;

procedure TCustomDIBSlider.SetMax(const Value: Integer);
begin
  FMax := Value;
  if Max <= Min then Min := Max - 1;
  if Max < Position then Position := Max;
end;

procedure TCustomDIBSlider.SetMin(const Value: Integer);
begin
  FMin := Value;
  if Min >= Max then Max := Min + 1;
  if Min > Position then Position := Min;
end;

procedure TCustomDIBSlider.SetOverlayBorderX(const Value: Byte);
begin
  FOverlayBorderX := Value;
  if AutoSize then
    AdjustSize
  else
    CalcRects;
  Invalidate;
end;

procedure TCustomDIBSlider.SetOverlayBorderY(const Value: Byte);
begin
  FOverlayBorderY := Value;
  if AutoSize then
    AdjustSize
  else
    CalcRects;
  Invalidate;
end;

procedure TCustomDIBSlider.SetOverlayOpacity(const Value: Byte);
begin
  FOverlayOpacity := Value;
  Invalidate;
end;

procedure TCustomDIBSlider.SetPointerOffset(const Value: Integer);
begin
  FPointerOffset := Value;
  if AutoSize then
    AdjustSize
  else
    CalcRects;
  Invalidate;
end;

procedure TCustomDIBSlider.SetPointerOpacityHigh(const Value: Byte);
begin
  FPointerOpacityHigh := Value;
  invalidate;
end;

procedure TCustomDIBSlider.SetPointerOpacityLow(const Value: Byte);
begin
  FPointerOpacityLow := Value;
  Invalidate;
end;

procedure TCustomDIBSlider.SetPointerPosition(const Value: Integer);
begin
  if VisualRange = 0 then exit;

  if Value < 0 then
    FPointerPosition := 0
  else if Value > VisualRange then
    FPointerposition := VisualRange
  else
    FPointerPosition := Value;
  FPosition := CalcPositionFromPointer(Value);
  CalcRects;
  Invalidate;
  Change;
end;

procedure TCustomDIBSlider.SetPosition(const Value: Integer);
begin
  if Value < Min then
    FPosition := Min
  else if Value > Max then
    FPosition := Max
  else
    FPosition := Value;

  FPointerPosition := CalcPointerFromPosition(Value);
  CalcRects;
  Invalidate;
  Change;
end;

procedure TCustomDIBSlider.SetSliderType(const Value: TSliderType);
begin
  FSliderType := Value;
  if AutoSize then
    AdjustSize
  else
    CalcRects;
  Invalidate;
end;

procedure TCustomDIBSlider.SetStretchBackground(const Value: Boolean);
begin
  FStretchBackground := Value;
  Invalidate;
end;

function TCustomDIBSlider.VisualRange: Integer;
begin
  Result := 0;
  case SliderType of
    stHorizontal:
      begin
        Result := FRectMain.Right - (FRectMain.Left - 1);
        Result := Result - (FRectPointer.Right - (FRectPointer.Left - 1));
      end;
    stVertical:
      begin
        Result := FRectMain.Bottom - (FRectMain.Top - 1);
        Result := Result - (FRectPointer.Bottom - (FRectPointer.Top - 1));
      end;
  end;
end;

end.