mmscroll.pas

一套及时通讯的原码

{-- TMMScrollPanel ------------------------------------------------------}
procedure TMMScrollPanel.SetSliderColor(Value: TColor);
begin
   if Value <> FSliderColor then
   begin
      FSliderColor := Value;
      Invalidate;
   end;
end;

{-- TMMScrollPanel ------------------------------------------------------}
procedure TMMScrollPanel.SetSliderLight(Value: TColor);
begin
   if Value <> FSliderLight then
   begin
      FSliderLight := Value;
      Invalidate;
   end;
end;

{-- TMMScrollPanel ------------------------------------------------------}
procedure TMMScrollPanel.SetSliderShadow(Value: TColor);
begin
   if Value <> FSliderShadow then
   begin
      FSliderShadow := Value;
      Invalidate;
   end;
end;

{-- TMMScrollPanel ------------------------------------------------------}
procedure TMMScrollPanel.Pixel(var PixMin, PixMax: integer);
var
   VirtualPixel : integer;

begin
   PixMin := X_ToPixel(FSliderMin);
   PixMax := X_ToPixel(FSliderMax);
   VirtualPixel := PixMax - PixMin;
   if VirtualPixel >= MinPixel then exit;        { Breite ist o.k. }

   PixMin := Limit(PixMin-(MinPixel-VirtualPixel) div 2,
             X_ToPixel(FRangeMin),X_ToPixel(FRangeMax)-MinPixel);
   PixMax := Limit(PixMax+(MinPixel-VirtualPixel) div 2,
             X_ToPixel(FRangeMin)+MinPixel,X_ToPixel(FRangeMax));
end;

{-- TMMScrollPanel ------------------------------------------------------}
procedure TMMScrollPanel.Track;
begin
   if not (csLoading in ComponentState) and
      not (csReading in ComponentState) then
   begin
      if (FShift = skLeft) or (FShift = skRight) then
      begin
         if Assigned(FOnTrackSize) then FOnTrackSize(Self,SliderMin,SliderMax);
      end
      else
         if Assigned(FOnTrack) then FOnTrack(Self,SliderMin,SliderMax);
      end;
end;

{-- TMMScrollPanel ------------------------------------------------------}
procedure TMMScrollPanel.TrackEnd;
begin
   if not (csLoading in ComponentState) and
      not (csReading in ComponentState) then
      if Assigned(FOnTrackEnd) then FOnTrackEnd(Self,SliderMin,SliderMax);
end;

{-- TMMScrollPanel ------------------------------------------------------}
procedure TMMScrollPanel.SetLocator(Value: Longint);
begin
   if (Value <> FLocator) then
   begin
      FLocator := Value;
      if (X_ToPixel(FLocator) <> FLastLoc) then
      begin
         DrawLocator(Canvas, FLastLoc);
      end;
   end;
end;

{-- TMMScrollPanel ------------------------------------------------------}
function TMMScrollPanel.MouseAction(X, Y: integer): TMMScrollShiftKind;
var
   PixMin, PixMax : integer;
begin
   Pixel(PixMin, PixMax);
   if FKind = spVertical then
     X := Y;
   if inrange(X, PixMin, PixMin+Griff) and FSizeable then
      Result := skLeft
   else if inrange(X, PixMax-Griff, PixMax) and FSizeable then
      Result := skRight
   else if inrange(X, PixMin, PixMax) then
      Result := skBoth
   else if inRange(X,X_ToPixel(FRangeMin),X_ToPixel(FRangeMax)) then
      Result := skJump
   else
      Result := skNone;
end;

{-- TMMScrollPanel ------------------------------------------------------}
procedure TMMScrollPanel.MouseDown(Button: TMouseButton; Shift: TShiftState; X,Y : integer);
begin
   if (Button <> mbLeft) or (ssDouble in Shift) then exit;
   FShift := MouseAction(X, Y);
   if FShift = skRight then
      FShiftOffset := FSliderMax-PixelTo_X(X,Y)
   else
      FShiftOffset := PixelTo_X(X,Y)-FSliderMin;

   if (FShift = skBoth) and ((SliderMin > RangeMin) or (SliderMax < RangeMax)) then
      SliderDown := True
   else if FShift = skJump then
   begin
      SetSliderAll(limit(PixelTo_X(X, Y) - (FSliderMax-FSliderMin) div 2,
                   FRangeMin, FRangeMax - (FSliderMax - FSliderMin)),
                   limit(PixelTo_X(X, Y) + (FSliderMax-FSliderMin) div 2,
                   FRangeMin + (FSliderMax - FSliderMin), FRangeMax));
   end;

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


{-- TMMScrollPanel ------------------------------------------------------}
procedure TMMScrollPanel.MouseMove(Shift: TShiftState; X,Y: integer);
var
   xv, mi, ma : longint;

