mmscrlr.pas

一套及时通讯的原码

{-- TMMCustomScroller --------------------------------------------------}
procedure TMMCustomScroller.SetAutoSize(Value: Boolean);
begin
   if FAutoSize <> Value then
   begin
      FAutoSize := Value;
      if Value then
         DoAutoSize;
   end;
end;

{-- TMMCustomScroller --------------------------------------------------}
procedure TMMCustomScroller.DoAutoSize;
begin
   if not BackGroundDIB.Empty then
      SetBounds(Left,Top,BackgroundDIB.Width+2*BevelExtend,BackgroundDIB.Height+2*BevelExtend);
end;

{-- TMMCustomScroller --------------------------------------------------}
procedure TMMCustomScroller.Paint;
begin
   DrawScroller(True);
end;

{-- TMMCustomScroller --------------------------------------------------}
procedure TMMCustomScroller.DrawScroller(Back: Boolean);
var
   R: TRect;
begin
   if Back then
      R := Bevel.PaintBevel(Canvas,ClientRect, True)
   else
      R := FClientRect;

   DIBCanvas.DIB_InitDrawing;

   DrawBackground;                                 { draw the background }
   DrawText;

   DIBCanvas.DIB_BitBlt(Canvas.Handle,R,0,0);           { copy to screen }
   DIBCanvas.DIB_DoneDrawing;
end;

{-- TMMCustomScroller --------------------------------------------------}
procedure TMMCustomScroller.DrawBackGround;
begin
   if assigned(FOnDrawBackGround) then
      FOnDrawBackGround(Self,DIBCanvas,FClientRect)
   else
      inherited;
end;

{-- TMMCustomScroller --------------------------------------------------}
procedure TMMCustomScroller.DrawText;
var
   i       : integer;
   Y       : integer;
   X       : integer;
   R       : TRect;
   AWidth  : integer;
   TH      : integer;
   DC      : HDC;
   {$IFNDEF WIN32}
   Buf     : array[0..255] of Char;
   {$ENDIF}

begin
   with DIBCanvas do
   begin
      AWidth      := FTextWidth;
      Brush.Style := bsClear;
      i           := 0;
      Y           := FScrollPosY;
      X           := 0;
      TH          := TextHeight('A');

      case Alignment of
         taLeftJustify   : X := 0;
         taRightJustify  : X := AWidth;
         taCenter        : X := AWidth div 2;
      end;

      {$IFDEF WIN32}
      GDIFlush;
      {$ENDIF}

      DC := DIBCanvas.Handle;

      while i < FText.Count do
      begin
         R := Bounds(FScrollPosX,Y,AWidth,TH);
         if RectVisible(DC,R) then
         {$IFDEF WIN32}
            ExtTextOut(DC, X+FScrollPosX, Y, ETO_CLIPPED, @R, PChar(FText[i]),Length(FText[i]),nil);
         {$ELSE}
            ExtTextOut(DC, X+FScrollPosX, Y, ETO_CLIPPED, @R, StrPCopy(Buf,FText[i]),Length(FText[i]),nil);
         {$ENDIF}


         Inc(Y,R.Bottom-R.Top);
         Inc(i);
      end;

      {$IFDEF WIN32}
      GDIFlush;
      {$ENDIF}
   end;
end;

{-- TMMCustomScroller --------------------------------------------------}
procedure TMMCustomScroller.SetScrollPos(Index: Integer; Value: Integer);
begin
   case Index of
      0 : begin
            Value := MinMax(Value,StartPosX,Max(StartPosX,EndPosX));
            if Value <> FScrollPosX then
                FScrollPosX := Value
            else
                Exit;
          end;
      1 : begin
            Value := MinMax(Value,StartPosY,Max(StartPosY,EndPosY));
            if Value <> FScrollPosY then
                FScrollPosY := Value
            else
                Exit;
          end;
   end;

   if not FInUpdate then
      if not (csLoading in ComponentState) then
         Invalidate;
end;

{-- TMMCustomScroller --------------------------------------------------}
function TMMCustomScroller.StoreScrollPos(Index: Integer): Boolean;
begin
   Result := True;
   if AutoScroll then
      Result := False
   else
   begin
      case Index of
         0 : Result := FScrollPosX <> 0;
         1 : Result := FScrollPosY <> 0;
      end;
   end;
end;

{-- TMMCustomScroller --------------------------------------------------}
function TMMCustomScroller.GetTextHeight : Integer;
var
   i: Integer;
begin
   Result := 0;
   Canvas.Font := Font;
   for i := 0 to FText.Count - 1 do
       Result := Result + Canvas.TextHeight('A');
end;

{-- TMMCustomScroller --------------------------------------------------}
function TMMCustomScroller.GetTextWidth : Integer;
var
   i: Integer;
