mmscrlr.pas

一套及时通讯的原码

{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Fax.: [phone]              =}
{=  Loewenstr.7a                = [e-mail]                     =}
{========================================================================}
{=  Actual versions on http://www.swiftsoft.de/mmtools.html             =}
{========================================================================}
{=  This code is for reference purposes only and may not be copied or   =}
{=  distributed in any format electronic or otherwise except one copy   =}
{=  for backup purposes.                                                =}
{=                                                                      =}
{=  No Delphi Component Kit or Component individually or in a collection=}
{=  subclassed or otherwise from the code in this unit, or associated   =}
{=  .pas, .dfm, .dcu, .asm or .obj files may be sold or distributed     =}
{=  without express permission from SwiftSoft.                          =}
{=                                                                      =}
{=  For more licence informations please refer to the associated        =}
{=  HelpFile.                                                           =}
{========================================================================}
{=  $Date: 06.09.98 - 14:39:46 $                                        =}
{========================================================================}
unit MMScrlr;

{$I COMPILER.INC}

interface

uses
{$IFDEF WIN32}
    Windows,
{$ELSE}
    WinTypes,
    WinProcs,
{$ENDIF}
    SysUtils,
    Classes,
    Controls,
    Graphics,
    Forms,
    Messages,
    MMSystem,
    MMObj,
    MMUtils,
    MMDIBCv,
    MMTimer;

type
    TMMDrawBackGround   = procedure(Sender: TObject; DIB: TMMDIBCanvas; Rect: TRect) of object;
    TMMEndNotifyEvent   = procedure(Sender: TObject; var Reset: Boolean) of object;
    TMMHorizPos         = (hpLeftLeft,hpLeftRight,hpCenter,hpRightLeft,hpRightRight,hpUser);
    TMMVertPos          = (vpTopTop,vpTopBottom,vpCenter,vpBottomTop,vpBottomBottom,vpUser);

const
    {$IFDEF CBUILDER3} {$EXTERNALSYM defAutoSize } {$ENDIF}
    defAutoSize     = True;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defAlignment } {$ENDIF}
    defAlignment    = taCenter;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defAutoScroll } {$ENDIF}
    defAutoScroll   = False;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defScrollSpeed } {$ENDIF}
    defScrollSpeed  = 100;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defScrollStepX } {$ENDIF}
    defScrollStepX  = 0;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defScrollStepY } {$ENDIF}
    defScrollStepY  = 0;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defHorizStart } {$ENDIF}
    defHorizStart   = hpCenter;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defHorizEnd } {$ENDIF}
    defHorizEnd     = hpCenter;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defVertStart } {$ENDIF}
    defVertStart    = vpCenter;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defVertEnd } {$ENDIF}
    defVertEnd      = vpCenter;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defWidth } {$ENDIF}
    defWidth        = 100;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defHeight } {$ENDIF}
    defHeight       = 100;

