salphalistbox.pas

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

unit sAlphaListBox;

{$I sDefs.inc}

interface

uses StdCtrls, controls, classes, forms, graphics, messages, windows, sysutils,
  consts, sCommonData, sScrollBar, sConst, sDefaults;

type

  TsAlphaListBox = class(TWinControl)
  private
    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;
    procedure OnVSBChange(Sender : TObject; OldValue : integer);
    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 WMSize(var Message: TWMSize); message WM_SIZE;
    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 WMNCPaint (var Message: TWMPaint); message WM_NCPAINT;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure WMNCCalcSize (var Message: TWMNCCalcSize); message WM_NCCALCSIZE;
    procedure LBGetItemRect (var Message: TMessage); message LB_GETITEMRECT;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure WMEraseBkgnd (var Message: TWMPaint); message WM_ERASEBKGND;
    procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
    procedure WMKeyDown (var Message: TWMKeyDown); message WM_KEYDOWN;
    procedure SetDisabledKind(const Value: TsDisabledKind);
  protected
    VSBar : TsScrollBar;
    SavedIndex : integer;
    Scrolling : boolean;
    FMoving: Boolean;
    FTopIndex : integer;
    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;
    procedure RefreshScrolls;
    procedure RefreshScrollBounds;
    property ExtendedSelect: Boolean read FExtendedSelect write SetExtendedSelect default True;
    property MultiSelect: Boolean read FMultiSelect write SetMultiSelect default False;
    procedure Paint; virtual;
    procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); virtual;
    procedure WndProc(var Message: TMessage); override;
    procedure ChangeSelected (IndexOld, IndexNew : integer);
    procedure UpdateListBox;
  public
    procedure AfterConstruction; override;
    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;
    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;
  published
    property Align;
    property Anchors;
    property BiDiMode;
    property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
    property Color;
    property Columns: Integer read FColumns write SetColumns default 0;
    property CommonData : TsCommonData read FCommonData write FCommonData;
    property Constraints;
    property Ctl3D;
    property DisabledKind : TsDisabledKind read FDisabledKind write SetDisabledKind default DefDisabledKind;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    //property ExtendedSelect;
    property Font;
    property ImeMode;
    property ImeName;
    property IntegralHeight: Boolean read FIntegralHeight write SetIntegralHeight default False;
    property ItemHeight: Integer read GetItemHeight write SetItemHeight;
    property Items: TStrings read FItems write SetItems;
    //property MultiSelect;
    property ParentBiDiMode;
    property ParentColor default False;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Sorted: Boolean read FSorted write SetSorted default False;
    property Style: TListBoxStyle read FStyle write SetStyle default lbStandard;
    property TabOrder;
    property TabStop default True;
    property TabWidth: Integer read FTabWidth write SetTabWidth default 0;
    property Visible;
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnDrawItem: TDrawItemEvent read FOnDrawItem write FOnDrawItem;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMeasureItem: TMeasureItemEvent read FOnMeasureItem write FOnMeasureItem;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDock;
    property OnStartDrag;
    Property OnVScroll : TNotifyEvent read FOnVScroll write FOnVScroll;
  end;

implementation

uses sVCLUtils, sMaskData, sUtils, sGraphUtils, math, sMessages, sStyleSimply,
  sSkinProps, sAlphaGraph
{$IFDEF DELPHI6UP}
  , RTLConsts
{$ENDIF}
  ;

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

var
  Flag : boolean = False;

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;
  CommonData.Loaded;
  RefreshScrolls;
end;

procedure TsAlphaListBox.ChangeSelected(IndexOld, IndexNew: integer);
begin
//  Repaint; Exit;
  if IndexOld = -1 then IndexOld := IndexNew;
  if IndexNew = -1 then IndexNew := IndexOld;
  if (IndexOld <> IndexNew) and (IndexOld - TopIndex > -1) then DrawItem(IndexOld - TopIndex, ItemRect(IndexOld - TopIndex), []);
  if (IndexNew - TopIndex > -1) then DrawItem(IndexNew - TopIndex, ItemRect(IndexNew - TopIndex), [odSelected]);
