mmspin.pas

一套及时通讯的原码

{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Tel.: [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: 20.01.1998 - 18:00:00 $                                      =}
{========================================================================}
Unit MMSpin;

{$I COMPILER.INC}

interface

uses
{$IFDEF WIN32}
    Windows,
{$ELSE}
    WinTypes,
    WinProcs,
{$ENDIF}
    SysUtils,
    Messages,
    Classes,
    Graphics,
    Controls,
    Forms,
    Dialogs,
    ExtCtrls,
    StdCtrls,
    Menus,
    Buttons,
    MMSystem,
    MMObj,
    MMUtils,
    MMString,
    MMButton;

type
  TMMTimeBtnState = set of (tbFocusRect, tbAllowTimer, tbDragging);
  TMMFocusStyle   = (fsNone,fsSolid,fsDot);
  TMMOrientation  = (orVertical,orHorizontal);

  {== TMMTimerSpeedButton ================================================}
  TMMTimerSpeedButton = class(TMMSpeedButton)
  private
    FButtonFace  : Boolean;
    FFocusColor  : TColor;
    FFocusStyle  : TMMFocusStyle;
    FRepeatTimer : TTimer;
    FTimeBtnState: TMMTimeBtnState;

    procedure TimerExpired(Sender: TObject);
    procedure FocusLine(X1,Y1,X2,Y2: integer);
    procedure SetButtonFace(aValue: Boolean);
    procedure SetEnabled(aValue: Boolean);
    function  GetEnabled: Boolean;
  protected
    procedure Paint; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
                        X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
                      X, Y: Integer); override;
  public
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;
    property TimeBtnState: TMMTimeBtnState read FTimeBtnState write FTimeBtnState;
    property FocusColor: TColor read FFocusColor write FFocusColor;
    property FocusStyle: TMMFocusStyle read FFocusStyle write FFocusStyle default fsSolid;
    property Enabled: Boolean read GetEnabled write SetEnabled default True;
    property ButtonFace: Boolean read FButtonFace write SetButtonFace default False;
  end;

  {== TMMCustomSpinButton ===============================================}
  TMMCustomSpinButton = class(TMMCustomControl)
  private
    FUpButton      : TMMTimerSpeedButton;
    FDownButton    : TMMTimerSpeedButton;
    FFastButton    : TMMTimerSpeedButton;
    FFocusedButton : TMMTimerSpeedButton;
    FFocusControl  : TWinControl;
    FFocusColor    : TColor;
    FFocusStyle    : TMMFocusStyle;
    FButtonFace    : Boolean;
    FMiddleButton  : Boolean;
    FOrientation   : TMMOrientation;

    FIncrement     : LongInt;
    FMinValue      : LongInt;
    FMaxValue      : LongInt;
    FValue         : Longint;

    FStartValue    : Longint;
    FOldPos        : integer;

    FOldWndProc     : TFarProc;
    FHookWnd        : HWND;

    FOnUpClick     : TNotifyEvent;
    FOnDownClick   : TNotifyEvent;
    FOnChange      : TNotifyEvent;

    function  CreateButton: TMMTimerSpeedButton;
    function  GetUpGlyph: TBitmap;
    function  GetDownGlyph: TBitmap;
    procedure SetUpGlyph(Value: TBitmap);
    procedure SetUpNumGlyphs(Value: TNumGlyphs);
    function  GetUpNumGlyphs: TNumGlyphs;
    procedure SetDownGlyph(Value: TBitmap);
    procedure SetDownNumGlyphs(Value: TNumGlyphs);
    function  GetDownNumGlyphs: TNumGlyphs;
    procedure SetFocusColor(Value: TColor);
    procedure SetFocusStyle(Value: TMMFocusStyle);
    procedure SetFocusControl(aControl: TWinControl);
    procedure SetEnabled(Value: Boolean);
    function  GetEnabled: Boolean;
    procedure SetButtonFace(Value: Boolean);
    procedure SetMiddleButton(Value: Boolean);
    procedure SetOrientation(aValue: TMMOrientation);

    procedure SetIncrement(aValue: Longint);
    procedure SetMaxValue(aValue: Longint);
    procedure SetMinValue(aValue: Longint);
    procedure SetValue(aValue: Longint);

    procedure BtnClick(Sender: TObject);
    procedure BtnMouseDown(Sender: TObject; Button: TMouseButton;
                           Shift: TShiftState; X, Y: Integer);
    procedure BtnMouseMove(Sender: TObject; Shift: TShiftState;
                           X, Y: Integer);
    procedure BtnMouseUp(Sender: TObject; Button: TMouseButton;
                         Shift: TShiftState; X, Y: Integer);
    procedure SetFocusBtn(Btn: TMMTimerSpeedButton);
    procedure UpdateMiddleButton;
    procedure AdjustBounds;
    procedure AdjustSize (var W, H: Integer);
    procedure WMSize(var Message: TWMSize);  message WM_SIZE;
    procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
    procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
    procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
    procedure HookWndProc(var Message : TMessage);
    function  ProcessKeys(Wnd: HWND; Msg, Key: Word): Boolean;
    procedure UpdateButtonState;

  protected
    procedure Loaded; override;
    procedure Changed; override;
    procedure Paint; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyUp(var Key: Word; Shift: TShiftState); override;
    procedure Notification(aComponent: TComponent; Operation: TOperation); override ;

    procedure UpClicked; dynamic;
    procedure DownClicked; dynamic;
    procedure Change; dynamic;

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
    property  UpButton: TMMTimerSpeedButton read FUpButton write FUpButton;
    property  DownButton: TMMTimerSpeedButton read FDownButton write FDownButton;
    property  FocusStyle: TMMFocusStyle read FFocusStyle write SetFocusStyle default fsSolid;

  protected
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnDownClick: TNotifyEvent read FOnDownClick write FOnDownClick;
    property OnUpClick: TNotifyEvent read FOnUpClick write FOnUpClick;

    { Orientation must be the first }
    property Orientation: TMMOrientation read FOrientation write SetOrientation default orVertical;
    property DownGlyph: TBitmap read GetDownGlyph write SetDownGlyph;
    property DownNumGlyphs: TNumGlyphs read GetDownNumGlyphs write SetDownNumGlyphs;
    property Enabled: Boolean read GetEnabled write SetEnabled default True;
    property FocusColor: TColor read FFocusColor write SetFocusColor default clBlack;
    property FocusControl: TWinControl read FFocusControl write SetFocusControl;
    property TabStop default True;
    property UpGlyph: TBitmap read GetUpGlyph write SetUpGlyph;
    property UpNumGlyphs: TNumGlyphs read GetUpNumGlyphs write SetUpNumGlyphs;
    property Width default 21;
    property Height default 28;
    property ButtonFace: Boolean read FButtonFace write SetButtonFace default False;
    property MiddleButton: Boolean read FMiddleButton write SetMiddleButton default False;
    property Increment: Longint read FIncrement write SetIncrement default 1;
    property MaxValue: LongInt read FMaxValue write SetMaxValue default 100;
    property MinValue: LongInt read FMinValue write SetMinValue default 0;
    property Value: Longint read FValue write SetValue default 0;
  end;

  {== TMMCustomSpinButton ===============================================}
  TMMSpinButton = class(TMMCustomSpinButton)
  published
    property OnChange;
    property OnDownClick;
    property OnUpClick;

    property Bevel;
    property Orientation;
    property DownGlyph;
    property DownNumGlyphs;
    property DragCursor;
    property DragMode;
    property Enabled;
    property FocusColor;
    property FocusControl;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabStop;
    property TabOrder;
    property UpGlyph;
    property UpNumGlyphs;
    property Visible;
    property Width;
    property Height;
    property ButtonFace;
    property MiddleButton;
    property Increment;
    property MaxValue;
    property MinValue;
    property Value;
  end;