type
    {-- TMMCustomScroller --------------------------------------------------}
    TMMCustomScroller   = class(TMMDIBGraphicControl)
    private
        FHandle          : THandle;
        FLastTime        : Longint;
        FAutoScroll      : Boolean;
        FTimerId         : LongInt;
        FScrollSpeed     : Integer;
        FScrollStepX     : Integer;
        FScrollStepY     : Integer;
        FStartPosX       : Integer;
        FStartPosY       : Integer;
        FEndPosX         : Integer;
        FEndPosY         : Integer;
        FHorizStart      : TMMHorizPos;
        FHorizEnd        : TMMHorizPos;
        FVertStart       : TMMVertPos;
        FVertEnd         : TMMVertPos;
        FText            : TStringList;
        FTextHeight      : integer;
        FTextWidth       : integer;
        FAutoSize        : Boolean;
        FScrollPosX      : Integer;
        FScrollPosY      : Integer;
        FAlignment       : TAlignment;
        FClientRect      : TRect;
        FOnBeginX        : TNotifyEvent;
        FOnBeginY        : TNotifyEvent;
        FOnEndX          : TMMEndNotifyEvent;
        FOnEndY          : TMMEndNotifyEvent;
        FOnStep          : TNotifyEvent;
        FOnDrawBackGround: TMMDrawBackGround;

        FTempAutoScroll  : Boolean;
        FInUpdate        : Boolean;
        FMessageDone     : Boolean;

        procedure SetText(Value: TStrings);
        function  GetText : TStrings;
        procedure TextChanged(Sender: TObject);
        procedure SetAutoSize(Value: Boolean);
        procedure SetScrollPos(Index: Integer; Value: Integer);
        function  StoreScrollPos(Index: Integer): Boolean;
        function  GetTextHeight: Integer;
        function  GetTextWidth: Integer;
        procedure SetAlignment(Value: TAlignment);
        procedure SetAutoScroll(Value: Boolean);
        procedure SetScrollSpeed(Value: Integer);
        procedure SetScrollStep(Index: Integer; Value: Integer);
        procedure SetStartPos(Index: Integer; Value: Integer);
        procedure SetEndPos(Index: Integer; Value: Integer);
        function  GetStartPos(Index: Integer): Integer;
        function  GetEndPos(Index: Integer): Integer;
        function  StoreStartPos(Index: Integer): Boolean;
        function  StoreEndPos(Index: Integer): Boolean;
        procedure SetHorizStart(Value: TMMHorizPos);
        procedure SetHorizEnd(Value: TMMHorizPos);
        procedure SetVertStart(Value: TMMVertPos);
        procedure SetVertEnd(Value: TMMVertPos);
        procedure TimerProc(var Msg: TMessage);
        procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
        procedure UpdateControl;
        procedure UpdateFont;

    protected
        procedure Changed; override;
        procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer);override;
        procedure Loaded; override;
        procedure DoAutoSize;
        procedure Paint; override;

        procedure DrawText;
        procedure DrawScroller(Back: Boolean);

        procedure BeginScroll(Index: Integer); virtual;
        procedure DoBegin(Index: Integer); dynamic;
        function  EndScroll(Index: Integer) : Boolean; virtual;
        function  DoEnd(Index: Integer): Boolean; dynamic;
        procedure StepScroll; virtual;
        procedure DoStep; dynamic;

        function HorizPos(Pos: TMMHorizPos; Pix: Integer): Integer;
        function VertPos(Pos: TMMVertPos; Pix: Integer): Integer;

    public
        constructor Create(AOwner: TComponent); override;
        destructor  Destroy; override;

        procedure DrawBackGround; override;
        procedure UpdateScrollPos;
        procedure ResetScrollPos;

    protected
        property OnDrawBackGround: TMMDrawBackGround read FOnDrawBackGround write FOnDrawBackGround;
        property OnBeginX: TNotifyEvent read FOnBeginX write FOnBeginX;
        property OnBeginY: TNotifyEvent read FOnBeginY write FOnBeginY;
        property OnEndX: TMMEndNotifyEvent read FOnEndX write FOnEndX;
        property OnEndY: TMMEndNotifyEvent read FOnEndY write FOnEndY;
        property OnStep: TNotifyEvent read FOnStep write FOnStep;

        property TextHeight: integer read FTextHeight;
        property TextWidth: integer read FTextWidth;

        property Width default defWidth;
        property Height default defHeight;

        property AutoSize: Boolean read FAutoSize write SetAutoSize default defAutoSize;
        property Text: TStrings read GetText write SetText;
        property ScrollPosX: Integer index 0 read FScrollPosX write SetScrollPos stored StoreScrollPos;
        property ScrollPosY: Integer index 1 read FScrollPosY write SetScrollPos stored StoreScrollPos;
        property Alignment: TAlignment read FAlignment write SetAlignment default defAlignment;
        property AutoScroll: Boolean read FAutoScroll write SetAutoScroll default defAutoScroll;
        property ScrollSpeed: Integer read FScrollSpeed write SetScrollSpeed default defScrollSpeed;
        property ScrollStepX: Integer index 0 read FScrollStepX write SetScrollStep default defScrollStepX;
        property ScrollStepY: Integer index 1 read FScrollStepY write SetScrollStep default defScrollStepY;
        property StartPosX: Integer index 0 read GetStartPos write SetStartPos stored StoreStartPos;
        property StartPosY: Integer index 1 read GetStartPos write SetStartPos stored StoreStartPos;
        property EndPosX: Integer index 0 read GetEndPos write SetEndPos stored StoreEndPos;
        property EndPosY: Integer index 1 read GetEndPos write SetEndPos stored StoreEndPos;
        property HorizStart: TMMHorizPos read FHorizStart write SetHorizStart default defHorizStart;
        property HorizEnd: TMMHorizPos read FHorizEnd write SetHorizEnd default defHorizEnd;
        property VertStart: TMMVertPos read FVertStart write SetVertStart default defVertStart;
        property VertEnd: TMMVertPos read FVertEnd write SetVertEnd default defVertEnd;
    end;

    {-- TMMScroller --------------------------------------------------------}
    TMMScroller = class(TMMCustomScroller)
    public
        property TextHeight;
        property TextWidth;
    published
        property OnClick;
        property OnDblClick;
        property OnMouseDown;
        property OnMouseMove;
        property OnMouseUp;

        property OnBeginX;
        property OnBeginY;
        property OnEndX;
        property OnEndY;
        property OnStep;
        property OnDrawBackGround;

        property Bevel;
        property UseBackGroundDIB;
        property BackGroundDIB;
        property PaletteRealize;
        property PaletteMapped;

        property Left;
        property Top;
        property Align;
        property Width;
        property Height;
        property Visible;
        property Enabled;

        property Alignment;
        property Font;
        property ParentFont;
        property AutoSize;
        property Text;
        property Color;
        property ParentColor;
        property ShowHint;
        property ParentShowHint;

        property ScrollPosX;
        property ScrollPosY;

        property AutoScroll;
        property ScrollSpeed;
        property ScrollStepX;
        property ScrollStepY;
        property StartPosX;
        property StartPosY;
        property EndPosX;
        property EndPosY;
        property HorizStart;
        property HorizEnd;
        property VertStart;
        property VertEnd;
    end;

