salphalistbox.pas

Alpha Controls 界面控件包

unit sAlphaListBox;
{$I sDefs.inc}
{.$DEFINE LOGGED}

interface

uses StdCtrls, controls, classes, forms, graphics, messages, windows, sysutils, consts, sCommonData,
  sConst, sDefaults, commctrl, acSBUtils{$IFNDEF DELPHI5}, types{$ENDIF};

type

{$IFNDEF NOTFORHELP}
{$IFNDEF DELPHI6UP}
  TListBoxStyle = (lbStandard, lbOwnerDrawFixed, lbOwnerDrawVariable, lbVirtual, lbVirtualOwnerDraw);
  TLBGetDataEvent = procedure(Control: TWinControl; Index: Integer; var Data: string) of object;
  TLBGetDataObjectEvent = procedure(Control: TWinControl; Index: Integer; var DataObject: TObject) of object;
  TLBFindDataEvent = function(Control: TWinControl; FindString: string): Integer of object;
{$ENDIF}
{$ENDIF} // NOTFORHELP

  TsAlphaListBox = class(TWinControl)
{$IFNDEF NOTFORHELP}
  private
    FCount: Integer;
    FOldCount: Integer;
    FFilter: String;
    FLastTime: DWord;
    FItems: TStrings;
    FBorderStyle: TBorderStyle;
    FCanvas: TCanvas;
    FColumns: Integer;
    FItemHeight: Integer;
    FStyle: TListBoxStyle;
    FIntegralHeight: Boolean;
    FMultiSelect: Boolean;
    FSorted: Boolean;
    FExtendedSelect: Boolean;
    FTabWidth: Integer;
    FSaveItems: TStringList;
    FSaveTopIndex: Integer;
    FSaveItemIndex: Integer;
    FOnDrawItem: TDrawItemEvent;
    FOnMeasureItem: TMeasureItemEvent;
    FCommonData: TsCommonData;
    FOnVScroll: TNotifyEvent;
    FDisabledKind: TsDisabledKind;
    FBoundLabel: TsBoundLabel;
    FOnDataFind: TLBFindDataEvent;
    FOnData: TLBGetDataEvent;
    FOnDataObject: TLBGetDataObjectEvent;
    FAutoComplete: Boolean;
    FAutoHideScroll: boolean;
    FAutoCompleteDelay: Word;
    function GetItemHeight: Integer;
    function GetItemIndex: Integer;
    function GetSelCount: Integer;
    function GetSelected(Index: Integer): Boolean;
    function GetTopIndex: Integer;
    procedure SetBorderStyle(Value: TBorderStyle);
    procedure SetColumnWidth;
    procedure SetColumns(Value: Integer);
    procedure SetExtendedSelect(Value: Boolean);
    procedure SetIntegralHeight(Value: Boolean);
    procedure SetItemHeight(Value: Integer);
    procedure SetItems(Value: TStrings);
    procedure SetItemIndex(Value: Integer);
    procedure SetMultiSelect(Value: Boolean);
    procedure SetSelected(Index: Integer; Value: Boolean);
    procedure SetSorted(Value: Boolean);
    procedure SetStyle(Value: TListBoxStyle);
    procedure SetTabWidth(Value: Integer);
    procedure SetTopIndex(Value: Integer);
    procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;
    procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
    procedure CNMeasureItem(var Message: TWMMeasureItem); message CN_MEASUREITEM;
    procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
