mmslider.pas

一套及时通讯的原码

            Inc(Result.Top,FPicLeft.Height);

    if not FPicRight.Empty then
        if Orientation = orHorizontal then
            Dec(Result.Right,FPicRight.Width)
        else
            Dec(Result.Bottom,FPicRight.Height);
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.WMSetFocus(var Message: TWMSetFocus);
begin
   inherited;

   { Added January, 30 2000 }
   if Assigned(FOnGetFocus) then FOnGetFocus(Self);

   if (FFocusAction <> faNone) then
   begin
      UpdateFocusTimer(True);
      Refresh;
   end;
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.WMKillFocus(var Message: TWMKillFocus);
begin
   inherited;

   { Added January, 30 2000 }
   if Assigned(FOnLostFocus) then FOnLostFocus(Self);

   if (FFocusAction <> faNone) then
   begin
      UpdateFocusTimer(False);
      Refresh;
   end;
end;

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

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.CMEnabledChanged(var Message: TMessage);
begin
   inherited;

   Refresh;
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.WMSize(var Message: TWMSize);
begin
   if Height > Width then
      Orientation := orVertical else Orientation := orHorizontal;
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.Loaded;
begin
   inherited Loaded;

   UpdateBitmap(Width,Height);
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.UpdateBitmap(aWidth,aHeight: integer);
begin
   if (csLoading in ComponentState) or
      (csReading in ComponentState) then exit;

   RemoveCacheBitmap(FBitmap);
   FBitmap := LoadCacheBitmap(Max(aWidth,0),Max(aHeight,0));

   Invalidate;
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.SetBounds(aLeft, aTop, aWidth, aHeight: integer);
begin
   if (Width <> aWidth) or (Height <> aHeight) or (FBitmap = nil) then
   begin
      UpdateBitmap(aWidth,aHeight);
   end;

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

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.SetColors(index: integer; aValue: TColor);
begin
   case index of
      0: if aValue = FFocusColor then exit else FFocusColor := aValue;
      1: if aValue = FGrooveColor then exit else FGrooveColor := aValue;
      2: if aValue = FThumbColor then exit else FThumbColor := aValue;
      3: if aValue = FDisabledColor then exit else FDisabledColor := aValue;
   end;
   Refresh;

   {$IFDEF WIN32}
   {$IFDEF TRIAL}
   {$DEFINE _HACK1}
   {$I MMHACK.INC}
   {$ENDIF}
   {$ENDIF}
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.SetThumbBorder(aValue: Boolean);
begin
   if (aValue <> FThumbBorder) then
   begin
      FThumbBorder := aValue;
      Invalidate;
   end;
end;
{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.SetThumbSize(index: integer; aValue: Byte);
begin
   case Index of
       0: if (aValue = FThumbWidth) then exit else FThumbWidth := aValue;
       1: if (aValue = FThumbHeight) then exit else FThumbHeight := aValue;
   end;
   HalfTH := FThumbHeight div 2;
   HalfTW := FThumbWidth div 2;
   Refresh;

   {$IFDEF WIN32}
   {$IFDEF TRIAL}
   {$DEFINE _HACK2}
   {$I MMHACK.INC}
   {$ENDIF}
   {$ENDIF}
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.SetThumbStyle(aValue: TMMThumbStyle);
begin
   if (FThumbStyle <> aValue) then
   begin
      FThumbStyle := aValue;
      Refresh;
   end;
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.SetGrooveStyle(aValue: TMMGrooveStyle);
begin
   if (FGrooveStyle <> aValue) then
   begin
      FGrooveStyle := aValue;
      Refresh;
   end;
end;

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

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.SetLogMode;
var
   oldVal: integer;
begin
   if (aValue <> FlogMode) then
   begin
      oldVal := Position;
      FLogMode := aValue;
      Position := oldVal;
   end;
end;

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

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

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.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+1);
      FForceChange := True;
      Position := MinMax(Position,FMin,FMax);
      FForceChange := False;
      Refresh;
   end;
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.SetOrientation(aValue: TMMOrientation);
var
   Temp: integer;

