mmwheel.pas

一套及时通讯的原码

begin
   FScale.Assign(Value);
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.SetRadius(Value : Integer);
begin
   Value := MinMax(Value,0,MaxInt);
   if Value <> FRadius then
   begin
      FRadius := Value;
      UpdateControl;
   end;
end;

{-- TMMCustomWheel ------------------------------------------------------}
function TMMCustomWheel.GetRadius : Integer;
begin
   if FRadius = 0 then
      Result := Min(Width,Height) div 2 - HandleMargin - BevelExtend - FrameSpace - ScaleSpace
   else
      Result := FRadius;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.SetHandleStyle(Value : TMMHandleStyle);
begin
   if FHandleStyle <> Value then
   begin
      FHandleStyle := Value;
      UpdateControl;
   end;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.SetHandleSize(Value : Integer);
begin
   Value := MinMax(Value, 2, MaxInt);
   if FHandleSize <> Value then
   begin
      FHandleSize := Value;
      UpdateControl;
   end;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.SetHandleMargin(Value : Integer);
begin
   Value := MinMax(Value, 0, MaxInt);
   if FHandleMargin <> Value then
   begin
      FHandleMargin := Value;
      UpdateControl;
   end;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.SetFrameSpace(Value : Integer);
begin
   Value := MinMax(Value,0,MaxInt);
   if FFrameSpace <> Value then
   begin
      FFrameSpace := Value;
      DoneStretched;
      if AutoSize then
         DoAutoSize;
   end;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.SetScaleMargin(Value : Integer);
begin
   Value := MinMax(Value,0,MaxInt);
   if FScaleMargin <> Value then
   begin
      FScaleMargin := Value;
      DoneStretched;
      if AutoSize then
         DoAutoSize;
   end;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.ScaleChanged(Sender : TObject);
begin
   DoneStretched;
   if AutoSize then
      DoAutoSize;
   UpdateControl;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.InitStretched;
var
   Temp   : TBitmap;
   SWidth : Integer;
   SHeight: Integer;
   BWidth : Integer;
   BHeight: Integer;
   R      : TRect;
   SRect  : TRect;
begin
   SWidth  := Width - BevelExtend * 2;
   SHeight := Height - BevelExtend * 2;

   if SWidth < 0 then
      SWidth := 0;

   if SHeight < 0 then
      SHeight := 0;

   FStretched        := TBitmap.Create;
   FStretched.Width  := SWidth;
   FStretched.Height := SHeight;

   if (SWidth = 0) or (SHeight = 0) then Exit;

   SRect := Bounds(0,0,SWidth,SHeight);

   FStretched.Canvas.Font:= Font;
   FScale.Canvas         := FStretched.Canvas;

   Temp := TBitmap.Create;
   try
      FStretched.Canvas.Brush.Color := Color;
      FStretched.Canvas.FillRect(SRect);
      R := SRect;
      InflateRect(R,-(FrameSpace+ScaleSpace),-(FrameSpace+ScaleSpace));
      BWidth  := R.Right - R.Left;
      BHeight := R.Bottom - R.Top;

      if (BWidth > 0) and (BHeight > 0) then
      begin
         Temp.Width  := BWidth;
         Temp.Height := BHeight;

         Temp.Canvas.CopyRect(Bounds(0, 0, BWidth, BHeight),
                              FBackBmp.Canvas,
                              Bounds(0, 0, FBackBmp.Width, FBackBmp.Height));

         if Transparent then
            FStretched.Canvas.BrushCopy(R, Temp,
                                        Bounds(0, 0, BWidth, BHeight),
                                        Temp.TransparentColor)
         else
            FStretched.Canvas.CopyRect(R, Temp.Canvas,
                                       Bounds(0, 0, BWidth, BHeight));
      end;

   finally
     Temp.Free;
   end;

   if FScale.Visible then
   with FScale do
   begin
      MinValue := Self.MinValue;
      MaxValue := Self.MaxValue;
      StartAngle := Self.StartAngle;
      EndAngle   := Self.EndAngle;
      R          := SRect;
      InflateRect(R,-(FrameSpace),-(FrameSpace));
      DrawElliptic(FStretched.Canvas, R);
   end;

   if ((FocusAction = faFrameRect) or (FocusAction = faAll)) then
       if Focused then
       begin
          R           := SRect;
          InflateRect(R,-(FrameSpace-2),-(FrameSpace-2));
          FStretched.Canvas.DrawFocusRect(R);
       end;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.DoneStretched;
begin
   FStretched.Free;
   FStretched := nil;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.CalcSize(var W, H : Integer);
var
   Space : Integer;
begin
   Space := BevelExtend + FrameSpace + ScaleSpace;

   W := FBackBmp.Width + 2*Space;
   H := FBackBmp.Height + 2*Space;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.DoAutoSize;
var
   W, H: Integer;
begin
   if csLoading in ComponentState then Exit;

   CalcSize(W,H);
   SetBounds(Left, Top, W, H);
end;

{-- TMMCustomWheel ------------------------------------------------------}
function TMMCustomWheel.ScaleSpace  : Integer;
begin
   if Scale.Visible then
      Result := Scale.ScaleHeight + ScaleMargin
   else
      Result := 0;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.UpdateControl;
begin
   if not (csLoading in ComponentState) then
   begin
      RecalcAngle;
      Invalidate;
   end;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.Change;
begin
   DoChange;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.DoChange;
