mmctrl.pas

一套及时通讯的原码

      aWidth  := (Right - Left) - FThumbWidth;
      WhereY  := WhereY - Top - (FThumbHeight div 2);
      WhereX  := WhereX - Left - (FThumbWidth div 2);
   end;

   if IsVert then
   begin
      if IsInverted then
         Result := Round((WhereY/aHeight)*(FMax-FMin)+FMin)
      else
         Result := Round(((aHeight-WhereY)/aHeight)*(FMax-FMin)+FMin);
   end
   else
   begin
      if IsInverted then
         Result := Round(((aWidth-WhereX)/aWidth)*(FMax-FMin)+FMin)
      else
         Result := Round((WhereX/aWidth)*(FMax-FMin)+FMin);
   end;

   Result := Min(Max(Result,FMin),FMax);
end;

{-- TMMBitmapSlider -----------------------------------------------------}
function TMMBitmapSlider.IsVert: Boolean;
begin
   Result := (Orientation = orVertical);
end;

{-- TMMBitmapSlider -----------------------------------------------------}
function TMMBitmapSlider.IsInverted: Boolean;
begin
   Result := (ZeroPosition = zpTopRight);
end;

{-- TMMBitmapSlider -----------------------------------------------------}
function TMMBitmapSlider.FindTransparentColor: TColor;
var
   HBM: HBITMAP;

begin
   Result := clDefault;

   if assigned(BitmapList) then
   begin
      if ThumbBitmapValid then
          HBM := ThumbBitmap.Handle
      else if BitmapValid then
          HBM := Bitmap.Handle
      else exit;

      Result := MMUtils.GetTransparentColor(HBM);
   end;
 end;

{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.SetMargin(aValue: integer);
begin
   if (aValue <> FMargin) then
   begin
      FMargin := MinMax(aValue,0,25);
      Refresh;
   end;
end;

{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.SetThumbMargin(aValue: integer);
begin
   if (aValue <> FThumbMargin) then
   begin
      FThumbMargin := MinMax(aValue,-5,5);
      Refresh;
   end;
end;

{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
   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
         UpdatePosition(NewPosition(X,Y))
      else if (FNumThumbGlyphs > 1) then
         RedrawThumb;

      Track;
   end;

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

{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.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 ClientRect do
      begin
         aHeight := (Bottom - Top) - FThumbHeight - 2*Margin;
         aWidth  := (Right - Left) - FThumbWidth - 2*Margin;
      end;

      if IsVert then
      begin
         if IsInverted then
            aPos := Round(((Y-FDragOffset)*(FMax-FMin))/aHeight)
         else
            aPos := Round(((FDragOffset-Y)*(FMax-FMin))/aHeight);
      end
      else
      begin
         if IsInverted then
            aPos := Round(((FDragOffset-X)*(FMax-FMin))/aWidth)
         else
            aPos := Round(((X-FDragOffset)*(FMax-FMin))/aWidth);
      end;

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

      if UpdatePosition(aPos) then Track;
   end;

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

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

      if (FNumThumbGlyphs > 1) then RedrawThumb;

      Update;

      TrackEnd;
   end;

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

{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.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
      if (FMax-FMin = 0) then
          Each := (aHeight-FThumbHeight-2*Margin)/1
      else
          Each := (aHeight-FThumbHeight-2*Margin)/Max(FMax-FMin,Sign(FMin));

      if IsInverted then
         ThumbY := Round(Each*(FPosition-FMin))+Margin
      else
         ThumbY := (aHeight-Round(Each*(FPosition-FMin))-FThumbHeight)-Margin;

      ThumbY := ClientRect.Top + Max(0,Min(aHeight-FThumbHeight-Margin,ThumbY));
      ThumbX := ClientRect.Left + ((aWidth+1) div 2) - ((FThumbWidth+1) div 2) + FThumbMargin;
   end
   else
   begin
      if (FMax-FMin = 0) then
          Each := (aWidth-FThumbWidth-2*Margin)/1
      else
          Each := (aWidth-FThumbWidth-2*Margin)/(FMax-FMin);

      if IsInverted then
         ThumbX := (aWidth-Round(Each*(FPosition-FMin))-FThumbWidth)-Margin
      else
         ThumbX := Round(Each*(FPosition-FMin))+Margin;

      ThumbX := ClientRect.Left + Max(0,Min(aWidth-FThumbWidth-Margin,ThumbX))+FThumbMargin;
      ThumbY := ClientRect.Top + ((aHeight+1) div 2) - ((FThumbHeight+1) div 2);
   end;
   aRect := Rect(ThumbX,ThumbY,ThumbX+FThumbWidth,ThumbY+FThumbHeight);
end;

{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.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;

{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.DrawThumb(Canvas: TCanvas; aRect: TRect);
var
   index: integer;
   SrcRect: TRect;

begin
   with Canvas,aRect do
   begin
      if ThumbBitmapValid then
      begin
         index := 0;

         if assigned(FOnGetThumbGlyphIndex) then
         begin
            FOnGetThumbGlyphIndex(Self, FDragging, Index);
            Index := MinMax(Index,0,FNumThumbGlyphs-1);
         end
         else
         begin
            case FNumThumbGlyphs of   {normal,disabled,down,down }
               2: if not Enabled then Index := 1;
               3: if not Enabled then
                     Index := 1
                  else if Dragging then
                     Index := 2;
            end;
         end;

         SrcRect := GetThumbSrcRect(index);

         DrawTransparentBitmapEx(Handle, ThumbBitmap.Handle,
                                 aRect.Left, aRect.Top,
                                 SrcRect,
                                 GetTransparentColor);
      end;
   end;
end;

{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.Paint;
var
   S: string;
   SrcRect: TRect;
   index,Done,H,W: integer;

begin
   if (FSaveBitmap = nil) then exit;

   if not (csDesigning in ComponentState) and assigned(FOnGetBackground) then
   begin
      FOnGetBackground(Self,FSaveBitmap,Rect(0,Height,Width,2*Height));
   end
   else
   begin
      { save the actual background to the bottom of the bitmap }
      FSaveBitmap.Canvas.CopyRect(Rect(0,Height,Width,2*Height),Canvas,ClientRect);
   end;
   FBitmapOK := True;

   { draw the image to our bitmap }
   with FSaveBitmap.Canvas,ClientRect do
   begin
      if not BitmapValid then
      begin
         if (csDesigning in ComponentState) then
         begin
            Font := Self.Font;
            Brush.Style := bsClear;
            S := 'Empty';
            TextOut((Right-TextWidth(S)) div 2,Height+((Bottom-TextHeight(S))) div 2,S);
            Pen.Style   := psDot;
            Rectangle(Left,Height+Top,Right,Height+Bottom);
            Pen.Mode := pmCopy;
         end;
      end
      else
      begin
         Index := 0;
         if assigned(FOnGetGlyphIndex) then
         begin
            FOnGetGlyphIndex(Self, FDragging, Index);
            Index := MinMax(Index,0,FNumGlyphs-1);
         end;

         SrcRect := GetSrcRect(Index);

         { draw the background to the top of the bitmap }
         DrawBitmapImage(FSaveBitmap.Canvas,Bitmap,0,Height,SrcRect);
      end;
   end;

   { copy the background to screen }
   Canvas.CopyRect(ClientRect,FSaveBitmap.Canvas,Rect(0,Height,Width,2*Height));

   { draw the Thumb }
   WhereIsThumb(ClientRect,FThumbRect);
   DrawThumb(Canvas,FThumbRect);
end;

end.