newchecklistbox.pas

源代码

unit NewCheckListBox;

{ TNewCheckListBox by Martijn Laan for My Inno Setup Extensions
  See http://isx.wintax.nl/ for more information

  Based on TPBCheckListBox by Patrick Brisacier and TCheckListBox by Borland

  Group item support, child item support, exclusive item support, hint support,
  ShowLines support and 'WantTabs mode' by Alex Yackimoff.

  Note: TNewCheckListBox uses Items.Objects to store the item state. Don't use
  Item.Objects yourself, use ItemObject instead.

  Note 2: To get correct hint support when using Delphi 2, please patch
  Application.Idle in Forms.pas by removing 'or (FMouseControl = FHintWindow)'.

  $jrsoftware: issrc/Components/NewCheckListBox.pas,v 1.30 2004/11/21 01:28:22 jr Exp $
}

{$IFDEF VER90}
  {$DEFINE DELPHI2}
{$ENDIF}

{$IFNDEF DELPHI2}
  {$IFNDEF VER100}
    {$DEFINE HINTSHOWPAUSE}
  {$ENDIF}
{$ENDIF}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, UxThemeISX;

const
  WM_UPDATEUISTATE = $0128;

type

  TItemType = (itGroup, itCheck, itRadio);
  TCheckBoxState2 = (cb2Normal, cb2Hot, cb2Pressed, cb2Disabled);

  TItemState = class (TObject)
  public
    Enabled: Boolean;
    HasInternalChildren: Boolean;
    CheckWhenParentChecked: Boolean;
    IsLastChild: Boolean;
    ItemType: TItemType;
    Level: Byte;
    Obj: TObject;
    State: TCheckBoxState;
    SubItem: string;
    ThreadCache: set of Byte;
    MeasuredHeight: Integer;
  end;

  TEnumChildrenProc = procedure(Index: Integer; HasChildren: Boolean; Ext: Longint) of object;

  TNewCheckListBox = class (TCustomListBox)
  private
    FAccObjectInstance: TObject;
    FCaptureIndex: Integer;
    FSpaceDown: Boolean;
    FCheckHeight: Integer;
    FCheckWidth: Integer;
    FFormFocusChanged: Boolean;
    FFlat: Boolean;
    FLastMouseMoveIndex: Integer;
    FMinItemHeight: Integer;
    FOffset: Integer;
    FOnClickCheck: TNotifyEvent;
    FShowLines: Boolean;
    FStateList: TList;
    FWantTabs: Boolean;
    FThemeData: HTHEME;
    FThreadsUpToDate: Boolean;
    FHotIndex: Integer;
    {$IFDEF HINTSHOWPAUSE}
    FShowHintImmediately: Boolean;
    FHintsShowing: Boolean;
    {$ENDIF}
    {$IFDEF DELPHI2}
    FHintStr: string;
    FActiveShowHintHandler: TShowHintEvent;
    procedure ApplicationShowHintHook(var HintStr: string; var CanShow: Boolean;
      var HintInfo: THintInfo);
    {$ENDIF}
    procedure UpdateThemeData(const Close, Open: Boolean);
    function CanFocusItem(Item: Integer): Boolean;
    function CheckItem(const Index: Integer; const AChecked: Boolean): Boolean;
    function CheckPotentialRadioParents(Index, ALevel: Integer): Boolean;
    procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
    procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
    procedure CMExit(var Message: TCMExit); message CM_EXIT;
    procedure CMFocusChanged(var Message: TCMFocusChanged); message CM_FOCUSCHANGED;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW;
    {$IFDEF HINTSHOWPAUSE}
    procedure CMHintShowPause(var Message: TMessage); message CM_HINTSHOWPAUSE;
    {$ENDIF}
    procedure CMWantSpecialKey(var Message: TMessage); message CM_WANTSPECIALKEY;
    procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
    procedure EndCapture(Cancel: Boolean);
    function AddItem(AType: TItemType; const ACaption, ASubItem: string;
      ALevel: Byte; AChecked, AEnabled, AHasInternalChildren,
      ACheckWhenParentChecked: Boolean; AObject: TObject): Integer;
    function FindAccel(VK: Word): Integer;
    function FindNextItem(StartFrom: Integer; GoForward,
      SkipUncheckedRadios: Boolean): Integer;
    function GetItemState(Index: Integer): TItemState;
    procedure InvalidateCheck(Index: Integer);
    procedure RemeasureItem(Index: Integer);
    procedure Toggle(Index: Integer);
    procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
    procedure WMGetObject(var Message: TMessage); message $003D; //WM_GETOBJECT
    procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;
    procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
    procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
    procedure WMThemeChanged(var Message: TMessage); message WM_THEMECHANGED;
    procedure WMUpdateUIState(var Message: TMessage); message WM_UPDATEUISTATE;
  protected
    procedure CreateWnd; override;
    procedure MeasureItem(Index: Integer; var Height: Integer); override;
    procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
      override;
    function GetChecked(Index: Integer): Boolean;
    function GetItemEnabled(Index: Integer): Boolean;
    function GetLevel(Index: Integer): Byte;
    function GetObject(Index: Integer): TObject;
    function GetState(Index: Integer): TCheckBoxState;
    function GetSubItem(Index: Integer): string;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyUp(var Key: Word; Shift: TShiftState); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
      override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure UpdateHotIndex(NewHotIndex: Integer);
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure SetChecked(Index: Integer; const AChecked: Boolean);
    procedure SetFlat(Value: Boolean);
    procedure SetItemEnabled(Index: Integer; const AEnabled: Boolean);
    procedure SetObject(Index: Integer; const AObject: TObject);
    procedure SetOffset(AnOffset: Integer);
    procedure SetShowLines(Value: Boolean);
    procedure SetSubItem(Index: Integer; const ASubItem: String);
    property ItemStates[Index: Integer]: TItemState read GetItemState; 
  public
    constructor Create(AOwner: TComponent); override;
    procedure CreateWindowHandle(const Params: TCreateParams); override;
    destructor Destroy; override;
    function AddCheckBox(const ACaption, ASubItem: string; ALevel: Byte;
      AChecked, AEnabled, AHasInternalChildren, ACheckWhenParentChecked: Boolean;
      AObject: TObject): Integer;
    function AddGroup(const ACaption, ASubItem: string; ALevel: Byte;
      AObject: TObject): Integer;
    function AddRadioButton(const ACaption, ASubItem: string;
      ALevel: Byte; AChecked, AEnabled: Boolean; AObject: TObject): Integer;
    procedure EnumChildrenOf(Item: Integer; Proc: TEnumChildrenProc; Ext: Longint);
    function GetParentOf(Item: Integer): Integer;
    procedure UpdateThreads;
    property Checked[Index: Integer]: Boolean read GetChecked write SetChecked;
    property ItemEnabled[Index: Integer]: Boolean
      read GetItemEnabled write         SetItemEnabled;
    property ItemLevel[Index: Integer]: Byte read GetLevel;
    property ItemObject[Index: Integer]: TObject read GetObject write SetObject;
    property ItemSubItem[Index: Integer]: string read GetSubItem write SetSubItem;
    property State[Index: Integer]: TCheckBoxState read GetState;
  published
    property Align;
    property BorderStyle;
    property Color;
    property Ctl3D;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Flat: Boolean read FFlat write SetFlat default False;
    property Font;
    property IntegralHeight;
    property ItemHeight;
    property Items;
    property MinItemHeight: Integer read FMinItemHeight write FMinItemHeight default 16;
    property Offset: Integer read FOffset write SetOffset default 4;
    property OnClick;
    property OnClickCheck: TNotifyEvent read FOnClickCheck write FOnClickCheck;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDrag;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property ShowLines: Boolean read FShowLines write SetShowLines default True;
    property Sorted;
    property Style default lbOwnerDrawFixed;
    property TabOrder;
    property TabWidth;
    property Visible;
    property WantTabs: Boolean read FWantTabs write FWantTabs default False;
  end;