begin
   Result := 0;
   Canvas.Font := Font;
   for i := 0 to FText.Count - 1 do
       Result := Max(Result,Canvas.TextWidth(FText[i]));
end;

{-- TMMCustomScroller --------------------------------------------------}
procedure TMMCustomScroller.BeginScroll(Index: Integer);
begin
   DoBegin(Index);
end;

{-- TMMCustomScroller --------------------------------------------------}
procedure TMMCustomScroller.DoBegin(Index: Integer);
begin
   case Index of
     0 : if Assigned(FOnBeginX) then FOnBeginX(Self);
     1 : if Assigned(FOnBeginY) then FOnBeginY(Self);
   end;
end;

{-- TMMCustomScroller --------------------------------------------------}
function TMMCustomScroller.EndScroll(Index: Integer) : Boolean;
begin
   Result := DoEnd(Index);
end;

{-- TMMCustomScroller --------------------------------------------------}
function TMMCustomScroller.DoEnd(Index: Integer) : Boolean;
begin
   Result := True;
   case Index of
      0 : if Assigned(FOnEndX) then FOnEndX(Self,Result);
      1 : if Assigned(FOnEndY) then FOnEndY(Self,Result);
   end;
end;

{-- TMMCustomScroller --------------------------------------------------}
procedure TMMCustomScroller.StepScroll;
begin
   DoStep;
end;

{-- TMMCustomScroller --------------------------------------------------}
procedure TMMCustomScroller.DoStep;
begin
   if Assigned(FOnStep) then FOnStep(Self);
end;

{-- TMMCustomScroller --------------------------------------------------}
procedure TMMCustomScroller.SetAutoScroll(Value: Boolean);
begin
   if csLoading in ComponentState then
      FTempAutoScroll := Value
   else if FAutoScroll <> Value then
   begin
      FAutoScroll := Value;
      if Value then
      begin
         ResetScrollPos;
         MMTimeSetInterval(FTimerId,FScrollSpeed);
         MMTimeResumeEvent(FTimerId);
      end
      else MMTimeSuspendEvent(FTimerId);
   end;
end;

{-- TMMCustomScroller --------------------------------------------------}
procedure TMMCustomScroller.SetScrollSpeed(Value: Integer);
begin
   Value := MinMax(Value,TIMERELAPSE,MaxInt);
   if FScrollSpeed <> Value then
   begin
      FScrollSpeed := (Value div TIMERELAPSE) * TIMERELAPSE;
      if AutoScroll then
         MMTimeSetInterval(FTimerId,FScrollSpeed);
   end;
end;

{-- TMMCustomScroller --------------------------------------------------}
procedure TMMCustomScroller.SetScrollStep(Index: Integer; Value: Integer);
begin
   case Index of
      0 : if FScrollStepX <> Value then FScrollStepX := Value else Exit;
      1 : if FScrollStepY <> Value then FScrollStepY := Value else Exit;
   end;
end;

{-- TMMCustomScroller --------------------------------------------------}
procedure TMMCustomScroller.SetStartPos(Index: Integer; Value: Integer);
begin
   case Index of
      0 : if FStartPosX <> Value then begin FStartPosX := Value; HorizStart := hpUser; end else Exit;
      1 : if FStartPosY <> Value then begin FStartPosY := Value; VertStart := vpUser; end else Exit;
   end;
   ResetScrollPos;
end;

{-- TMMCustomScroller --------------------------------------------------}
procedure TMMCustomScroller.SetEndPos(Index: Integer; Value: Integer);
begin
   case Index of
      0 : if FEndPosX <> Value then begin FEndPosX := Value; HorizEnd := hpUser; end else Exit;
      1 : if FEndPosY <> Value then begin FEndPosY := Value; VertEnd := vpUser; end else Exit;
   end;
   ResetScrollPos;
end;

{-- TMMCustomScroller --------------------------------------------------}
function TMMCustomScroller.HorizPos(Pos: TMMHorizPos; Pix: Integer): Integer;
var
    W : Integer;
begin
    W := FClientRect.Right - FClientRect.Left;
    case Pos of
        hpLeftLeft  : Result := -TextWidth;
        hpLeftRight : Result := 0;
        hpRightLeft : Result := W - TextWidth;
        hpRightRight: Result := W;
        hpCenter    : Result := (W - TextWidth) div 2;
    else
        Result := Pix;
    end;
    Result := Result;
end;

{-- TMMCustomScroller --------------------------------------------------}
function TMMCustomScroller.VertPos(Pos: TMMVertPos; Pix: Integer): Integer;
var
    H : Integer;
begin
    H := FClientRect.Bottom - FClientRect.Top;
    case Pos of
        vpTopTop        : Result := -TextHeight;
        vpTopBottom     : Result := 0;
        vpBottomTop     : Result := H - TextHeight;
        vpBottomBottom  : Result := H;
        vpCenter        : Result := (H - TextHeight) div 2;
    else
        Result := Pix;
    end;
    Result := Result;