begin
   case MouseAction(X,Y) of
      skLeft,
      skRight:
      begin
         if FKind = spHorizontal then Cursor := crSizeWE
         else Cursor := crSizeNS;
      end;
     else Cursor := crDefault;
   end;

   xv := Max(PixelTo_X(MinPixel,MinPixel) - PixelTo_X(0,0),1);

   if FShift = skBoth then
   begin
      mi := limit(PixelTo_X(X,Y)-FShiftOffset,FRangeMin, FRangeMax-FSliderMax+FSliderMin);
      ma := mi + FSliderMax-FSliderMin;
      SetSliderBoth(mi, ma);
      Track;
   end
   else if FShift = skLeft then
   begin
      SetSliderBoth(Limit(PixelTo_X(X,Y)-FShiftOffset, FRangeMin,
                    FSliderMax - xv), FSliderMax);
      Track;
   end
   else if FShift = skRight then
   begin
      SetSliderBoth(FSliderMin, Limit(PixelTo_X(X,Y)+FShiftOffset,
                    FSliderMin + xv, FRangeMax));
      Track;
   end;

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

{-- TMMScrollPanel ------------------------------------------------------}
procedure TMMScrollPanel.MouseUp(Button : TMouseButton; Shift: TShiftState; X,Y : integer);
begin
   if Button = mbLeft then
   begin
      FShift := sknone;
      SliderDown := false;
      TrackEnd;
   end;

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

{-- TMMScrollPanel ------------------------------------------------------}
procedure TMMScrollPanel.DblClick;
var
   aPos : TPoint;

begin
   if FSizeable then
   begin
      GetCursorPos(aPos);
      aPos := ScreenToClient(aPos);
      if Mouseaction(aPos.X, aPos.Y) = skBoth then
      begin
         if (SliderMin=FRangeMin) and (SliderMax=FRangeMax) then
         begin
            if (FLastMin<>0) or (FlastMax<>0) then
            begin
               SetSliderAll(FlastMin,FLastMax);
               FlastMin := 0; FLastMax := 0;
            end;
         end
         else
         begin
            FLastmin := FSliderMin; FLastMax := FSliderMax;
            SetSliderAll(FRangeMin, FRangeMax);
         end;
      end;
   end;

   inherited DblClick;

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

{-- TMMScrollPanel ------------------------------------------------------}
procedure TMMScrollPanel.DrawLocator(aCanvas: TCanvas; var LastLoc: integer);
var
   Loc: integer;

begin
   if not (csDesigning in ComponentState) and not Visible then exit;

   if (FLocator >= 0) then
       Loc := X_ToPixel(FLocator)
   else
       Loc := FLocator;

   with aCanvas do
   begin
      Pen.Width := 1;
      Pen.Mode := pmXor;
      Pen.Color := FLocColor;
      { alten Locator l鰏chen }
      if (LastLoc <> -1) then
      begin
         if FKind = spHorizontal then
         begin
            MoveTo(LastLoc,BevelExtend+1);
            LineTo(LastLoc,Height-(BevelExtend+1));
         end
         else
         begin
            MoveTo(BevelExtend+1,LastLoc);
            LineTo(Width-(BevelExtend+1),LastLoc);
         end;
      end;

      if inRange(Loc,BevelExtend,Width-BevelExtend-1) then
      begin
         { neuen Locator zeicnen }
         if FKind = spHorizontal then
         begin
            MoveTo(Loc,BevelExtend+1);
            LineTo(Loc,Height-(BevelExtend+1));
         end
         else
         begin
            MoveTo(BevelExtend+1,Loc);
            LineTo(Width-(BevelExtend+1),Loc);
         end;
         LastLoc := Loc;
      end
      else LastLoc := -1;
      Pen.Mode := pmCopy;
   end;
end;

{-- TMMScrollPanel ------------------------------------------------------}
procedure TMMScrollPanel.CMTextChanged(var Message: TMessage);
begin
   Invalidate;
end;

{-- TMMScrollPanel ------------------------------------------------------}
procedure TMMScrollPanel.Paint;
var
   R : TRect;
   Pixmax, Pixmin : integer;
   tlen: integer;


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

      Pixel(PixMin, PixMax);
      if FKind = spHorizontal then
         R := Rect(PixMin,BevelExtend,PixMax+1,Height-BevelExtend)
      else
         R := Rect(BevelExtend,PixMin,Width-BevelExtend,PixMax+1);

      Pen.Mode := pmCopy;
      Pen.Width := 1;
      if SliderDown then
         Frame3D(Canvas,R,FSliderShadow,FSliderLight,1)
      else
         Frame3D(Canvas,R,FSliderLight,FSliderShadow,1);
      Brush.Color := FSliderColor;
      FillRect(R);

      if (Caption <> '') and (FKind = spHorizontal) then
      begin
         Font := Self.Font;
         tlen := TextWidth(Caption);
         if tlen < PixMax-PixMin-4 then
            TextOut(PixMin + (PixMax-PixMin-tlen) div 2,
                    (Height-TextHeight(Caption)) div 2, Caption);
      end;

      FLastLoc := -1;
      DrawLocator(Canvas,FLastLoc);
   end;
end;

end.