implementation

const
   MM_TIMER = MM_USER+1;

{== TMMCustomScroller ==================================================}
procedure TimeCallback(uTimerID, dwUser: Longint); export;
begin
   if dwUser <> 0 then
   with TMMCustomScroller(dwUser) do
   begin
      if Enabled and not (csDestroying in ComponentState) then
      begin
         if FMessageDone then
         begin
            FMessageDone := False;
            PostMessage(FHandle,MM_TIMER,0,dwUser);
         end;
      end;
   end;
end;

{-- TMMCustomScroller --------------------------------------------------}
constructor TMMCustomScroller.Create(AOwner: TComponent);
begin
   inherited Create(AOwner);

   FText           := TStringList.Create;
   FText.OnChange  := TextChanged;
   FTextWidth      := 0;
   FTextHeight     := 0;
   FAutoSize       := defAutoSize;
   FAlignment      := defAlignment;
   FScrollSpeed    := defScrollSpeed;
   FLastTime       := 0;
   Width           := defWidth;
   Height          := defHeight;

   FAutoScroll     := defAutoScroll;
   FScrollStepX    := defScrollStepX;
   FScrollStepY    := defScrollStepY;
   FHorizStart     := defHorizStart;
   FVertStart      := defVertStart;
   FHorizEnd       := defHorizEnd;
   FVertEnd        := defVertEnd;
   FMessageDone    := True;

   {$IFDEF BUILD_ACTIVEX}
   Color           := clBtnFace;
   {$ENDIF}

   FHandle         := AllocateHWND(TimerProc);
   FTimerId        := MMTimeSetEvent(FScrollSpeed,True,TimeCallback,LongInt(Self));

   ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
   if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);