begin
   if (csLoading in ComponentState) or
      (csReading in ComponentState) then exit;

   if Assigned(FOnChange) then FOnChange(Self);
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.RecalcAngle;
var
   dVal : Extended;
   dAng : Extended;
begin
   if FMinValue >= FMaxValue then
      dVal := 0
   else
      dVal := (FValue - FMinValue) / (FMaxValue - FMinValue);

   if FStartAngle > FEndAngle then
      dAng := 360
   else
      dAng := FStartAngle + (360 - FEndAngle);

   FAngle := Round(FStartAngle - dVal * dAng);

   if FAngle < 0 then
      FAngle := FAngle + 360;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.Paint;
begin
   with Canvas do
   begin
      { Do not use inherited Paint because we don't need to clear space }
      { before blitting }
      if assigned(FOnPaint) then
         FOnPaint(Self,Canvas,ClientRect)
      else
      begin
         Bevel.PaintBevel(Canvas,ClientRect,True);
         Draw(BevelExtend, BevelExtend, Stretched);
      end;
      DrawHandle(FAngle);
   end;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.DrawHandle(Angle : Integer);
var
   X, Y: Integer;
   HS  : Integer;
begin
   X    := (Width div 2) + Round(Radius * cos(Angle / 180 * Pi));
   Y    := (Height div 2) - Round(Radius * sin(Angle / 180 * Pi));

   with Canvas do
   begin
      if Focused and ((FocusAction = faHandleColor) or (FocusAction = faAll)) then
         Brush.Color := FocusedColor
      else
         Brush.Color := HandleColor;

      Brush.Style := bsSolid;
      Pen.Style   := psSolid;
      Pen.Color   := Brush.Color;

      if HandleStyle = hsOwnerDraw then
         DoDrawHandle(ClientRect, Point(X,Y), Focused)
      else
      begin
         HS := HandleSize div 2;
         Ellipse(X-HS,Y-HS,X+HS,Y+HS);
      end;
   end;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.DoDrawHandle(Rect : TRect; Origin : TPoint; Focused : Boolean);
begin
   if Assigned(FOnDrawHandle) then
      FOnDrawHandle(Self,Canvas,Rect,Origin,Focused);
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.Loaded;
begin
   inherited Loaded;
   if AutoSize then
      DoAutoSize;
   UpdateControl;
end;

{-- TMMCustomWheel ------------------------------------------------------}
function TMMCustomWheel.GetStretched: TBitmap;
begin
   if FStretched = nil then
      InitStretched;
   Result := FStretched;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
   if AutoSize then
      CalcSize(AWidth,AHeight);
   inherited SetBounds(ALeft,ATop,AWidth,AHeight);
   DoneStretched;
   Invalidate;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.CMColorChanged(var Msg);
begin
   DoneStretched;
   inherited;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
   if (Button = mbLeft) and not FDragging then
   begin
      FDragging := True;
      SetFocus;
      if not FUpDown then
         Rotate(X,Y)
      else
      begin
         FStartY         := Y;
         FStartValue     := Value;
      end;
   end;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
   if (ssLeft in Shift) and FDragging then
      if not FUpDown then
         Rotate(X,Y)
      else
         Value := FStartValue + Round((FStartY - Y) * (MaxValue - MinValue) / ScrollSize);
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
   if (Button = mbLeft) and FDragging then
   begin
      FDragging := False;
      if not FUpDown then
         Rotate(X,Y);
   end;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.KeyDown(var Key: Word; Shift: TShiftState);
begin
   inherited KeyDown(Key,Shift);
   case Key of
      VK_DOWN, VK_LEFT: Value := Value - FLineStep;
      VK_UP, VK_RIGHT : Value := Value + FLineStep;
      VK_NEXT         : Value := Value - FPageStep;
      VK_PRIOR        : Value := Value + FPageStep;
      VK_HOME         : Value := FMaxValue;
      VK_END          : Value := FMinValue;
     else
        Exit;
   end;
   Key := 0;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.Rotate(X, Y : Integer);
var
   dX, dY : Extended;
   dAngle : Extended;
   Ang    : Extended;
   S, E   : Extended;

begin
   dX := X - (Width div 2);
   dY := (Height div 2) - Y;

   if (dX = 0) and (dY = 0) then Exit;

   Ang := ArcTan2(dY, dX) / Pi * 180;
   if Ang < 0 then
      Ang := 360 + Ang;

   S := FStartAngle;
   if FStartAngle > FEndAngle then
      E := S
   else
      E := FEndAngle;

   dAngle := S + (360 - E);

   if (Ang > S) and (Ang < E) then
       if (Ang - S) < ((E - S) / 2) then
           Ang := S
       else
           Ang := E;

   Ang := FStartAngle - Ang;
   if Ang < 0 then
      Ang := 360 + Ang;

   if (MaxValue < MinValue) or (dAngle = 0) then
       Value := MinValue
   else
       Value := Round((MaxValue - MinValue) * (Ang / dAngle)) + MinValue;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.WMGetDlgCode(var Message: TWMGetDlgCode);
begin
   Message.Result := DLGC_WANTARROWS;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.WMSetFocus(var Msg);
begin
   DoneStretched;
   UpdateControl;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.WMKillFocus(var Msg);
begin
   DoneStretched;
   UpdateControl;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.Changed;
begin
   { Looks like bevel has changed }
   DoneStretched;
   if AutoSize then
      DoAutoSize;
   UpdateControl;
end;

end.