implementation

{$IFDEF WIN32}
  {$R MMSPIN.D32}
{$ELSE}
  {$R MMSPIN.D16}
{$ENDIF}

const
     InitialPause = 400;  { time in ms before first repeat occurs }
     RepeatPause  = 50;   { time in ms between subsequent repeats }
     HookList: TList = nil;

{== TMMTimerSpeedButton ==================================================}
constructor TMMTimerSpeedButton.Create(aOwner: TComponent);
begin
     inherited Create(aOwner);

     FFocusColor := clBlack;
     FFocusStyle := fsSolid;
     FRepeatTimer:= Nil;
     FButtonFace := False;
     Enabled := True;
end;

{-- TMMTimerSpeedButton --------------------------------------------------}
destructor TMMTimerSpeedButton.Destroy;
begin
     if (FRepeatTimer <> Nil) then
        FRepeatTimer.Free;

     inherited Destroy;
end;

{-- TMMTimerSpeedButton --------------------------------------------------}
procedure TMMTimerSpeedButton.SetButtonFace(aValue: Boolean);
begin
   if (aValue <> FButtonFace) then
   begin
      FButtonFace := aValue;
      Invalidate;
   end;
end;

{-- TMMTimerSpeedButton --------------------------------------------------}
procedure TMMTimerSpeedButton.SetEnabled(aValue: Boolean);
begin
     if (aValue <> inherited Enabled) then
     begin
          {$IFNDEF BUILD_ACTIVEX}
          if Not (csDesigning in ComponentState) then
          begin
               { Win31 makes problems without this }
               if (Parent <> Nil) And (FState = bsDown) then
               begin
                    Parent.Enabled := not Parent.Enabled;
                    Parent.Enabled := not Parent.Enabled;
                    Parent.SetFocus;
               end;
          end;
          {$ENDIF}

          inherited Enabled := aValue;
     end;