//    procedure WMNCPaint (var Message: TWMPaint); message WM_NCPAINT;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure WMNCCalcSize (var Message: TWMNCCalcSize); message WM_NCCALCSIZE;
    procedure WMEraseBkgnd (var Message: TWMPaint); message WM_ERASEBKGND;
    procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
    procedure WMLButtonUp(var Message: TMessage); message WM_LBUTTONUP;
    procedure SetDisabledKind(const Value: TsDisabledKind);

    procedure LBGetText(var Message: TMessage); message LB_GETTEXT;
    procedure LBGetTextLen(var Message: TMessage); message LB_GETTEXTLEN;
    function GetCount: Integer;
    procedure SetCount(const Value: Integer);
    procedure SetAutoHideScroll(const Value: boolean);
    function GetScrollWidth: Integer;
    procedure SetScrollWidth(const Value: Integer);
  protected
    FMoving: Boolean;
    FTopIndex : integer;
    ListSW : TacScrollWnd;

    function DoGetData(const Index: Integer): String;
    function DoGetDataObject(const Index: Integer): TObject;
    function DoFindData(const Data: String): Integer;
    procedure KeyPress(var Key: Char); override;

    procedure PrepareCache; virtual;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure DestroyWnd; override;
    procedure DragCanceled; override;
    procedure MeasureItem(Index: Integer; var Height: Integer); virtual;
    function InternalGetItemData(Index: Integer): Longint; dynamic;
    procedure InternalSetItemData(Index: Integer; AData: Longint); dynamic;
    function GetItemData(Index: Integer): LongInt; dynamic;
    function VisibleRows : integer;
    procedure SetItemData(Index: Integer; AData: LongInt); dynamic;
    procedure ResetContent; dynamic;
    procedure DeleteString(Index: Integer); dynamic;
    property ExtendedSelect: Boolean read FExtendedSelect write SetExtendedSelect default True;
    procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); virtual;
    procedure WndProc(var Message: TMessage); override;
  public
    procedure AfterConstruction; override;
    procedure DeleteSelected;
    procedure ClearSelection;
    procedure Loaded; override;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Clear;
    function ItemAtPos(Pos: TPoint; Existing: Boolean): Integer;
    function ItemRect(Index: Integer): TRect;
    procedure RepaintItem(Index : Integer);
    property Canvas: TCanvas read FCanvas;
    property ItemIndex: Integer read GetItemIndex write SetItemIndex;
    property SelCount: Integer read GetSelCount;
    property Selected[Index: Integer]: Boolean read GetSelected write SetSelected;
    property TopIndex: Integer read GetTopIndex write SetTopIndex;
    property MultiSelect: Boolean read FMultiSelect write SetMultiSelect default False;
    property ScrollWidth: Integer read GetScrollWidth write SetScrollWidth default 0;
{$ENDIF} // NOTFORHELP
    property Count: Integer read GetCount write SetCount;
  published
    property AutoCompleteDelay : Word read FAutoCompleteDelay write FAutoCompleteDelay;
    property AutoComplete: Boolean read FAutoComplete write FAutoComplete default True;
    property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
    property BoundLabel : TsBoundLabel read FBoundLabel write FBoundLabel;
    property Columns: Integer read FColumns write SetColumns default 0;
    property SkinData : TsCommonData read FCommonData write FCommonData;
    property DisabledKind : TsDisabledKind read FDisabledKind write SetDisabledKind default DefDisabledKind;
    property IntegralHeight: Boolean read FIntegralHeight write SetIntegralHeight default False;
    property ItemHeight: Integer read GetItemHeight write SetItemHeight;
    property Items: TStrings read FItems write SetItems;
    property Sorted: Boolean read FSorted write SetSorted default False;
    property Style: TListBoxStyle read FStyle write SetStyle default lbStandard;
    property TabWidth: Integer read FTabWidth write SetTabWidth default 0;

{$IFNDEF NOTFORHELP}
    property AutoHideScroll : boolean read FAutoHideScroll write SetAutoHideScroll default True;
    {:@event}
    property OnData: TLBGetDataEvent read FOnData write FOnData;
    {:@event}
    property OnDataObject: TLBGetDataObjectEvent read FOnDataObject write FOnDataObject;
    {:@event}
    property OnDataFind: TLBFindDataEvent read FOnDataFind write FOnDataFind;
    {:@event}
    property OnDrawItem: TDrawItemEvent read FOnDrawItem write FOnDrawItem;
    {:@event}
    property OnMeasureItem: TMeasureItemEvent read FOnMeasureItem write FOnMeasureItem;
    {:@event}
    property OnVScroll : TNotifyEvent read FOnVScroll write FOnVScroll;
    property Align;
    property Anchors;
    property BiDiMode;
    property Color;
    property Constraints;
    property Ctl3D;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Font;
    property ImeMode;
    property ImeName;
    property ParentBiDiMode;
    property ParentColor default False;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop default True;
    property Visible;
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDock;
    property OnStartDrag;
{$ENDIF} // NOTFORHELP
  end;

  TsListBox = class(TsAlphaListBox)
  published
{$IFNDEF NOTFORHELP}
    property MultiSelect;
    property ExtendedSelect;
{$ENDIF} // NOTFORHELP
  end;

{$IFNDEF NOTFORHELP}
var
  mPressed : boolean = False;
  ScrollsUpdating : boolean = False;
{$ENDIF}


implementation

uses sVCLUtils, sGraphUtils, math, sMessages, sStyleSimply, sSkinProps, sAlphaGraph, sStrings
  {$IFDEF DELPHI6UP}, RTLConsts{$ENDIF} {$IFDEF LOGGED}, sDebugMsgs{$ENDIF};

const
  BorderStyles: array[TBorderStyle] of DWORD = (0, WS_BORDER);

