sscrollbar.pas

AlphaControls是一个Delphi标准控件的集合

unit sScrollBar;
{$I sDefs.inc}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls,
  Consts, sPanel, sUtils, sStyleUtil, sConst, extctrls, sCommonData, sDefaults;

type

  TsScrollInfo = record
    Visible : boolean;
    Max : integer;
    Range : integer;
    Page : integer;
    SmallChange : integer;
    BigChange : integer;
    Rect : TRect;
  end;

  TOnChangeEvent = procedure(Sender: TObject; OldValue : integer) of object;

  TsScrollBar = class(TWinControl)
  private
    FKind: TScrollBarKind;
    FPosition: Integer;
    FMin: Integer;
    FMax: Integer;
    FPageSize: Integer;
    FRTLFactor: Integer;
    FSmallChange: TScrollBarInc;
    FLargeChange: TScrollBarInc;
    FOnChange: TOnChangeEvent;
    FOnScroll: TScrollEvent;
    FBtn1Rect : TRect;
    FBtn2Rect : TRect;
    FBar1Rect : TRect;
    FBar2Rect : TRect;
    FSliderRect : TRect;
    FBtn1SkinIndex : integer;
    FBtn2SkinIndex : integer;
    FScrollSliderIndex : integer;
    Timer : TTimer;
    FBtn1State: integer;
    FBar2State: integer;
    FBtn2State: integer;
    FBar1State: integer;
    FSliderState : integer;
    FSmooth: boolean;
    FCommonData: TsCommonData;
    FDisabledKind: TsDisabledKind;
    procedure DoScroll(var Message: TWMScroll);
    function NotRightToLeft: Boolean;
    procedure SetKind(Value: TScrollBarKind);
    procedure SetMax(Value: Integer);
    procedure SetMin(Value: Integer);
    procedure SetPosition(Value: Integer);
    procedure SetPageSize(Value: Integer);
    procedure CNHScroll(var Message: TWMHScroll); message CN_HSCROLL;
    procedure CNVScroll(var Message: TWMVScroll); message CN_VSCROLL;
    procedure CNCtlColorScrollBar(var Message: TMessage); message CN_CTLCOLORSCROLLBAR;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
    procedure WMGetDlgCode(var Msg: TWMGetDlgCode); message WM_GETDLGCODE;
    procedure WMPaint(var Msg: TMessage); message WM_PAINT;
    procedure WMNCPaint(var Msg: TMessage); message WM_NCPAINT;
    procedure CMMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;
    procedure CMMouseEnter(var Msg: TMessage); message CM_MOUSEENTER;
    procedure SetInteger(Index : integer; Value: integer);
    procedure SetDisabledKind(const Value: TsDisabledKind);
  protected
    CI : TCacheInfo;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure Change(OldValue : integer); dynamic;
    procedure Scroll(ScrollCode: TScrollCode; var ScrollPos: Integer); dynamic;
    procedure WndProc(var Message: TMessage); override;
    procedure Paint;

    procedure InitDontChange;
    procedure ClearDontChange;

    procedure DrawBtnTop(b : TBitmap); overload;
    procedure DrawBtnLeft(b : TBitmap); overload;
    procedure DrawBtnRight(b : TBitmap); overload;
    procedure DrawBtnBottom(b : TBitmap); overload;
    procedure DrawSlider(b : TBitmap); overload;

    function Bar1Rect : TRect;
    function Bar2Rect : TRect;
    function Btn1Rect : TRect;
    function Btn2Rect : TRect;
    function Btn1DRect : TRect;
    function Btn2DRect : TRect;
    function WorkSize : integer;
    function SliderRect : TRect;
    function SliderSize : integer;
    function Btn1SkinIndex : integer;
    function Btn2SkinIndex : integer;
    function ScrollSliderIndex : integer;
    function CoordToPoint(p : TPoint) : TPoint;
    function CoordToPosition(p : TPoint) : integer;
    function PositionToCoord : integer;
    function FirstPoint : integer;
    function SliderSectionName : string;
    function BarIsHot : boolean;
    procedure PrepareTimer;
    procedure PrepareBtnTimer;
    procedure PrepareBarTimer;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure KeyDown(var Key: word; Shift: TShiftState); override;
  public
    RepaintNeeded : boolean;
    MouseOffset : integer;
    DrawingForbidden : boolean;
    LinkedControl : TControl;
    Ontop : boolean;
    DontChange : boolean;
    LastPosition : integer;
    function CanFocus: Boolean; override;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function Skinable : boolean;
    procedure AfterConstruction; override;
    procedure Loaded; override;
    procedure SetParams(APosition, AMin, AMax: Integer);
    procedure UpdateBar;
    procedure OnTimer(Sender : TObject);
    procedure OnBtnTimer(Sender : TObject);
    procedure OnBarTimer(Sender : TObject);
    property Btn1State : integer index 0 read FBtn1State write SetInteger;
    property Btn2State : integer index 1 read FBtn2State write SetInteger;
    property Bar1State : integer index 2 read FBar1State write SetInteger;
    property Bar2State : integer index 3 read FBar2State write SetInteger;
    property SliderState : integer index 4 read FSliderState write SetInteger;
    property CommonData : TsCommonData read FCommonData write FCommonData;
  published
    property Align;
    property Anchors;
    property BiDiMode;
    property Constraints;
    property Ctl3D;
    property DisabledKind : TsDisabledKind read FDisabledKind write SetDisabledKind default DefDisabledKind;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Kind: TScrollBarKind read FKind write SetKind default sbHorizontal;
    property LargeChange: TScrollBarInc read FLargeChange write FLargeChange default 1;
    property Max: Integer read FMax write SetMax default 100;
    property Min: Integer read FMin write SetMin default 0;
    property PageSize: Integer read FPageSize write SetPageSize;
    property ParentBiDiMode;
    property ParentCtl3D;
    property ParentShowHint;
    property PopupMenu;
    property Position: Integer read FPosition write SetPosition default 0;
    property ShowHint;
    property SmallChange: TScrollBarInc read FSmallChange write FSmallChange default 1;
    property Smooth : boolean read FSmooth write FSmooth default True;
    property TabOrder;
    property TabStop default True;
    property Visible;
    property OnContextPopup;
    property OnChange: TOnChangeEvent read FOnChange write FOnChange;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseUp;
    property OnScroll: TScrollEvent read FOnScroll write FOnScroll;
    property OnStartDock;
    property OnStartDrag;
  end;