end;

{-- TMMTimerSpeedButton --------------------------------------------------}
function TMMTimerSpeedButton.GetEnabled: Boolean;
begin
     Result := inherited Enabled;
end;

{-- TMMTimerSpeedButton --------------------------------------------------}
procedure TMMTimerSpeedButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
     inherited MouseDown (Button, Shift, X, Y);

     if tbAllowTimer in FTimeBtnState then
     begin
          if (FRepeatTimer = Nil) then
          begin
             FRepeatTimer := TTimer.Create(Self);
             FRepeatTimer.OnTimer := TimerExpired;
          end;

          FRepeatTimer.Interval := InitialPause;
          FRepeatTimer.Enabled  := True;
     end;
end;

{-- TMMTimerSpeedButton --------------------------------------------------}
procedure TMMTimerSpeedButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
                                  X, Y: Integer);
begin
     inherited MouseUp (Button, Shift, X, Y);

     FRepeatTimer.Free;
     FRepeatTimer := Nil;
end;

{-- TMMTimerSpeedButton --------------------------------------------------}
procedure TMMTimerSpeedButton.TimerExpired(Sender: TObject);
begin
     FRepeatTimer.Interval := RepeatPause;

     if (FState = bsDown) And MouseCapture then
     begin
          try
             Click;
          except
             FRepeatTimer.Enabled := False;
             raise;
          end;
     end;
end;

{-- TMMTimerSpeedButton --------------------------------------------------}
procedure TMMTimerSpeedButton.FocusLine(X1,Y1,X2,Y2: integer);
Var
   i: integer;

begin
   if (FFocusStyle = fsDot) then
   begin
     if (X1 = X2) then
     begin
          i := Y1;
          while i < Y2 do
          begin
               Canvas.Pixels[X1, i] := FFocusColor;
               inc(i,2)
          end;
     end
     else if (Y1 = Y2) then
     begin
          i := X1;
          while i < X2 do
          begin
               Canvas.Pixels[i, Y1] := FFocusColor;
               inc(i,2)
          end;
     end;
   end
   else if (FFocusStyle = fsSolid) then
   begin
        Canvas.MoveTo(X1, Y1);
        Canvas.LineTo(X2, Y2);
   end;
end;

{-- TMMTimerSpeedButton --------------------------------------------------}
procedure TMMTimerSpeedButton.Paint;
Var
   R: TRect;

begin
   if (Not Enabled) And Not(csDesigning in ComponentState) then
   begin
      FState := bsDisabled;
      FDragging := False;
   end
   else if FState = bsDisabled then
   FState := bsUp;

   with Canvas do
   begin
      R := ClientRect;
      Brush.Color := clBtnFace;
      FillRect(R);

      if FButtonFace then
      begin
         if (FState in [bsDown]) or (tbDragging in FTimeBtnState) then
         begin
            OffsetRect(R,1,1);
            DrawGlyph(Canvas, R);
            OffsetRect(R,-1,-1);
            Frame3D(Canvas, R, clBtnShadow, clBtnFace, 1);
            Pixels[R.Left-1,R.Bottom] := clBtnShadow;
            Pixels[R.Right,R.Top-1] := clBtnShadow;
         end
         else
         begin
            Frame3D(Canvas, R, clBtnHighLight,clBtnShadow,1);
            DrawGlyph(Canvas, R);
         end;
      end
      else DrawGlyph(Canvas, R);

      if Parent.Focused and not TMMCustomSpinButton(Parent).FButtonFace then
      begin
         R := Bounds(0, 0, Width-1, Height-1);
         InflateRect(R, -1, -1);
         Pen.Color := FFocusColor;