mmctrl.pas

一套及时通讯的原码

{-- TMMBitmapSlider -----------------------------------------------------}
function TMMBitmapSlider.GetSrcRect(index: integer): TRect;
begin
   index := Min(index,FNumGlyphs-1);
   if (Orientation = orHorizontal) then
   begin
      Result.Left := 0;
      Result.Top := index * (Bitmap.Height div FNumGlyphs);
      Result.Right := Bitmap.Width;
      Result.Bottom := (index+1) * (Bitmap.Height div FNumGlyphs);
   end
   else
   begin
      Result.Left := index * (Bitmap.Width div FNumGlyphs);
      Result.Top := 0;
      Result.Right := (index+1) * (Bitmap.Width div FNumGlyphs);
      Result.Bottom := Bitmap.Height;
   end;
end;

{-- TMMBitmapSlider -----------------------------------------------------}
function TMMBitmapSlider.GetThumbSrcRect(index: integer): TRect;
begin
   index := Min(index,FNumThumbGlyphs-1);
   Result.Left := index * (ThumbBitmap.Width div FNumThumbGlyphs);
   Result.Top := 0;
   Result.Right := (index+1) * (ThumbBitmap.Width div FNumThumbGlyphs);
   Result.Bottom := ThumbBitmap.Height;
end;