implementation

uses sGraphUtils, sBorders, sSkinProps, math, sMessages, commctrl, sMaskData,
  sStyleSimply, sVclUtils, sAlphaGraph;

var
  i1 : integer;
  p : TPoint;
//  co : integer;

{ TsScrollBar }

procedure TsScrollBar.AfterConstruction;
begin
  inherited;
  FCommonData.Loaded;
end;

function TsScrollBar.Btn1Rect: TRect;
begin
  FBtn1Rect.Left := 0;
  FBtn1Rect.Top := 0;
  if Kind = sbHorizontal then begin
    FBtn1Rect.Right := GetSystemMetrics(SM_CXHSCROLL);
    FBtn1Rect.Bottom := Height;
  end
  else begin
    FBtn1Rect.Right := Width;
    FBtn1Rect.Bottom := GetSystemMetrics(SM_CYVSCROLL);
  end;
  Result := FBtn1Rect;
end;

function TsScrollBar.Btn1SkinIndex: integer;
begin
  if Kind = sbHorizontal then begin
    FBtn1SkinIndex := GetSkinIndex(ArrowLeft);
  end
  else begin
    FBtn1SkinIndex := GetSkinIndex(ArrowTop);
  end;
  Result := FBtn1SkinIndex;
end;

function TsScrollBar.Btn2Rect: TRect;
begin
  if Kind = sbHorizontal then begin
    FBtn2Rect.Left := Width - GetSystemMetrics(SM_CXHSCROLL);
    FBtn2Rect.Top := 0;
    FBtn2Rect.Right := Width;
    FBtn2Rect.Bottom := Height;
  end
  else begin
    FBtn2Rect.Left := 0;
    FBtn2Rect.Top := Height - GetSystemMetrics(SM_CYVSCROLL);
    FBtn2Rect.Right := Width;
    FBtn2Rect.Bottom := Height;
  end;
  Result := FBtn2Rect;
end;