procedure Register;

implementation

uses
  TmSchemaISX, {$IFDEF DELPHI2} Ole2 {$ELSE} ActiveX {$ENDIF};

const
  sRadioCantHaveDisabledChildren = 'Radio item cannot have disabled child items';

  OBM_CHECKBOXES = 32759;
  WM_CHANGEUISTATE = $0127;
  WM_QUERYUISTATE = $0129;
  UIS_SET = 1;
  UIS_CLEAR = 2;
  UIS_INITIALIZE = 3;
  UISF_HIDEFOCUS = $1;
  UISF_HIDEACCEL = $2;
  DT_HIDEPREFIX = $00100000;

  OBJID_CLIENT = $FFFFFFFC;
  CHILDID_SELF = 0;
  ROLE_SYSTEM_OUTLINE = $23;
  ROLE_SYSTEM_STATICTEXT = $29;
  ROLE_SYSTEM_CHECKBUTTON = $2c;
  ROLE_SYSTEM_RADIOBUTTON = $2d;
  STATE_SYSTEM_UNAVAILABLE = $1;
  STATE_SYSTEM_CHECKED = $10;
  STATE_SYSTEM_MIXED = $20;
  EVENT_OBJECT_STATECHANGE = $800A;

  IID_IUnknown: TGUID = (
    D1:$00000000; D2:$0000; D3:$0000; D4:($C0,$00,$00,$00,$00,$00,$00,$46));
  IID_IDispatch: TGUID = (
    D1:$00020400; D2:$0000; D3:$0000; D4:($C0,$00,$00,$00,$00,$00,$00,$46));
  IID_IAccessible: TGUID = (
    D1:$618736e0; D2:$3c3d; D3:$11cf; D4:($81,$0c,$00,$aa,$00,$38,$9b,$71));