{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.SetNumGlyphs(aValue: integer);
begin
   if (FNumGlyphs <> aValue) then
   begin
      FNumGlyphs := Max(aValue,1);
      UpdateSlider;
      Refresh;
   end;
end;

{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.SetNumThumbGlyphs(aValue: integer);
begin
   if (FNumThumbGlyphs <> aValue) then
   begin
      FNumThumbGlyphs := Max(aValue,1);
      UpdateSlider;
      Refresh;
   end;
end;

{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.Track;
begin
   FNeedTrackEnd := True;
   if assigned(FOnTrack) then FOnTrack(Self);
end;

{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.TrackEnd;
begin
   if FNeedTrackEnd then
   begin
      if assigned(FOnTrackEnd) then FOnTrackEnd(Self);
      FNeedTrackEnd := False;
   end;
end;

{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.CMEnabledChanged(var Message: TMessage);
begin
   if (csDesigning in ComponentState) or not FBitmapOK then
      Invalidate
   else
      RedrawThumb;
end;

{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.SetBounds(aLeft, aTop, aWidth, aHeight: integer);
begin
   if BitmapValid and AutoSize then
   begin
      aWidth := Bitmap.Width;
      aHeight:= Bitmap.Height;
      if (Orientation = orHorizontal) then
          aHeight := aHeight div FNumGlyphs
      else
          aWidth := aWidth div FNumGlyphs;
   end;

   if (Width <> aWidth) or (Height <> aHeight) and (FSaveBitmap <> nil) then
   begin
      FSaveBitmap.Width  := aWidth;
      FSaveBitmap.Height := 2*aHeight;
      FBitmapOK          := False;
   end;

   inherited SetBounds(aLeft, aTop, aWidth, aHeight);
end;

{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.SetSensitivity(aValue: integer);
var
   oldVal: integer;
begin
   aValue:= MinMax(aValue, -96, -10);
   if aValue <> FSensitivity then
   begin
      oldVal := Position;
      FSensitivity:= aValue;
      Position := oldVal;
   end;
end;

{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.SetLogMode;
var
   oldVal: integer;
begin
   if (aValue <> FlogMode) then
   begin
      oldVal := Position;
      FLogMode := aValue;
      if not (csLoading in ComponentState) then FMax := Max(FMax,FMin+Ord(FLogMode));
      Position := oldVal;
   end;
end;

{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.SetMin(aValue: Longint);
begin
   SetMinMax(aValue,FMax);
end;

{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.SetMax(aValue: Longint);
begin
   SetMinMax(FMin,aValue);
end;

{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.SetMinMax(aMin,aMax: Longint);
begin
   if (FMin <> aMin) or (FMax <> aMax) then
   begin
      FMin := aMin;
      FMax := aMax;
      if not (csLoading in ComponentState) then
         FMax := Max(FMax,FMin+Ord(FLogMode));
      FForceChange := True;
      Position := MinMax(Position,FMin,FMax);
      FForceChange := False;
      if (csDesigning in ComponentState) or not FBitmapOK then
          Invalidate
      else
          RedrawThumb;
   end;
end;

{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.SetOrientation(aValue: TMMOrientation);
begin
   if (aValue <> FOrientation) then
   begin
      FOrientation := aValue;
      UpdateSlider;
   end;
   {$IFDEF WIN32}
   {$IFDEF TRIAL}
   {$DEFINE _HACK2}
   {$I MMHACK.INC}
   {$ENDIF}
   {$ENDIF}
end;

{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.SetZeroPosition(aValue: TMMZeroPosition);
begin
   if (aValue <> FZeroPosition) then
   begin
      FZeroPosition := aValue;
      Invalidate;
   end;
end;

{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.DrawBitmapImage(Canvas: TCanvas; Bitmap: TBItmap; X, Y: integer; Src: TRect);
var
   Done,H,W: integer;
begin
   if (Orientation = orVertical) and (Src.Bottom-Src.Top >= Height) or
      (Orientation = orHorizontal) and (Src.Right-Src.Left >= Width) then
   begin
      DrawTransparentBitmapEx(Canvas.Handle, Bitmap.Handle, X, Y, Src, GetTransparentColor);
   end
   else if (Orientation = orVertical) then
   begin
      Done := 0;
      Dec(Src.Bottom,2);
      while (Done < Height) do
      begin
         DrawTransparentBitmapEx(Canvas.Handle, Bitmap.Handle, X, Y+Done, Src, GetTransparentColor);
         H := Src.Bottom-Src.Top;
         if (Done = 0) then Inc(Src.Top,2);
         inc(Done,H);
      end;
   end
   else
   begin
      Done := 0;
      Dec(Src.Right,2);
      while (Done < Width) do
      begin
         DrawTransparentBitmapEx(Canvas.Handle, Bitmap.Handle, X+Done, Y, Src, GetTransparentColor);
         W := Src.Right-Src.Left;
         if (Done = 0) then Inc(Src.Left,4);
         inc(Done,W);
      end;
   end;
end;

{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.RedrawThumb;
var
   index: integer;
   SrcRect: TRect;

begin
   if Visible then
   begin
      { copy saved background to temp bitmap (top) }
      FSaveBitmap.Canvas.CopyRect(Rect(0,0,Width,Height),
                                  FSaveBitmap.Canvas,
                                  Rect(0,Height,Width,2*Height));

      if (NumGlyphs > 1) and BitmapValid then
      begin
         Index := 0;
         if assigned(FOnGetGlyphIndex) then
         begin
            FOnGetGlyphIndex(Self, FDragging, Index);
            Index := MinMax(Index,0,FNumGlyphs-1);
         end;

         SrcRect := GetSrcRect(Index);

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

      { draw Thumb to Bitmap }
      DrawThumb(FSaveBitmap.Canvas,FThumbRect);
      { and copy to screen }
      Canvas.Draw(0,0,FSaveBitmap);
   end;
end;

{-- TMMBitmapSlider -----------------------------------------------------}
function TMMBitmapSlider.UpdatePosition(aValue: Longint): Boolean;
var
   aRect: TRect;
begin
   if (aValue <> FPosition) or FForceChange then
   begin
      Result := True;
      FPosition := MinMax(aValue,FMin,FMax);
      if not (csDesigning in ComponentState) and
         not (csLoading in ComponentState) then
      begin
         WhereIsThumb(ClientRect,aRect);

         if (aRect.Left <> FThumbRect.Left) or (aRect.Top <> FThumbRect.Top) or
            (aRect.Right <> FThumbRect.Right) or (aRect.Bottom <> FThumbRect.Bottom) then
         begin
            FThumbRect := aRect;
            if FBitmapOK then
               RedrawThumb
            else
               Refresh;
         end;
         Change;
      end
      else Refresh;
   end
   else Result := False;
end;

{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.SetPosition(aValue: Longint);
var
   aPos: Float;
begin
   if FLogMode and (aValue <> 0) then
   begin
      aPos:= Log10(aValue/(FMax-FMin))*20 + -FSensitivity;
      aPos:= MinMax(Round(aPos*(FMax-FMin)/-FSensitivity),FMin,FMax);
      aValue := Round(aPos);
   end;
   UpdatePosition(aValue);
end;

{-- TMMBitmapSlider -----------------------------------------------------}
function TMMBitmapSlider.GetPosition: Longint;
var
   aPos: Float;
begin
   aPos := MinMax(FPosition,FMin,FMax);

   if FLogMode and (aPos <> 0) then
   begin
      aPos:= Pow(10,(aPos*(-FSensitivity)/(FMax-FMin)-(-FSensitivity))/20)*(FMax-FMin);
   end;
   Result := MinMax(Round(aPos),FMin,FMax);
end;

{-- TMMBitmapSlider -----------------------------------------------------}
function TMMBitmapSlider.NewPosition(WhereX,WhereY: Integer): Longint;
var
  aHeight,aWidth: Integer;

begin
   { Calculate the nearest position to where the mouse is located }
   with ClientRect do
   begin
      aHeight := (Bottom - Top) - FThumbHeight;