function TsScrollBar.Btn2SkinIndex: integer;
begin
  if Kind = sbHorizontal then begin
    FBtn2SkinIndex := GetSkinIndex(ArrowRight);
  end
  else begin
    FBtn2SkinIndex := GetSkinIndex(ArrowBottom);
  end;
  Result := FBtn2SkinIndex;
end;

procedure TsScrollBar.Change(OldValue : integer);
begin
  inherited Changed;
  if Assigned(FOnChange) and not (DontChange) then FOnChange(Self, OldValue);
end;

procedure TsScrollBar.CNCtlColorScrollBar(var Message: TMessage);
begin
  with Message do CallWindowProc(DefWndProc, Handle, Msg, WParam, LParam);
end;

procedure TsScrollBar.CNHScroll(var Message: TWMHScroll);
begin
  DoScroll(Message);
end;

procedure TsScrollBar.CNVScroll(var Message: TWMVScroll);
begin
  DoScroll(Message);
end;

function TsScrollBar.CoordToPoint(p: TPoint): TPoint;
begin
  Result := ScreenToClient(P);
end;

function TsScrollBar.CoordToPosition(p: TPoint): integer;
begin
  if Enabled then begin
    if Kind = sbHorizontal then begin
      Result := Round(
                (p.x - GetSystemMetrics(SM_CXHSCROLL) - SliderSize / 2) * (Max - Min) / (Width - 2 * GetSystemMetrics(SM_CXHSCROLL) - SliderSize)
                );
    end
    else begin
      Result := Round(
                (p.y - GetSystemMetrics(SM_CYVSCROLL) - SliderSize / 2) * (Max - Min) / (Height - 2 * GetSystemMetrics(SM_CYVSCROLL) - SliderSize)
                );
    end;
  end
  else Result := 0;
end;

constructor TsScrollBar.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCommonData := TsCommonData.Create(TWinControl(Self), True);
  FCommonData.FCacheBmp.PixelFormat := pf24bit;
  CI.Bmp := FCommonData.FCacheBmp;
  CI.Ready := True;
  CI.x := 0;
  CI.Y := 0;
  FCommonData.COC := COC_TsScrollBar;
  Width := 121;
  Height := GetSystemMetrics(SM_CYHSCROLL);
  TabStop := True;
  ControlStyle := [csDoubleClicks, csOpaque];
  FKind := sbHorizontal;
  FPosition := 0;
  FMin := 0;
  FMax := 100;
  FSmallChange := 1;
  FLargeChange := 1;
  FSmooth := True;

  Btn1State := 0;
  Btn2State := 0;
  Bar1State := 0;
  Bar2State := 0;
  FBtn1SkinIndex := -1;
  FBtn2SkinIndex := -1;

  FBtn1Rect.Right := 0;
  FBtn2Rect.Right := 0;
  if SysLocale.FarEast and (Win32Platform = VER_PLATFORM_WIN32_NT) then ImeMode := imDisable;
  FDisabledKind := DefDisabledKind;
end;


procedure TsScrollBar.CreateParams(var Params: TCreateParams);
const
  Kinds: array[TScrollBarKind] of DWORD = (SBS_HORZ, SBS_VERT);
begin
  Params.WindowClass.style := Params.WindowClass.style and not WS_BORDER and not WS_DLGFRAME and not WS_THICKFRAME;
  inherited CreateParams(Params);
  // Currently drawing by system is not used
{  if not Skinable then begin
    CreateSubClass(Params, 'SCROLLBAR');
    Params.Style := Params.Style or Kinds[FKind];
    if FKind = sbVertical then
      if not UseRightToLeftAlignment then
        Params.Style := Params.Style or SBS_RIGHTALIGN
      else
        Params.Style := Params.Style or SBS_LEFTALIGN;
  end;}
  if NotRightToLeft then FRTLFactor := 1 else FRTLFactor := -1;
end;


procedure TsScrollBar.CreateWnd;
var
  ScrollInfo: TScrollInfo;
begin
  inherited CreateWnd;
  SetScrollRange(Handle, SB_CTL, FMin, FMax, False);
  ScrollInfo.cbSize := SizeOf(ScrollInfo);
  ScrollInfo.nPage := FPageSize;
  ScrollInfo.fMask := SIF_PAGE;
  SetScrollInfo(Handle, SB_CTL, ScrollInfo, False);
  if NotRightToLeft then begin
    SetScrollPos(Handle, SB_CTL, FPosition, True)
  end
  else begin
    SetScrollPos(Handle, SB_CTL, FMax - FPosition, True);
  end;