end;

{-- TMMCustomScroller --------------------------------------------------}
destructor  TMMCustomScroller.Destroy;
var
   Msg: TMsg;

begin
   if (FTimerId <> 0) then
      MMTimeKillEvent(FTimerId);

   if (FHandle <> 0) then
   begin
       { remove pending messages }
       while PeekMessage(Msg, FHandle, MM_TIMER, MM_TIMER, PM_REMOVE) do;
       DeAllocateHWND(FHandle);
   end;

   FText.Free;
   inherited Destroy;
end;

{-- TMMCustomScroller --------------------------------------------------}
procedure TMMCustomScroller.TimerProc(var Msg: TMessage);
var
   NewTime: Longint;
begin
   with Msg do
   try
      if (Msg = MM_TIMER) and (lParam = Longint(Self)) then
      begin
         if not FInUpdate then
         begin
            NewTime := TimeGetTime;
            if (NewTime - FLastTime) >= FScrollSpeed then
                UpdateScrollPos;
            FLastTime := NewTime;
         end;
         FMessageDone := True;
      end;

      Result := DefWindowProc(FHandle, Msg, wParam, lParam);
   except
      Application.HandleException(Self);
   end;
end;

{-- TMMCustomScroller --------------------------------------------------}
procedure TMMCustomScroller.SetText(Value : TStrings);
begin
   FText.Assign(Value);
end;

{-- TMMCustomScroller --------------------------------------------------}
function TMMCustomScroller.GetText : TStrings;
begin
   Result := FText;
end;

{-- TMMCustomScroller --------------------------------------------------}
procedure TMMCustomScroller.TextChanged(Sender: TObject);
begin
   UpdateFont;
   ResetScrollPos;
end;

{-- TMMCustomScroller --------------------------------------------------}
procedure TMMCustomScroller.CMFontChanged(var Message: TMessage);
begin
   UpdateFont;
end;

{-- TMMCustomScroller --------------------------------------------------}
procedure TMMCustomScroller.UpdateFont;
const
   Aligns: array[TAlignment] of UINT =
                (TA_TOP + TA_LEFT, TA_TOP + TA_RIGHT, TA_TOP + TA_CENTER);
begin
   DIBCanvas.Font := Self.Font;
   SetTextAlign(DIBCanvas.Handle,Aligns[Alignment]);
   FTextHeight := GetTextHeight;
   FTextWidth  := GetTextWidth;
end;

{-- TMMCustomScroller --------------------------------------------------}
procedure TMMCustomScroller.UpdateControl;
var
   AWidth : Integer;
   AHeight: Integer;

begin
   FClientRect := BeveledRect;
   AWidth      := Max(FClientRect.Right - FClientRect.Left,4);
   AHeight     := Max(FClientRect.Bottom - FClientRect.Top,4);
   DIBCanvas.SetBounds(0,0,AWidth,AHeight);
   UpdateFont;
   Invalidate;
end;

{-- TMMCustomScroller --------------------------------------------------}
procedure TMMCustomScroller.SetAlignment(Value: TAlignment);
begin
   if FAlignment <> Value then
   begin
      FAlignment := Value;
      UpdateFont;
      Invalidate;
   end;
end;

{-- TMMCustomScroller --------------------------------------------------}
procedure TMMCustomScroller.Changed;
begin
   UpdateControl;
end;

{-- TMMCustomScroller --------------------------------------------------}
procedure TMMCustomScroller.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
   inherited SetBounds(ALeft,ATop,AWidth,AHeight);
   UpdateControl;
end;

{-- TMMCustomScroller --------------------------------------------------}
procedure TMMCustomScroller.Loaded;
begin
   if AutoSize then DoAutoSize;

   inherited Loaded;

   AutoScroll := FTempAutoScroll;
end;