mmslider.pas

一套及时通讯的原码

end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.KeyUp(var Key: Word; Shift: TShiftState);
begin
   TrackEnd;

   inherited KeyUp(Key,Shift);
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
{$IFNDEF BUILD_ACTIVEX}
   SetFocus;
{$ELSE}
   Windows.SetFocus(Handle);
{$ENDIF}

   if PtInRect(FThumbRect,Point(X,Y)) then
   begin
      if (Button = mbLeft) then FDragging := True;

      SetThumbCursor(True);
   end;

   if (Button = mbLeft) then
   begin
      if IsVert then
         FDragOffset := Y
      else
         FDragOffset := X;

      FDragVal := FPosition;

      if not FDragging then
      begin
         if not UpdatePosition(NewPosition(X,Y)) then
            Invalidate;
      end
      else Invalidate;

      Track;
   end;

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

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.MouseMove(Shift: TShiftState; X, Y: Integer);
var
   aPos,aWidth,aHeight: integer;

begin
   if not FDragging then
   begin
     {$IFDEF WIN32}
     SetThumbCursor(ptInRect(FThumbRect,Point(X,Y)));
     {$ELSE}
     SetThumbCursor(ptInRect(FThumbRect,Point(X,Y)) or FDragging);
     {$ENDIF}
   end;

   {Is the left mouse button down and dragging the thumb bar?}
   if (ssLeft in Shift) and FDragging then
   begin
      with CalcClientRect do
      begin
         aHeight := Bottom - Top - FThumbHeight;
         aWidth  := Right - Left - FThumbWidth;
      end;

      if IsVert then
         aPos := MulDiv(FDragOffset-Y,FMax-FMin,aHeight)
      else
         aPos := MulDiv(X-FDragOffset,FMax-FMin,aWidth);

      aPos := Min(Max(FDragVal+aPos,FMin),FMax);

      if UpdatePosition(aPos) then Track;
   end;

   inherited MouseMove(Shift, X, Y);
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
   if (Button = mbLeft) then
   begin
      FDragging := False;
      Refresh;

      TrackEnd;
   end;

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

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.WhereIsThumb(const ClientRect: TRect; var aRect: Trect);
var
  Each              : Real;
  ThumbX,ThumbY     : Integer;
  AWidth, AHeight   : Integer ;
begin
   AWidth := ClientRect.Right - ClientRect.Left ;
   AHeight := ClientRect.Bottom - ClientRect.Top ;
   { Calculate where to paint the thumb bar - store in aRect }
   if IsVert then
   begin
      Each   := (AHeight-FThumbHeight)/(FMax-FMin);
      ThumbY := AHeight-Round(Each*(FPosition-FMin))-FThumbHeight;
      ThumbY := ClientRect.Top + Max(0,Min(AHeight-FThumbHeight,ThumbY));

      if Scale.Visible and (FScalePos = spBelowOrRight) then
         ThumbX := ClientRect.Left
      else if Scale.Visible and (FScalePos = spAboveOrLeft) then
         ThumbX := ClientRect.Left + AWidth-ThumbWidth
      else
         ThumbX := ClientRect.Left + AWidth div 2 - HalfTW;
   end
   else
   begin
      Each := (AWidth-FThumbWidth)/(FMax-FMin);
      ThumbX := Round(Each*(FPosition-FMin));
      ThumbX := ClientRect.Left + Max(0,Min(AWidth-FThumbWidth,ThumbX));

      if Scale.Visible and (FScalePos = spBelowOrRight) then
         ThumbY := ClientRect.Top
      else if Scale.Visible and (FScalePos = spAboveOrLeft) then
         ThumbY := ClientRect.Top + AHeight-ThumbHeight
      else
         ThumbY := ClientRect.Top + AHeight div 2 - HalfTH;
   end;
   aRect := Rect(ThumbX,ThumbY,ThumbX+FThumbWidth,ThumbY+FThumbHeight);
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.DrawScale(Canvas: TCanvas; aRect: TRect);
begin
   if Scale.Visible then
   with Scale do
   begin
      MinValue := Self.MinValue;
      MaxValue := Self.MaxValue;
   end
   else Exit;

   Scale.Canvas := Canvas;

   if isVert then
   begin
      Inc(aRect.Top, HalfTH);
      Dec(aRect.Bottom, HalfTH);
      if (FScalePos = spAboveOrLeft) or (FScalePos = spBoth) then
          Scale.DrawRect(Canvas,Rect(aRect.Left-Scale.ScaleHeight-FScaleDistance,
                         aRect.Top,aRect.Left-FScaleDistance,aRect.Bottom),True);
      if (FScalePos = spBelowOrRight) or (FScalePos = spBoth) then
          Scale.DrawRect(Canvas,Rect(aRect.Right+FScaleDistance,
                         aRect.Top,aRect.Right+Scale.ScaleHeight+FScaleDistance,
                         aRect.Bottom),False);
   end
   else
   begin
      Inc(aRect.Left, HalfTW);
      Dec(aRect.Right, HalfTW);
      if (FScalePos = spAboveOrLeft) or (FScalePos = spBoth) then
          Scale.DrawRect(Canvas,Rect(aRect.Left,aRect.Top-Scale.ScaleHeight-FScaleDistance-1,
                         aRect.Right,aRect.Top-FScaleDistance-1),True);
      if (FScalePos = spBelowOrRight) or (FScalePos = spBoth) then
          Scale.DrawRect(Canvas,Rect(aRect.Left,aRect.Bottom+FScaleDistance+1,
                         aRect.Right,aRect.Bottom+Scale.ScaleHeight+FScaleDistance+1),False);
   end;
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.DrawTrench(Canvas: TCanvas; aRect: TRect);
var
  aWidth,aHeight: integer;
  X1,Y1,X2,Y2   : integer;
  R1,R2,R3      : TRect;