end;

destructor TsScrollBar.Destroy;
begin
//  ParentSStyle := nil;
  if Assigned(FCommonData) then FreeAndNil(FCommonData);
  if Assigned(Timer) then FreeAndNil(Timer);
  inherited Destroy;
end;

procedure TsScrollBar.DoScroll(var Message: TWMScroll);
var
  ScrollPos: Integer;
  NewPos: Longint;
  ScrollInfo: TScrollInfo;
begin
  with Message do begin
    NewPos := FPosition;
    case TScrollCode(ScrollCode) of
      scLineUp:
        Dec(NewPos, FSmallChange * FRTLFactor);
      scLineDown:
        Inc(NewPos, FSmallChange * FRTLFactor);
      scPageUp:
        Dec(NewPos, FLargeChange * FRTLFactor);
      scPageDown:
        Inc(NewPos, FLargeChange * FRTLFactor);
      scPosition, scTrack:
        with ScrollInfo do begin
          cbSize := SizeOf(ScrollInfo);
          fMask := SIF_ALL;
          GetScrollInfo(Handle, SB_CTL, ScrollInfo);
          NewPos := nTrackPos;
          { We need to reverse the positioning because SetPosition below
            calls SetParams that reverses the position. This acts as a
            double negative. }
          if not NotRightToLeft then NewPos := FMax - NewPos;
        end;
      scTop:
        NewPos := FMin;
      scBottom:
        NewPos := FMax;
    end;
    if NewPos < FMin then NewPos := FMin;
    if NewPos > FMax then NewPos := FMax;
    ScrollPos := NewPos;
    Scroll(TScrollCode(ScrollCode), ScrollPos);
    SetPosition(ScrollPos);
  end;
end;

procedure TsScrollBar.DrawBtnBottom(b: TBitmap);
begin
  Ci.Bmp := b;
  PaintItem(Btn2SkinIndex, ArrowBottom, Ci, True,
    Btn2State,
    Btn2DRect,
    Point(Btn2Rect.Left, Btn2Rect.Top), b);
  Ci.Bmp := FCommonData.FCacheBmp;

  i1 := GetMaskIndex(FBtn2SkinIndex, ArrowBottom, ItemGlyph);
  if IsValidImgIndex(i1) and (ma[i1].Bmp.Height div 2 < HeightOf(FBtn2Rect)) then begin
    p.x := FBtn2Rect.Left + (WidthOf(FBtn2Rect) - ma[i1].Bmp.Width div 3) div 2;// + integer(Btn2State = 2);
    p.y := FBtn2Rect.Top + (HeightOf(FBtn2Rect) - ma[i1].Bmp.Height div 2) div 2;// + integer(Btn2State = 2);
    if (p.x < 0) or (p.y < 0) then Exit; 
    PaintRasterGlyph(b, ma[i1].Bmp,
            p, Btn2State, ma[i1].TransparentColor);
  end;
end;

procedure TsScrollBar.DrawBtnLeft(b: TBitmap);
begin
  Ci.Bmp := b;
  PaintItem(Btn1SkinIndex, ArrowLeft, Ci, True,
    Btn1State,
    Btn1DRect,
    Point(Btn1Rect.Left, Btn1Rect.Left), b);
  Ci.Bmp := FCommonData.FCacheBmp;

  i1 := GetMaskIndex(Btn1SkinIndex, ArrowLeft, ItemGlyph);
  if IsValidImgIndex(i1) and (ma[i1].Bmp.Width div 3 < WidthOf(FBtn1Rect)) then begin
    p.x := FBtn1Rect.Left + (WidthOf(FBtn1Rect) - ma[i1].Bmp.Width div 3) div 2;// + integer(Btn1State = 2);
    p.y := FBtn1Rect.Top + (HeightOf(FBtn1Rect) - ma[i1].Bmp.Height div 2) div 2;// + integer(Btn1State = 2);
    if (p.x < 0) or (p.y < 0) then Exit; 
    PaintRasterGlyph(b, ma[i1].Bmp,
            p, Btn1State, ma[i1].TransparentColor);