var
  CanQueryUIState: Boolean;

type
  TWinControlAccess = class (TWinControl);

{$IFNDEF DELPHI2}
  TNewCheckListBoxHintWindow = class (THintWindow)
  private
    procedure WMNCPaint(var Message: TMessage); message WM_NCPAINT;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
  public
    procedure ActivateHintData(Rect: TRect; const AHint: string; AData: Pointer);
      override;
    function CalcHintRect(MaxWidth: Integer; const AHint: string;
      AData: Pointer): TRect; override;
    function IsHintMsg(var Msg: TMsg): Boolean; override;
  end;
{$ENDIF}

  { Note: We have to use TVariantArg for Delphi 2 compat., because D2 passes
    Variant parameters by reference (wrong), unlike D3+ which pass
    Variant/OleVariant parameters by value }
  NewOleVariant = TVariantArg;
  NewWideString = Pointer;

  TIUnknown = class
  public
    function QueryInterface(const iid: TIID; var obj): HRESULT; virtual; stdcall; abstract;
    function AddRef: Longint; virtual; stdcall; abstract;
    function Release: Longint; virtual; stdcall; abstract;
  end;

  TIDispatch = class(TIUnknown)
  public
    function GetTypeInfoCount(var ctinfo: Integer): HRESULT; virtual; stdcall; abstract;
    function GetTypeInfo(itinfo: Integer; lcid: TLCID; var tinfo: ITypeInfo): HRESULT; virtual; stdcall; abstract;
    function GetIDsOfNames(const iid: TIID; rgszNames: POleStrList;
      cNames: Integer; lcid: TLCID; rgdispid: PDispIDList): HRESULT; virtual; stdcall; abstract;
    function Invoke(dispIDMember: TDispID; const iid: TIID; lcid: TLCID;
      flags: Word; var dispParams: TDispParams; varResult: PVariant;
      excepInfo: PExcepInfo; argErr: PInteger): HRESULT; virtual; stdcall; abstract;
  end;

  TIAccessible = class(TIDispatch)
  public
    function get_accParent(var ppdispParent: IDispatch): HRESULT; virtual; stdcall; abstract;
    function get_accChildCount(var pcountChildren: Integer): HRESULT; virtual; stdcall; abstract;
    function get_accChild(varChild: NewOleVariant; var ppdispChild: IDispatch): HRESULT; virtual; stdcall; abstract;
    function get_accName(varChild: NewOleVariant; var pszName: NewWideString): HRESULT; virtual; stdcall; abstract;
    function get_accValue(varChild: NewOleVariant; var pszValue: NewWideString): HRESULT; virtual; stdcall; abstract;
    function get_accDescription(varChild: NewOleVariant; var pszDescription: NewWideString): HRESULT; virtual; stdcall; abstract;
    function get_accRole(varChild: NewOleVariant; var pvarRole: NewOleVariant): HRESULT; virtual; stdcall; abstract;
    function get_accState(varChild: NewOleVariant; var pvarState: NewOleVariant): HRESULT; virtual; stdcall; abstract;
    function get_accHelp(varChild: NewOleVariant; var pszHelp: NewWideString): HRESULT; virtual; stdcall; abstract;
    function get_accHelpTopic(var pszHelpFile: NewWideString; varChild: NewOleVariant; var pidTopic: Integer): HRESULT; virtual; stdcall; abstract;
    function get_accKeyboardShortcut(varChild: NewOleVariant; var pszKeyboardShortcut: NewWideString): HRESULT; virtual; stdcall; abstract;
    function get_accFocus(var pvarID: NewOleVariant): HRESULT; virtual; stdcall; abstract;
    function get_accSelection(var pvarChildren: NewOleVariant): HRESULT; virtual; stdcall; abstract;
    function get_accDefaultAction(varChild: NewOleVariant; var pszDefaultAction: NewWideString): HRESULT; virtual; stdcall; abstract;
    function accSelect(flagsSelect: Integer; varChild: NewOleVariant): HRESULT; virtual; stdcall; abstract;
    function accLocation(var pxLeft: Integer; var pyTop: Integer; var pcxWidth: Integer;
      var pcyHeight: Integer; varChild: NewOleVariant): HRESULT; virtual; stdcall; abstract;
    function accNavigate(navDir: Integer; varStart: NewOleVariant; var pvarEnd: NewOleVariant): HRESULT; virtual; stdcall; abstract;
    function accHitTest(xLeft: Integer; yTop: Integer; var pvarID: NewOleVariant): HRESULT; virtual; stdcall; abstract;
    function accDoDefaultAction(varChild: NewOleVariant): HRESULT; virtual; stdcall; abstract;
    function put_accName(varChild: NewOleVariant; const pszName: NewWideString): HRESULT; virtual; stdcall; abstract;
    function put_accValue(varChild: NewOleVariant; const pszValue: NewWideString): HRESULT; virtual; stdcall; abstract;
  end;

  TAccObject = class(TIAccessible)
  private
    FControl: TNewCheckListBox;
    FRefCount: Integer;
    FStdAcc: TIAccessible;
    { TIUnknown }
    function QueryInterface(const iid: TIID; var obj): HRESULT; override;
    function AddRef: Longint; override;
    function Release: Longint; override;
    { TIDispatch }
    function GetTypeInfoCount(var ctinfo: Integer): HRESULT; override;
    function GetTypeInfo(itinfo: Integer; lcid: TLCID; var tinfo: ITypeInfo): HRESULT; override;
    function GetIDsOfNames(const iid: TIID; rgszNames: POleStrList;
      cNames: Integer; lcid: TLCID; rgdispid: PDispIDList): HRESULT; override;
    function Invoke(dispIDMember: TDispID; const iid: TIID; lcid: TLCID;
      flags: Word; var dispParams: TDispParams; varResult: PVariant;
      excepInfo: PExcepInfo; argErr: PInteger): HRESULT; override;
    { TIAccessible }
    function get_accParent(var ppdispParent: IDispatch): HRESULT; override;
    function get_accChildCount(var pcountChildren: Integer): HRESULT; override;
    function get_accChild(varChild: NewOleVariant; var ppdispChild: IDispatch): HRESULT; override;
    function get_accName(varChild: NewOleVariant; var pszName: NewWideString): HRESULT; override;
    function get_accValue(varChild: NewOleVariant; var pszValue: NewWideString): HRESULT; override;
    function get_accDescription(varChild: NewOleVariant; var pszDescription: NewWideString): HRESULT; override;
    function get_accRole(varChild: NewOleVariant; var pvarRole: NewOleVariant): HRESULT; override;
    function get_accState(varChild: NewOleVariant; var pvarState: NewOleVariant): HRESULT; override;
    function get_accHelp(varChild: NewOleVariant; var pszHelp: NewWideString): HRESULT; override;
    function get_accHelpTopic(var pszHelpFile: NewWideString; varChild: NewOleVariant; var pidTopic: Integer): HRESULT; override;
    function get_accKeyboardShortcut(varChild: NewOleVariant; var pszKeyboardShortcut: NewWideString): HRESULT; override;
    function get_accFocus(var pvarID: NewOleVariant): HRESULT; override;
    function get_accSelection(var pvarChildren: NewOleVariant): HRESULT; override;
    function get_accDefaultAction(varChild: NewOleVariant; var pszDefaultAction: NewWideString): HRESULT; override;
    function accSelect(flagsSelect: Integer; varChild: NewOleVariant): HRESULT; override;
    function accLocation(var pxLeft: Integer; var pyTop: Integer; var pcxWidth: Integer;
      var pcyHeight: Integer; varChild: NewOleVariant): HRESULT; override;
    function accNavigate(navDir: Integer; varStart: NewOleVariant; var pvarEnd: NewOleVariant): HRESULT; override;
    function accHitTest(xLeft: Integer; yTop: Integer; var pvarID: NewOleVariant): HRESULT; override;
    function accDoDefaultAction(varChild: NewOleVariant): HRESULT; override;
    function put_accName(varChild: NewOleVariant; const pszName: NewWideString): HRESULT; override;
    function put_accValue(varChild: NewOleVariant; const pszValue: NewWideString): HRESULT; override;
  public
    constructor Create(AControl: TNewCheckListBox);
    destructor Destroy; override;
    procedure ControlDestroying;
 end;