end;

{-- TMMCustomScroller --------------------------------------------------}
function TMMCustomScroller.GetStartPos(Index: Integer): Integer;
begin
   if Index = 0 then
      Result := HorizPos(HorizStart,FStartPosX)
   else
      Result := VertPos(VertStart,FStartPosY);
end;

{-- TMMCustomScroller --------------------------------------------------}
function TMMCustomScroller.GetEndPos(Index: Integer): Integer;
begin
   if Index = 0 then
      Result := HorizPos(HorizEnd,FEndPosX)
   else
      Result := VertPos(VertEnd,FEndPosY);
end;

{-- TMMCustomScroller --------------------------------------------------}
function TMMCustomScroller.StoreStartPos(Index: Integer): Boolean;
begin
   Result := False;
   if ((Index = 0) and (HorizStart <> hpUser)) or
      ((Index = 1) and (VertStart <> vpUser)) then Exit;
   Result := True;
end;

{-- TMMCustomScroller --------------------------------------------------}
function TMMCustomScroller.StoreEndPos(Index: Integer): Boolean;
begin
   Result := False;
   if ((Index = 0) and (HorizEnd <> hpUser)) or
      ((Index = 1) and (VertEnd <> vpUser)) then Exit;
   Result := True;
end;

{-- TMMCustomScroller --------------------------------------------------}
procedure TMMCustomScroller.SetHorizStart(Value: TMMHorizPos);
begin
   if Value <> FHorizStart then
   begin
      FHorizStart := Value;
      ResetSCrollPos;
   end;
end;

{-- TMMCustomScroller --------------------------------------------------}
procedure TMMCustomScroller.SetVertStart(Value: TMMVertPos);
begin
   if Value <> FVertStart then
   begin
      FVertStart := Value;
      ResetScrollPos;
   end;
end;

{-- TMMCustomScroller --------------------------------------------------}
procedure TMMCustomScroller.SetHorizEnd(Value: TMMHorizPos);
begin
   if Value <> FHorizEnd then
   begin
      FHorizEnd := Value;
      ResetScrollPos;
   end;
end;

{-- TMMCustomScroller --------------------------------------------------}
procedure TMMCustomScroller.SetVertEnd(Value: TMMVertPos);
begin
   if Value <> FVertEnd then
   begin
      FVertEnd := Value;
      ResetScrollPos;
   end;
end;

{-- TMMCustomScroller --------------------------------------------------}
procedure TMMCustomScroller.UpdateScrollPos;
var
   PrevPosX, PrevPosY : Integer;
   ScrollX, ScrollY   : Boolean;

begin
   FInUpdate := True;
   try
      ScrollX := (ScrollStepX <> 0) and (EndPosX > StartPosX);
      ScrollY := (ScrollStepY <> 0) and (EndPosY > StartPosY);
      PrevPosX := ScrollPosX;
      PrevPosY := ScrollPosY;
      
      if ScrollX then
         { Check for begin }
         if ((ScrollStepX > 0) and (ScrollPosX = StartPosX)) or
            ((ScrollStepX < 0) and (ScrollPosX = EndPosX)) then
              BeginScroll(0);

      if ScrollY then
         if ((ScrollStepY > 0) and (ScrollPosY = StartPosY)) or
            ((ScrollStepY < 0) and (ScrollPosY = EndPosY)) then
              BeginScroll(1);

      if ScrollX then ScrollPosX := ScrollPosX + ScrollStepX;
      if ScrollY then ScrollPosY := ScrollPosY + ScrollStepY;

      StepScroll;

      if ScrollX then
         if ((ScrollStepX > 0) and (ScrollPosX = EndPosX)) or
            ((ScrollStepX < 0) and (ScrollPosX = StartPosX)) then
         begin
            if EndScroll(0) then
               if ScrollPosX = EndPosX then
                  ScrollPosX := StartPosX
               else
                  ScrollPosX := EndPosX
         end;

      if ScrollY then
         if ((ScrollStepY > 0) and (ScrollPosY = EndPosY)) or
            ((ScrollStepY < 0) and (ScrollPosY = StartPosY)) then
            if EndScroll(1) then
               ResetScrollPos;

   finally
      FInUpdate := False;
   end;

   if (ScrollPosX <> PrevPosX) or (ScrollPosY <> PrevPosY) then
       FastDraw(DrawScroller,False);
end;

{-- TMMCustomScroller --------------------------------------------------}
procedure TMMCustomScroller.ResetScrollPos;
begin
   if ScrollStepX < 0 then
      ScrollPosX := EndPosX
   else
      ScrollPosX := StartPosX;

   if ScrollStepY < 0 then
      ScrollPosY := EndPosY
   else
      ScrollPosY := StartPosY;
end;

end.