end;

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

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

procedure TsAlphaListBox.CMFontChanged(var Message: TMessage);
begin
  CommonData.BGChanged := True;
  inherited;
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
  with Message.DrawItemStruct^ do begin
    State := TOwnerDrawState(LongRec(itemState).Lo);
    FCanvas.Handle := hDC;
    FCanvas.Font := Font;
    FCanvas.Brush := Brush;
    if (Integer(itemID) >= 0) and (odSelected in State) then begin
      FCanvas.Brush.Color := clHighlight;
      FCanvas.Font.Color := clHighlightText
    end;
    if (Integer(itemID) >= 0) or FCommonData.Skinned then DrawItem(itemID, rcItem, State) else FCanvas.FillRect(rcItem);
    if (odFocused in State) and not FCommonData.Skinned then DrawFocusRect(hDC, rcItem);
    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];
  Width := 121;
  Height := 97;
  TabStop := True;
  ParentColor := False;
  FItems := TListBoxStrings.Create;
  TListBoxStrings(FItems).ListBox := Self;
  FCanvas := TControlCanvas.Create;
  TControlCanvas(FCanvas).Control := Self;
  FItemHeight := 16;
  FBorderStyle := bsSingle;
  FExtendedSelect := True;
  FCommonData := TsCommonData.Create(Self, True);
  FTopIndex := 0;
  FDisabledKind := DefDisabledKind;
end;

procedure TsAlphaListBox.CreateParams(var Params: TCreateParams);
type
  PSelects = ^TSelects;
  TSelects = array[Boolean] of DWORD;
const
  Styles: array[TListBoxStyle] of DWORD =
    (0, LBS_OWNERDRAWFIXED, LBS_OWNERDRAWVARIABLE
{$IFDEF DELPHI6UP}
     , LBS_OWNERDRAWFIXED, LBS_OWNERDRAWFIXED
{$ENDIF}
    );
{  Styles: array[TListBoxStyle] of DWORD =
    (0, LBS_OWNERDRAWFIXED, LBS_OWNERDRAWVARIABLE, LBS_OWNERDRAWFIXED,
     LBS_OWNERDRAWFIXED);}

  Sorteds: array[Boolean] of DWORD = (0, LBS_SORT);
  MultiSelects: array[Boolean] of DWORD = (0, LBS_MULTIPLESEL);
  ExtendSelects: array[Boolean] of DWORD = (0, LBS_EXTENDEDSEL);
  IntegralHeights: array[Boolean] of DWORD = (LBS_NOINTEGRALHEIGHT, 0);
  MultiColumns: array[Boolean] of DWORD = (0, LBS_MULTICOLUMN);
  TabStops: array[Boolean] of DWORD = (0, LBS_USETABSTOPS);
  CSHREDRAW: array[Boolean] of DWORD = (CS_HREDRAW, 0);
var
  Selects: PSelects;
begin
  inherited CreateParams(Params);
  CreateSubClass(Params, 'LISTBOX');
  with Params do begin
    Selects := @MultiSelects;
    if FExtendedSelect then Selects := @ExtendSelects;
    Style := Style or (WS_HSCROLL or WS_VSCROLL or LBS_HASSTRINGS or
      LBS_NOTIFY) or Styles[FStyle] or Sorteds[FSorted] or
      Selects^[FMultiSelect] or IntegralHeights[FIntegralHeight] or
      MultiColumns[FColumns <> 0] or BorderStyles[FBorderStyle] or
      TabStops[FTabWidth <> 0];
    if NewStyleControls and Ctl3D and (FBorderStyle = bsSingle) then begin
      Style := Style and not WS_BORDER;
      ExStyle := ExStyle or WS_EX_CLIENTEDGE;
    end;
    WindowClass.style := WindowClass.style and not (CSHREDRAW[UseRightToLeftAlignment] or CS_VREDRAW);
  end;
  with Params do if Style and (LBS_OWNERDRAWFIXED or LBS_OWNERDRAWVARIABLE) = 0 then Style := Style or LBS_OWNERDRAWFIXED;
end;

procedure TsAlphaListBox.CreateWnd;
var
  W, H: Integer;