function CoDisconnectObject(unk: TIUnknown; dwReserved: DWORD): HRESULT;
  stdcall; external 'ole32.dll';

var
  NotifyWinEventFunc: procedure(event: DWORD; hwnd: HWND; idObject: DWORD;
    idChild: Longint); stdcall;
  OleAccInited: BOOL;
  OleAccAvailable: BOOL;
  LresultFromObjectFunc: function(const riid: TGUID; wParam: WPARAM;
    pUnk: TIUnknown): LRESULT; stdcall;
  CreateStdAccessibleObjectFunc: function(hwnd: HWND; idObject: Longint;
    const riidInterface: TGUID; var ppvObject: Pointer): HRESULT; stdcall;

function InitializeOleAcc: Boolean;
var
  M: HMODULE;
begin
  if not OleAccInited then begin
    M := LoadLibrary('oleacc.dll');
    if M <> 0 then begin
      LresultFromObjectFunc := GetProcAddress(M, 'LresultFromObject');
      CreateStdAccessibleObjectFunc := GetProcAddress(M, 'CreateStdAccessibleObject');
      if Assigned(LresultFromObjectFunc) and
         Assigned(CreateStdAccessibleObjectFunc) then
        OleAccAvailable := True;
    end;
    OleAccInited := True;
  end;
  Result := OleAccAvailable;