{----------------------------------------------------------------------------- The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL/MPL-1.1.html Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for the specific language governing rights and limitations under the License. The Original Code is: JvxCheckListBox.pas, released on 2003-10-19. The Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev Copyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev Copyright (c) 2001,2002 SGB Software All Rights Reserved. Contributor(s): Polaris Software Peter Thornqvist [peter3 at sourceforge dot net] Andreas Hausladen (XP theming) Changes: 2003-10-19: * Moved TJvxCustomListBox and TJvxCheckListBox from JvxCtrls to this unit 2004-10-07: * Changed by hofi TJvxCheckListBox procedure DrawCheck(R: TRect; AState: TCheckBoxState; Enabled: Boolean); now protected to support possible call from derived classes. You may retrieve the latest version of this file at the Project JEDI's JVCL home page, located at http://jvcl.sourceforge.net Known Issues: -----------------------------------------------------------------------------} // $Id: JvxCheckListBox.pas 10613 2006-05-19 19:21:43Z jfudickar $ unit JvxCheckListBox; {$I jvcl.inc} interface uses {$IFDEF UNITVERSIONING} JclUnitVersioning, {$ENDIF UNITVERSIONING} Windows, Messages, Classes, Controls, Graphics, StdCtrls, Forms, {$IFDEF HAS_UNIT_TYPES} Types, {$ENDIF HAS_UNIT_TYPES} {$IFDEF HAS_UNIT_RTLCONSTS} RTLConsts, {$ENDIF HAS_UNIT_RTLCONSTS} JvAppStorage, JvFormPlacement, JvComponent; type TGetItemWidthEvent = procedure(Control: TWinControl; Index: Integer; var Width: Integer) of object; TJvxCustomListBox = class(TJvWinControl) private FItems: TStrings; FBorderStyle: TBorderStyle; FCanvas: TControlCanvas; FColumns: Integer; FItemHeight: Integer; FStyle: TListBoxStyle; FIntegralHeight: Boolean; FMultiSelect: Boolean; FSorted: Boolean; FExtendedSelect: Boolean; FTabWidth: Integer; FSaveItems: TStringList; FSaveTopIndex: Integer; FSaveItemIndex: Integer; FAutoScroll: Boolean; FGraySelection: Boolean; FMaxItemWidth: Integer; FOnDrawItem: TDrawItemEvent; FOnMeasureItem: TMeasureItemEvent; FOnGetItemWidth: TGetItemWidthEvent; procedure ResetHorizontalExtent; procedure SetHorizontalExtent; function GetCanvas: TCanvas; function GetAutoScroll: Boolean; function GetItemHeight: Integer; virtual; function GetItemIndex: Integer; function GetSelCount: Integer; function GetSelected(Index: Integer): Boolean; function GetTopIndex: Integer; procedure SetAutoScroll(Value: Boolean); procedure SetBorderStyle(Value: TBorderStyle); procedure SetColumnWidth; procedure SetColumns(Value: Integer); procedure SetExtendedSelect(Value: Boolean); procedure SetIntegralHeight(Value: Boolean); procedure SetItemHeight(Value: Integer); 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 SetGraySelection(Value: Boolean); procedure SetOnDrawItem(Value: TDrawItemEvent); procedure SetOnGetItemWidth(Value: TGetItemWidthEvent); procedure WMPaint(var Msg: TWMPaint); message WM_PAINT; procedure CNCommand(var Msg: TWMCommand); message CN_COMMAND; procedure CNDrawItem(var Msg: TWMDrawItem); message CN_DRAWITEM; procedure CNMeasureItem(var Msg: TWMMeasureItem); message CN_MEASUREITEM; procedure WMLButtonDown(var Msg: TWMLButtonDown); message WM_LBUTTONDOWN; procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST; procedure CMCtl3DChanged(var Msg: TMessage); message CM_CTL3DCHANGED; protected procedure BoundsChanged; override; procedure FocusKilled(NextWnd: THandle); override; procedure FocusSet(PrevWnd: THandle); override; procedure CreateParams(var Params: TCreateParams); override; procedure CreateWnd; override; procedure DestroyWnd; override; function CreateItemList: TStrings; virtual; function GetItemWidth(Index: Integer): Integer; virtual; procedure WndProc(var Msg: TMessage); override; procedure DragCanceled; override; procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); virtual; procedure MeasureItem(Index: Integer; var Height: Integer); virtual; function GetItemData(Index: Integer): Longint; dynamic; procedure SetItemData(Index: Integer; AData: Longint); dynamic; function GetItems: TStrings; virtual; procedure SetItems(Value: TStrings); virtual; procedure ResetContent; dynamic; procedure DeleteString(Index: Integer); dynamic; property AutoScroll: Boolean read GetAutoScroll write SetAutoScroll default False; property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle; property Columns: Integer read FColumns write SetColumns default 0; property ExtendedSelect: Boolean read FExtendedSelect write SetExtendedSelect default True; property GraySelection: Boolean read FGraySelection write SetGraySelection default False; property IntegralHeight: Boolean read FIntegralHeight write SetIntegralHeight default False; property ItemHeight: Integer read GetItemHeight write SetItemHeight; property MultiSelect: Boolean read FMultiSelect write SetMultiSelect default False; property ParentColor default False; 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; property OnDrawItem: TDrawItemEvent read FOnDrawItem write SetOnDrawItem; property OnMeasureItem: TMeasureItemEvent read FOnMeasureItem write FOnMeasureItem; property OnGetItemWidth: TGetItemWidthEvent read FOnGetItemWidth write SetOnGetItemWidth; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Clear; procedure DefaultDrawText(X, Y: Integer; const S: string); function ItemAtPos(Pos: TPoint; Existing: Boolean): Integer; function ItemRect(Index: Integer): TRect; property Canvas: TCanvas read GetCanvas; property Items: TStrings read GetItems write SetItems; 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; end; TCheckKind = (ckCheckBoxes, ckRadioButtons, ckCheckMarks); TChangeStateEvent = procedure(Sender: TObject; Index: Integer) of object; TJvxCheckListBox = class(TJvxCustomListBox) private FAllowGrayed: Boolean; FCheckKind: TCheckKind; FSaveStates: TList; FDrawBitmap: TBitmap; FCheckWidth, FCheckHeight: Integer; FReserved: Integer; FInUpdateStates: Boolean; FIniLink: TJvIniLink; FOnClickCheck: TNotifyEvent; FOnStateChange: TChangeStateEvent; procedure ResetItemHeight; function GetItemHeight: Integer; override; procedure SetCheckKind(Value: TCheckKind); procedure SetChecked(Index: Integer; AChecked: Boolean); function GetChecked(Index: Integer): Boolean; procedure SetState(Index: Integer; AState: TCheckBoxState); function GetState(Index: Integer): TCheckBoxState; procedure SetItemEnabled(Index: Integer; Value: Boolean); function GetItemEnabled(Index: Integer): Boolean; function GetAllowGrayed: Boolean; procedure ToggleClickCheck(Index: Integer); procedure InvalidateCheck(Index: Integer); procedure InvalidateItem(Index: Integer); function CreateCheckObject(Index: Integer): TObject; function FindCheckObject(Index: Integer): TObject; function GetCheckObject(Index: Integer): TObject; function IsCheckObject(Index: Integer): Boolean; procedure ReadVersion(Reader: TReader); procedure WriteVersion(Writer: TWriter); procedure ReadCheckData(Reader: TReader); procedure WriteCheckData(Writer: TWriter); function GetStorage: TJvFormPlacement; procedure SetStorage(Value: TJvFormPlacement); procedure IniSave(Sender: TObject); procedure IniLoad(Sender: TObject); procedure UpdateCheckStates; function GetCheckedIndex: Integer; procedure SetCheckedIndex(Value: Integer); procedure CNDrawItem(var Msg: TWMDrawItem); message CN_DRAWITEM; protected procedure FontChanged; override; function CreateItemList: TStrings; override; procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override; procedure DefineProperties(Filer: TFiler); override; function GetItemWidth(Index: Integer): Integer; override; function GetItemData(Index: Integer): Longint; override; procedure SetItemData(Index: Integer; AData: Longint); override; procedure KeyPress(var Key: Char); override; procedure Loaded; override; procedure DrawCheck(R: TRect; AState: TCheckBoxState; Enabled: Boolean); procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure ResetContent; override; procedure DeleteString(Index: Integer); override; procedure ClickCheck; dynamic; procedure ChangeItemState(Index: Integer); dynamic; procedure CreateParams(var Params: TCreateParams); override; procedure CreateWnd; override; procedure DestroyWnd; override; procedure WMDestroy(var Msg: TWMDestroy); message WM_DESTROY; function GetCheckWidth: Integer; procedure SetItems(Value: TStrings); override; procedure InternalLoad(const Section: string); procedure InternalSave(const Section: string); public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure LoadFromAppStorage(const AppStorage: TJvCustomAppStorage; const Path: string); procedure SaveToAppStorage(const AppStorage: TJvCustomAppStorage; const Path: string); procedure Load; procedure Save; procedure ApplyState(AState: TCheckBoxState; EnabledOnly: Boolean); property Checked[Index: Integer]: Boolean read GetChecked write SetChecked; property State[Index: Integer]: TCheckBoxState read GetState write SetState; property EnabledItem[Index: Integer]: Boolean read GetItemEnabled write SetItemEnabled; published property AllowGrayed: Boolean read GetAllowGrayed write FAllowGrayed default False; property CheckKind: TCheckKind read FCheckKind write SetCheckKind default ckCheckBoxes; property CheckedIndex: Integer read GetCheckedIndex write SetCheckedIndex default -1; property IniStorage: TJvFormPlacement read GetStorage write SetStorage; property Align; property AutoScroll default True; property BorderStyle; property Color; property Columns; property DragCursor; property DragMode; property Enabled; property ExtendedSelect; property Font; property GraySelection; property Anchors; property BiDiMode; property Constraints; property DragKind; property ParentBiDiMode; property ImeMode; property ImeName; property IntegralHeight; property ItemHeight; property Items stored False; property MultiSelect; property ParentColor; property ParentFont; property ParentShowHint; property PopupMenu; property ShowHint; property Sorted; property Style; property TabOrder; property TabStop default True; property TabWidth; property Visible; property OnStateChange: TChangeStateEvent read FOnStateChange write FOnStateChange; property OnClickCheck: TNotifyEvent read FOnClickCheck write FOnClickCheck; property OnClick; property OnDblClick; property OnDragDrop; property OnDragOver; property OnDrawItem; property OnEndDrag; property OnEnter; property OnExit; property OnGetItemWidth; property OnKeyDown; property OnKeyPress; property OnKeyUp; property OnMeasureItem; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnStartDrag; property OnContextPopup; property OnMouseWheelDown; property OnMouseWheelUp; property OnEndDock; property OnStartDock; end; const clbDefaultState = cbUnchecked; clbDefaultEnabled = True; function CheckBitmap: TBitmap; {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/tags/JVCL3_32/run/JvxCheckListBox.pas $'; Revision: '$Revision: 10613 $'; Date: '$Date: 2006-05-19 21:21:43 +0200 (ven., 19 mai 2006) $'; LogPath: 'JVCL\run' ); {$ENDIF UNITVERSIONING} implementation {$R JvxCheckListBox.res} uses {$IFDEF CLR} Borland.Vcl.WinUtils, {$ENDIF CLR} SysUtils, Consts, Math, JvConsts, JvJVCLUtils, JvThemes; //=== { TJvListBoxStrings } ================================================== type TJvListBoxStrings = class(TStrings) private ListBox: TJvxCustomListBox; protected 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; public function Add(const S: string): Integer; override; procedure Clear; override; procedure Delete(Index: Integer); override; procedure Insert(Index: Integer; const S: string); override; end; function TJvListBoxStrings.GetCount: Integer; begin Result := SendMessage(ListBox.Handle, LB_GETCOUNT, 0, 0); end; function TJvListBoxStrings.Get(Index: Integer): string; var Len: Integer; {$IFNDEF CLR} Text: array [0..4095] of Char; {$ENDIF !CLR} begin {$IFDEF CLR} Len := SendGetTextMessage(ListBox.Handle, LB_GETTEXT, Index, Result, 4096); if Len < 0 then Error(SListIndexError, Index); {$ELSE} Len := SendMessage(ListBox.Handle, LB_GETTEXT, Index, LPARAM(@Text)); if Len < 0 then Error(SListIndexError, Index); SetString(Result, Text, Len); {$ENDIF CLR} end; function TJvListBoxStrings.GetObject(Index: Integer): TObject; begin Result := TObject(ListBox.GetItemData(Index)); if Longint(Result) = LB_ERR then Error(SListIndexError, Index); end; procedure TJvListBoxStrings.PutObject(Index: Integer; AObject: TObject); begin ListBox.SetItemData(Index, Longint(AObject)); end; function TJvListBoxStrings.Add(const S: string): Integer; begin {$IFDEF CLR} Result := SendTextMessage(ListBox.Handle, LB_ADDSTRING, 0, S); {$ELSE} Result := SendMessage(ListBox.Handle, LB_ADDSTRING, 0, LPARAM(PChar(S))); {$ENDIF CLR} if Result < 0 then {$IFDEF CLR} raise EOutOfResources.Create(SInsertLineError); {$ELSE} raise EOutOfResources.CreateRes(@SInsertLineError); {$ENDIF CLR} end; procedure TJvListBoxStrings.Insert(Index: Integer; const S: string); begin {$IFDEF CLR} if SendTextMessage(ListBox.Handle, LB_INSERTSTRING, Index, S) < 0 then raise EOutOfResources.Create(SInsertLineError); {$ELSE} if SendMessage(ListBox.Handle, LB_INSERTSTRING, Index, LPARAM(PChar(S))) < 0 then raise EOutOfResources.CreateRes(@SInsertLineError); {$ENDIF CLR} end; procedure TJvListBoxStrings.Delete(Index: Integer); begin ListBox.DeleteString(Index); end; procedure TJvListBoxStrings.Clear; begin ListBox.ResetContent; end; procedure TJvListBoxStrings.SetUpdateState(Updating: Boolean); begin SendMessage(ListBox.Handle, WM_SETREDRAW, Ord(not Updating), 0); if not Updating then ListBox.Refresh; end; //=== { TJvxCustomListBox } ================================================== { TJvxCustomListBox implementation copied from STDCTRLS.PAS and modified } {$IFDEF CLR} procedure ListIndexError(Index: Integer); begin raise EStringListError.CreateFmt(SListIndexError, [Index]); end; {$ELSE} procedure ListIndexError(Index: Integer); function ReturnAddr: Pointer; asm MOV EAX,[EBP+4] end; begin raise EStringListError.CreateResFmt(@SListIndexError, [Index]) at ReturnAddr; end; {$ENDIF CLR} constructor TJvxCustomListBox.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 := CreateItemList; TJvListBoxStrings(FItems).ListBox := Self; FCanvas := TControlCanvas.Create; FCanvas.Control := Self; FItemHeight := 16; FBorderStyle := bsSingle; FExtendedSelect := True; end; destructor TJvxCustomListBox.Destroy; begin // (ahuser) moved inherited to the top otherwise it will raise an AV in csDesigning inherited Destroy; FCanvas.Free; FItems.Free; FSaveItems.Free; end; function TJvxCustomListBox.CreateItemList: TStrings; begin Result := TJvListBoxStrings.Create; end; function TJvxCustomListBox.GetCanvas: TCanvas; begin Result := FCanvas; end; function TJvxCustomListBox.GetItemData(Index: Integer): Longint; begin Result := SendMessage(Handle, LB_GETITEMDATA, Index, 0); end; procedure TJvxCustomListBox.SetItemData(Index: Integer; AData: Longint); begin SendMessage(Handle, LB_SETITEMDATA, Index, AData); end; procedure TJvxCustomListBox.DeleteString(Index: Integer); begin SendMessage(Handle, LB_DELETESTRING, Index, 0); end; procedure TJvxCustomListBox.SetHorizontalExtent; begin SendMessage(Handle, LB_SETHORIZONTALEXTENT, FMaxItemWidth, 0); end; function TJvxCustomListBox.GetItemWidth(Index: Integer): Integer; var ATabWidth: array [0..0] of Integer; S: string; begin Result := 0; if csDestroying in ComponentState then Exit; if (Style <> lbStandard) and Assigned(FOnGetItemWidth) and Assigned(FOnDrawItem) then FOnGetItemWidth(Self, Index, Result) else begin S := Items[Index] + 'x'; if TabWidth > 0 then begin {if (FTabChar > #0) then for I := 1 to Length(S) do if S[I] = FTabChar then S[I] := #9;} ATabWidth[0] := Round((TabWidth * FCanvas.TextWidth('0')) * 0.25); Result := {$IFDEF CLR} LoWord(GetTabbedTextExtent(FCanvas.Handle, S, Length(S), 1, ATabWidth)); {$ELSE} LoWord(GetTabbedTextExtent(FCanvas.Handle, PChar(S), Length(S), 1, ATabWidth)); {$ENDIF CLR} end else Result := FCanvas.TextWidth(S); end; end; procedure TJvxCustomListBox.ResetHorizontalExtent; var I: Integer; begin FMaxItemWidth := 0; for I := 0 to Items.Count - 1 do FMaxItemWidth := Max(FMaxItemWidth, GetItemWidth(I)); SetHorizontalExtent; end; procedure TJvxCustomListBox.ResetContent; begin SendMessage(Handle, LB_RESETCONTENT, 0, 0); end; procedure TJvxCustomListBox.Clear; begin FItems.Clear; end; procedure TJvxCustomListBox.SetColumnWidth; begin if FColumns > 0 then SendMessage(Handle, LB_SETCOLUMNWIDTH, (Width + FColumns - 3) div FColumns, 0); end; procedure TJvxCustomListBox.SetColumns(Value: Integer); begin if FColumns <> Value then if (FColumns = 0) or (Value = 0) then begin FColumns := Value; RecreateWnd; end else begin FColumns := Value; if HandleAllocated then SetColumnWidth; end; end; function TJvxCustomListBox.GetItemIndex: Integer; begin Result := SendMessage(Handle, LB_GETCURSEL, 0, 0); end; function TJvxCustomListBox.GetSelCount: Integer; begin Result := SendMessage(Handle, LB_GETSELCOUNT, 0, 0); end; procedure TJvxCustomListBox.SetItemIndex(Value: Integer); begin if GetItemIndex <> Value then SendMessage(Handle, LB_SETCURSEL, Value, 0); end; procedure TJvxCustomListBox.SetExtendedSelect(Value: Boolean); begin if Value <> FExtendedSelect then begin FExtendedSelect := Value; RecreateWnd; end; end; procedure TJvxCustomListBox.SetIntegralHeight(Value: Boolean); begin if Value <> FIntegralHeight then begin FIntegralHeight := Value; RecreateWnd; end; end; function TJvxCustomListBox.GetAutoScroll: Boolean; begin Result := FAutoScroll and (Columns = 0); end; procedure TJvxCustomListBox.SetOnDrawItem(Value: TDrawItemEvent); begin if Assigned(FOnDrawItem) <> Assigned(Value) then begin FOnDrawItem := Value; Perform(WM_HSCROLL, SB_TOP, 0); if HandleAllocated then if AutoScroll then ResetHorizontalExtent else SendMessage(Handle, LB_SETHORIZONTALEXTENT, 0, 0); end else FOnDrawItem := Value; end; procedure TJvxCustomListBox.SetOnGetItemWidth(Value: TGetItemWidthEvent); begin if Assigned(FOnGetItemWidth) <> Assigned(Value) then begin FOnGetItemWidth := Value; Perform(WM_HSCROLL, SB_TOP, 0); if HandleAllocated then if AutoScroll then ResetHorizontalExtent else SendMessage(Handle, LB_SETHORIZONTALEXTENT, 0, 0); end else FOnGetItemWidth := Value; end; procedure TJvxCustomListBox.SetAutoScroll(Value: Boolean); begin if AutoScroll <> Value then begin FAutoScroll := Value; Perform(WM_HSCROLL, SB_TOP, 0); if HandleAllocated then if AutoScroll then ResetHorizontalExtent else SendMessage(Handle, LB_SETHORIZONTALEXTENT, 0, 0); end; end; function TJvxCustomListBox.GetItemHeight: Integer; var R: TRect; begin Result := FItemHeight; if HandleAllocated and (FStyle = lbStandard) then begin {$IFDEF CLR} Perform(LB_GETITEMRECT, 0, R); {$ELSE} Perform(LB_GETITEMRECT, 0, Longint(@R)); {$ENDIF CLR} Result := R.Bottom - R.Top; end; end; procedure TJvxCustomListBox.SetItemHeight(Value: Integer); begin if (FItemHeight <> Value) and (Value > 0) then begin FItemHeight := Value; RecreateWnd; end; end; procedure TJvxCustomListBox.SetTabWidth(Value: Integer); begin if Value < 0 then Value := 0; if FTabWidth <> Value then begin FTabWidth := Value; RecreateWnd; end; end; procedure TJvxCustomListBox.SetMultiSelect(Value: Boolean); begin if FMultiSelect <> Value then begin FMultiSelect := Value; RecreateWnd; end; end; function TJvxCustomListBox.GetSelected(Index: Integer): Boolean; var R: Longint; begin R := SendMessage(Handle, LB_GETSEL, Index, 0); if R = LB_ERR then ListIndexError(Index); Result := LongBool(R); end; procedure TJvxCustomListBox.SetSelected(Index: Integer; Value: Boolean); begin if MultiSelect then begin if SendMessage(Handle, LB_SETSEL, Ord(Value), Index) = LB_ERR then ListIndexError(Index); end else begin if Value then SetItemIndex(Index) else if ItemIndex = Index then SetItemIndex(-1); end; end; procedure TJvxCustomListBox.SetSorted(Value: Boolean); begin if FSorted <> Value then begin FSorted := Value; RecreateWnd; end; end; procedure TJvxCustomListBox.SetStyle(Value: TListBoxStyle); begin if FStyle <> Value then begin FStyle := Value; RecreateWnd; end; end; function TJvxCustomListBox.GetTopIndex: Integer; begin Result := SendMessage(Handle, LB_GETTOPINDEX, 0, 0); end; procedure TJvxCustomListBox.SetBorderStyle(Value: TBorderStyle); begin if FBorderStyle <> Value then begin FBorderStyle := Value; RecreateWnd; end; end; procedure TJvxCustomListBox.SetTopIndex(Value: Integer); begin if GetTopIndex <> Value then SendMessage(Handle, LB_SETTOPINDEX, Value, 0); end; procedure TJvxCustomListBox.SetGraySelection(Value: Boolean); begin if FGraySelection <> Value then begin FGraySelection := Value; if not Focused then Invalidate; end; end; function TJvxCustomListBox.GetItems: TStrings; begin Result := FItems; end; procedure TJvxCustomListBox.SetItems(Value: TStrings); begin Items.Assign(Value); end; function TJvxCustomListBox.ItemAtPos(Pos: TPoint; Existing: Boolean): Integer; var Count: Integer; ItemRect: TRect; begin if PtInRect(ClientRect, Pos) then begin Result := TopIndex; Count := Items.Count; while Result < Count do begin {$IFDEF CLR} Perform(LB_GETITEMRECT, Result, ItemRect); {$ELSE} Perform(LB_GETITEMRECT, Result, Longint(@ItemRect)); {$ENDIF CLR} if PtInRect(ItemRect, Pos) then Exit; Inc(Result); end; if not Existing then Exit; end; Result := -1; end; function TJvxCustomListBox.ItemRect(Index: Integer): TRect; var Count: Integer; begin Count := Items.Count; if (Index = 0) or (Index < Count) then {$IFDEF CLR} Perform(LB_GETITEMRECT, Index, Result) {$ELSE} Perform(LB_GETITEMRECT, Index, Longint(@Result)) {$ENDIF CLR} else if Index = Count then begin {$IFDEF CLR} Perform(LB_GETITEMRECT, Index - 1, Result); {$ELSE} Perform(LB_GETITEMRECT, Index - 1, Longint(@Result)); {$ENDIF CLR} OffsetRect(Result, 0, Result.Bottom - Result.Top); end else Result := Rect(0, 0, 0, 0); end; procedure TJvxCustomListBox.CreateParams(var Params: TCreateParams); type {$IFNDEF CLR} PSelects = ^TSelects; {$ENDIF !CLR} TSelects = array [Boolean] of Longword; const BorderStyles: array [TBorderStyle] of Longword = (0, WS_BORDER); Styles: array [TListBoxStyle] of Longword = (0, LBS_OWNERDRAWFIXED, LBS_OWNERDRAWVARIABLE {$IFDEF COMPILER6_UP}, LBS_OWNERDRAWFIXED, LBS_OWNERDRAWFIXED {$ENDIF}); Sorteds: TSelects = (0, LBS_SORT); MultiSelects: TSelects = (0, LBS_MULTIPLESEL); ExtendSelects: TSelects = (0, LBS_EXTENDEDSEL); IntegralHeights: TSelects = (LBS_NOINTEGRALHEIGHT, 0); MultiColumns: TSelects = (0, LBS_MULTICOLUMN); TabStops: TSelects = (0, LBS_USETABSTOPS); var {$IFDEF CLR} Selects: TSelects; {$ELSE} Selects: PSelects; {$ENDIF CLR} begin inherited CreateParams(Params); CreateSubClass(Params, 'LISTBOX'); with Params do begin Selects := {$IFNDEF CLR}@{$ENDIF} MultiSelects; if FExtendedSelect then Selects := {$IFNDEF CLR}@{$ENDIF} 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 (CS_HREDRAW or CS_VREDRAW); end; end; procedure TJvxCustomListBox.CreateWnd; var W, H: Integer; {$IFDEF CLR} Buf: record TabWidth: Integer; end; {$ENDIF CLR} begin W := Width; H := Height; inherited CreateWnd; SetWindowPos(Handle, 0, Left, Top, W, H, SWP_NOZORDER or SWP_NOACTIVATE); if FTabWidth <> 0 then begin {$IFDEF CLR} Buf.TabWidth := FTabWidth; SendGetStructMessage(Handle, LB_SETTABSTOPS, 1, Buf); FTabWidth := Buf.TabWidth; {$ELSE} SendMessage(Handle, LB_SETTABSTOPS, 1, LPARAM(@FTabWidth)); {$ENDIF CLR} end; SetColumnWidth; if FSaveItems <> nil then begin FItems.Assign(FSaveItems); SetTopIndex(FSaveTopIndex); SetItemIndex(FSaveItemIndex); FSaveItems.Free; FSaveItems := nil; end; end; procedure TJvxCustomListBox.DestroyWnd; begin if FItems.Count > 0 then begin FSaveItems := TStringList.Create; FSaveItems.Assign(FItems); FSaveTopIndex := GetTopIndex; FSaveItemIndex := GetItemIndex; end; inherited DestroyWnd; end; procedure TJvxCustomListBox.WndProc(var Msg: TMessage); {$IFDEF CLR} var MouseMsg: TWMMouse; {$ENDIF CLR} begin if AutoScroll then begin case Msg.Msg of LB_ADDSTRING, LB_INSERTSTRING: begin inherited WndProc(Msg); FMaxItemWidth := Max(FMaxItemWidth, GetItemWidth(Msg.Result)); SetHorizontalExtent; Exit; end; LB_DELETESTRING: begin if GetItemWidth(Msg.WParam) >= FMaxItemWidth then begin Perform(WM_HSCROLL, SB_TOP, 0); inherited WndProc(Msg); ResetHorizontalExtent; end else inherited WndProc(Msg); Exit; end; LB_RESETCONTENT: begin FMaxItemWidth := 0; SetHorizontalExtent; Perform(WM_HSCROLL, SB_TOP, 0); inherited WndProc(Msg); Exit; end; WM_SETFONT: begin inherited WndProc(Msg); if not (csDestroying in ComponentState) then begin FCanvas.Font.Assign(Self.Font); ResetHorizontalExtent; end; Exit; end; end; end; {for auto drag mode, let listbox handle itself, instead of TControl} if not (csDesigning in ComponentState) and ((Msg.Msg = WM_LBUTTONDOWN) or (Msg.Msg = WM_LBUTTONDBLCLK)) and not Dragging then begin if DragMode = dmAutomatic then begin {$IFDEF CLR} MouseMsg := TWMMouse.Create(Msg); if IsControlMouseMsg(MouseMsg) then Exit; {$ELSE} if IsControlMouseMsg(TWMMouse(Msg)) then Exit; {$ENDIF CLR} ControlState := ControlState + [csLButtonDown]; Dispatch(Msg); {overrides TControl's BeginDrag} Exit; end; end; inherited WndProc(Msg); end; procedure TJvxCustomListBox.WMLButtonDown(var Msg: TWMLButtonDown); var ItemNo: Integer; ShiftState: TShiftState; begin ShiftState := KeysToShiftState(Msg.Keys); if (DragMode = dmAutomatic) and FMultiSelect then begin if not (ssShift in ShiftState) or (ssCtrl in ShiftState) then begin ItemNo := ItemAtPos(SmallPointToPoint(Msg.Pos), True); if (ItemNo >= 0) and Selected[ItemNo] then begin BeginDrag(False); Exit; end; end; end; inherited; if (DragMode = dmAutomatic) and not (FMultiSelect and ((ssCtrl in ShiftState) or (ssShift in ShiftState))) then BeginDrag(False); end; procedure TJvxCustomListBox.WMNCHitTest(var Msg: TWMNCHitTest); begin if csDesigning in ComponentState then DefaultHandler(Msg) else inherited; end; procedure TJvxCustomListBox.CNCommand(var Msg: TWMCommand); begin case Msg.NotifyCode of LBN_SELCHANGE: begin inherited Changed; Click; end; LBN_DBLCLK: DblClick; end; end; procedure TJvxCustomListBox.WMPaint(var Msg: TWMPaint); procedure PaintListBox; var DrawItemMsg: TWMDrawItem; MeasureItemMsg: TWMMeasureItem; DrawItemStruct: TDrawItemStruct; MeasureItemStruct: TMeasureItemStruct; R: TRect; Y, I, H, W: Integer; begin { Initialize drawing records } DrawItemMsg.Msg := CN_DRAWITEM; DrawItemMsg.DrawItemStruct := {$IFNDEF CLR}@{$ENDIF} DrawItemStruct; DrawItemMsg.Ctl := Handle; DrawItemStruct.CtlType := ODT_LISTBOX; DrawItemStruct.itemAction := ODA_DRAWENTIRE; DrawItemStruct.itemState := 0; DrawItemStruct.HDC := Msg.DC; DrawItemStruct.CtlID := Handle; DrawItemStruct.hwndItem := Handle; { Intialize measure records } MeasureItemMsg.Msg := CN_MEASUREITEM; MeasureItemMsg.IDCtl := Handle; MeasureItemMsg.MeasureItemStruct := {$IFNDEF CLR}@{$ENDIF}MeasureItemStruct; MeasureItemStruct.CtlType := ODT_LISTBOX; MeasureItemStruct.CtlID := Handle; { Draw the listbox } Y := 0; I := TopIndex; GetClipBox(Msg.DC, R); H := Height; W := Width; while Y < H do begin MeasureItemStruct.itemID := I; if I < Items.Count then MeasureItemStruct.itemData := Longint(Items.Objects[I]); MeasureItemStruct.itemWidth := W; MeasureItemStruct.itemHeight := FItemHeight; DrawItemStruct.itemData := MeasureItemStruct.itemData; DrawItemStruct.itemID := I; Dispatch(MeasureItemMsg); DrawItemStruct.rcItem := Rect(0, Y, MeasureItemStruct.itemWidth, Y + Integer(MeasureItemStruct.itemHeight)); Dispatch(DrawItemMsg); Inc(Y, MeasureItemStruct.itemHeight); Inc(I); if I >= Items.Count then Break; end; end; begin if Msg.DC <> 0 then PaintListBox else inherited; end; procedure TJvxCustomListBox.BoundsChanged; begin inherited BoundsChanged; SetColumnWidth; end; procedure TJvxCustomListBox.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 TJvxCustomListBox.DefaultDrawText(X, Y: Integer; const S: string); var ATabWidth: array [0..0] of Longint; begin if csDestroying in ComponentState then Exit; FCanvas.UpdateTextFlags; if FTabWidth = 0 then FCanvas.TextOut(X, Y, S) else begin ATabWidth[0] := Round((TabWidth * FCanvas.TextWidth('0')) * 0.25); {$IFDEF CLR} TabbedTextOut(FCanvas.Handle, X, Y, S, Length(S), 1, ATabWidth, X); {$ELSE} TabbedTextOut(FCanvas.Handle, X, Y, PChar(S), Length(S), 1, ATabWidth, X); {$ENDIF CLR} end; end; procedure TJvxCustomListBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); begin if csDestroying in ComponentState then Exit; if Assigned(FOnDrawItem) then FOnDrawItem(Self, Index, Rect, State) else begin FCanvas.FillRect(Rect); if Index < Items.Count then begin if not UseRightToLeftAlignment then Inc(Rect.Left, 2) else Dec(Rect.Right, 2); DefaultDrawText(Rect.Left, Max(Rect.Top, (Rect.Bottom + Rect.Top - CanvasMaxTextHeight(FCanvas)) div 2), Items[Index]); end; end; end; procedure TJvxCustomListBox.MeasureItem(Index: Integer; var Height: Integer); begin if Assigned(FOnMeasureItem) then FOnMeasureItem(Self, Index, Height); end; procedure TJvxCustomListBox.CNDrawItem(var Msg: TWMDrawItem); var State: TOwnerDrawState; begin if csDestroying in ComponentState then Exit; with Msg.DrawItemStruct{$IFNDEF CLR}^{$ENDIF} do begin State := TOwnerDrawState(LoWord(itemState)); FCanvas.Handle := HDC; FCanvas.Font := Font; FCanvas.Brush := Brush; if (Integer(itemID) >= 0) and (odSelected in State) then begin with FCanvas do if not (csDesigning in ComponentState) and FGraySelection and not Focused then begin Brush.Color := clBtnFace; if ColorToRGB(Font.Color) = ColorToRGB(clBtnFace) then Font.Color := clBtnText; end else begin Brush.Color := clHighlight; Font.Color := clHighlightText end; end; if Integer(itemID) >= 0 then DrawItem(itemID, rcItem, State) else FCanvas.FillRect(rcItem); if odFocused in State then DrawFocusRect(HDC, rcItem); FCanvas.Handle := 0; end; end; procedure TJvxCustomListBox.CNMeasureItem(var Msg: TWMMeasureItem); var LItemHeight: Integer; {$IFDEF CLR} MeasureItemStruct: TMeasureItemStruct; {$ENDIF CLR} begin {$IFDEF CLR} MeasureItemStruct := Msg.MeasureItemStruct; with MeasureItemStruct do {$ELSE} with Msg.MeasureItemStruct^ do {$ENDIF CLR} begin LItemHeight := FItemHeight; if FStyle = lbOwnerDrawVariable then MeasureItem(itemID, LItemHeight); itemHeight := UINT(LItemHeight); end; {$IFDEF CLR} Msg.MeasureItemStruct := MeasureItemStruct; {$ENDIF CLR} end; procedure TJvxCustomListBox.FocusKilled(NextWnd: THandle); begin inherited FocusKilled(NextWnd); if FGraySelection and MultiSelect and (SelCount > 1) then Invalidate; end; procedure TJvxCustomListBox.FocusSet(PrevWnd: THandle); begin inherited FocusSet(PrevWnd); if FGraySelection and MultiSelect and (SelCount > 1) then Invalidate; end; procedure TJvxCustomListBox.CMCtl3DChanged(var Msg: TMessage); begin if NewStyleControls and (FBorderStyle = bsSingle) then RecreateWnd; inherited; end; //=== { TJvCheckListBoxItem } ================================================ type TJvCheckListBoxItem = class(TObject) private FData: Longint; FState: TCheckBoxState; FEnabled: Boolean; function GetChecked: Boolean; public constructor Create; property Checked: Boolean read GetChecked; property Enabled: Boolean read FEnabled write FEnabled; property State: TCheckBoxState read FState write FState; end; constructor TJvCheckListBoxItem.Create; begin inherited Create; FState := clbDefaultState; FEnabled := clbDefaultEnabled; end; function TJvCheckListBoxItem.GetChecked: Boolean; begin Result := FState = cbChecked; end; //=== { TJvCheckListBoxStrings } ============================================= type TJvCheckListBoxStrings = class(TJvListBoxStrings) public procedure Exchange(Index1, Index2: Integer); override; procedure Move(CurIndex, NewIndex: Integer); override; end; procedure TJvCheckListBoxStrings.Exchange(Index1, Index2: Integer); var TempEnabled1, TempEnabled2: Boolean; TempState1, TempState2: TCheckBoxState; begin with TJvxCheckListBox(ListBox) do begin TempState1 := State[Index1]; TempEnabled1 := EnabledItem[Index1]; TempState2 := State[Index2]; TempEnabled2 := EnabledItem[Index2]; inherited Exchange(Index1, Index2); State[Index1] := TempState2; EnabledItem[Index1] := TempEnabled2; State[Index2] := TempState1; EnabledItem[Index2] := TempEnabled1; end; end; procedure TJvCheckListBoxStrings.Move(CurIndex, NewIndex: Integer); var TempEnabled: Boolean; TempState: TCheckBoxState; begin with TJvxCheckListBox(ListBox) do begin TempState := State[CurIndex]; TempEnabled := EnabledItem[CurIndex]; inherited Move(CurIndex, NewIndex); State[NewIndex] := TempState; EnabledItem[NewIndex] := TempEnabled; end; end; //=== { TJvxCheckListBox } =================================================== // (rom) changed to var var GCheckBitmap: TBitmap = nil; function CheckBitmap: TBitmap; begin if GCheckBitmap = nil then begin GCheckBitmap := TBitmap.Create; GCheckBitmap.Handle := LoadBitmap(HInstance, 'JvxCheckListBoxIMAGES'); end; Result := GCheckBitmap; end; const InternalVersion = 202; { for backward compatibility only } constructor TJvxCheckListBox.Create(AOwner: TComponent); begin inherited Create(AOwner); FAutoScroll := True; with CheckBitmap do begin FCheckWidth := Width div 6; FCheckHeight := Height div 3; end; FDrawBitmap := TBitmap.Create; with FDrawBitmap do begin Width := FCheckWidth; Height := FCheckHeight; end; FIniLink := TJvIniLink.Create; FIniLink.OnSave := IniSave; FIniLink.OnLoad := IniLoad; end; destructor TJvxCheckListBox.Destroy; begin FSaveStates.Free; FSaveStates := nil; FDrawBitmap.Free; FDrawBitmap := nil; FIniLink.Free; inherited Destroy; end; procedure TJvxCheckListBox.Loaded; begin inherited Loaded; UpdateCheckStates; end; function TJvxCheckListBox.CreateItemList: TStrings; begin Result := TJvCheckListBoxStrings.Create; end; const sCount = 'Count'; sItem = 'Item'; procedure TJvxCheckListBox.LoadFromAppStorage(const AppStorage: TJvCustomAppStorage; const Path: string); var I: Integer; ACount: Integer; begin ACount := Min(AppStorage.ReadInteger(AppStorage.ConcatPaths([Path, sCount]), 0), Items.Count); for I := 0 to ACount - 1 do begin State[I] := TCheckBoxState(AppStorage.ReadInteger(AppStorage.ConcatPaths([Path, sItem + IntToStr(I)]), Integer(clbDefaultState))); if (State[I] = cbChecked) and (FCheckKind = ckRadioButtons) then Exit; end; end; procedure TJvxCheckListBox.SaveToAppStorage(const AppStorage: TJvCustomAppStorage; const Path: string); var I: Integer; begin AppStorage.DeleteSubTree(Path); AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, sCount]), Items.Count); for I := 0 to Items.Count - 1 do AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, sItem + IntToStr(I)]), Ord(State[I])); end; procedure TJvxCheckListBox.Load; begin IniLoad(nil); end; procedure TJvxCheckListBox.Save; begin IniSave(nil); end; function TJvxCheckListBox.GetStorage: TJvFormPlacement; begin Result := FIniLink.Storage; end; procedure TJvxCheckListBox.SetStorage(Value: TJvFormPlacement); begin FIniLink.Storage := Value; end; procedure TJvxCheckListBox.IniSave(Sender: TObject); begin if (Name <> '') and Assigned(IniStorage) then InternalSave(GetDefaultSection(Self)); end; procedure TJvxCheckListBox.IniLoad(Sender: TObject); begin if (Name <> '') and Assigned(IniStorage) then InternalLoad(GetDefaultSection(Self)); end; procedure TJvxCheckListBox.ReadCheckData(Reader: TReader); var I: Integer; begin Items.BeginUpdate; try Reader.ReadListBegin; Clear; while not Reader.EndOfList do begin I := Items.Add(Reader.ReadString); if FReserved >= InternalVersion then begin State[I] := TCheckBoxState(Reader.ReadInteger); EnabledItem[I] := Reader.ReadBoolean; end else begin { for backward compatibility only } Checked[I] := Reader.ReadBoolean; EnabledItem[I] := Reader.ReadBoolean; if FReserved > 0 then State[I] := TCheckBoxState(Reader.ReadInteger); end; end; Reader.ReadListEnd; UpdateCheckStates; finally Items.EndUpdate; end; end; procedure TJvxCheckListBox.WriteCheckData(Writer: TWriter); var I: Integer; begin with Writer do begin WriteListBegin; for I := 0 to Items.Count - 1 do begin WriteString(Items[I]); WriteInteger(Ord(Self.State[I])); WriteBoolean(EnabledItem[I]); end; WriteListEnd; end; end; procedure TJvxCheckListBox.ReadVersion(Reader: TReader); begin FReserved := Reader.ReadInteger; end; procedure TJvxCheckListBox.WriteVersion(Writer: TWriter); begin Writer.WriteInteger(InternalVersion); end; procedure TJvxCheckListBox.DefineProperties(Filer: TFiler); function DoWrite: Boolean; var I: Integer; Ancestor: TJvxCheckListBox; begin Result := False; Ancestor := TJvxCheckListBox(Filer.Ancestor); if (Ancestor <> nil) and (Ancestor.Items.Count = Items.Count) and (Ancestor.Items.Count > 0) then for I := 1 to Items.Count - 1 do begin Result := (CompareText(Items[I], Ancestor.Items[I]) <> 0) or (State[I] <> Ancestor.State[I]) or (EnabledItem[I] <> Ancestor.EnabledItem[I]); if Result then Break; end else Result := Items.Count > 0; end; begin inherited DefineProperties(Filer); Filer.DefineProperty('InternalVersion', ReadVersion, WriteVersion, Filer.Ancestor = nil); Filer.DefineProperty('Strings', ReadCheckData, WriteCheckData, DoWrite); end; procedure TJvxCheckListBox.CreateWnd; begin inherited CreateWnd; if FSaveStates <> nil then begin FSaveStates.Free; FSaveStates := nil; end; ResetItemHeight; end; procedure TJvxCheckListBox.DestroyWnd; begin inherited DestroyWnd; end; procedure TJvxCheckListBox.WMDestroy(var Msg: TWMDestroy); var I: Integer; begin if Items.Count > 0 then begin if FSaveStates <> nil then FSaveStates.Clear else FSaveStates := TList.Create; for I := 0 to Items.Count - 1 do begin FSaveStates.Add(TObject(MakeLong(Ord(EnabledItem[I]), Word(State[I])))); FindCheckObject(I).Free; end; end; inherited; end; procedure TJvxCheckListBox.CreateParams(var Params: TCreateParams); begin inherited CreateParams(Params); with Params do if Style and (LBS_OWNERDRAWFIXED or LBS_OWNERDRAWVARIABLE) = 0 then Style := Style or LBS_OWNERDRAWFIXED; end; procedure TJvxCheckListBox.SetItems(Value: TStrings); var I: Integer; begin Items.BeginUpdate; try inherited SetItems(Value); if (Value <> nil) and (Value is TJvListBoxStrings) and (TJvListBoxStrings(Value).ListBox <> nil) and (TJvListBoxStrings(Value).ListBox is TJvxCheckListBox) then begin for I := 0 to Items.Count - 1 do if I < Value.Count then begin Self.State[I] := TJvxCheckListBox(TJvListBoxStrings(Value).ListBox).State[I]; EnabledItem[I] := TJvxCheckListBox(TJvListBoxStrings(Value).ListBox).EnabledItem[I]; end; end; finally Items.EndUpdate; end; end; procedure TJvxCheckListBox.InternalLoad(const Section: string); begin if Assigned(IniStorage) then with IniStorage do LoadFromAppStorage(AppStorage, AppStorage.ConcatPaths([AppStoragePath, Section])); end; procedure TJvxCheckListBox.InternalSave(const Section: string); begin if Assigned(IniStorage) then with IniStorage do SaveToAppStorage(AppStorage, AppStorage.ConcatPaths([AppStoragePath, Section])); end; function TJvxCheckListBox.GetItemWidth(Index: Integer): Integer; begin Result := inherited GetItemWidth(Index) + GetCheckWidth; end; function TJvxCheckListBox.GetCheckWidth: Integer; begin Result := FCheckWidth + 2; end; function TJvxCheckListBox.GetAllowGrayed: Boolean; begin Result := FAllowGrayed and (FCheckKind in [ckCheckBoxes, ckCheckMarks]); end; procedure TJvxCheckListBox.FontChanged; begin inherited FontChanged; ResetItemHeight; end; function TJvxCheckListBox.GetItemHeight: Integer; var R: TRect; begin Result := FItemHeight; if HandleAllocated and ((FStyle = lbStandard) or ((FStyle = lbOwnerDrawFixed) and not Assigned(FOnDrawItem))) then begin {$IFDEF CLR} Perform(LB_GETITEMRECT, 0, R); {$ELSE} Perform(LB_GETITEMRECT, 0, Longint(@R)); {$ENDIF CLR} Result := R.Bottom - R.Top; end; end; procedure TJvxCheckListBox.ResetItemHeight; var H: Integer; begin if csDestroying in ComponentState then Exit; if (Style = lbStandard) or ((Style = lbOwnerDrawFixed) and not Assigned(FOnDrawItem)) then begin FCanvas.Font := Font; H := Max(CanvasMaxTextHeight(FCanvas), FCheckHeight); if Style = lbOwnerDrawFixed then H := Max(H, FItemHeight); Perform(LB_SETITEMHEIGHT, 0, H); if (H * Items.Count) <= ClientHeight then SetScrollRange(Handle, SB_VERT, 0, 0, True); end; end; procedure TJvxCheckListBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); var R: TRect; SaveEvent: TDrawItemEvent; begin if csDestroying in ComponentState then Exit; if Index < Items.Count then begin R := Rect; if not UseRightToLeftAlignment then begin R.Right := Rect.Left; R.Left := R.Right - GetCheckWidth; end else begin R.Left := Rect.Right; R.Right := R.Left + GetCheckWidth; end; DrawCheck(R, GetState(Index), EnabledItem[Index]); if not EnabledItem[Index] then if odSelected in State then FCanvas.Font.Color := clInactiveCaptionText else FCanvas.Font.Color := clGrayText; end; if (Style = lbStandard) and Assigned(FOnDrawItem) then begin SaveEvent := OnDrawItem; OnDrawItem := nil; try inherited DrawItem(Index, Rect, State); finally OnDrawItem := SaveEvent; end; end else inherited DrawItem(Index, Rect, State); end; procedure TJvxCheckListBox.CNDrawItem(var Msg: TWMDrawItem); {$IFDEF CLR} var DrawItemStruct: TDrawItemStruct; {$ENDIF CLR} begin {$IFDEF CLR} DrawItemStruct := Msg.DrawItemStruct; with DrawItemStruct do {$ELSE} with Msg.DrawItemStruct^ do {$ENDIF CLR} if not UseRightToLeftAlignment then rcItem.Left := rcItem.Left + GetCheckWidth else rcItem.Right := rcItem.Right - GetCheckWidth; {$IFDEF CLR} Msg.DrawItemStruct := DrawItemStruct; {$ENDIF CLR} inherited; end; procedure TJvxCheckListBox.DrawCheck(R: TRect; AState: TCheckBoxState; Enabled: Boolean); const CheckImages: array [TCheckBoxState, TCheckKind, Boolean] of Integer = (((3, 0), (9, 6), (15, 12)), { unchecked } ((4, 1), (10, 7), (16, 13)), { checked } ((5, 2), (11, 8), (17, 14))); { grayed } var DrawRect: TRect; SaveColor: TColor; {$IFDEF JVCLThemesEnabled} Flags: Cardinal; {$ENDIF JVCLThemesEnabled} begin if csDestroying in ComponentState then Exit; DrawRect.Left := R.Left + (R.Right - R.Left - FCheckWidth) div 2; DrawRect.Top := R.Top + (R.Bottom - R.Top - FCheckHeight) div 2; DrawRect.Right := DrawRect.Left + FCheckWidth; DrawRect.Bottom := DrawRect.Top + FCheckHeight; SaveColor := FCanvas.Brush.Color; {$IFDEF JVCLThemesEnabled} if ThemeServices.ThemesEnabled and (CheckKind in [ckCheckBoxes, ckRadioButtons]) then begin Flags := 0; if not Enabled then Flags := Flags or DFCS_INACTIVE; if AState = cbChecked then Flags := Flags or DFCS_CHECKED else if AState = cbGrayed then Flags := Flags or DFCS_MONO; if CheckKind = ckCheckBoxes then DrawThemedFrameControl(Self, Canvas.Handle, DrawRect, DFC_BUTTON, DFCS_BUTTONCHECK or Flags) else if CheckKind = ckRadioButtons then DrawThemedFrameControl(Self, Canvas.Handle, DrawRect, DFC_BUTTON, DFCS_BUTTONRADIO or Flags); end else {$ENDIF JVCLThemesEnabled} begin AssignBitmapCell(CheckBitmap, FDrawBitmap, 6, 3, CheckImages[AState, CheckKind, Enabled]); FCanvas.Brush.Color := Self.Color; try FCanvas.BrushCopy(DrawRect, FDrawBitmap, Bounds(0, 0, FCheckWidth, FCheckHeight), CheckBitmap.TransparentColor and not PaletteMask); finally FCanvas.Brush.Color := SaveColor; end; end; end; procedure TJvxCheckListBox.ApplyState(AState: TCheckBoxState; EnabledOnly: Boolean); var I: Integer; begin if FCheckKind in [ckCheckBoxes, ckCheckMarks] then for I := 0 to Items.Count - 1 do if not EnabledOnly or EnabledItem[I] then State[I] := AState; end; function TJvxCheckListBox.GetCheckedIndex: Integer; var I: Integer; begin Result := -1; if FCheckKind = ckRadioButtons then for I := 0 to Items.Count - 1 do if State[I] = cbChecked then begin Result := I; Break; end; end; procedure TJvxCheckListBox.SetCheckedIndex(Value: Integer); begin if (FCheckKind = ckRadioButtons) and (Items.Count > 0) then SetState(Max(Value, 0), cbChecked); end; procedure TJvxCheckListBox.UpdateCheckStates; begin if (FCheckKind = ckRadioButtons) and (Items.Count > 0) then begin FInUpdateStates := True; try SetState(Max(GetCheckedIndex, 0), cbChecked); finally FInUpdateStates := False; end; end; end; procedure TJvxCheckListBox.SetCheckKind(Value: TCheckKind); begin if FCheckKind <> Value then begin FCheckKind := Value; UpdateCheckStates; Invalidate; end; end; procedure TJvxCheckListBox.SetChecked(Index: Integer; AChecked: Boolean); const CheckStates: array [Boolean] of TCheckBoxState = (cbUnchecked, cbChecked); begin SetState(Index, CheckStates[AChecked]); end; procedure TJvxCheckListBox.SetState(Index: Integer; AState: TCheckBoxState); var I: Integer; begin if (AState <> GetState(Index)) or FInUpdateStates then begin if (FCheckKind = ckRadioButtons) and (AState = cbUnchecked) and (GetCheckedIndex = Index) then Exit; TJvCheckListBoxItem(GetCheckObject(Index)).State := AState; if (FCheckKind = ckRadioButtons) and (AState = cbChecked) then for I := Items.Count - 1 downto 0 do begin if (I <> Index) and (GetState(I) = cbChecked) then begin TJvCheckListBoxItem(GetCheckObject(I)).State := cbUnchecked; InvalidateCheck(I); end; end; InvalidateCheck(Index); if not (csReading in ComponentState) then ChangeItemState(Index); end; end; procedure TJvxCheckListBox.SetItemEnabled(Index: Integer; Value: Boolean); begin if Value <> GetItemEnabled(Index) then begin TJvCheckListBoxItem(GetCheckObject(Index)).Enabled := Value; InvalidateItem(Index); end; end; procedure TJvxCheckListBox.InvalidateCheck(Index: Integer); var R: TRect; begin R := ItemRect(Index); if not UseRightToLeftAlignment then R.Right := R.Left + GetCheckWidth else R.Left := R.Right - GetCheckWidth; InvalidateRect(Handle, {$IFNDEF CLR}@{$ENDIF} R, not (csOpaque in ControlStyle)); UpdateWindow(Handle); end; procedure TJvxCheckListBox.InvalidateItem(Index: Integer); var R: TRect; begin R := ItemRect(Index); InvalidateRect(Handle, {$IFNDEF CLR}@{$ENDIF} R, not (csOpaque in ControlStyle)); UpdateWindow(Handle); end; function TJvxCheckListBox.GetChecked(Index: Integer): Boolean; begin if IsCheckObject(Index) then Result := TJvCheckListBoxItem(GetCheckObject(Index)).GetChecked else Result := False; end; function TJvxCheckListBox.GetState(Index: Integer): TCheckBoxState; begin if IsCheckObject(Index) then Result := TJvCheckListBoxItem(GetCheckObject(Index)).State else Result := clbDefaultState; if (FCheckKind = ckRadioButtons) and (Result <> cbChecked) then Result := cbUnchecked; end; function TJvxCheckListBox.GetItemEnabled(Index: Integer): Boolean; begin if IsCheckObject(Index) then Result := TJvCheckListBoxItem(GetCheckObject(Index)).Enabled else Result := clbDefaultEnabled; end; procedure TJvxCheckListBox.KeyPress(var Key: Char); begin inherited KeyPress(Key); case Key of ' ': begin ToggleClickCheck(ItemIndex); Key := #0; end; '+': begin ApplyState(cbChecked, True); ClickCheck; end; '-': begin ApplyState(cbUnchecked, True); ClickCheck; end; end; end; procedure TJvxCheckListBox.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var Index: Integer; begin inherited MouseDown(Button, Shift, X, Y); if Button = mbLeft then begin Index := ItemAtPos(Point(X, Y), True); if Index <> -1 then begin if not UseRightToLeftAlignment then begin if X - ItemRect(Index).Left < GetCheckWidth then ToggleClickCheck(Index); end else begin Dec(X, ItemRect(Index).Right - GetCheckWidth); if (X > 0) and (X < GetCheckWidth) then ToggleClickCheck(Index); end; end; end; end; procedure TJvxCheckListBox.ToggleClickCheck(Index: Integer); var State: TCheckBoxState; begin if (Index >= 0) and (Index < Items.Count) and EnabledItem[Index] then begin State := Self.State[Index]; case State of cbUnchecked: if AllowGrayed then State := cbGrayed else State := cbChecked; cbChecked: State := cbUnchecked; cbGrayed: State := cbChecked; end; Self.State[Index] := State; ClickCheck; end; end; procedure TJvxCheckListBox.ChangeItemState(Index: Integer); begin if Assigned(FOnStateChange) then FOnStateChange(Self, Index); end; procedure TJvxCheckListBox.ClickCheck; begin if Assigned(FOnClickCheck) then FOnClickCheck(Self); end; function TJvxCheckListBox.GetItemData(Index: Integer): Longint; var Item: TJvCheckListBoxItem; begin Result := 0; if IsCheckObject(Index) then begin Item := TJvCheckListBoxItem(GetCheckObject(Index)); if Item <> nil then Result := Item.FData; end; end; function TJvxCheckListBox.GetCheckObject(Index: Integer): TObject; begin Result := FindCheckObject(Index); if Result = nil then Result := CreateCheckObject(Index); end; function TJvxCheckListBox.FindCheckObject(Index: Integer): TObject; var ItemData: Longint; begin Result := nil; ItemData := inherited GetItemData(Index); if ItemData = LB_ERR then ListIndexError(Index) else begin Result := TJvCheckListBoxItem(TObject(ItemData)); if not (Result is TJvCheckListBoxItem) then Result := nil; end; end; function TJvxCheckListBox.CreateCheckObject(Index: Integer): TObject; begin Result := TJvCheckListBoxItem.Create; inherited SetItemData(Index, Longint(Result)); end; function TJvxCheckListBox.IsCheckObject(Index: Integer): Boolean; begin Result := FindCheckObject(Index) <> nil; end; procedure TJvxCheckListBox.SetItemData(Index: Integer; AData: Longint); var Item: TJvCheckListBoxItem; L: Longint; begin Item := TJvCheckListBoxItem(GetCheckObject(Index)); Item.FData := AData; if (FSaveStates <> nil) and (FSaveStates.Count > 0) then begin L := Longint(FSaveStates[0]); Item.FState := TCheckBoxState(HiWord(L)); Item.FEnabled := LoWord(L) <> 0; FSaveStates.Delete(0); end; end; procedure TJvxCheckListBox.ResetContent; var I: Integer; begin for I := Items.Count - 1 downto 0 do begin if IsCheckObject(I) then GetCheckObject(I).Free; inherited SetItemData(I, 0); end; inherited ResetContent; end; procedure TJvxCheckListBox.DeleteString(Index: Integer); begin if IsCheckObject(Index) then GetCheckObject(Index).Free; inherited SetItemData(Index, 0); inherited DeleteString(Index); end; initialization {$IFDEF UNITVERSIONING} RegisterUnitVersion(HInstance, UnitVersioning); {$ENDIF UNITVERSIONING} finalization FreeAndNil(GCheckBitmap); {$IFDEF UNITVERSIONING} UnregisterUnitVersion(HInstance); {$ENDIF UNITVERSIONING} end.