begin
   if (aValue <> FOrientation) then
   begin
      FOrientation := aValue;
      if (csDesigning in ComponentState) and
         not (csLoading in ComponentState) and
         not (csReading in ComponentState) then
      begin
         { exchange Thumb sizes }
         Temp := ThumbWidth;
         ThumbWidth := ThumbHeight;
         ThumbHeight := Temp;

         if (isVert and (Width > Height)) or
            (not isVert and (Height > Width)) then
            SetBounds(Left,Top,Height,Width);
      end;
      Refresh;
   end;
   {$IFDEF WIN32}
   {$IFDEF TRIAL}
   {$DEFINE _HACK2}
   {$I MMHACK.INC}
   {$ENDIF}
   {$ENDIF}
end;

{-- TMMCustomSlider -----------------------------------------------------}
function TMMCustomSlider.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(CalcClientRect,aRect);

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

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

{-- TMMCustomSlider -----------------------------------------------------}
function TMMCustomSlider.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;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.SetGrooveSize(aValue: Byte);
begin
   If (aValue >= 0) then
   begin
      FGrooveSize := aValue;
      Refresh;
   end;
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.SetScaleDist(aValue: Integer);
begin
  if (aValue <> FScaleDistance) then
  begin
     FScaleDistance := aValue;
     Refresh;
  end;
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.SetScalePos(aValue: TMMScalePos);
begin
   if (aValue <> FScalePos) then
   begin
      FScalePos := aValue;
      Refresh;
   end;
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.SetScale(Value: TMMScale);
begin
    FScale.Assign(Value);
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.TimerAction(Sender: TObject);
begin
   if not FDragging then
   begin
      FFocusTime := not FFocusTime;
      Refresh;
   end
   else FFocusTime := True;
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.UpdateFocusTimer(Enable: Boolean);
begin
   if (FocusTimer <> nil) and (FocusTimer.Owner = Self) then
   begin
      FocusTimer.Enabled := False;
      FocusTimer.Free;
      FocusTimer :=  nil;
      FFocusTime := False;
   end;

   if not (csDesigning in ComponentState) then
   begin
      if Enable and Focused and (FocusAction in [faFocusThumb,faAll]) then
      begin
         if (FocusTimer = nil) then FocusTimer := TTimer.Create(Self);
         FocusTimer.OnTimer := TimerAction;
         FocusTimer.Interval := 500;
         FocusTimer.Enabled := True;
      end;
   end;
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.SetFocusAction(aValue: TMMFocusAction);
begin
  if (FFocusAction <> aValue) then
  begin
     FFocusAction := aValue;
     UpdateFocusTimer(Enabled);
     Refresh;
  end;
end;

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

begin
   { Calculate the nearest position to where the mouse is located }
   with CalcClientRect do
   begin
      aHeight := Bottom - Top - FThumbHeight;
      aWidth  := Right - Left -FThumbWidth;
      WhereY  := WhereY - Top - HalfTH;
      WhereX  := WhereX - Left - HalfTW;
   end;

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

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

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

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.KeyDown(var Key: Word; Shift: TShiftState);
var
  Pos : Integer;

begin
   Pos := FPosition; { To avoid compiler warning }

   try
      case Key of
         VK_NEXT : if (FPosition-FPageSize) > FMin then
                       Pos := FPosition - FPageSize else Pos := FMin;
         VK_PRIOR: if (FPosition+FPageSize) < FMax then
                       Pos := FPosition + FPageSize else Pos := FMax;
         VK_END  : if IsVert then Pos := FMin else Pos := FMax;
         VK_HOME : if IsVert then Pos := FMax else Pos := FMin;
         VK_LEFT,
         VK_DOWN : if FPosition > FMin then Pos := FPosition - FLineSize;
         VK_UP,
         VK_RIGHT: if FPosition < FMax then Pos := FPosition + FLineSize;
        else exit;
      end;
      if UpdatePosition(Pos) then Track;

   finally
      inherited KeyDown(Key,Shift);
   end;