begin
   {This procedure simply draws the slot that the thumb bar will travel through}
   {including the tick-marks. The bar itself is not drawn.}

   {Calculate the corners of the trench dependant on orientation}
   aWidth := aRect.Right-aRect.Left;
   aHeight:= aRect.Bottom-aRect.Top;
   with Canvas do
   begin
      if IsVert then
      begin
         if Scale.Visible and (FScalePos = spBelowOrRight) then
            X1 := aRect.Left+HalfTW-FGroove.BevelExtend -(FGrooveSize div 2)
         else if Scale.Visible and (FScalePos = spAboveOrLeft) then
            X1 := aRect.Right-HalfTW-FGroove.BevelExtend-(FGrooveSize div 2)-1
         else
            X1 := aRect.Left+(aWidth div 2) - FGroove.BevelExtend -(FGrooveSize div 2);

         X2 := X1 + 2*FGroove.BevelExtend + FGrooveSize;
         Y1 := aRect.Top;
         Y2 := aRect.Bottom;
      end
      else
      begin
         if Scale.Visible and (FScalePos = spBelowOrRight) then
            Y1 := aRect.Top+HalfTH-FGroove.BevelExtend -(FGrooveSize div 2)
         else if Scale.Visible and (FScalePos = spAboveOrLeft) then
            Y1 := aRect.Bottom-HalfTH-FGroove.BevelExtend-(FGrooveSize div 2)-1
         else
            Y1 := aRect.Top+(aHeight div 2)-FGroove.BevelExtend-(FGrooveSize div 2);

         Y2 := Y1 + 2*FGroove.BevelExtend+ FGrooveSize;
         X1 := aRect.Left;
         X2 := aRect.Right;
      end;
      R1 := Rect(X1,Y1,X2,Y2);

      DrawScale(Canvas,R1);

      R2 := DrawGroove(Canvas,R1);

      {Now do a filled rectangle in the center if the control has focus}
      Brush.Color := FGrooveColor;
      if Focused then
      begin
         if (FFocusAction = faFocusRect) or (FFocusAction = faAll) then
         begin
            R3 := aRect;
            if ((Bevel.BorderWidth > 0) and (Bevel.BevelInner = bvNone)) or
               (Bevel.BorderSpace > 0) then
               InflateRect(R3,1,1);
            DrawFocusRect(R3);
         end;

         if (FFocusAction = faFocusColor) or (FFocusAction = faAll) then
             Brush.Color := FocusColor;
      end;
      FillRect(R2);
   end;
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.DrawThumb(Canvas: TCanvas; aRect: Trect);
var
   X, Y: integer;
   Clr: TColor;

begin
   with Canvas,aRect do
   begin
      case FThumbStyle of
        tsOwnerDraw: OwnerDrawThumb(Canvas, aRect, FDragging, FFocusTime);
        tsRect:
        begin
           if FThumbBorder then
              Frame3D(Canvas, aRect, clWindowFrame, clWindowFrame, 1)
           else
           begin
              Pen.Color := clWindowFrame;
              MoveTo(aRect.Left,aRect.Bottom-1);
              LineTo(aRect.Right-1,aRect.Bottom-1);
              LineTo(aRect.Right-1,aRect.Top-1);
              dec(aRect.Right);
              dec(aRect.Bottom);
           end;

           Frame3D(Canvas, aRect, clBtnHighlight, clBtnShadow, 1);

           Pixels[aRect.Right,aRect.Top-1] := clBtnHighLight;
           Pixels[aRect.Left-1,aRect.Bottom] := clBtnHighLight;

           Brush.Color := FThumbColor;
           FillRect(aRect);

           if not Enabled or FFocusTime then
           begin
              if not Enabled then
                 Clr := FDisabledColor
              else
                 Clr := clBlack;

              for Y := aRect.Top to aRect.Bottom-1 do
                  for X := aRect.Left to aRect.Right-1 do
                  if (Y mod 2) = (X mod 2) then
                     Pixels[X, Y] := Clr;
           end;
        end;
      end;
   end;