begin
  W := Width;
  H := Height;
  inherited CreateWnd;
  SetWindowPos(Handle, 0, Left, Top, W, H, SWP_NOZORDER or SWP_NOACTIVATE);
  if FTabWidth <> 0 then SendMessage(Handle, LB_SETTABSTOPS, 1, Longint(@FTabWidth));
  SetColumnWidth;
  if FSaveItems <> nil then begin
    FItems.Assign(FSaveItems);
    SetTopIndex(FSaveTopIndex);
    SetItemIndex(FSaveItemIndex);
    FSaveItems.Free;
    FSaveItems := nil;
  end;
end;

procedure TsAlphaListBox.DeleteString(Index: Integer);
begin
  SendMessage(Handle, LB_DELETESTRING, Index, 0);
end;

destructor TsAlphaListBox.Destroy;
begin
  if Assigned(FCommonData) then FreeAndNil(FCommonData);
  inherited Destroy;
  FCanvas.Free;
  FItems.Free;
  FSaveItems.Free;
end;

procedure TsAlphaListBox.DestroyWnd;
begin
  if FItems.Count > 0 then
  begin
    FSaveItems := TStringList.Create;
    FSaveItems.Assign(FItems);
    FSaveTopIndex := GetTopIndex;
    FSaveItemIndex := GetItemIndex;
  end;
  inherited DestroyWnd;
end;

procedure TsAlphaListBox.DragCanceled;
var
  M: TWMMouse;
  MousePos: TPoint;
begin
  with M do
  begin
    Msg := WM_LBUTTONDOWN;
    GetCursorPos(MousePos);
    Pos := PointToSmallPoint(ScreenToClient(MousePos));
    Keys := 0;
    Result := 0;
  end;
  DefaultHandler(M);
  M.Msg := WM_LBUTTONUP;
  DefaultHandler(M);
end;

procedure TsAlphaListBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
var
  Flags: Longint;
  TempBmp : Graphics.TBitmap;
  R : TRect;
  CI : TCacheInfo;
begin
  if FCommonData.Skinned then begin
    if FCommonData.Skinned then if Self.ClientHeight = Height then begin
      Perform(CM_RECREATEWND, 0, 0); // Fixing of error in CalcSize..
      Perform(CM_INVALIDATE, 0, 0); 
      Exit;
    end;
    TempBmp := Graphics.TBitmap.Create;
    TempBmp.PixelFormat := pf24Bit;
    TempBmp.Width := WidthOf(Rect);
    TempBmp.Height := HeightOf(Rect);
    try
      R := Classes.Rect(0, 0, TempBmp.Width, TempBmp.Height);
      if SavedIndex - TopIndex = Index then begin
        State := [odSelected]; if Focused then State := State + [odFocused];
        TempBmp.Canvas.Brush.Color := clHighlight;
        TempBmp.Canvas.Brush.Style := bsSolid;
        TempBmp.Canvas.FillRect(R);
        TempBmp.Canvas.Font.Color := clHighlightText;
      end
      else begin
        BitBlt(TempBmp.Canvas.Handle, 0, 0, TempBmp.Width, TempBmp.Height, CommonData.FCacheBmp.Canvas.Handle, Rect.Left + 3, Rect.Top + 3, SRCCOPY);
        State := [];
        TempBmp.Canvas.Brush.Color := clWhite;
        TempBmp.Canvas.Brush.Style := bsClear;
        TempBmp.Canvas.Font.Color := Font.Color;
      end;
      if Assigned(FOnDrawItem) then FOnDrawItem(Self, Index, Rect, State) else begin
        R.Left := 2;
        if (Index + TopIndex < Items.Count) and (Index + TopIndex > -1) then begin
          if State = [] then begin
            WriteTextEx(TempBmp.Canvas, PChar(Items[Index + TopIndex]), True,//Enabled,
                                    R, DT_VCENTER, FCOmmonData.SkinIndex, ControlIsActive(FCommonData));
          end
          else begin
            WriteText(TempBmp.Canvas, PChar(Items[Index + TopIndex]), True{Enabled}, R, DT_VCENTER);
          end;
        end;