type   
  TListBoxStrings = class(TStrings)
  private
    ListBox: TsAlphaListBox;
  protected
    procedure Put(Index: Integer; const S: string); override;
    function Get(Index: Integer): string; override;
    function GetCount: Integer; override;
    function GetObject(Index: Integer): TObject; override;
    procedure PutObject(Index: Integer; AObject: TObject); override;
    procedure SetUpdateState(Updating: Boolean); override;
    procedure Update;
  public
    function Add(const S: string): Integer; override;
    procedure Clear; override;
    procedure Delete(Index: Integer); override;
    procedure Exchange(Index1, Index2: Integer); override;
    function IndexOf(const S: string): Integer; override;
    procedure Insert(Index: Integer; const S: string); override;
    procedure Move(CurIndex, NewIndex: Integer); override;
  end;

{ TsAlphaListBox }
procedure TsAlphaListBox.AfterConstruction;
begin
  inherited AfterConstruction;
  SkinData.Loaded;
end;

procedure TsAlphaListBox.Clear;
begin
  FItems.Clear;
end;

procedure TsAlphaListBox.ClearSelection;
var
  I: Integer;
begin
  if MultiSelect then for I := 0 to Items.Count - 1 do Selected[I] := False else ItemIndex := -1;
end;

procedure TsAlphaListBox.CMCtl3DChanged(var Message: TMessage);
begin
  if NewStyleControls and (FBorderStyle = bsSingle) then RecreateWnd;
  inherited;
end;

procedure TsAlphaListBox.CMEnabledChanged(var Message: TMessage);
begin
  FCommonData.BGChanged := True;
  Perform(WM_PAINT, 0, 0);
  Perform(WM_NCPAINT, 0, 0);
  inherited;
end;

procedure TsAlphaListBox.CMFontChanged(var Message: TMessage);
var
  R : TRect;
begin
  inherited;
  if not (csLoading in ComponentState) then begin
    SkinData.BGChanged := True;
    Repaint;
//    RecreateWnd; v4.71
    if HandleAllocated and (FStyle = lbStandard) then begin
      Perform(LB_GETITEMRECT, 0, Longint(@R));
      ItemHeight := R.Bottom - R.Top;
    end;
  end;
end;

procedure TsAlphaListBox.CNCommand(var Message: TWMCommand);
begin
  case Message.NotifyCode of
    LBN_SELCHANGE: begin
      inherited Changed;
      Click;
    end;
    LBN_DBLCLK: DblClick;
  end;
end;

procedure TsAlphaListBox.CNDrawItem(var Message: TWMDrawItem);
var
  State: TOwnerDrawState;
begin
  FCommonData.Updating := FCommonData.Updating;
  if FCommonData.Updating and SkinData.Skinned then Exit;
  if Items.Count < 1 then Exit;
  with Message.DrawItemStruct^ do begin
    State := TOwnerDrawState(LongRec(itemState).Lo);
    FCanvas.Handle := hDC;
    FCanvas.Font := Font;
    FCanvas.Brush := Brush;
    if not ((Style in [lbOwnerDrawFixed, lbOwnerDrawVariable, lbVirtualOwnerDraw]) and Assigned(OnDrawItem)) and (Integer(itemID) >= 0) and ((odSelected in State) or ((integer(itemID) = ItemIndex) and not Focused)) then begin
      FCanvas.Brush.Color := clHighlight;
      FCanvas.Font.Color := clHighlightText
    end
    else if not FCommonData.CustomFont then begin
      if not Enabled then FCanvas.Font.Color := AverageColor(Font.Color, Color) else FCanvas.Font.Color := Font.Color;
    end;

    DrawItem(Message.DrawItemStruct^.itemID, Message.DrawItemStruct^.rcItem, State);
    FCanvas.Handle := 0;
  end;
end;

procedure TsAlphaListBox.CNMeasureItem(var Message: TWMMeasureItem);
begin
  with Message.MeasureItemStruct^ do begin
    itemHeight := FItemHeight;
    if FStyle = lbOwnerDrawVariable then MeasureItem(itemID, Integer(itemHeight));
  end;
end;

constructor TsAlphaListBox.Create(AOwner: TComponent);
const
  ListBoxStyle = [csSetCaption, csDoubleClicks];
begin
  inherited Create(AOwner);
  if NewStyleControls then ControlStyle := ListBoxStyle else ControlStyle := ListBoxStyle + [csFramed, csOpaque];
  Width := 121;
  Height := 97;
  TabStop := True;
  ParentColor := False;
  FItems := TListBoxStrings.Create;
  TListBoxStrings(FItems).ListBox := Self;
  FCanvas := TControlCanvas.Create;