end;

{-- TMMCustomSlider -----------------------------------------------------}
function  TMMCustomSlider.DrawPics(Canvas: TCanvas; aRect: TRect): TRect;
var
    AWidth, AHeight: Integer;
    OrigX, OrigY   : Integer;

    procedure   DrawPic(Pic: TBitmap; R: TRect);
    var
        X, Y: Integer;
    begin
        X := R.Left + (R.Right - R.Left - Pic.Width) div 2;
        Y := R.Top + (R.Bottom - R.Top - Pic.Height) div 2;
        Canvas.BrushCopy(Bounds(X,Y,Pic.Width,Pic.Height),Pic,Bounds(0,0,Pic.Width,Pic.Height),Pic.TransparentColor);
    end;
begin
    AWidth := aRect.Right - aRect.Left;
    AHeight:= aRect.Bottom- aRect.Top;

    OrigY := AHeight div 2 + aRect.Top;
    if Orientation = orHorizontal then
        if Scale.Visible then
            if ScalePosition = spAboveOrLeft then
                OrigY := aRect.Bottom - FThumbHeight div 2
            else if ScalePosition = spBelowOrRight then
                OrigY := aRect.Top + FThumbHeight div 2;
  
    OrigX := AWidth div 2 + aRect.Left;
    if Orientation = orVertical then
        if Scale.Visible then
            if ScalePosition = spAboveOrLeft then
                OrigX := aRect.Right - FThumbWidth div 2
            else if ScalePosition = spBelowOrRight then
                OrigX := aRect.Left + FThumbWidth div 2;

    if not FPicLeft.Empty then
        if Orientation = orHorizontal then
        begin
          DrawPic(FPicLeft,Bounds(aRect.Left,OrigY-FPicLeft.Height div 2,FPicLeft.Width,FPicLeft.Height));
          Inc(aRect.Left,FPicLeft.Width);
        end
        else
        begin
           DrawPic(FPicLeft,Bounds(OrigX-FPicLeft.Width div 2,aRect.Top,FPicLeft.Width,FPicLeft.Height));
           Inc(aRect.Top,FPicLeft.Height);
        end;

    if not FPicRight.Empty then
        if Orientation = orHorizontal then
        begin
           DrawPic(FPicRight,Bounds(aRect.Right-FPicRight.Width,OrigY-FPicRight.Height div 2,
                   FPicRight.Width,FPicRight.Height));
           Dec(aRect.Right,FPicRight.Width);
        end
        else
        begin
           DrawPic(FPicRight,Bounds(OrigX-FPicRight.Width div 2,aRect.Bottom-FPicRight.Height,
                   FPicRight.Width,FPicRight.Height));
           Dec(aRect.Bottom,FPicRight.Height);
        end;

    Result := aRect;
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.SetPicLeft(Value: TBitmap);
begin
   FPicLeft.Assign(Value);
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.SetPicRight(Value: TBitmap);
begin
   FPicRight.Assign(Value);
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.Paint;
var
   aRect: TRect;

begin
   if (FBitmap = nil) then exit;

   with FBitmap do
   begin
      { draw the Bevel and fill the area }
      aRect := Bevel.PaintBevel(Canvas, ClientRect,True);
      with FBitmap.Canvas do
      begin
         Brush.Color := Color;
         Brush.Style := bsSolid;
         FillRect(aRect);

         aRect := DrawPics(Canvas,aRect);
         WhereIsThumb(aRect,FThumbRect);
         DrawTrench(Canvas, aRect);
         DrawThumb(Canvas, FThumbRect);
     
      end;
   end;
   Canvas.Draw(0,0,FBitmap); 
end;

{-- TMMCustomSlider -----------------------------------------------------}
function TMMCustomSlider.DrawGroove(Canvas: TCanvas; aRect: TRect): TRect;
begin
   if FGrooveStyle = gsOwnerDraw then
   begin
      InflateRect(aRect,0,-FGroove.BevelExtend);
      OwnerDrawGroove(Canvas,aRect);
      Result := aRect;
   end
   else
      Result := FGroove.PaintBevel(Canvas, aRect, True);
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.SetThumbCursor(AtThumb: Boolean);
begin
   if AtThumb then
      if FHandCursor then
         SetCursor(Screen.Cursors[crsHand5])
      else
         SetCursor(Screen.Cursors[ThumbCursor])
   else
       SetCursor(Screen.Cursors[Cursor]);
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.CMMouseEnter(var msg: TMessage);
begin
   if Assigned(FOnMouseEnter) then FOnMouseEnter(Self);
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.CMMouseLeave(var msg: TMessage);
begin
   if Assigned(FOnMouseLeave) then FOnMouseLeave(Self);
end;

end.