unit ORCtrls; // Oct 26, 1997 @ 10:00am // To Do: eliminate topindex itemtip on mousedown (seen when choosing clinic pts) interface // -------------------------------------------------------------------------------- uses Windows, Messages, SysUtils, Classes, Graphics, Controls, StdCtrls, Forms, ComCtrls, Commctrl, Buttons, ExtCtrls, Grids, ImgList, Menus, CheckLst, Accessibility_TLB, Variants; const UM_SHOWTIP = (WM_USER + 9436); // message id to display item tip **was 300 UM_GOTFOCUS = (WM_USER + 9437); // message to post when combo gets focus **was 301 MAX_TABS = 40; // maximum number of tab stops or pieces LL_REVERSE = -1; // long list scrolling in reverse direction LL_POSITION = 0; // long list thumb moved LL_FORWARD = 1; // long list scrolling in forward direction LLS_LINE = '^____________________________________________________________________________'; LLS_DASH = '^----------------------------------------------------------------------------'; LLS_SPACE = '^ '; type TORStaticText = class(TStaticText) private FOnEnter: TNotifyEvent; FOnExit: TNotifyEvent; published property OnEnter: TNotifyEvent read FOnEnter write FOnEnter; property OnExit: TNotifyEvent read FOnExit write FOnExit; procedure DoEnter; override; procedure DoExit; override; end; TORComboBox = class; // forward declaration for FParentCombo TTranslator = function (MString: string): string of object; TORStrings = class(TStrings) private MList: TStringList; FPlainText: TStrings; FTranslator: TTranslator; FVerification: boolean; procedure Verify; protected function Get( index:integer): string; override; function GetCount: integer; override; function GetObject(index:integer): TObject; override; procedure Put(Index: Integer; const S: string); override; procedure PutObject(index:integer; Value: TObject); override; procedure SetUpdateState( Value: boolean); override; public function Add(const S: string): integer; override; constructor Create(PlainText: TStrings; Translator: TTranslator); destructor Destroy; override; procedure Clear; override; procedure Delete( index: integer); override; procedure Insert(Index: Integer; const S: string); override; function IndexOf(const S: string): Integer; override; property PlainText: TStrings read FPlainText; property Translator: TTranslator read FTranslator; property Verification: boolean read FVerification write FVerification; end; TORDirection = -1..1; // for compatibility, type is now integer TORNeedDataEvent = procedure(Sender: TObject; const StartFrom: string; Direction, InsertAt: Integer) of object; TORBeforeDrawEvent = procedure(Sender: TObject; Index: Integer; Rect: TRect; State: TOwnerDrawState) of object; TORItemNotifyEvent = procedure(Sender: TObject; Index: integer) of object; TORCheckComboTextEvent = procedure(Sender: TObject; NumChecked: integer; var Text: string) of object; TORSynonymCheckEvent = procedure(Sender: TObject; const Text: string; var IsSynonym: boolean) of object; PItemRec = ^TItemRec; TItemRec = record Reference: Variant; // variant value associated with item UserObject: TObject; // Objects[n] property of listbox item CheckedState: TCheckBoxState; // Used to indicate check box values end; TORListBox = class(TListBox) private FFocusIndex: Integer; // item with focus when using navigation keys FLargeChange: Integer; // visible items less one FTipItem: Integer; // item currently displaying ItemTip FItemTipActive: Boolean; // used to delay appearance of the ItemTip FItemTipColor: TColor; // background color for ItemTip window FItemTipEnable: Boolean; // allows display of ItemTips over items FLastMouseX: Integer; // mouse X position on last MouseMove event FLastMouseY: Integer; // mouse Y position on last MouseMove event FLastItemIndex: Integer; // used for the OnChange event FFromSelf: Boolean; // true if listbox message sent from this unit FDelimiter: Char; // delimiter used by Pieces property FWhiteSpace: Char; // may be space or tab (between pieces) FTabPosInPixels: boolean; // determines if TabPosition is Pixels or Chars FTabPos: array[0..MAX_TABS] of Integer; // character based positions of tab stops FTabPix: array[0..MAX_TABS] of Integer; // pixel positions of tab stops FPieces: array[0..MAX_TABS] of Integer; // pieces that should be displayed for item FLongList: Boolean; // if true, enables special LongList properties FScrollBar: TScrollBar; // scrollbar used when in LongList mode FFirstLoad: Boolean; // true if NeedData has never been called FFromNeedData: Boolean; // true means items added to LongList part FDataAdded: Boolean; // true if items added during NeedData call FCurrentTop: Integer; // TopIndex, changes when inserting to LongList FWaterMark: Integer; // first LongList item after the short list FDirection: Integer; // direction of the current NeedData call FInsertAt: Integer; // insert point for the current NeedData call FParentCombo: TORComboBox; // used when listbox is part of dropdown combo FOnChange: TNotifyEvent; // event called when ItemIndex changes FOnNeedData: TORNeedDataEvent; // event called when LongList needs more items FHideSynonyms: boolean; // Hides Synonyms from the list FSynonymChars: string; // Chars a string must contain to be considered a synonym FOnSynonymCheck: TORSynonymCheckEvent; // Event that allows for custom synonym checking FCreatingItem: boolean; // Used by Synonyms to prevent errors when adding new items FCreatingText: string; // Used by Synonyms to prevent errors when adding new items FOnBeforeDraw: TORBeforeDrawEvent; // event called prior to drawing an item FRightClickSelect: boolean; // When true, a right click selects teh item FCheckBoxes: boolean; // When true, list box contains check boxes FFlatCheckBoxes: boolean; // When true, list box check boxes are flat FCheckEntireLine: boolean; // When checked, clicking anywhere on the line checks the checkbox FOnClickCheck: TORItemNotifyEvent; // Event notifying of checkbox change FDontClose: boolean; // Used to keep drop down open when checkboxes FItemsDestroyed: boolean; // Used to make sure items are not destroyed multiple times FAllowGrayed: boolean; FMItems: TORStrings; // Used to save corresponding M strings ("the pieces") FCaption: TStaticText; // Used to supply a title to IAccessible interface FAccessible: IAccessible; FCaseChanged: boolean; // If true, the names are stored in the database as all caps, but loaded and displayed in mixed-case FLookupPiece: integer; // If zero, list look-up comes from display string; if non-zero, indicates which piece of the item needs to be used for list lookup procedure WMGetObject(var Message: TMessage); message WM_GETOBJECT; procedure AdjustScrollBar; procedure CreateScrollBar; procedure FreeScrollBar; function GetDisplayText(Index: Integer): string; function GetItemID: Variant; function GetItemIEN: Int64; function GetPieces: string; function GetReference(Index: Integer): Variant; function GetTabPositions: string; function GetStyle: TListBoxStyle; procedure NeedData(Direction: Integer; StartFrom: string); function PositionThumb: Integer; procedure ResetItems; procedure ScrollTo(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer); function GetStringIndex(const AString: string): Integer; function SelectString(const AString: string): Integer; procedure SetCheckBoxes(const Value: boolean); procedure SetDelimiter(Value: Char); procedure SetFlatCheckBoxes(const Value: boolean); procedure SetFocusIndex(Value: Integer); procedure SetLongList(Value: Boolean); procedure SetPieces(const Value: string); procedure SetReference(Index: Integer; AReference: Variant); procedure SetTabPositions(const Value: string); procedure SetTabPosInPixels(const Value: boolean); procedure SetTabStops; procedure SetHideSynonyms(Value: boolean); procedure SetSynonymChars(Value: string); procedure SetStyle(Value: TListBoxStyle); function IsSynonym(const TestStr: string): boolean; function TextToShow(S: string): string; procedure LBGetText (var Message: TMessage); message LB_GETTEXT; procedure LBGetTextLen (var Message: TMessage); message LB_GETTEXTLEN; procedure LBGetItemData (var Message: TMessage); message LB_GETITEMDATA; procedure LBSetItemData (var Message: TMessage); message LB_SETITEMDATA; procedure LBAddString (var Message: TMessage); message LB_ADDSTRING; procedure LBInsertString (var Message: TMessage); message LB_INSERTSTRING; procedure LBDeleteString (var Message: TMessage); message LB_DELETESTRING; procedure LBResetContent (var Message: TMessage); message LB_RESETCONTENT; procedure LBSetCurSel (var Message: TMessage); message LB_SETCURSEL; procedure CMFontChanged (var Message: TMessage); message CM_FONTCHANGED; procedure CNDrawItem (var Message: TWMDrawItem); message CN_DRAWITEM; procedure WMDestroy (var Message: TWMDestroy); message WM_DESTROY; procedure WMKeyDown (var Message: TWMKeyDown); message WM_KEYDOWN; procedure WMLButtonDown (var Message: TWMLButtonDown); message WM_LBUTTONDOWN; procedure WMLButtonUp (var Message: TWMLButtonUp); message WM_LBUTTONUP; procedure WMRButtonUp (var Message: TWMRButtonUp); message WM_RBUTTONUP; procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK; procedure WMCancelMode (var Message: TMessage); message WM_CANCELMODE; procedure WMMove (var Message: TWMMove); message WM_MOVE; procedure WMSize (var Message: TWMSize); message WM_SIZE; procedure WMVScroll (var Message: TWMVScroll); message WM_VSCROLL; procedure CMHintShow (var Message: TMessage); message CM_HINTSHOW; procedure UMShowTip (var Message: TMessage); message UM_SHOWTIP; function GetChecked(Index: Integer): Boolean; procedure SetChecked(Index: Integer; const Value: Boolean); function GetMultiSelect: boolean; function GetCheckedString: string; procedure SetCheckedString(const Value: string); function GetCheckedState(Index: Integer): TCheckBoxState; procedure SetCheckedState(Index: Integer; const Value: TCheckBoxState); function GetMItems: TStrings; procedure SetMItems( Value: TStrings); procedure SetCaption(const Value: string); function GetCaption: string; protected procedure SetMultiSelect(Value: boolean); override; procedure CreateParams(var Params: TCreateParams); override; procedure CreateWnd; override; procedure DestroyWnd; override; procedure Click; override; procedure DoChange; virtual; procedure DoEnter; override; procedure DoExit; override; procedure DestroyItems; procedure Loaded; override; procedure ToggleCheckBox(idx: integer); procedure KeyPress(var Key: Char); override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure MeasureItem(Index: Integer; var Height: Integer); override; procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override; function GetIndexFromY(YPos :integer) :integer; property HideSynonyms: boolean read FHideSynonyms write SetHideSynonyms default FALSE; property SynonymChars: string read FSynonymChars write SetSynonymChars; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure ClearTop; function AddReference(const S: string; AReference: Variant): Integer; procedure InsertReference(Index: Integer; const S: string; AReference: Variant); function IndexOfReference(AReference: Variant): Integer; procedure InsertSeparator; procedure ForDataUse(Strings: TStrings); procedure InitLongList(S: string); function GetIEN(AnIndex: Integer): Int64; function SelectByIEN(AnIEN: Int64): Integer; function SelectByID(const AnID: string): Integer; function SetExactByIEN(AnIEN: Int64; const AnItem: string): Integer; procedure Clear; override; property ItemID: Variant read GetItemID; property ItemIEN: Int64 read GetItemIEN; property FocusIndex: Integer read FFocusIndex write SetFocusIndex; property DisplayText[Index: Integer]: string read GetDisplayText; property References[Index: Integer]: Variant read GetReference write SetReference; property ShortCount: Integer read FWaterMark; property Checked[Index: Integer]: Boolean read GetChecked write SetChecked; property CheckedString: string read GetCheckedString write SetCheckedString; property CheckedState[Index: Integer]: TCheckBoxState read GetCheckedState write SetCheckedState; property MItems: TStrings read GetMItems write SetMItems; procedure MakeAccessible(Accessible: IAccessible); function VerifyUnique(SelectIndex: Integer; iText: String): integer; published property AllowGrayed: boolean read FAllowGrayed write FAllowGrayed default FALSE; property Caption: string read GetCaption write SetCaption; property CaseChanged: boolean read FCaseChanged write FCaseChanged default TRUE; property Delimiter: Char read FDelimiter write SetDelimiter default '^'; property ItemTipColor: TColor read FItemTipColor write FItemTipColor; property ItemTipEnable: Boolean read FItemTipEnable write FItemTipEnable default True; property LongList: Boolean read FLongList write SetLongList; property LookupPiece: integer read FLookupPiece write FLookupPiece default 0; property Pieces: string read GetPieces write SetPieces; property TabPosInPixels: boolean read FTabPosInPixels write SetTabPosInPixels default False; // MUST be before TabPositions! property TabPositions: string read GetTabPositions write SetTabPositions; property OnChange: TNotifyEvent read FOnChange write FOnChange; property OnNeedData: TORNeedDataEvent read FOnNeedData write FOnNeedData; property OnBeforeDraw: TORBeforeDrawEvent read FOnBeforeDraw write FOnBeforeDraw; property RightClickSelect: boolean read FRightClickSelect write FRightClickSelect default FALSE; property CheckBoxes: boolean read FCheckBoxes write SetCheckBoxes default FALSE; property Style: TListBoxStyle read GetStyle write SetStyle default lbStandard; property FlatCheckBoxes: boolean read FFlatCheckBoxes write SetFlatCheckBoxes default TRUE; property CheckEntireLine: boolean read FCheckEntireLine write FCheckEntireLine default FALSE; property OnClickCheck: TORItemNotifyEvent read FOnClickCheck write FOnClickCheck; property MultiSelect: boolean read GetMultiSelect write SetMultiSelect default FALSE; property Items: TStrings read GetMItems write SetMItems; end; TORDropPanel = class(TPanel) private FButtons: boolean; procedure WMActivateApp(var Message: TMessage); message WM_ACTIVATEAPP; protected procedure CreateParams(var Params: TCreateParams); override; procedure Resize; override; procedure UpdateButtons; function GetButton(OKBtn: boolean): TSpeedButton; procedure ResetButtons; procedure BtnClicked(Sender: TObject); public constructor Create(AOwner: TComponent); override; end; TORComboStyle = (orcsDropDown, orcsSimple); TORComboPanelEdit = class(TPanel) private FFocused: boolean; FCanvas: TControlCanvas; protected procedure Paint; override; public destructor Destroy; override; end; TORComboEdit = class(TEdit) private procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS; procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS; protected procedure CreateParams(var Params: TCreateParams); override; end; TORComboBox = class(TWinControl) private FItems: TStrings; // points to Items in FListBox FMItems: TStrings; // points to MItems in FListBox FListBox: TORListBox; // listbox control for the combobox FEditBox: TORComboEdit; // edit control for the combobox FEditPanel: TORComboPanelEdit; // Used to enable Multi-Select Combo Boxes FDropBtn: TBitBtn; // drop down button for dropdown combo FDropPanel: TORDropPanel; // panel for dropdown combo (parent=desktop) FDroppedDown: Boolean; // true if the list part is dropped down FStyle: TORComboStyle; // style is simple or dropdown for combo FDropDownCount: Integer; // number of items to display when list appears FFromSelf: Boolean; // prevents recursive calls to change event FFromDropBtn: Boolean; // determines when to capture mouse on drop FKeyTimerActive: Boolean; // true when timer running for OnKeyPause FKeyIsDown: Boolean; // true between KeyDown & KeyUp events FChangePending: Boolean; FListItemsOnly: Boolean; FLastFound: string; FLastInput: string; // last thing the user typed into the edit box FOnChange: TNotifyEvent; // maps to editbox change event FOnClick: TNotifyEvent; // maps to listbox click event FOnDblClick: TNotifyEvent; // maps to listbox double click event FOnDropDown: TNotifyEvent; // event called when listbox appears FOnDropDownClose: TNotifyEvent; // event called when listbox disappears FOnKeyDown: TKeyEvent; // maps to editbox keydown event FOnKeyPress: TKeyPressEvent; // maps to editbox keypress event FOnKeyUp: TKeyEvent; // maps to editbox keyup event FOnKeyPause: TNotifyEvent; // delayed change event when using keyboard FOnMouseClick: TNotifyEvent; // called when click event triggered by mouse FOnNeedData: TORNeedDataEvent; // called for longlist when more items needed FCheckedState: string; // Used to refresh checkboxes when combo box cancel is pressed FOnCheckedText: TORCheckComboTextEvent; // Used to modify the edit box display text when using checkboxes FCheckBoxEditColor: TColor; // Edit Box color for Check Box Combo List, when not in Focus FTemplateField: boolean; FCharsNeedMatch: integer; // how many text need to be matched for auto selection FUniqueAutoComplete: Boolean; // If true only perform autocomplete for unique list items. function EditControl: TWinControl; procedure AdjustSizeOfSelf; procedure DropButtonDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure DropButtonUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure FwdChange(Sender: TObject); procedure FwdChangeDelayed; procedure FwdClick(Sender: TObject); procedure FwdDblClick(Sender: TObject); procedure FwdKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); procedure FwdKeyPress(Sender: TObject; var Key: Char); procedure FwdKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); procedure FwdMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure FwdNeedData(Sender: TObject; const StartFrom: string; Direction, InsertAt: Integer); procedure SetNumForMatch(const NumberForMatch: integer); function GetAutoSelect: Boolean; function GetColor: TColor; function GetDelimiter: Char; function GetDisplayText(Index: Integer): string; function GetItemHeight: Integer; function GetItemID: Variant; function GetItemIEN: Int64; function GetItemIndex: Integer; function GetItemTipEnable: Boolean; function GetItemTipColor: TColor; function GetLongList: Boolean; function GetMaxLength: Integer; function GetPieces: string; function GetReference(Index: Integer): Variant; function GetSelLength: Integer; function GetSelStart: Integer; function GetSelText: string; function GetShortCount: Integer; function GetSorted: Boolean; function GetHideSynonyms: boolean; function GetSynonymChars: string; function GetTabPositions: string; function GetTabPosInPixels: boolean; function GetText: string; procedure SetAutoSelect(Value: Boolean); procedure SetColor(Value: TColor); procedure SetDelimiter(Value: Char); procedure SetDropDownCount(Value: Integer); procedure SetDroppedDown(Value: Boolean); procedure SetEditRect; procedure SetEditText(const Value: string); procedure SetItemIndex(Value: Integer); procedure SetItemHeight(Value: Integer); procedure SetItemTipEnable(Value: Boolean); procedure SetItemTipColor(Value: TColor); procedure SetLongList(Value: Boolean); procedure SetMaxLength(Value: Integer); procedure SetPieces(const Value: string); procedure SetReference(Index: Integer; AReference: Variant); procedure SetSelLength(Value: Integer); procedure SetSelStart(Value: Integer); procedure SetSelText(const Value: string); procedure SetSorted(Value: Boolean); procedure SetHideSynonyms(Value: boolean); procedure SetSynonymChars(Value: string); procedure SetStyle(Value: TORComboStyle); procedure SetTabPositions(const Value: string); procedure SetTabPosInPixels(const Value: boolean); procedure SetText(const Value: string); procedure SetItems(const Value: TStrings); procedure StartKeyTimer; procedure StopKeyTimer; procedure WMDestroy (var Message: TWMDestroy); message WM_DESTROY; procedure CMFontChanged (var Message: TMessage); message CM_FONTCHANGED; procedure WMMove (var Message: TWMMove); message WM_MOVE; procedure WMSize (var Message: TWMSize); message WM_SIZE; procedure WMTimer (var Message: TWMTimer); message WM_TIMER; procedure UMGotFocus (var Message: TMessage); message UM_GOTFOCUS; function GetCheckBoxes: boolean; function GetChecked(Index: Integer): Boolean; function GetCheckEntireLine: boolean; function GetFlatCheckBoxes: boolean; procedure SetCheckBoxes(const Value: boolean); procedure SetChecked(Index: Integer; const Value: Boolean); procedure SetCheckEntireLine(const Value: boolean); procedure SetFlatCheckBoxes(const Value: boolean); function GetCheckedString: string; procedure SetCheckedString(const Value: string); procedure SetCheckBoxEditColor(const Value: TColor); procedure SetListItemsOnly(const Value: Boolean); procedure SetOnCheckedText(const Value: TORCheckComboTextEvent); procedure SetTemplateField(const Value: boolean); function GetOnSynonymCheck: TORSynonymCheckEvent; procedure SetOnSynonymCheck(const Value: TORSynonymCheckEvent); function GetMItems: TStrings; procedure SetCaption(const Value: string); function GetCaption: string; function GetCaseChanged: boolean; procedure SetCaseChanged(const Value: boolean); function GetLookupPiece: integer; procedure SetLookupPiece(const Value: integer); procedure SetUniqueAutoComplete(const Value: Boolean); protected procedure DropPanelBtnPressed(OKBtn, AutoClose: boolean); function GetEditBoxText(Index: Integer): string; procedure CheckBoxSelected(Sender: TObject; Index: integer); procedure UpdateCheckEditBoxText; procedure DoEnter; override; procedure DoExit; override; procedure Loaded; override; function GetEnabled: boolean; override; procedure SetEnabled(Value: boolean); override; public constructor Create(AOwner: TComponent); override; function AddReference(const S: string; AReference: Variant): Integer; procedure Clear; procedure ClearTop; procedure ForDataUse(Strings: TStrings); procedure InitLongList(S: string); procedure InsertSeparator; procedure SetTextAutoComplete(TextToMatch : String); function GetIEN(AnIndex: Integer): Int64; function SelectByIEN(AnIEN: Int64): Integer; function SelectByID(const AnID: string): Integer; function SetExactByIEN(AnIEN: Int64; const AnItem: string): Integer; function IndexOfReference(AReference: Variant): Integer; procedure InsertReference(Index: Integer; const S: string; AReference: Variant); procedure SelectAll; function MakeAccessible( Accessible: IAccessible): TORListBox; property DisplayText[Index: Integer]: string read GetDisplayText; property DroppedDown: Boolean read FDroppedDown write SetDroppedDown; property ItemID: Variant read GetItemID; property ItemIEN: Int64 read GetItemIEN; property ItemIndex: Integer read GetItemIndex write SetItemIndex; property References[Index: Integer]: Variant read GetReference write SetReference; property SelLength: Integer read GetSelLength write SetSelLength; property SelStart: Integer read GetSelStart write SetSelStart; property SelText: string read GetSelText write SetSelText; property ShortCount: Integer read GetShortCount; property Checked[Index: Integer]: Boolean read GetChecked write SetChecked; property CheckedString: string read GetCheckedString write SetCheckedString; property TemplateField: boolean read FTemplateField write SetTemplateField; property MItems: TStrings read GetMItems; published property Anchors; property CaseChanged: boolean read GetCaseChanged write SetCaseChanged default TRUE; property CheckBoxes: boolean read GetCheckBoxes write SetCheckBoxes default FALSE; property Style: TORComboStyle read FStyle write SetStyle; property Align; property AutoSelect: Boolean read GetAutoSelect write SetAutoSelect; property Caption: string read GetCaption write SetCaption; property Color: TColor read GetColor write SetColor; property Ctl3D; property Delimiter: Char read GetDelimiter write SetDelimiter default '^'; property DropDownCount: Integer read FDropDownCount write SetDropDownCount; property Enabled; property Font; property Items: TStrings read FItems write SetItems; property ItemHeight: Integer read GetItemHeight write SetItemHeight; property ItemTipColor: TColor read GetItemTipColor write SetItemTipColor; property ItemTipEnable: Boolean read GetItemTipEnable write SetItemTipEnable; property ListItemsOnly: Boolean read FListItemsOnly write SetListItemsOnly; property LongList: Boolean read GetLongList write SetLongList; property LookupPiece: Integer read GetLookupPiece write SetLookupPiece; property MaxLength: Integer read GetMaxLength write SetMaxLength; property ParentColor; property ParentCtl3D; property ParentFont; property ParentShowHint; property Pieces: string read GetPieces write SetPieces; property PopupMenu; property ShowHint; property HideSynonyms: boolean read GetHideSynonyms write SetHideSynonyms default FALSE; property Sorted: Boolean read GetSorted write SetSorted; property SynonymChars: string read GetSynonymChars write SetSynonymChars; property TabPosInPixels: boolean read GetTabPosInPixels write SetTabPosInPixels default False; // MUST be before TabPositions! property TabPositions: string read GetTabPositions write SetTabPositions; property TabOrder; property TabStop; property Text: string read GetText write SetText; property Visible; property FlatCheckBoxes: boolean read GetFlatCheckBoxes write SetFlatCheckBoxes default TRUE; property CheckEntireLine: boolean read GetCheckEntireLine write SetCheckEntireLine default FALSE; property CheckBoxEditColor: TColor read FCheckBoxEditColor write SetCheckBoxEditColor default clBtnFace; property OnCheckedText: TORCheckComboTextEvent read FOnCheckedText write SetOnCheckedText; property OnChange: TNotifyEvent read FOnChange write FOnChange; property OnClick: TNotifyEvent read FOnClick write FOnClick; property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick; property OnDragDrop; property OnDragOver; property OnDropDown: TNotifyEvent read FOnDropDown write FOnDropDown; property OnDropDownClose: TNotifyEvent read FOnDropDownClose write FOnDropDownClose; property OnEnter; property OnExit; property OnKeyDown: TKeyEvent read FOnKeyDown write FOnKeyDown; property OnKeyPress: TKeyPressEvent read FOnKeyPress write FOnKeyPress; property OnKeyUp: TKeyEvent read FOnKeyUp write FOnKeyUp; property OnKeyPause: TNotifyEvent read FOnKeyPause write FOnKeyPause; property OnMouseClick: TNotifyEvent read FOnMouseClick write FOnMouseClick; property OnNeedData: TORNeedDataEvent read FOnNeedData write FOnNeedData; property OnResize; property OnSynonymCheck: TORSynonymCheckEvent read GetOnSynonymCheck write SetOnSynonymCheck; property CharsNeedMatch: integer read FCharsNeedMatch write SetNumForMatch; {UniqueAutoComplete Was added as a result of the following defects: 7293 - PTM 85: Backspace and Dosage: Desired dosage does not populate if dosage is not in local dosage field 7337 - PTM 160 Meds: #8 IMO - Simple - Change Order in which Error generated if "Enter" is hit instead of "OK" 7278 - PTM 36 Meds: Select 40000 UNT/2ML and backspace to 4000 the dose selected remains 40000 7284 - Inconsistencies of pulling in a dose from the Possible Dose File } property UniqueAutoComplete: Boolean read FUniqueAutoComplete write SetUniqueAutoComplete default False; end; TORAutoPanel = class(TPanel) private FSizes: TList; procedure BuildSizes( Control: TWinControl); procedure DoResize( Control: TWinControl; var CurrentIndex: Integer); protected procedure Loaded; override; procedure Resize; override; public destructor Destroy; override; end; TOROffsetLabel = class(TGraphicControl) // see TCustomLabel in the VCL private FHorzOffset: Integer; // offset from left of label in pixels FVertOffset: Integer; // offset from top of label in pixels FWordWrap: Boolean; // true if word wrap should occur function GetTransparent: Boolean; procedure AdjustSizeOfSelf; procedure DoDrawText(var Rect: TRect; Flags: Word); procedure SetHorzOffset(Value: Integer); procedure SetVertOffset(Value: Integer); procedure SetTransparent(Value: Boolean); procedure SetWordWrap(Value: Boolean); procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED; procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED; protected procedure Paint; override; public constructor Create(AOwner: TComponent); override; published property Align; property Caption; property Color; property Enabled; property Font; property HorzOffset: Integer read FHorzOffset write SetHorzOffset; property ParentColor; property ParentFont; property ParentShowHint; property PopupMenu; property ShowHint; property Transparent: Boolean read GetTransparent write SetTransparent; property VertOffset: Integer read FVertOffset write SetVertOffset; property Visible; property WordWrap: Boolean read FWordWrap write SetWordWrap; property OnClick; property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnStartDrag; end; TORAlignButton = class(TButton) private FAlignment: TAlignment; FWordWrap: boolean; FLayout: TTextLayout; protected procedure CreateParams(var Params: TCreateParams); override; procedure SetAlignment(const Value: TAlignment); procedure SetLayout(const Value: TTextLayout); procedure SetWordWrap(const Value: boolean); public constructor Create(AOwner: TComponent); override; published property Align; property Alignment: TAlignment read FAlignment write SetAlignment default taCenter; property Layout: TTextLayout read FLayout write SetLayout default tlCenter; property WordWrap: boolean read FWordWrap write SetWordWrap default FALSE; end; { TORAlignBitBtn = class(TBitBtn) published property Align; end;} TORAlignSpeedButton = class(TSpeedButton) protected procedure Paint; override; public property Canvas; published property Align; property OnResize; end; TORAlignEdit = class(TEdit) //Depricated -- Use TCaptionEdit instead published property Align; end; TORDraggingEvent = procedure(Sender: TObject; Node: TTreeNode; var CanDrag: boolean) of object; TCaptionTreeView = class(TTreeView) private procedure SetCaption(const Value: string); function GetCaption: string; protected FCaptionComponent: TStaticText; published property Align; property Caption: string read GetCaption write SetCaption; end; TORTreeView = class; TORTreeNode = class(TTreeNode) private FTag: integer; FStringData: string; FAccessible: IAccessible; FCaption: string; procedure WMGetObject(var Message: TMessage); message WM_GETOBJECT; function GetParent: TORTreeNode; procedure SetCaption(const Value: string); protected function GetText: string; procedure SetText(const Value: string); procedure UpdateText(const Value: string; UpdateData: boolean = TRUE); function GetBold: boolean; procedure SetBold(const Value: boolean); procedure SetStringData(const Value: string); function GetORTreeView: TORTreeView; public procedure MakeAccessible(Accessible: IAccessible); procedure SetPiece(PieceNum: Integer; const NewPiece: string); procedure EnsureVisible; property Accessible: IAccessible read FAccessible write MakeAccessible; property Bold: boolean read GetBold write SetBold; property Tag: integer read FTag write FTag; property StringData: string read FStringData write SetStringData; property TreeView: TORTreeView read GetORTreeView; property Text: string read GetText write SetText; property Parent: TORTreeNode read GetParent; property Caption: string read FCaption write SetCaption; end; TNodeCaptioningEvent = procedure(Sender: TObject; var Caption: string) of object; TORTreeView = class(TCaptionTreeView) private FOnDragging: TORDraggingEvent; FDelim: Char; FPiece: integer; FOnAddition: TTVExpandedEvent; FAccessible: IAccessible; FShortNodeCaptions: boolean; FOnNodeCaptioning: TNodeCaptioningEvent; procedure WMGetObject(var Message: TMessage); message WM_GETOBJECT; procedure SetShortNodeCaptions(const Value: boolean); protected procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY; function CreateNode: TTreeNode; override; function GetHorzScrollPos: integer; procedure SetHorzScrollPos(Value: integer); function GetVertScrollPos: integer; procedure SetVertScrollPos(Value: integer); procedure SetNodeDelim(const Value: Char); procedure SetNodePiece(const Value: integer); public constructor Create(AOwner: TComponent); override; procedure MakeAccessible(Accessible: IAccessible); function FindPieceNode(Value: string; ParentDelim: Char = #0; StartNode: TTreeNode = nil): TORTreeNode; overload; function FindPieceNode(Value: string; APiece: integer; ParentDelim: Char = #0; StartNode: TTreeNode = nil): TORTreeNode; overload; procedure RenameNodes; function GetExpandedIDStr(APiece: integer; ParentDelim: char = #0): string; procedure SetExpandedIDStr(APiece: integer; const Value: string); overload; procedure SetExpandedIDStr(APiece: integer; ParentDelim: char; const Value: string); overload; function GetNodeID(Node: TORTreeNode; ParentDelim: Char = #0): string; overload; function GetNodeID(Node: TORTreeNode; APiece: integer; ParentDelim: Char = #0): string; overload; published property Caption; property NodeDelim: Char read FDelim write SetNodeDelim default '^'; property NodePiece: integer read FPiece write SetNodePiece; property OnAddition: TTVExpandedEvent read FOnAddition write FOnAddition; property OnDragging: TORDraggingEvent read FOnDragging write FOnDragging; property HorzScrollPos: integer read GetHorzScrollPos write SetHorzScrollPos default 0; property VertScrollPos: integer read GetVertScrollPos write SetVertScrollPos default 0; property ShortNodeCaptions: boolean read FShortNodeCaptions write SetShortNodeCaptions default False; property OnNodeCaptioning: TNodeCaptioningEvent read FOnNodeCaptioning write FOnNodeCaptioning; end; TORCBImageIndexes = class(TComponent) private FImages: TCustomImageList; FImageChangeLink: TChangeLink; FCheckedEnabledIndex: integer; FGrayedEnabledIndex: integer; FUncheckedEnabledIndex: integer; FCheckedDisabledIndex: integer; FGrayedDisabledIndex: integer; FUncheckedDisabledIndex: integer; protected procedure SetCheckedDisabledIndex(const Value: integer); procedure SetCheckedEnabledIndex(const Value: integer); procedure SetGrayedDisabledIndex(const Value: integer); procedure SetGrayedEnabledIndex(const Value: integer); procedure SetUncheckedDisabledIndex(const Value: integer); procedure SetUncheckedEnabledIndex(const Value: integer); procedure ImageListChanged(Sender: TObject); procedure Notification(AComponent: TComponent; Operation: TOperation); override; function IdxString: string; procedure SetIdxString(Value: string); procedure SetImages(const Value: TCustomImageList); public constructor Create(AOwner: TComponent); override; destructor Destroy; override; published property CheckedEnabledIndex: integer read FCheckedEnabledIndex write SetCheckedEnabledIndex; property CheckedDisabledIndex: integer read FCheckedDisabledIndex write SetCheckedDisabledIndex; property GrayedEnabledIndex: integer read FGrayedEnabledIndex write SetGrayedEnabledIndex; property GrayedDisabledIndex: integer read FGrayedDisabledIndex write SetGrayedDisabledIndex; property UncheckedEnabledIndex: integer read FUncheckedEnabledIndex write SetUncheckedEnabledIndex; property UncheckedDisabledIndex: integer read FUncheckedDisabledIndex write SetUncheckedDisabledIndex; end; TGrayedStyle = (gsNormal, gsQuestionMark, gsBlueQuestionMark); TORCheckBox = class(TCheckBox) private FStringData: string; FCanvas: TCanvas; FGrayedToChecked: boolean; FCustomImagesOwned: boolean; FCustomImages: TORCBImageIndexes; FGrayedStyle: TGrayedStyle; FWordWrap: boolean; FAutoSize: boolean; FSingleLine: boolean; FSizable: boolean; FGroupIndex: integer; FAllowAllUnchecked: boolean; FRadioStyle: boolean; FAssociate: TControl; FFocusOnBox: boolean; procedure SetFocusOnBox(value: boolean); procedure CNMeasureItem (var Message: TWMMeasureItem); message CN_MEASUREITEM; procedure CNDrawItem (var Message: TWMDrawItem); message CN_DRAWITEM; procedure CMFontChanged (var Message: TMessage); message CM_FONTCHANGED; procedure CMEnabledChanged (var Message: TMessage); message CM_ENABLEDCHANGED; procedure WMLButtonDblClk (var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK; procedure WMSize (var Message: TWMSize); message WM_SIZE; procedure BMSetCheck (var Message: TMessage); message BM_SETCHECK; procedure BMGetCheck (var Message: TMessage); message BM_GETCHECK; procedure BMGetState (var Message: TMessage); message BM_GETSTATE; function GetImageList: TCustomImageList; function GetImageIndexes: string; procedure SetImageIndexes(const Value: string); procedure SetImageList(const Value: TCustomImageList); procedure SetWordWrap(const Value: boolean); function GetCaption: TCaption; procedure SetCaption(const Value: TCaption); procedure SyncAllowAllUnchecked; procedure SetAllowAllUnchecked(const Value: boolean); procedure SetGroupIndex(const Value: integer); procedure SetRadioStyle(const Value: boolean); procedure SetAssociate(const Value: TControl); protected procedure SetAutoSize(Value: boolean); override; procedure GetDrawData(CanvasHandle: HDC; var Bitmap: TBitmap; var FocRect, Rect: TRect; var DrawOptions: UINT; var TempBitMap: boolean); procedure DrawItem(const DrawItemStruct: TDrawItemStruct); dynamic; procedure Toggle; override; procedure CreateParams(var Params: TCreateParams); override; procedure SetGrayedStyle(Value: TGrayedStyle); constructor ListViewCreate(AOwner: TComponent; ACustomImages: TORCBImageIndexes); procedure CreateCommon(AOwner: TComponent); property CustomImages: TORCBImageIndexes read FCustomImages; procedure SetParent(AParent: TWinControl); override; procedure UpdateAssociate; procedure Notification(AComponent: TComponent; Operation: TOperation); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure AutoAdjustSize; property SingleLine: boolean read FSingleLine; property StringData: string read FStringData write FStringData; published property FocusOnBox: boolean read FFocusOnBox write SetFocusOnBox default false; property GrayedStyle: TGrayedStyle read FGrayedStyle write SetGrayedStyle default gsNormal; property GrayedToChecked: boolean read FGrayedToChecked write FGrayedToChecked default TRUE; property ImageIndexes: string read GetImageIndexes write SetImageIndexes; property ImageList: TCustomImageList read GetImageList write SetImageList; property WordWrap: boolean read FWordWrap write SetWordWrap default FALSE; property AutoSize: boolean read FAutoSize write SetAutoSize default FALSE; property Caption: TCaption read GetCaption write SetCaption; property AllowAllUnchecked: boolean read FAllowAllUnchecked write SetAllowAllUnchecked default TRUE; property GroupIndex: integer read FGroupIndex write SetGroupIndex default 0; property RadioStyle: boolean read FRadioStyle write SetRadioStyle default FALSE; property Associate: TControl read FAssociate write SetAssociate; property OnEnter; property OnExit; end; TORListView = class(TListView) private protected procedure WMNotify(var Message: TWMNotify); message WM_NOTIFY; procedure LVMSetColumn(var Message: TMessage); message LVM_SETCOLUMN; procedure LVMSetColumnWidth(var Message: TMessage); message LVM_SETCOLUMNWIDTH; end; { TORPopupMenu and TORMenuItem are not available at design time, since they would offer little value there. They are currently used for dynamic menu creation } TORPopupMenu = class(TPopupMenu) private FData: string; public property Data: string read FData write FData; end; TORMenuItem = class(TMenuItem) private FData: string; public property Data: string read FData write FData; end; (* TORCalendar = class(TCalendar) protected procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override; end; *) TKeyClickPanel = class(TPanel) protected procedure KeyDown(var Key: Word; Shift: TShiftState); override; end; TKeyClickRadioGroup = class(TRadioGroup) protected procedure KeyDown(var Key: Word; Shift: TShiftState); override; procedure Click; override; public constructor Create(AOwner: TComponent); override; end; TCaptionListBox = class(TListBox) private FHoverItemPos: integer; FAccessible: IAccessible; FRightClickSelect: boolean; // When true, a right click selects teh item FHintOnItem: boolean; procedure SetCaption(const Value: string); function GetCaption: string; procedure WMGetObject(var Message: TMessage); message WM_GETOBJECT; procedure WMRButtonUp(var Message: TWMRButtonUp); message WM_RBUTTONUP; procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE; protected FCaptionComponent: TStaticText; procedure DoEnter; override; public procedure MakeAccessible( Accessible: IAccessible); published property RightClickSelect: boolean read FRightClickSelect write FRightClickSelect default FALSE; property Caption: string read GetCaption write SetCaption; //Make the ListBox's hint contain the contents of the listbox Item the mouse is currently over. property HintOnItem: boolean read FHintOnItem write FHintOnItem default FALSE; end; TCaptionCheckListBox = class(TCheckListBox) private procedure SetCaption(const Value: string); function GetCaption: string; protected FCaptionComponent: TStaticText; published property Caption: string read GetCaption write SetCaption; end; TCaptionMemo = class(TMemo) private procedure SetCaption(const Value: string); function GetCaption: string; protected FCaptionComponent: TStaticText; published property Caption: string read GetCaption write SetCaption; end; TCaptionEdit = class(TEdit) private procedure SetCaption(const Value: string); function GetCaption: string; protected FCaptionComponent: TStaticText; published property Align; property Caption: string read GetCaption write SetCaption; end; TCaptionRichEdit = class(TRichEdit) private FAccessible: IAccessible; procedure WMGetObject(var Message: TMessage); message WM_GETOBJECT; protected FCaption: string; public procedure MakeAccessible(Accessible: IAccessible); published property Align; property Caption: string read FCaption write FCaption; end; TCaptionComboBox = class(TComboBox) private procedure SetCaption(const Value: string); function GetCaption: string; protected FCaptionComponent: TStaticText; published property Caption: string read GetCaption write SetCaption; end; TCaptionListView = class(TListView) published property Caption; end; TCaptionStringGrid = class(TStringGrid) private FJustToTab: boolean; FCaption: string; FAccessible: IAccessible; procedure WMGetObject(var Message: TMessage); message WM_GETOBJECT; protected procedure KeyUp(var Key: Word; Shift: TShiftState); override; public procedure MakeAccessible( Accessible: IAccessible); procedure IndexToColRow( index: integer; var Col: integer; var Row: integer); function ColRowToIndex( Col: integer; Row: Integer): integer; published property Caption: string read FCaption write FCaption; property JustToTab: boolean read FJustToTab write FJustToTab default FALSE; end; function FontWidthPixel(FontHandle: THandle): Integer; function FontHeightPixel(FontHandle: THandle): Integer; function ItemTipKeyHook(Code: Integer; wParam: WPARAM; lParam: LPARAM): LRESULT; StdCall; {I may have messed up my Windows.pas file, but mine defines NotifyWinEvent without a stdcall.} procedure GoodNotifyWinEvent(event: DWORD; hwnd: HWND; idObject, idChild: Longint); stdcall; function CalcShortName( LongName: string; PrevLongName: string): string; {Returns True if any one of 3 mouse buttons are down left, right, or middle} function IsAMouseButtonDown : boolean; implementation // --------------------------------------------------------------------------- {$R ORCTRLS} uses uAccessAPI; const ALPHA_DISTRIBUTION: array[0..100] of string[3] = ('',' ','ACE','ADG','ALA','AMI','ANA','ANT', 'ARE','ASU','AZO','BCP','BIC','BOO','BST','CAF','CAR','CD6','CHE','CHO','CMC','CON','CPD', 'CVI','DAA','DEF','DEP','DIA','DIH','DIP','DP ','EAR','EM ','EPI','ETH','F2G','FIB','FML', 'FUM','GEL','GLU','GPQ','HAL','HEM','HIS','HUN','HYL','IDS','IND','INT','ISO','KEX','LAN', 'LEV','LOY','MAG','MAX','MER','MET','MIC','MON','MUD','NAI','NEU','NIT','NUC','OMP','OTH', 'P42','PAR','PEN','PHA','PHO','PLA','POL','PRA','PRO','PSE','PYR','RAN','REP','RIB','SAA', 'SCL','SFL','SMO','SPO','STR','SUL','TAG','TET','THI','TOL','TRI','TRY','UNC','VAR','VIT', 'WRO','ZYM',#127#127#127); CBO_CYMARGIN = 8; // vertical whitespace in the edit portion of combobox CBO_CXBTN = 13; // width of drop down button in combobox CBO_CXFRAME = 5; // offset to account for frame around the edit part of combobox NOREDRAW = 0; // suspend screen updates DOREDRAW = 1; // allow screen updates KEY_TIMER_DELAY = 500; // 500 ms delay after key up before OnKeyPause called KEY_TIMER_ID = 5800; // arbitrary, use high number in case TListBox uses timers { use high word to pass positioning flags since listbox is limited to 32767 items } //SFI_TOP = $80000000; // top of listbox (decimal value: -2147483648) //SFI_END = $90000000; // end of listbox (decimal value: -1879048192) SFI_TOP = -2147483646; // top of listbox (hex value: $80000001) SFI_END = -1879048192; // end of listbox (hex value: $90000000) CheckWidth = 15; // CheckBox Width space to reserve for TORListBox CheckComboBtnHeight = 21; MaxNeedDataLen = 64; type TItemTip = class(TCustomControl) private FShowing: Boolean; // true when itemtip is visible FListBox: TORListBox; // current listbox displaying itemtips FListItem: integer; FPoint: TPoint; FSelected: boolean; FTabs: array[0..MAX_TABS] of Integer; // Holds the pixel offsets for tabs procedure GetTabSettings; protected constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure CreateParams(var Params: TCreateParams); override; procedure Paint; override; procedure Hide; procedure UpdateText(CatchMouse: Boolean); procedure Show(AListBox: TORListBox; AnItem: Integer; APoint: TPoint; CatchMouse: Boolean); end; TSizeRatio = class // relative sizes and positions for resizing CLeft: Extended; CTop: Extended; CWidth: Extended; CHeight: Extended; constructor Create(ALeft, ATop, AWidth, AHeight: Extended); end; var uKeyHookHandle: HHOOK; // handle to capture key events & hide ItemTip window uItemTip: TItemTip; // ItemTip window uItemTipCount: Integer; // number of ItemTip clients uNewStyle: Boolean; // True if using Windows 95 interface { General functions and procedures --------------------------------------------------------- } function ClientWidthOfList(AListBox: TORListBox): Integer; begin with AListBox do begin Result := Width; if BorderStyle = bsSingle then begin Dec(Result, 1); if Ctl3D then Dec(Result, 1); end; end; Dec(Result, GetSystemMetrics(SM_CXVSCROLL)); end; function FontWidthPixel(FontHandle: THandle): Integer; { return in pixels the average character width of the font passed in FontHandle } var DC: HDC; SaveFont: HFont; Extent: TSize; begin DC := GetDC(0); try SaveFont := SelectObject(DC, FontHandle); try GetTextExtentPoint32(DC, 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz', 52, Extent); Result := Trunc((Extent.cx / 26 + 1) / 2); // Round() doesn't line up with dialog units finally SelectObject(DC, SaveFont); end; finally ReleaseDC(0, DC); end; end; function FontHeightPixel(FontHandle: THandle): Integer; { return in pixels the height of the font passed in FontHandle } var DC: HDC; SaveFont: HFont; FontMetrics: TTextMetric; begin DC := GetDC(0); SaveFont := SelectObject(DC, FontHandle); GetTextMetrics(DC, FontMetrics); Result := FontMetrics.tmHeight; SelectObject(DC, SaveFont); ReleaseDC(0, DC); end; function HigherOf(i, j: Integer): Integer; { returns the greater of two integers } begin Result := i; if j > i then Result := j; end; function LowerOf(i, j: Integer): Integer; { returns the lesser of two integers } begin Result := i; if j < i then Result := j; end; function Piece(const S: string; Delim: char; PieceNum: Integer): string; { returns the Nth piece (PieceNum) of a string delimited by Delim } var i: Integer; Strt, Next: PChar; begin i := 1; Strt := PChar(S); Next := StrScan(Strt, Delim); while (i < PieceNum) and (Next <> nil) do begin Inc(i); Strt := Next + 1; Next := StrScan(Strt, Delim); end; if Next = nil then Next := StrEnd(Strt); if i < PieceNum then Result := '' else SetString(Result, Strt, Next - Strt); end; procedure SetPiece(var x: string; Delim: Char; PieceNum: Integer; const NewPiece: string); { sets the Nth piece (PieceNum) of a string to NewPiece, adding delimiters as necessary } var i: Integer; Strt, Next: PChar; begin i := 1; Strt := PChar(x); Next := StrScan(Strt, Delim); while (i < PieceNum) and (Next <> nil) do begin Inc(i); Strt := Next + 1; Next := StrScan(Strt, Delim); end; if Next = nil then Next := StrEnd(Strt); if i < PieceNum then x := x + StringOfChar(Delim, PieceNum - i) + NewPiece else x := Copy(x, 1, Strt - PChar(x)) + NewPiece + StrPas(Next); end; function IntArrayToString(const IntArray: array of Integer): string; { converts an array of integers to a comma delimited string, 0 element assumed to be count } var i: Integer; begin Result := ''; for i := 1 to IntArray[0] do Result := Result + IntToStr(IntArray[i]) + ','; if Length(Result) > 0 then Delete(Result, Length(Result), 1); end; procedure StringToIntArray(AString: string; var IntArray: array of Integer; AllowNeg: boolean = FALSE); { converts a string to an array of positive integers, count is kept in 0 element } var ANum: Integer; APiece: string; begin FillChar(IntArray, SizeOf(IntArray), 0); repeat if Pos(',', AString) > 0 then begin APiece := Copy(AString, 1, Pos(',', AString) - 1); Delete(AString, 1, Pos(',', AString)); end else begin APiece := AString; AString := EmptyStr; end; ANum := StrToIntDef(Trim(APiece), 0); if(ANum > 0) or (AllowNeg and (ANum < 0)) then begin Inc(IntArray[0]); IntArray[IntArray[0]] := ANum; end; until (Length(AString) = 0) or (IntArray[0] = High(IntArray)); end; function StringBetween(const x, First, Last: string): Boolean; { returns true if x collates between the strings First and Last, not case sensitive } begin Result := True; if (CompareText(x, First) < 0) or (CompareText(x, Last) > 0) then Result := False; end; { ItemTip callback ------------------------------------------------------------------------- } function ItemTipKeyHook(Code: Integer; wParam: WPARAM; lParam: LPARAM): LRESULT; { callback used to hide the item tip window whenever a key is pressed } begin if lParam shr 31 = 0 then uItemTip.Hide; // hide only on key down Result := CallNextHookEx(uKeyHookHandle, Code, wParam, lParam); end; { TItemTip --------------------------------------------------------------------------------- } procedure AddItemTipRef; // kcm begin if uItemTipCount = 0 then uItemTip := TItemTip.Create(Application); // all listboxes share a single ItemTip window Inc(uItemTipCount); end; procedure RemoveItemTipRef; // kcm begin Dec(uItemTipCount); if (uItemTipCount = 0) and (uItemTip <> nil) then uItemTip.Free; end; constructor TItemTip.Create(AOwner: TComponent); { the windows hook allows the item tip window to be hidden whenever a key is pressed } begin inherited Create(AOwner); uKeyHookHandle := SetWindowsHookEx(WH_KEYBOARD, ItemTipKeyHook, 0, GetCurrentThreadID); end; destructor TItemTip.Destroy; { disconnects the windows hook (callback) for keyboard events } begin UnhookWindowsHookEx(uKeyHookHandle); inherited Destroy; uItemTip := nil; end; procedure TItemTip.CreateParams(var Params: TCreateParams); { makes the window so that is can be viewed but not activated (can't get events) } begin inherited CreateParams(Params); Params.Style := WS_POPUP or WS_DISABLED or WS_BORDER; if uNewStyle then Params.ExStyle := WS_EX_TOOLWINDOW; Params.ExStyle := Params.ExStyle or WS_EX_TOPMOST; // - test this!! end; procedure TItemTip.Paint; { displays the caption property for the window within the window } var AString: string; y: integer; begin AString := Caption; with Canvas do begin SetBkMode(Handle, TRANSPARENT); FillRect(ClientRect); y := ((ClientRect.Bottom - ClientRect.Top) - FontHeightPixel(Canvas.Font.Handle)) div 2; //TextOut(ClientRect.Left + 1, ClientRect.Top - 1, AString); // WARNING - Do NOT change the X pos or the tab starting pos - this will cause a missmatch // between the hint window and what the control displayes TabbedTextOut(Handle, 0, y, PChar(AString), Length(AString), MAX_TABS+1, FTabs[0], 0); end; end; procedure TItemTip.Hide; { hides the tip window and makes sure the listbox isn't still capturing the mouse } begin if FShowing then begin { The listbox should retain mousecapture if the left mouse button is still down or it is the dropdown list for a combobox. Otherwise, click events don't get triggered. } with FListBox do if not (csLButtonDown in ControlState) and (FParentCombo = nil) then MouseCapture := False; ShowWindow(Handle, SW_HIDE); FShowing := False; end; end; procedure TItemTip.GetTabSettings; var DX, X, i, count: integer; begin Count := FListBox.FTabPix[0]; FTabs[0] := 1; // Set first tab stop to location 1 for display purposes if(Count = 1) then begin DX := FListBox.FTabPix[1]; X := (DX * 2) - 1; end else begin DX := FontWidthPixel(FListBox.Font.Handle) * 8; // windows tab default is 8 chars X := FListBox.FTabPix[Count]; X := Trunc(X / DX) + 1; X := (X * DX) - 1; // get the next tab position after that which is specified end; for i := 1 to MAX_TABS do begin if(i <= Count) then FTabs[i] := FListBox.FTabPix[i] - 1 else begin FTabs[i] := X; inc(X, DX); end; end; end; procedure TItemTip.UpdateText(CatchMouse: Boolean); var AWidth, ListClientWidth, X: Integer; sr: TRect; begin Cursor := FListBox.Cursor; Canvas.Font := FListBox.Font; if FSelected then begin Canvas.Brush.Color := clHighlight; Canvas.Font.Color := clHighlightText; end else // the item is not selected begin Canvas.Brush.Color := FListBox.ItemTipColor; Canvas.Font.Color := clWindowText; end; Caption := #9 + FListBox.DisplayText[FListItem]; if Copy(Caption, 1, 2) = '__' then Caption := ' '; // so separators don't extend past window GetTabSettings; AWidth := LOWORD(GetTabbedTextExtent(Canvas.Handle, PChar(Caption), Length(Caption), MAX_TABS+1, FTabs[0])); // inherent scrollbar may not always be visible in a long list if FListBox.LongList then ListClientWidth := ClientWidthOfList(FListBox) else ListClientWidth := FListBox.ClientWidth; X := FPoint.X; if(FListBox.FCheckBoxes) then begin dec(ListClientWidth, CheckWidth); inc(X, CheckWidth); end; if AWidth > ListClientWidth then Inc(AWidth, 4) else AWidth := ListClientWidth; if SystemParametersInfo(SPI_GETWORKAREA, 0, @sr, 0) then begin if AWidth < (sr.Right - sr.Left) then begin if (X + AWidth) > sr.Right then X := sr.Right - AWidth; end else X := sr.Left; end; FShowing := True; if (GetCaptureControl = nil) and CatchMouse then FListBox.MouseCapture := True; SetWindowPos(Handle, HWND_TOP, X, FPoint.Y, AWidth, FListBox.ItemHeight, SWP_SHOWWINDOW or SWP_NOACTIVATE); Invalidate; end; procedure TItemTip.Show(AListBox: TORListBox; AnItem: Integer; APoint: TPoint; CatchMouse: Boolean); { sets the canvas properties and window size and text depending on the item in the listbox } begin if not AListBox.Visible then Exit; // added to support DropDown lists FListBox := AListBox; FListItem := AnItem; FPoint := APoint; FSelected := (FListBox.Perform(LB_GETSEL, FListItem, 0) > 0); UpdateText(CatchMouse); end; type TORCBImgIdx = (iiUnchecked, iiChecked, iiGrayed, iiQMark, iiBlueQMark, iiDisUnchecked, iiDisChecked, iiDisGrayed, iiDisQMark, iiFlatUnChecked, iiFlatChecked, iiFlatGrayed, iiRadioUnchecked, iiRadioChecked, iiRadioDisUnchecked, iiRadioDisChecked); const CheckBoxImageResNames: array[TORCBImgIdx] of PChar = ( 'ORCB_UNCHECKED', 'ORCB_CHECKED', 'ORCB_GRAYED', 'ORCB_QUESTIONMARK', 'ORCB_BLUEQUESTIONMARK', 'ORCB_DISABLED_UNCHECKED', 'ORCB_DISABLED_CHECKED', 'ORCB_DISABLED_GRAYED', 'ORCB_DISABLED_QUESTIONMARK', 'ORLB_FLAT_UNCHECKED', 'ORLB_FLAT_CHECKED', 'ORLB_FLAT_GRAYED', 'ORCB_RADIO_UNCHECKED', 'ORCB_RADIO_CHECKED', 'ORCB_RADIO_DISABLED_UNCHECKED', 'ORCB_RADIO_DISABLED_CHECKED'); var ORCBImages: array[TORCBImgIdx] of TBitMap; function GetORCBBitmap(Idx: TORCBImgIdx): TBitmap; begin if(not assigned(ORCBImages[Idx])) then begin ORCBImages[Idx] := TBitMap.Create; ORCBImages[Idx].LoadFromResourceName(HInstance, CheckBoxImageResNames[Idx]); end; Result := ORCBImages[Idx]; end; procedure DestroyORCBBitmaps; far; var i: TORCBImgIdx; begin for i := low(TORCBImgIdx) to high(TORCBImgIdx) do begin if(assigned(ORCBImages[i])) then ORCBImages[i].Free; end; end; { TORStaticText } procedure TORStaticText.DoEnter; begin inherited DoEnter; if Assigned(FOnEnter) then FOnEnter(Self); end; procedure TORStaticText.DoExit; begin inherited DoExit; if Assigned(FOnExit) then FOnExit(Self); end; { TORStrings } function TORStrings.Add(const S: string): integer; var RealVerification: Boolean; begin RealVerification := Verification; Verification := False; //Disable verification while lists are not matched result := FPlainText.Add(Translator(S)); Verification := RealVerification; MList.Insert(result, S); //Don't need to here because MList never gets custom handlers end; procedure TORStrings.Clear; var RealVerification: Boolean; begin Verify; MList.Clear; RealVerification := Verification; Verification := False; FPlainText.Clear; Verification := RealVerification; end; constructor TORStrings.Create(PlainText: TStrings; Translator: TTranslator); begin MList := TStringList.Create; FPlainText := PlainText; FTranslator := Translator; FVerification := False; end; procedure TORStrings.Delete(index: integer); var RealVerification: Boolean; begin Verify; MList.Delete(index); RealVerification := Verification; Verification := False; FPlainText.Delete(index); Verification := RealVerification; end; destructor TORStrings.Destroy; begin MList.Free; inherited; end; function TORStrings.Get(index: integer): string; begin Verify; result := MList[index]; end; function TORStrings.GetCount: integer; begin Verify; result := MList.Count; end; function TORStrings.GetObject(index: integer): TObject; begin Verify; result := FPlainText.Objects[index]; end; function TORStrings.IndexOf(const S: string): Integer; begin Verify; Result := FPlainText.IndexOf(S); end; procedure TORStrings.Insert(Index: Integer; const S: string); var RealVerification: Boolean; begin Verify; MList.Insert(index, S); RealVerification := Verification; Verification := False; FPlainText.Insert(index, Translator(S)); Verification := RealVerification; end; procedure TORStrings.Put(Index: Integer; const S: string); var RealVerification: Boolean; begin //If this method weren't overridden, the listbox would forget which item was selected. MList[Index] := S; RealVerification := Verification; Verification := False; //Disable verification while lists are not matched FPlainText[Index] := Translator(S); Verification := RealVerification; end; procedure TORStrings.PutObject(index: integer; Value: TObject); begin FPlainText.Objects[index] := Value; end; procedure TORStrings.SetUpdateState(Value: boolean); begin if Value then FPlainText.BeginUpdate else FPlainText.EndUpdate; end; procedure TORStrings.Verify; var Errors: TStringList; i: integer; M: string; Plain: string; TotalCount: integer; begin if Verification then begin if not Assigned(FPlainText) then raise Exception.Create( 'ORStrings is missing PlainText property.'); if not Assigned(FTranslator) then raise Exception.Create( 'ORStrings is missing Translator property.'); Errors := TStringList.Create; try TotalCount := MList.Count; if MList.Count <> PlainText.Count then begin Errors.Add('M string count:'+IntToStr(MList.Count)); Errors.Add('Plain string count:'+IntToStr(PlainText.Count)); if PlainText.Count > TotalCount then TotalCount := PlainText.Count; end; for i := 0 to TotalCount - 1 do begin if i >= MList.Count then Errors.Add('PlainText['+IntToStr(i)+']: '+PlainText[i]) else if i >= PlainText.Count then Errors.Add('ORStrings['+IntToStr(i)+']: '+Translator(MList[i])) else begin M := Translator(MList[i]); Plain := PlainText[i]; if M <> Plain then begin if UpperCase(M) = UpperCase(Plain) then //Listboxes don't always sort cases right, so we give them a little help here. begin PlainText[i] := M; end else begin Errors.Add('PlainText['+IntToStr(i)+']: '+Plain); Errors.Add('ORStrings['+IntToStr(i)+']: '+M); end; end; end; end; if Errors.Count > 0 then begin Errors.Insert( 0, 'OR strings are out of sync with plain text strings :'); raise Exception.Create( Errors.Text); end; finally Errors.Free; end; end; end; { TORListBox ------------------------------------------------------------------------------- } constructor TORListBox.Create(AOwner: TComponent); { sets initial values for fields used by added properties (ItemTip, Reference, Tab, LongList) } begin inherited Create(AOwner); AddItemTipRef; // kcm FTipItem := -1; FItemTipColor := clWindow; FItemTipEnable := True; FLastItemIndex := -1; FFromSelf := False; FDelimiter := '^'; FWhiteSpace := ' '; FLongList := False; FFromNeedData := False; FFirstLoad := True; FCurrentTop := -1; FFocusIndex := -1; ShowHint := True; FHideSynonyms := FALSE; FSynonymChars := '<>'; FTabPosInPixels := False; FRightClickSelect := FALSE; FCheckBoxes := FALSE; FFlatCheckBoxes := TRUE; FCaseChanged := TRUE; FLookupPiece := 0; end; destructor TORListBox.Destroy; { ensures that the special records associated with each listbox item are disposed } begin FMItems.Free; if uItemTip <> nil then uItemTip.Hide; DestroyItems; RemoveItemTipRef; //kcm inherited Destroy; end; procedure TORListBox.CreateParams(var Params: TCreateParams); { ensures that the listbox can support tab stops } begin inherited CreateParams(Params); with Params do Style := Style or LBS_USETABSTOPS; end; procedure TORListBox.CreateWnd; { makes sure that actual (rather than 'intercepted') values are restored from FSaveItems (FSaveItems is part of TCustomListBox), necessary if window is recreated by property change also gets the first bolus of data in the case of a LongList } var RealVerification: Boolean; begin FFromSelf := True; RealVerification := True; if Assigned( FMItems ) then begin RealVerification := FMItems.Verification; FMItems.Verification := False; end; inherited CreateWnd; if Assigned( FMItems ) then begin FMItems.Verification := RealVerification; FMItems.Verify; end; FFromSelf := False; if FTabPos[0] > 0 then SetTabStops; end; procedure TORListBox.Loaded; { after the properties are loaded, get the first data bolus for a LongList } begin inherited; if FLongList then FWaterMark := Items.Count; SetTabStops; end; procedure TORListBox.DestroyWnd; { makes sure that actual (rather than 'intercepted') values are saved to FSaveItems (FSaveItems is part of TCustomListBox), necessary if window is recreated by property change } begin FFromSelf := True; inherited DestroyWnd; FFromSelf := False; end; function TORListBox.TextToShow(S: string): string; { returns the text that will be displayed based on the Pieces and TabPosition properties } var i: Integer; begin if FPieces[0] > 0 then begin Result := ''; for i := 1 to FPieces[0] do Result := Result + Piece(S, FDelimiter, FPieces[i]) + FWhiteSpace; Result := TrimRight(Result); end else begin SetString(Result, PChar(S), Length(S)); end; end; function TORListBox.IsSynonym(const TestStr: string): boolean; var i,cnt,len :integer; begin Result := FALSE; if((FHideSynonyms) and (FSynonymChars <> '')) then begin len := length(FSynonymChars); cnt := 0; for i := 1 to len do if(pos(FSynonymChars[i], TestStr)>0) then inc(cnt); if(cnt = len) then Result := TRUE; if assigned(FOnSynonymCheck) then FOnSynonymCheck(Self, TestStr, Result); end; end; function TORListBox.GetDisplayText(Index: Integer): string; { get the item string actually displayed by the listbox rather than what is in Items[n] } var Len: Integer; Buf: array[0..4095] of Char; begin Result := ''; FFromSelf := True; Len := SendMessage(Handle,LB_GETTEXT, Index, Integer(@Buf)); FFromSelf := False; if Len > 0 then begin SetString(Result, Buf, Len); end; end; // The following 7 message handling procedures essentially reimplement the TListBoxStrings // object found in StdCtrls. They do this by intercepting the messages sent by the // TListBoxStrings object and modifying the contents of WParam, LParam, and Result. // This allows TORListBox to use the ItemData pointer that is part of each listbox item // to store its own information yet let the application still use the Objects property // of standard Delphi listboxes. It also makes it possible to implement the Pieces and // TabPosition properties without forcing the listbox to be owner drawn. procedure TORListBox.LBGetItemData(var Message: TMessage); { intercept LB_GETITEMDATA and repoint to UserObject rather than internal value in ItemData } var ItemRec: PItemRec; begin inherited; if not FFromSelf then with Message do begin ItemRec := PItemRec(Result); if(assigned(ItemRec)) then Result := Integer(ItemRec^.UserObject) else Result := 0; end; end; procedure TORListBox.LBSetItemData(var Message: TMessage); { intercept LB_SETITEMDATA as save object in UserObject since ItemData is used interally } var ItemRec: PItemRec; begin if not FFromSelf then with Message do begin FFromSelf := True; ItemRec := PItemRec(SendMessage(Handle,LB_GETITEMDATA, WParam, 0)); // WParam: list index FFromSelf := False; if(assigned(ItemRec)) then ItemRec^.UserObject := TObject(LParam); LParam := Integer(ItemRec); if uItemTip.FShowing and (uItemTip.FListBox = Self) and (uItemTip.FListItem = WParam) then uItemTip.UpdateText(FALSE); end; inherited; end; procedure TORListBox.LBGetText(var Message: TMessage); { intercept LB_GETTEXT and repoint to full item string rather than what's visible in listbox } var ItemRec: PItemRec; Text: string; begin inherited; if (not FFromSelf) and (Message.Result <> LB_ERR) then with Message do begin FFromSelf := True; ItemRec := PItemRec(SendMessage(Handle,LB_GETITEMDATA, WParam, 0)); // WParam: list index FFromSelf := False; if(assigned(ItemRec)) then begin FFromSelf := True; Text := TListBox(self).Items[WParam]; StrCopy(PChar(LParam), PChar(Text)); // LParam: points string buffer Result := Length(Text); // Result: length of string FFromSelf := False; end else begin StrPCopy(PChar(LParam),''); Result := 0; end; end; end; procedure TORListBox.LBGetTextLen(var Message: TMessage); { intercept LB_GETTEXTLEN and return true length of ItemRec^.FullText } { -- in response to HOU-0299-70576, Thanks to Stephen Kirby for this fix! } var ItemRec: PItemRec; begin inherited; if (not FFromSelf) and (Message.Result <> LB_ERR) then with Message do begin FFromSelf := True; ItemRec := PItemRec(SendMessage(Handle, LB_GETITEMDATA, WParam, 0)); if(assigned(ItemRec)) then Result := Length(TListBox(self).Items[WParam]) // Result:length of string else Result := 0; FFromSelf := False; end; end; procedure TORListBox.LBAddString(var Message: TMessage); { intercept LB_ADDSTRING and save full string in separate record. Then rebuild a string that has what's visible (based on Pieces, TabPosition properties) and substitute that in LParam } var ItemRec: PItemRec; begin if not FFromSelf then begin if FLongList then // -- special long list processing - begin begin if FFromNeedData then FDataAdded := True else with Message do begin WParam := FWaterMark; Result := Perform(LB_INSERTSTRING, WParam, LParam); // always insert into short list Exit; end; end; // -- special long list processing - end New(ItemRec); with ItemRec^, Message do begin UserObject := nil; CheckedState := cbUnchecked; FCreatingText := PChar(LParam); end; FCreatingItem := TRUE; inherited; FCreatingItem := FALSE; // insert into list AFTER calling inherited in case the listbox is sorted DoChange; with Message do if Result <> LB_ERR then begin FFromSelf := True; SendMessage(Handle,LB_SETITEMDATA, Result, Integer(ItemRec)); // Result: new item index FFromSelf := False; end else Dispose(ItemRec); end else inherited; end; procedure TORListBox.LBInsertString(var Message: TMessage); { intercepts LB_INSERTSTRING, similar to LBAddString except for special long list processing } var ItemRec: PItemRec; begin if not FFromSelf then begin if FLongList then // -- special long list processing - begin begin if FFromNeedData then begin FDataAdded := True; Inc(FCurrentTop); end else with Message do begin if WParam > FWaterMark then begin // make sure insert above watermark FMItems.MList.Move(WParam,FWaterMark); WParam := FWaterMark; end; Inc(FWaterMark); end; end; // -- special long list processing - end New(ItemRec); with ItemRec^, Message do begin UserObject := nil; CheckedState := cbUnchecked; FCreatingText := PChar(LParam); end; FCreatingItem := TRUE; inherited; FCreatingItem := FALSE; DoChange; with Message do if Result <> LB_ERR then begin FFromSelf := True; SendMessage(Handle,LB_SETITEMDATA, Result, Integer(ItemRec)); // Result: new item index FFromSelf := False; end else Dispose(ItemRec); end else inherited; end; procedure TORListBox.LBDeleteString(var Message: TMessage); { intercept LB_DELETESTRING and dispose the record associated with the item being deleted } var ItemRec: PItemRec; begin with Message do begin FFromSelf := True; ItemRec := PItemRec(SendMessage(Handle,LB_GETITEMDATA, WParam, 0)); // WParam: list index FFromSelf := False; if(assigned(ItemRec)) then begin if FLongList and not FFromNeedData then Dec(FWaterMark); Dispose(ItemRec); end; end; FFromSelf := True; // FFromSelf is set here because, under NT, LBResetContent is called inherited; // when deleting the last string from the listbox. Since ItemRec is FFromSelf := False; // already disposed, it shouldn't be disposed again. DoChange; end; procedure TORListBox.LBResetContent(var Message: TMessage); { intercept LB_RESETCONTENT (list is being cleared) and dispose all records } var ItemCount, i: Integer; ItemRec: PItemRec; begin if not FFromSelf then begin ItemCount := Perform(LB_GETCOUNT, 0, 0); for i := 0 to ItemCount - 1 do begin FFromSelf := True; ItemRec := PItemRec(SendMessage(Handle,LB_GETITEMDATA, i, 0)); FFromSelf := False; Dispose(ItemRec); end; Perform(LB_SETCOUNT, 0, 0); end; // This was casuing pain for ResetItems when FWaterMark was being cleared for short lists if FLongList then FWaterMark := 0; inherited; end; procedure TORListBox.LBSetCurSel(var Message: TMessage); { call DoChange, which calls OnChange event whenever ItemIndex changes } begin inherited; DoChange; end; procedure TORListBox.CMFontChanged(var Message: TMessage); { make sure itemtip and tabs respond to characteristics of the new font } begin inherited; FLargeChange := (Height div ItemHeight) - 1; SetTabStops; end; procedure TORListBox.WMKeyDown(var Message: TWMKeyDown); { intercept the keydown messages so that the listbox can be navigated by using the arrow keys and shifting the focus rectangle rather than generating Click for each keypress } var IsSelected: LongBool; begin //if Message.CharCode in [VK_RETURN, VK_ESCAPE] then inherited; // ignore other keys case Message.CharCode of VK_LBUTTON, VK_RETURN, VK_SPACE: if FocusIndex > -1 then begin if MultiSelect then begin IsSelected := LongBool(Perform(LB_GETSEL, FocusIndex, 0)); Perform(LB_SETSEL, Longint(not IsSelected), FocusIndex); end else Perform(LB_SETCURSEL, FocusIndex, 0); // Send WM_COMMAND here because LBN_SELCHANGE not triggered by LB_SETSEL // and LBN_SELCHANGE is what eventually triggers the Click event. // The LBN_SELCHANGE documentation implies we should send the control id, which is // 32 bits long, in the high word of WPARAM (16 bits). Since that won't work - we'll // try sending the item index instead. //PostMessage() not SendMessage() is Required here for checkboxes, SendMessage() doesn't //Allow the Checkbox state on the control to be updated if CheckBoxes then PostMessage(Parent.Handle, WM_COMMAND, MAKELONG(FocusIndex, LBN_SELCHANGE), LPARAM(Handle)) else SendMessage(Parent.Handle, WM_COMMAND, MAKELONG(FocusIndex, LBN_SELCHANGE), LPARAM(Handle)); end; VK_PRIOR: SetFocusIndex(FocusIndex - FLargeChange); VK_NEXT: SetFocusIndex(FocusIndex + FLargeChange); VK_END: SetFocusIndex(SFI_END); VK_HOME: SetFocusIndex(SFI_TOP); VK_LEFT, VK_UP: SetFocusIndex(FocusIndex - 1); VK_RIGHT, VK_DOWN: SetFocusIndex(FocusIndex + 1); else inherited; end; Message.Result := 0; end; procedure TORListBox.WMLButtonDown(var Message: TWMLButtonDown); { work around for a very ugly problem when the listbox is used with a dropdown combobox when the listbox is used this way (parent=desktop) the click events seem to be ignored } var AnItem: Integer; ScrollRect, ListRect: TRect; ScreenPoint: TSmallPoint; TmpRect: TRect; begin if FParentCombo <> nil then with Message do begin FDontClose := FALSE; ListRect := ClientRect; //+ if FLongList then ListRect.Right := ListRect.Left + ClientWidthOfList(Self); //+ // if the mouse was clicked in the client area set ItemIndex ourselves if PtInRect(ListRect, Point(XPos, YPos)) then //~ begin AnItem := GetIndexFromY(YPos); if AnItem < Items.Count then ItemIndex := AnItem; FParentCombo.FwdClick(FParentCombo); FDontClose := TRUE; end; // if the mouse was clicked on the scrollbar, send a message to make the scrolling happen // this is done with WM_NCLBUTTONDOWN, which is ignored if mousecapture is on, so we have // to turn mousecapture off, then back on since it's needed to hide the listbox with ListRect do ScrollRect := Rect(Right + 1, Top, Self.Width - 2, Bottom); //~ if {(Items.Count > (FLargeChange + 1)) and} PtInRect(ScrollRect, Point(XPos, YPos)) then //~ begin if FLongList then // for long lists begin ScreenPoint := PointToSmallPoint(FScrollBar.ScreenToClient( Self.ClientToScreen(Point(XPos, YPos)))); MouseCapture := False; SendMessage(FScrollBar.Handle, WM_LBUTTONDOWN, Message.Keys, MakeLParam(ScreenPoint.X, ScreenPoint.Y)); MouseCapture := True; end else // for normal lists begin ScreenPoint := PointToSmallPoint(Self.ClientToScreen(Point(XPos, YPos))); MouseCapture := False; SendMessage(Self.Handle, WM_NCLBUTTONDOWN, HTVSCROLL, MakeLParam(ScreenPoint.X, ScreenPoint.Y)); MouseCapture := True; end; end else if(FCheckBoxes) then begin TmpRect := ListRect; TmpRect.Top := TmpRect.Bottom; TmpRect.Right := TmpRect.Left + Width; inc(TmpRect.Bottom, CheckComboBtnHeight); if PtInRect(TmpRect, Point(XPos, YPos)) then begin inc(TmpRect.Left, (TmpRect.right - TmpRect.Left) div 2); FParentCombo.DropPanelBtnPressed(XPos <= TmpRect.Left, FALSE); end; end; end; inherited; end; procedure TORListBox.WMLButtonUp(var Message: TWMLButtonUp); { If the listbox is being used with a dropdown combo, hide the listbox whenever something is clicked. The mouse is captured at this point - this isn't called if clicking scrollbar. } begin if (FParentCombo <> nil) and ((not FDontClose) or (not FCheckBoxes)) then FParentCombo.DroppedDown := False; FDontClose := FALSE; inherited; end; procedure TORListBox.WMRButtonUp(var Message: TWMRButtonUp); { When the RightClickSelect property is true, this routine is used to select an item } var AnItem: Integer; ListRect: TRect; begin if(FRightClickSelect and (FParentCombo = nil)) then with Message do // List Boxes only, not Combo Boxes begin ListRect := ClientRect; //+ if FLongList then ListRect.Right := ListRect.Left + ClientWidthOfList(Self); //+ // if the mouse was clicked in the client area set ItemIndex ourselves if PtInRect(ListRect, Point(XPos, YPos)) then //~ begin AnItem := GetIndexFromY(YPos); if AnItem >= Items.Count then AnItem := -1; end else AnItem := -1; ItemIndex := AnItem; end; inherited; end; procedure TORListBox.WMLButtonDblClk(var Message: TWMLButtonDblClk); { treat a doubleclick in the scroll region as if it were a single click - see WMLButtonDown } var ScrollRect: TRect; ScreenPoint: TSmallPoint; begin if FParentCombo <> nil then with Message do begin if(FCheckBoxes) then FDontClose := TRUE; // if the mouse was clicked on the scrollbar, send a message to make the scrolling happen // this is done with WM_NCLBUTTONDOWN, which is ignored if mousecapture is on, so we have // to turn mousecapture off, then back on since it's needed to hide the listbox with ClientRect do ScrollRect := Rect(Right + 1, Top, Self.Width - 2, Bottom); if (Items.Count > (FLargeChange + 1)) and PtInRect(ScrollRect, Point(XPos, YPos)) then begin if FLongList then // for long lists begin ScreenPoint := PointToSmallPoint(FScrollBar.ScreenToClient( Self.ClientToScreen(Point(XPos, YPos)))); MouseCapture := False; SendMessage(FScrollBar.Handle, WM_LBUTTONDOWN, Message.Keys, MakeLParam(ScreenPoint.X, ScreenPoint.Y)); MouseCapture := True; end else // for normal lists begin ScreenPoint := PointToSmallPoint(Self.ClientToScreen(Point(XPos, YPos))); MouseCapture := False; SendMessage(Self.Handle, WM_NCLBUTTONDOWN, HTVSCROLL, MakeLParam(ScreenPoint.X, ScreenPoint.Y)); MouseCapture := True; end; {if FLongList} end; {if (Items.Count)} end; {if FParentCombo} inherited; end; procedure TORListBox.WMCancelMode(var Message: TMessage); { This message is sent when focus shifts to another window - need to hide the listbox at this point if it is being used with a dropdown combobox. } begin uItemTip.Hide; if FParentCombo <> nil then FParentCombo.DroppedDown := False; inherited; end; procedure TORListBox.WMMove(var Message: TWMMove); { whenever in LongList mode we need to move the scrollbar along with the listbox } begin inherited; if FScrollBar <> nil then AdjustScrollBar; end; procedure TORListBox.WMSize(var Message: TWMSize); { calculate the number of visible items in the listbox whenever it is resized if in LongList mode, size the scrollbar to match the listbox } begin inherited; FLargeChange := (Message.Height div ItemHeight) - 1; if FScrollBar <> nil then AdjustScrollBar; end; procedure TORListBox.WMVScroll(var Message: TWMVScroll); { makes sure the itemtip is hidden whenever the listbox is scrolled } // it would be better if this was done right away (before endscroll, but it seems to mess // up mouse capture (SaveCaptureControl, HideItemTip, RestoreCaptureControl?) begin inherited; if Message.ScrollCode = SB_ENDSCROLL then uItemTip.Hide; end; procedure TORListBox.CMHintShow(var Message: TMessage); { if ShowHint is used to delay showing tip, starts showing ItemTip when hint timer expires } var APoint: TPoint; begin inherited; FItemTipActive := True; GetCursorPos(APoint); APoint := ScreenToClient(APoint); MouseMove([], APoint.X, APoint.Y); // assume nothing in ShiftState for now end; procedure TORListBox.Click; begin inherited Click; DoChange; end; procedure TORListBox.DoChange; { call the OnChange Event if ItemIndex is changed } begin if ItemIndex <> FLastItemIndex then begin FLastItemIndex := ItemIndex; if Assigned(FOnChange) then FOnChange(Self); end; end; procedure TORListBox.DoEnter; { display the item tip window when the listbox gets keyboard focus - if itemtip enabled } begin //if Items.Count > 0 then SetFocusIndex(TopIndex); // this seems to cause problems //Fix For ClearQuest: HDS00001576 //This fix has been commented out, becuase it causes problems { if (Items.Count > 0) and (Not IsAMouseButtonDown()) and (ItemIndex = -1) then SetFocusIndex(TopIndex);//ItemIndex := TopIndex; } inherited DoEnter; end; procedure TORListBox.DoExit; { make sure item tip is hidden for this listbox when focus shifts to something else } begin uItemTip.Hide; FItemTipActive := False; inherited DoExit; end; procedure TORListBox.DestroyItems; var ItemCount,i: Integer; ItemRec: PItemRec; begin if(not FItemsDestroyed) then begin ItemCount := Perform(LB_GETCOUNT, 0, 0); for i := 0 to ItemCount - 1 do begin FFromSelf := True; ItemRec := PItemRec(SendMessage(Handle,LB_GETITEMDATA, i, 0)); FFromSelf := False; if Assigned(ItemRec) then Dispose(ItemRec); end; FItemsDestroyed := TRUE; end; end; procedure TORListBox.ToggleCheckBox(idx: integer); var ItemRec: PItemRec; OldFromSelf: boolean; Rect: TRect; begin if(not FCheckBoxes) or (idx < 0) or (idx >= Items.Count) then exit; OldFromSelf := FFromSelf; FFromSelf := True; ItemRec := PItemRec(SendMessage(Handle,LB_GETITEMDATA, idx, 0)); FFromSelf := OldFromSelf; if(assigned(ItemRec)) then begin if(FAllowGrayed) then begin case ItemRec^.CheckedState of cbUnchecked: ItemRec^.CheckedState := cbGrayed; cbGrayed: ItemRec^.CheckedState := cbChecked; cbChecked: ItemRec^.CheckedState := cbUnchecked; end; end else begin if(ItemRec^.CheckedState = cbUnchecked) then ItemRec^.CheckedState := cbChecked else ItemRec^.CheckedState := cbUnChecked; end; end; Rect := ItemRect(Idx); InvalidateRect(Handle, @Rect, FALSE); if(assigned(FOnClickCheck)) then FOnClickCheck(Self, idx); if(assigned(FParentCombo)) then FParentCombo.UpdateCheckEditBoxText; end; procedure TORListBox.KeyPress(var Key: Char); begin inherited; if (Key = ' ') then ToggleCheckBox(ItemIndex); end; procedure TORListBox.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); { hide the item tip window whenever an item is clicked - ignored if itemtip not enabled} var idx: integer; begin uItemTip.Hide; inherited MouseDown(Button, Shift, X, Y); if(FCheckBoxes) and (X >= 0) and (X <= Width) and (Y >= 0) and (Y <= Height) then begin idx := GetIndexFromY(Y); if(idx >= 0) then begin if(FCheckEntireLine) then ToggleCheckBox(idx) else if(X < CheckWidth) then ToggleCheckBox(idx); end; end; end; procedure TORListBox.MouseMove(Shift: TShiftState; X, Y: Integer); { hide and show the appropriate item tip window as the mouse moves through the listbox } const CATCH_MOUSE = True; var AnItem: Integer; TrueOffset :integer; TipPos: TPoint; begin inherited MouseMove(Shift, X, Y); if (not FItemTipEnable) or (not Application.Active) then Exit; { Make sure mouse really moved before continuing. For some reason, MouseMove gets called every time a navigation key is pressed. If FItemTipActive is true, mouse is pausing over the list.} if (not FItemTipActive) and (X = FLastMouseX) and (Y = FLastMouseY) then Exit; FLastMouseX := X; FLastMouseY := Y; // when captured mouse moving outside listbox if not PtInRect(ClientRect, Point(X, Y)) then begin uItemTip.Hide; FItemTipActive := False; FTipItem := -1; Exit; end; // borrow hint timer to delay first ItemTip if ShowHint and not FItemTipActive then Exit; // when mouse moving within listbox AnItem := GetIndexFromY(Y); TrueOffset := (Y div ItemHeight) + TopIndex; if AnItem <> FTipItem then begin if (AnItem < Items.Count) and ((TrueOffset - TopIndex + 1) * ItemHeight < Height) then begin TipPos := ClientToScreen(Point(0, (TrueOffset - TopIndex) * ItemHeight)); uItemTip.Show(Self, AnItem, TipPos, CATCH_MOUSE); FTipItem := AnItem; end else begin uItemTip.Hide; FTipItem := -1; end; end; end; procedure TORListBox.MeasureItem(Index: Integer; var Height: Integer); var Txt:string; begin if(FHideSynonyms) and (fSynonymChars <> '') then begin if(FCreatingItem) then Txt := FCreatingText else Txt := Items[Index]; if(IsSynonym(Txt)) then Height := 0; end; inherited MeasureItem(Index, Height); end; procedure TORListBox.WMDestroy(var Message: TWMDestroy); begin if(assigned(Owner)) and (csDestroying in Owner.ComponentState) then DestroyItems; inherited; end; procedure TORListBox.CNDrawItem(var Message: TWMDrawItem); begin if(FCheckBoxes) then with Message.DrawItemStruct^ do inc(rcItem.Left, CheckWidth); inherited; end; procedure TORListBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); var Flags: Longint; ItemRec: PItemRec; OldFromSelf :boolean; BMap: TBitMap; i, DY: integer; TmpR: TRect; Neg: boolean; ShowText: string; begin if(assigned(FOnBeforeDraw)) then FOnBeforeDraw(Self, Index, Rect, State); if Assigned(OnDrawItem) then OnDrawItem(Self, Index, Rect, State) else begin Canvas.FillRect(Rect); if Index < Items.Count then begin Flags := DrawTextBiDiModeFlags(DT_SINGLELINE or DT_VCENTER); if not UseRightToLeftAlignment then Inc(Rect.Left, 2) else Dec(Rect.Right, 2); OldFromSelf := FFromSelf; FFromSelf := True; ItemRec := PItemRec(SendMessage(Handle,LB_GETITEMDATA, Index, 0)); // WParam: list index FFromSelf := OldFromSelf; if(FCheckBoxes) then begin if(assigned(ItemRec)) then begin case ItemRec^.CheckedState of cbUnchecked: begin if(FFlatCheckBoxes) then BMap := GetORCBBitmap(iiFlatUnChecked) else BMap := GetORCBBitmap(iiUnchecked); end; cbChecked: begin if(FFlatCheckBoxes) then BMap := GetORCBBitmap(iiFlatChecked) else BMap := GetORCBBitmap(iiChecked); end; else // cbGrayed: begin if(FFlatCheckBoxes) then BMap := GetORCBBitmap(iiFlatGrayed) else BMap := GetORCBBitmap(iiGrayed); end; end; end else begin if(FFlatCheckBoxes) then BMap := GetORCBBitmap(iiFlatGrayed) else BMap := GetORCBBitmap(iiGrayed); end; TmpR := Rect; TmpR.Right := TmpR.Left; dec(TmpR.Left, CheckWidth+1); DY := ((TmpR.Bottom - TmpR.Top) - BMap.Height) div 2; Canvas.Draw(TmpR.Left, TmpR.Top + DY, BMap); end; if(FTabPos[0] > 0) then Flags := (FTabPos[1] * 256) or Flags or DT_TABSTOP or DT_EXPANDTABS; ShowText := GetDisplayText(Index); if(Style <> lbStandard) and (FTabPos[0] > 0) then begin for i := 1 to FTabPix[0] do begin Neg := (FTabPix[i] < 0); if Neg then FTabPix[i] := -FTabPix[i]; inc(FTabPix[i],Rect.Left-1); if Neg then FTabPix[i] := -FTabPix[i]; end; TabbedTextOut(Canvas.Handle, Rect.Left, Rect.Top+1, PChar(ShowText), Length(ShowText), FTabPix[0], FTabPix[1], -1); for i := 1 to FTabPix[0] do begin Neg := (FTabPix[i] < 0); if Neg then FTabPix[i] := -FTabPix[i]; dec(FTabPix[i],Rect.Left-1); if Neg then FTabPix[i] := -FTabPix[i]; end; end else DrawText(Canvas.Handle, PChar(ShowText), Length(ShowText), Rect, Flags); end; end; end; function TORListBox.GetIndexFromY(YPos :integer) :integer; begin if(FHideSynonyms) then begin Result := TopIndex-1; repeat inc(Result); if(Perform(LB_GETITEMHEIGHT, Result, 0) > 0) then dec(YPos,ItemHeight); until((YPos < 0) or (Result >= Items.Count)); end else Result := (YPos div ItemHeight) + TopIndex; end; procedure TORListBox.SetFocusIndex(Value: Integer); { move the focus rectangle to an item and show the item tip window if enabled in the case of a LongList, scroll the list so that new items are loaded appropriately } const CATCH_MOUSE = True; NO_CATCH_MOUSE = False; var ScrollCount, ScrollPos, InitialTop, i: Integer; begin if FLongList then // -- special long list processing - begin begin if (Value = SFI_TOP) or (Value = SFI_END) then // scroll to top or bottom begin if Value = SFI_TOP then ScrollPos := 0 else ScrollPos := 100; ScrollTo(Self, scPosition, ScrollPos); // ScrollTo is scrollbar event FScrollBar.Position := ScrollPos; if ScrollPos = 0 then Value := FFocusIndex else Value := FFocusIndex + FLargeChange; end else begin InitialTop := TopIndex; ScrollCount := Value - InitialTop; ScrollPos := 50; // arbitrary, can be anything from 1-99 if ScrollCount < 0 then // scroll backwards begin if ScrollCount = -FLargeChange then ScrollTo(Self, scPageUp, ScrollPos) else for i := 1 to Abs(ScrollCount) do ScrollTo(Self, scLineUp, ScrollPos); FScrollBar.Position := ScrollPos; Value := Value + (FCurrentTop - InitialTop); end; if ScrollCount > FLargeChange then // scroll forwards begin if ScrollCount = (FLargeChange * 2) then ScrollTo(Self, scPageDown, ScrollPos) else for i := FLargeChange + 1 to ScrollCount do ScrollTo(Self, scLineDown, ScrollPos); FScrollBar.Position := ScrollPos; end; if(FHideSynonyms) then begin while((Perform(LB_GETITEMHEIGHT, Value, 0) = 0) and (Value >= 0) and (value < Items.Count)) do begin if(Value < FFocusIndex) then dec(Value) else inc(Value); end; end; end; end; // -- special long list processing - end if (Value = SFI_TOP) or (Value < 0) then Value := 0; if (Value = SFI_END) or (not (Value < Items.Count)) then Value := Items.Count - 1; FFocusIndex := Value; ItemIndex := Value; if MultiSelect then Perform(LB_SETCARETINDEX, FFocusIndex, 0) // LPARAM=0, scrolls into view else begin // LB_SETCARETINDEX doesn't scroll with single select so we have to do it ourselves // ( a LongList should always come through here - it should never be MultiSelect ) if FocusIndex < TopIndex then TopIndex := FocusIndex else if FocusIndex > (TopIndex + FLargeChange) then TopIndex := HigherOf(FocusIndex - FLargeChange, 0); end; // need to have a way to move the focus rectangle for single select listboxs w/o itemtips // if FItemTipEnable or not MultiSelect then ... Show: if not ItemTipEnable then AWidth := 0? // // can't show the item tip from keyboard input for dropdown combo without causing problems // with mouse capture, post the message to allow the selected attribute to be posted if FItemTipEnable {and (FParentCombo = nil)} then PostMessage(Self.Handle, UM_SHOWTIP, Value, 0); end; procedure TORListBox.UMShowTip(var Message: TMessage); { show item tip, Tip Position in parameters: wParam=X and lParam=Y } const NO_CATCH_MOUSE = False; var TipPos: TPoint; TrueOffset :integer; TmpIdx :integer; begin // if listbox is dropdown combo but control is not focused - if (Parent is TORComboBox) and (FParentCombo <> nil) and (Screen.ActiveControl <> Parent) then Exit; // if listbox is dropdown combo and list is not dropped down - if (FParentCombo <> nil) and (FParentCombo.DroppedDown = False) then Exit; // if control is not focused - if (Screen.ActiveControl <> Self) and (Screen.ActiveControl <> Parent) then Exit; if(FHideSynonyms) then begin TrueOffset := TopIndex; TmpIdx := TopIndex; while((TmpIdx < Message.wParam) and (TmpIdx < Items.Count)) do begin if(Perform(LB_GETITEMHEIGHT, TmpIdx, 0) > 0) then inc(TrueOffset); inc(TmpIdx); end; end else TrueOffset := Message.wParam; TipPos := ClientToScreen(Point(0, (TrueOffset - TopIndex) * ItemHeight)); //uItemTip.Show(Self, FFocusIndex, TipPos, NO_CATCH_MOUSE); uItemTip.Show(Self, FFocusIndex, TipPos, FParentCombo = nil); // if DropDown, no mousecapture end; function TORListBox.GetIEN(AnIndex: Integer): Int64; { return as an integer the first piece of the Item identified by AnIndex } begin if (AnIndex < Items.Count) and (AnIndex > -1) then Result := StrToInt64Def(Piece(Items[AnIndex], FDelimiter, 1), 0) else Result := 0; end; function TORListBox.GetItemIEN: Int64; { return as an integer the first piece of the currently selected item } begin if ItemIndex > -1 then Result := StrToInt64Def(Piece(Items[ItemIndex], FDelimiter, 1), 0) else Result := 0; end; function TORListBox.SelectByIEN(AnIEN: Int64): Integer; { cause the item where the first piece = AnIEN to be selected (sets ItemIndex) } var i: Integer; begin Result := -1; for i := 0 to Items.Count - 1 do if GetIEN(i) = AnIEN then begin ItemIndex := i; Result := i; break; end; end; function TORListBox.SetExactByIEN(AnIEN: Int64; const AnItem: string): Integer; { finds an exact entry (matches IEN) in a list or a long list and returns ItemIndex } var ItemFound: Boolean; i, ListEnd: Integer; begin ItemFound := False; Result := -1; if FLongList then ListEnd := FWaterMark - 1 else ListEnd := Items.Count - 1; for i := 0 to ListEnd do if (GetIEN(i) = AnIEN) and (GetDisplayText(i) = AnItem) then begin ItemIndex := i; Result := i; ItemFound := True; break; end; if FLongList and not ItemFound then begin InitLongList(AnItem); Result := SelectByIEN(AnIEN); end; end; function TORListBox.GetItemID: Variant; { return as a variant the first piece of the currently selected item } begin if ItemIndex > -1 then Result := Piece(Items[ItemIndex], FDelimiter, 1) else Result := ''; end; function TORListBox.SelectByID(const AnID: string): Integer; { cause the item where the first piece = AnID to be selected (sets ItemIndex) } var i: Integer; begin Result := -1; for i := 0 to Items.Count - 1 do if Piece(Items[i], FDelimiter, 1) = AnID then begin ItemIndex := i; Result := i; break; end; end; function TORListBox.GetReference(Index: Integer): Variant; { retrieves a variant value that is associated with an item in a listbox } var ItemRec: PItemRec; begin if (Index < 0) or (Index >= Items.Count) then raise Exception.Create('List Index Out of Bounds'); FFromSelf := True; ItemRec := PItemRec(SendMessage(Handle,LB_GETITEMDATA, Index, 0)); FFromSelf := False; if(assigned(ItemRec)) then Result := ItemRec^.Reference else Result := Null; end; procedure TORListBox.SetReference(Index: Integer; AReference: Variant); { stores a variant value that is associated with an item in a listbox } var ItemRec: PItemRec; begin if (Index < 0) or (Index >= Items.Count) then raise Exception.Create('List Index Out of Bounds'); FFromSelf := True; ItemRec := PItemRec(SendMessage(Handle,LB_GETITEMDATA, Index, 0)); FFromSelf := False; if(assigned(ItemRec)) then ItemRec^.Reference := AReference; end; function TORListBox.AddReference(const S: string; AReference: Variant): Integer; { adds a string to a listbox, along with a variant value to be associated with the string } begin Result := Items.Add(S); SetReference(Result, AReference); end; procedure TORListBox.InsertReference(Index: Integer; const S: string; AReference: Variant); { inserts a string at a position into a listbox, along with its associated variant value } begin Items.Insert(Index, S); SetReference(Index, AReference); end; function TORListBox.IndexOfReference(AReference: Variant): Integer; { looks through the list of References (variants) and returns the index of the first match } var i: Integer; begin Result := -1; for i := 0 to Items.Count - 1 do if GetReference(i) = AReference then begin Result := i; Break; end; end; function TORListBox.GetTabPositions: string; { returns the character based tab stops that are currently set, if any } begin if(FTabPosInPixels) then Result := IntArrayToString(FTabPix) else Result := IntArrayToString(FTabPos); end; procedure TORListBox.SetTabPositions(const Value: string); { converts a string of character position tab stops to an array of integer & sets now tabs } var TabTmp: array[0..MAX_TABS] of Integer; i: Integer; begin StringToIntArray(Value, TabTmp, TRUE); for i := 2 to TabTmp[0] do if (abs(TabTmp[i]) < abs(TabTmp[i - 1])) or (TabTmp[i] = TabTmp[i - 1]) then raise Exception.Create('Tab positions must be in ascending order'); if(FTabPosInPixels) then begin for i := 0 to TabTmp[0] do FTabPix[i] := TabTmp[i]; end else begin for i := 0 to TabTmp[0] do FTabPos[i] := TabTmp[i]; end; SetTabStops; if FTabPos[0] > 0 then FWhiteSpace := #9 else FWhiteSpace := ' '; ResetItems; end; procedure TORListBox.SetTabPosInPixels(const Value: boolean); begin if(FTabPosInPixels <> Value) then begin FTabPosInPixels := Value; SetTabStops; end; end; procedure TORListBox.SetTabStops; { sets new tabs stops based on dialog units, FTabPix array also used by ItemTip } var TabDlg: array[0..MAX_TABS] of Integer; i, AveWidth: Integer; begin FillChar(TabDlg, SizeOf(TabDlg), 0); AveWidth := FontWidthPixel(Self.Font.Handle); if(FTabPosInPixels) then begin FillChar(FTabPos, SizeOf(FTabPos), 0); FTabPos[0] := FTabPix[0]; for i := 1 to FTabPix[0] do begin FTabPos[i] := FTabPix[i] div AveWidth; TabDlg[i] := (FTabPix[i] * 4) div AveWidth; end; end else begin FillChar(FTabPix, SizeOf(FTabPix), 0); FTabPix[0] := FTabPos[0]; for i := 1 to FTabPos[0] do begin // do dialog units first so that pixels gets the same rounding error TabDlg[i] := FTabPos[i] * 4; // 4 dialog units per character FTabPix[i] := (TabDlg[i] * AveWidth) div 4; end; end; TabDlg[0] := FTabPos[0]; Perform(LB_SETTABSTOPS, TabDlg[0], Integer(@TabDlg[1])); Refresh; end; procedure TORListBox.SetHideSynonyms(Value :boolean); var TmpIH :integer; begin if(FHideSynonyms <> Value) then begin if((Value) and (not FLongList)) then raise Exception.Create('Hide Synonyms only allowed on Long Lists'); FHideSynonyms := Value; if(not FHideSynonyms) then begin Style := lbStandard; end else begin if(FSynonymChars = '') then FSynonymChars := '<>'; TmpIH := ItemHeight; Style := lbOwnerDrawVariable; ItemHeight := TmpIH; end; end; end; procedure TORListBox.SetSynonymChars(Value :string); begin if(FSynonymChars <> Value) then begin FSynonymChars := Value; if((Value = '') and (FHideSynonyms)) then SetHideSynonyms(FALSE); if(FHideSynonyms) then begin SetHideSynonyms(FALSE); SetHideSynonyms(TRUE); end; end; end; function TORListBox.GetStyle: TListBoxStyle; begin Result := inherited Style; end; procedure TORListBox.SetStyle(Value: TListBoxStyle); begin if(Value <> lbOwnerDrawVariable) and (FHideSynonyms) then FHideSynonyms := FALSE; if(FCheckBoxes) and (Value = lbStandard) then FCheckBoxes := FALSE; inherited Style := Value; end; procedure TORListBox.SetDelimiter(Value: Char); { change the delimiter used in conjunction with the pieces property (default = '^') } begin FDelimiter := Value; ResetItems; end; function TORListBox.GetPieces: string; { returns the pieces of an item currently selected for display } begin Result := IntArrayToString(FPieces); end; procedure TORListBox.SetPieces(const Value: string); { converts a string of comma-delimited integers into an array of string pieces to display } begin StringToIntArray(Value, FPieces); ResetItems; end; procedure TORListBox.ResetItems; { saves listbox objects then rebuilds listbox including references and user objects } var SaveItems: TList; Strings: TStringList; i, Pos: Integer; ItemRec: PItemRec; SaveListMode: Boolean; RealVerify: Boolean; begin SaveListMode := False; Strings := nil; SaveItems := nil; RealVerify := TORStrings(Items).Verification; try TORStrings(Items).Verification := False; HandleNeeded; // ensures that Items is valid if in the middle of RecreateWnd SaveListMode := FLongList; Strings := TStringList.Create; SaveItems := TList.Create; FLongList := False; // so don't have to track WaterMark FFromSelf := True; for i := 0 to Items.Count - 1 do // put pointers to TItemRec in SaveItems begin ItemRec := PItemRec(SendMessage(Handle, LB_GETITEMDATA, i, 0)); SaveItems.Add(ItemRec); end; Strings.Assign(Items); Items.Clear; // still FromSelf so don't dispose recs FFromSelf := False; for i := 0 to SaveItems.Count - 1 do // use saved ItemRecs to rebuild listbox begin ItemRec := SaveItems[i]; if(assigned(ItemRec)) then begin Pos := Items.AddObject(Strings[i], ItemRec^.UserObject); References[Pos] := ItemRec^.Reference; end; end; finally SaveItems.Free; Strings.Free; TORStrings(Items).Verification := RealVerify; FLongList := SaveListMode; end; end; procedure TORListBox.SetLongList(Value: Boolean); { changes the list box so that it runs in LongList mode (calls OnNeedData) } begin if Value <> FLongList then begin if Value = True then CreateScrollBar else begin FreeScrollBar; if(FHideSynonyms) then SetHideSynonyms(FALSE); end; end; end; procedure TORListBox.AdjustScrollBar; { ensures that the scrollbar used for a long list is placed properly within the listbox } var L, T, W, H, OffsetLT, OffsetWH: Integer; begin if uNewStyle then begin OffsetLT := 2; OffsetWH := 4; end // Win95 else begin OffsetLT := 0; OffsetWH := 0; end; // Win3.1 W := GetSystemMetrics(SM_CXVSCROLL); L := Left + Width - W - OffsetLT; T := Top + OffsetLT; H := Height - OffsetWH; FScrollBar.SetBounds(L, T, W, H); FScrollBar.Invalidate; end; procedure TORListBox.CreateScrollBar; { a long list uses it's own scrollbar (mapped to APLHA_DISTRIBUTION, rather than the listbox's } begin FLongList := True; if MultiSelect then MultiSelect := False; // LongLists do not support multiple selections FScrollBar := TScrollBar.Create(Self); FScrollBar.Kind := sbVertical; FScrollBar.TabStop := False; FScrollBar.ControlStyle := FScrollBar.ControlStyle - [csCaptureMouse]; AdjustScrollBar; FScrollBar.OnScroll := ScrollTo; if FParentCombo = nil then FScrollBar.Parent := Parent else FScrollBar.Parent := FParentCombo.FDropPanel; end; procedure TORListBox.FreeScrollBar; { frees the scrollbar for a longlist (called when LongList property becomes false) } begin FLongList := False; FScrollBar.Free; // don't call from destroy because scrollbar may already be free FScrollBar := nil; end; procedure TORListBox.ForDataUse(Strings: TStrings); { adds or inserts items into a list box after determining the proper collating sequence } var Ascend: Boolean; FirstItem, LastItem: string; i: Integer; begin if Strings.Count = 0 then Exit; { To prevent the problem where the initial list item(s) are returned repeatedly because the DisplayText is longer than the subscript in a cross-reference, compare the last item returned with the first item in the long list. If they are the same, assume the long list is already scrolled to the first item. } if (FDirection = LL_REVERSE) and (FWaterMark < Items.Count) and (CompareText(Strings[Strings.Count - 1], Items[FWaterMark]) = 0) then Exit; FirstItem := TextToShow(Strings[0]); LastItem := TextToShow(Strings[Strings.Count-1]); Ascend := True; case FDirection of LL_REVERSE: if CompareText(FirstItem, LastItem) < 0 then Ascend := False; LL_FORWARD: if CompareText(FirstItem, LastItem) > 0 then Ascend := False; end; case Ascend of // should call AddObject & InsertObject instead? False: case FDirection of LL_REVERSE: for i := Strings.Count - 1 downto 0 do Items.Insert(FInsertAt, Strings[i]); LL_FORWARD: for i := Strings.Count - 1 downto 0 do Items.Add(Strings[i]); end; True: case FDirection of LL_REVERSE: for i := 0 to Strings.Count - 1 do Items.Insert(FInsertAt, Strings[i]); LL_FORWARD: for i := 0 to Strings.Count - 1 do Items.Add(Strings[i]); end; end; end; procedure TORListBox.InitLongList(S: string); { clears the listbox starting at FWaterMark and makes the initial NeedData call } var index: integer; begin if FLongList then begin if LookUpPiece <> 0 then begin index := GetStringIndex(S); if index > -1 then S := Piece(Items[index],Delimiter,LookUpPiece); end; if CaseChanged then S := UpperCase(S); // decrement last char & concat '~' for $ORDER if Length(S) > 0 then S := Copy(S, 1, Length(S) - 1) + Pred(S[Length(S)]) + '~'; NeedData(LL_POSITION, S); if S = '' then TopIndex := 0 else TopIndex := FWaterMark; FScrollBar.Position := PositionThumb; end; end; procedure TORListBox.InsertSeparator; begin if FWaterMark > 0 then begin Items.Insert(FWaterMark,LLS_LINE); Items.Insert(FWaterMark,LLS_SPACE); end; end; procedure TORListBox.ClearTop; { clears a long listbox up to FWaterMark (doesn't clear long list) } var i: Integer; begin SendMessage(Handle, WM_SETREDRAW, NOREDRAW, 0); for i := FWaterMark - 1 downto 0 do Items.Delete(i); SendMessage(Handle, WM_SETREDRAW, DOREDRAW, 0); Invalidate; end; procedure TORListBox.NeedData(Direction: Integer; StartFrom: string); { called whenever the longlist needs more data inserted at a certain point into the listbox } var CtrlPos, CharPos, index: Integer; procedure ClearLong; { clears a portion or all of the longlist to conserve the memory it occupies } var i: Integer; begin case FDirection of LL_REVERSE: for i := Items.Count - 1 downto HigherOf(FCurrentTop + FLargeChange, FWaterMark) do Items.Delete(i); LL_POSITION: for i := Items.Count - 1 downto FWaterMark do Items.Delete(i); LL_FORWARD: for i := FCurrentTop - 1 downto FWaterMark do Items.Delete(i); end; end; begin {NeedData} FFromNeedData := True; FFirstLoad := False; FDataAdded := False; FDirection := Direction; SendMessage(Handle, WM_SETREDRAW, NOREDRAW, 0); if Items.Count > 1000 then ClearLong; case FDirection of LL_REVERSE: if FWaterMark < Items.Count then StartFrom := DisplayText[FWaterMark]; LL_POSITION: begin ClearLong; if StartFrom = #127#127#127 then begin FDirection := LL_REVERSE; StartFrom := ''; end else FDirection := LL_FORWARD; end; LL_FORWARD: if (FWaterMark < Items.Count) and (Items.Count > 0) then StartFrom := DisplayText[Items.Count - 1]; end; if LookupPiece <> 0 then begin index := GetStringIndex(StartFrom); if index > -1 then StartFrom := Piece(Items[index],Delimiter,LookUpPiece); end; if CaseChanged then StartFrom := Uppercase(StartFrom); StartFrom := Copy(StartFrom, 1, 128); // limit length to 128 characters CtrlPos := 0; // make sure no ctrl characters for CharPos := 1 to Length(StartFrom) do if StartFrom[CharPos] in [#0..#31] then begin CtrlPos := CharPos; break; end; if CtrlPos > 0 then StartFrom := Copy(StartFrom, 1, CtrlPos - 1); if FDirection = LL_FORWARD then FInsertAt := Items.Count else FInsertAt := FWaterMark; if Assigned(FOnNeedData) then FOnNeedData(Self, copy(StartFrom, 1, MaxNeedDataLen), FDirection, FInsertAt); SendMessage(Handle, WM_SETREDRAW, DOREDRAW, 0); FFromNeedData := False; Invalidate; end; function TORListBox.PositionThumb: Integer; { returns the proper thumb position for the TopIndex item relative to ALPHA_DISTRIBUTION } var x: string; begin Result := 1; x := DisplayText[TopIndex]; if (FWaterMark > 0) and (TopIndex < FWaterMark) then Result := 0 // short list visible else while (CompareText(ALPHA_DISTRIBUTION[Result], x) < 0) and (Result < 100) do Inc(Result); // only long list visible end; procedure TORListBox.ScrollTo(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer); { event code for the longlist scrollbar, adjusts TopIndex & calls OnNeedData as necessary } var Count, Goal, Dir :integer; Done :boolean; begin uItemTip.Hide; FCurrentTop := TopIndex; if(ScrollCode = scPosition) then begin NeedData(LL_POSITION, ALPHA_DISTRIBUTION[ScrollPos]); case ScrollPos of 0: TopIndex := 0; 1..99: TopIndex := FWaterMark; 100: TopIndex := HigherOf(Items.Count - FLargeChange, 0); end; FFocusIndex := TopIndex; end else if(HideSynonyms) then begin Count := 0; case ScrollCode of scLineUp: begin Dir := -1; Goal := 1; end; scLineDown: begin Dir := 1; Goal := 1; end; scPageUp: begin Dir := -1; Goal := FLargeChange; end; scPageDown: begin Dir := 1; Goal := FLargeChange; end; else exit; end; repeat Done := FALSE; if(Dir > 0) then begin if (FCurrentTop + (FLargeChange * 2)) > (Items.Count - 1) then NeedData(LL_FORWARD, ''); if(FCurrentTop >= Items.Count - 1) then begin FCurrentTop := Items.Count - 1; Done := TRUE; end; end else begin if (FCurrentTop - FLargeChange) < FWaterMark then NeedData(LL_REVERSE, ''); if(FCurrentTop <= 0) then begin FCurrentTop := 0; Done := TRUE; end; end; if(not Done) then begin FCurrentTop := FCurrentTop + Dir; if(Perform(LB_GETITEMHEIGHT, FCurrentTop, 0) > 0) then begin inc(Count); Done := (Count >= Goal); end; end; until Done; TopIndex := FCurrentTop; end else begin case ScrollCode of scLineUp: begin if (FCurrentTop - FLargeChange) < FWaterMark then NeedData(LL_REVERSE, ''); TopIndex := HigherOf(FCurrentTop - 1, 0); end; scLineDown: begin if (FCurrentTop + (FLargeChange * 2)) > (Items.Count - 1) then NeedData(LL_FORWARD, ''); TopIndex := LowerOf(FCurrentTop + 1, Items.Count - 1); end; scPageUp: begin if (FCurrentTop - FLargeChange) < FWaterMark then NeedData(LL_REVERSE, ''); TopIndex := HigherOf(FCurrentTop - FLargeChange, 0); end; scPageDown: begin if (FCurrentTop + (FLargeChange * 2)) > (Items.Count - 1) then NeedData(LL_FORWARD, ''); TopIndex := LowerOf(FCurrentTop + FLargeChange, Items.Count - 1); end; end; end; if (ScrollPos > 0) and (ScrollPos < 100) then ScrollPos := PositionThumb; end; function TORListBox.GetStringIndex(const AString: string): Integer; {returns the index of the first string that partially matches AString} var i: Integer; begin Result := -1; if Length(AString) > 0 then {*KCM*} begin if not FLongList then // Normal List begin Result := SendMessage(Handle, LB_FINDSTRING, -1, Longint(PChar(AString))); if Result = LB_ERR then Result := -1; end else // Long List begin if FScrollBar.Position = 0 then for i := 0 to FWatermark - 1 do begin if CompareText(AString, Copy(DisplayText[i], 1, Length(AString))) = 0 then begin Result := i; break; end; end; if Result < 0 then begin Result := SendMessage(Handle, LB_FINDSTRING, FWaterMark - 1, Longint(PChar(AString))); if Result < FWaterMark then Result := -1; end; {if Result} end; {if not FLongList} end; {if Length(AString)} end; function TORListBox.SelectString(const AString: string): Integer; { causes the first string that partially matches AString to be selected & returns the index } var x: string; i: Integer; index: integer; begin Result := -1; if Length(AString) > 0 then {*KCM*} begin if not FLongList then // Normal List begin Result := SendMessage(Handle, LB_FINDSTRING, -1, Longint(PChar(AString))); if Result = LB_ERR then Result := -1; // use FFocusIndex instead of FocusIndex to reduce flashing FFocusIndex := Result; end else // Long List begin if FScrollBar.Position = 0 then for i := 0 to FWatermark - 1 do begin if CompareText(AString, Copy(DisplayText[i], 1, Length(AString))) = 0 then begin Result := i; break; end; end; if not StringBetween(AString, DisplayText[FWaterMark], DisplayText[Items.Count - 1]) then begin x := AString; if LookupPiece <> 0 then begin index := GetStringIndex(x); if index > -1 then x := Piece(Items[index],Delimiter,LookUpPiece); end; if CaseChanged then x := UpperCase(x); // decrement last char & concat '~' for $ORDER if Length(x) > 0 then x := Copy(x, 1, Length(x) - 1) + Pred(x[Length(x)]) + '~'; NeedData(LL_POSITION, x); end; if Result < 0 then begin Result := SendMessage(Handle, LB_FINDSTRING, FWaterMark - 1, Longint(PChar(AString))); if Result < FWaterMark then Result := -1; if Result >= FWatermark then FocusIndex := Result; uItemTip.Hide; end; {if Result} end; {if not FLongList} end; {if Length(AString)} ItemIndex := Result; FFocusIndex := Result; if Result > -1 then TopIndex := Result; // will scroll item into view if FLongList then FScrollBar.Position := PositionThumb; // done after topindex set end; procedure TORListBox.SetCheckBoxes(const Value: boolean); begin if(FCheckBoxes <> Value) then begin FCheckBoxes := Value; if(Value) then begin if(GetStyle = lbStandard) then SetStyle(lbOwnerDrawFixed); if(inherited MultiSelect) then SetMultiSelect(FALSE); end; invalidate; end; end; procedure TORListBox.SetFlatCheckBoxes(const Value: boolean); begin if(FFlatCheckBoxes <> Value) then begin FFlatCheckBoxes := Value; invalidate; end; end; function TORListBox.GetChecked(Index: Integer): Boolean; var ItemRec: PItemRec; begin Result := False; if Index < 0 then exit; FFromSelf := True; ItemRec := PItemRec(SendMessage(Handle,LB_GETITEMDATA, Index, 0)); FFromSelf := FALSE; if(assigned(ItemRec)) then Result := (ItemRec^.CheckedState = cbChecked) else Result := False; end; procedure TORListBox.SetChecked(Index: Integer; const Value: Boolean); var ItemRec: PItemRec; Rect: TRect; begin FFromSelf := True; ItemRec := PItemRec(SendMessage(Handle,LB_GETITEMDATA, Index, 0)); FFromSelf := False; if (assigned(ItemRec)) and (Value <> (ItemRec^.CheckedState = cbChecked)) then begin if(Value) then ItemRec^.CheckedState := cbChecked else ItemRec^.CheckedState := cbUnChecked; Rect := ItemRect(Index); InvalidateRect(Handle, @Rect, FALSE); if(assigned(FOnClickCheck)) then FOnClickCheck(Self, Index); end; end; function TORListBox.GetCheckedState(Index: Integer): TCheckBoxState; var ItemRec: PItemRec; begin FFromSelf := True; ItemRec := PItemRec(SendMessage(Handle,LB_GETITEMDATA, Index, 0)); FFromSelf := FALSE; if(assigned(ItemRec)) then Result := ItemRec^.CheckedState else Result := cbGrayed; end; procedure TORListBox.SetCheckedState(Index: Integer; const Value: TCheckBoxState); var ItemRec: PItemRec; Rect: TRect; begin FFromSelf := True; ItemRec := PItemRec(SendMessage(Handle,LB_GETITEMDATA, Index, 0)); FFromSelf := False; if (assigned(ItemRec)) and (Value <> ItemRec^.CheckedState) then begin ItemRec^.CheckedState := Value; Rect := ItemRect(Index); InvalidateRect(Handle, @Rect, FALSE); if(assigned(FOnClickCheck)) then FOnClickCheck(Self, Index); end; end; function TORListBox.GetMultiSelect: boolean; begin result := inherited MultiSelect; end; procedure TORListBox.SetMultiSelect(Value: boolean); begin inherited SetMultiSelect(Value); if(Value) then SetCheckBoxes(FALSE); end; function TORListBox.GetCheckedString: string; var i: integer; begin Result := ''; if(FCheckBoxes) then begin for i := 0 to Items.Count-1 do Result := Result + Char(ord('0') + Ord(GetCheckedState(i))); end; end; procedure TORListBox.SetCheckedString(const Value: string); var i: integer; begin for i := 0 to Items.Count-1 do SetCheckedState(i, TCheckBoxState(StrToIntDef(copy(Value,i+1,1),0))); end; function TORListBox.GetMItems: TStrings; begin if not Assigned(FMItems) then FMItems := TORStrings.Create(Tlistbox(Self).Items,TextToShow); result := FMItems; end; procedure TORListBox.SetMItems( Value: TStrings); begin if not Assigned(FMItems) then FMItems := TORStrings.Create(Tlistbox(Self).Items,TextToShow); FMItems.Assign( Value ); end; procedure TORListBox.Clear; begin Items.Clear; inherited; end; procedure TORListBox.SetCaption(const Value: string); begin if not Assigned(FCaption) then begin FCaption := TStaticText.Create(self); FCaption.AutoSize := False; FCaption.Height := 0; FCaption.Width := 0; FCaption.Visible := True; if Assigned (FParentCombo) then FCaption.Parent := FParentCombo else FCaption.Parent := Parent; FCaption.BringToFront; end; FCaption.Caption := Value; end; function TORListBox.GetCaption: string; begin result := FCaption.Caption; end; procedure TORListBox.MakeAccessible(Accessible: IAccessible); begin if Assigned(FAccessible) and Assigned(Accessible) then raise Exception.Create(Caption + ' List Box is already Accessible!') else FAccessible := Accessible; end; procedure TORListBox.WMGetObject(var Message: TMessage); begin if (Message.LParam = integer(OBJID_CLIENT)) and Assigned(FAccessible) then Message.Result := GetLResult(Message.wParam, FAccessible) else inherited; end; { TORDropPanel ----------------------------------------------------------------------------- } const OKBtnTag = 1; CancelBtnTag = 2; procedure TORDropPanel.BtnClicked(Sender: TObject); begin (Owner as TORComboBox).DropPanelBtnPressed((Sender as TSpeedButton).Tag = OKBtnTag, TRUE); end; constructor TORDropPanel.Create(AOwner: TComponent); { Creates a panel the contains the listbox portion of a combobox when the combobox style is orcsDropDown. This is necessary for the combobox to scroll the list properly. The panel acts as the parent for the list, which recieves the scroll events. If the panel is not used, the scroll events to the the Desktop and are not received by the application } begin inherited Create(AOwner); BevelInner := bvNone; BevelOuter := bvNone; BorderStyle := bsNone; Caption :=''; Ctl3D := False; Visible := False; UpdateButtons; end; procedure TORDropPanel.CreateParams(var Params: TCreateParams); { changes parent of panel to desktop so when list is dropped it can overlap other windows } begin inherited CreateParams(Params); if not (csDesigning in ComponentState) then with Params do begin if uNewStyle then Params.ExStyle := Params.ExStyle or WS_EX_TOOLWINDOW; Params.ExStyle := Params.ExStyle or WS_EX_TOPMOST; // - incompatible with ItemTip WindowClass.Style := WindowClass.Style or CS_SAVEBITS; WndParent := GetDesktopWindow; end; end; function TORDropPanel.GetButton(OKBtn: boolean): TSpeedButton; var i: integer; begin Result := nil; if(FButtons) then begin for i := 0 to ControlCount-1 do if(Controls[i] is TSpeedButton) then begin if((OKBtn and ((Controls[i] as TSpeedButton).Tag = OKBtnTag)) or ((not OKBtn) and ((Controls[i] as TSpeedButton).Tag = CancelBtnTag))) then begin Result := TSpeedButton(Controls[i]); break; end; end; end; end; procedure TORDropPanel.ResetButtons; var sb: TSpeedButton; begin sb := GetButton(TRUE); if(assigned(sb)) then sb.Down := FALSE; sb := GetButton(FALSE); if(assigned(sb)) then sb.Down := FALSE; end; procedure TORDropPanel.Resize; var half: integer; btn: TSpeedButton; begin inherited; if(FButtons) then begin btn := GetButton(TRUE); if(assigned(btn)) then begin half := width div 2; btn.Left := 0; btn.Width := Half; btn.Top := Height-btn.Height; btn := GetButton(FALSE); btn.Left := Half; btn.Width := Width - Half; btn.Top := Height-btn.Height; end; end; end; procedure TORDropPanel.UpdateButtons; var btn: TSpeedButton; cbo: TORComboBox; i:integer; begin cbo := (Owner as TORComboBox); if(cbo.FListBox.FCheckBoxes) then begin if(not FButtons) then begin btn := TSpeedButton.Create(Self); btn.Parent := Self; btn.Caption := 'OK'; btn.Height := CheckComboBtnHeight; btn.Tag := OKBtnTag; btn.AllowAllUp := TRUE; btn.GroupIndex := 1; btn.OnClick := BtnClicked; btn := TSpeedButton.Create(Self); btn.Parent := Self; btn.Caption := 'Cancel'; btn.Height := CheckComboBtnHeight; btn.Tag := CancelBtnTag; btn.AllowAllUp := TRUE; btn.GroupIndex := 1; btn.OnClick := BtnClicked; FButtons := TRUE; Resize; end; end else if(FButtons) then begin for i := ControlCount-1 downto 0 do if(Controls[i] is TButton) then Controls[i].Free; FButtons := FALSE; Resize; end; end; procedure TORDropPanel.WMActivateApp(var Message: TMessage); { causes drop down list to be hidden when another application is activated (i.e., Alt-Tab) } begin if BOOL(Message.wParam) = False then with Owner as TORComboBox do DroppedDown := False; end; { TORComboEdit ----------------------------------------------------------------------------- } const ComboBoxImages: array[boolean] of string = ('BMP_CBODOWN_DISABLED', 'BMP_CBODOWN'); procedure TORComboEdit.CreateParams(var Params: TCreateParams); { sets a one line edit box to multiline style so the editing rectangle can be changed } begin inherited CreateParams(Params); Params.Style := Params.Style or ES_MULTILINE or WS_CLIPCHILDREN; end; procedure TORComboEdit.WMKillFocus(var Message: TWMKillFocus); begin inherited; with (Owner as TORComboBox) do begin if (FListBox.FCheckBoxes) and assigned(FEditPanel) and (Message.FocusedWnd <> FListBox.Handle) and ((not assigned(FDropBtn)) or (Message.FocusedWnd <> FDropBtn.Handle)) then begin FEditPanel.FFocused := FALSE; FEditPanel.Invalidate; end; end; end; procedure TORComboEdit.WMSetFocus(var Message: TWMSetFocus); begin inherited; with (Owner as TORComboBox) do begin if FListBox.FCheckBoxes and assigned(FEditPanel) then begin HideCaret(Self.Handle); FEditPanel.FFocused := TRUE; FEditPanel.Invalidate; end; end; end; { TORComboBox ------------------------------------------------------------------------------ } constructor TORComboBox.Create(AOwner: TComponent); { create the editbox and listbox used for the combobox - the default style is Simple } begin inherited Create(AOwner); Width := 121; Height := 97; FLastInput := ''; FDropDownCount := 8; FStyle := orcsSimple; FCheckBoxEditColor := clBtnFace; FListBox := TORListBox.Create(Self); FListBox.Parent := Self; FListBox.TabStop := False; FListBox.OnClick := FwdClick; FListBox.OnDblClick := FwdDblClick; FListBox.OnMouseUp := FwdMouseUp; FListBox.OnNeedData := FwdNeedData; FListBox.OnClickCheck := CheckBoxSelected; FListBox.Visible := True; FItems := FListBox.Items; FMItems := FListBox.MItems; FEditBox := TORComboEdit.Create(Self); FEditBox.Parent := Self; FEditBox.OnChange := FwdChange; FEditBox.OnKeyDown := FwdKeyDown; FEditBox.OnKeyPress := FwdKeyPress; FEditBox.OnKeyUp := FwdKeyUp; FEditBox.Visible := True; fCharsNeedMatch := 1; end; procedure TORComboBox.WMDestroy(var Message: TWMDestroy); begin if(assigned(Owner)) and (csDestroying in Owner.ComponentState) then FListBox.DestroyItems; inherited; end; procedure TORComboBox.CMFontChanged(var Message: TMessage); { resize the edit portion of the combobox to match the font } begin inherited; AdjustSizeOfSelf; end; procedure TORComboBox.WMMove(var Message: TWMMove); { for DropDown style, need to hide listbox whenever control moves (since listbox isn't child) } begin inherited; DroppedDown := False; end; procedure TORComboBox.WMSize(var Message: TWMSize); { whenever control is resized, adjust the components (edit, list, button) within it } begin inherited; AdjustSizeOfSelf; end; procedure TORComboBox.WMTimer(var Message: TWMTimer); begin inherited; if (Message.TimerID = KEY_TIMER_ID) then begin StopKeyTimer; if FListBox.LongList and FChangePending then FwdChangeDelayed; if Assigned(FOnKeyPause) then FOnKeyPause(Self); end; end; function TORComboBox.EditControl: TWinControl; begin if(assigned(FEditPanel)) then Result := FEditPanel else Result := FEditBox; end; procedure TORComboBox.AdjustSizeOfSelf; { adjusts the components of the combobox to fit within the control boundaries } var FontHeight: Integer; cboBtnX,cboBtnY: integer; cboYMargin: integer; begin DroppedDown := False; FontHeight := FontHeightPixel(Self.Font.Handle); if FTemplateField then begin cboYMargin := 0; cboBtnX := 1; cboBtnY := 1; end else begin cboYMargin := CBO_CYMARGIN; cboBtnX := CBO_CXFRAME; cboBtnY := CBO_CXFRAME; end; Height := HigherOf(FontHeight + cboYMargin, Height); // must be at least as high as text EditControl.SetBounds(0, 0, Width, FontHeight + cboYMargin); if(assigned(FEditPanel)) then FEditBox.SetBounds(2, 3, FEditPanel.Width - 4, FEditPanel.Height - 5); if FStyle = orcsDropDown then begin Height := FontHeight + cboYMargin; // DropDown can only be text height FDropBtn.SetBounds(EditControl.Width - CBO_CXBTN - cboBtnX, 0, CBO_CXBTN, EditControl.Height - cboBtnY); end else begin FListBox.SetBounds(0, FontHeight + CBO_CYMARGIN, Width, Height - FontHeight - CBO_CYMARGIN); end; SetEditRect; end; procedure TORComboBox.DropButtonDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); { display the listbox for a DropDown style combobox whenever the drop down button is pressed } begin if (Button = mbLeft) then begin FFromDropBtn := True; DroppedDown := not FDroppedDown; FFromDropBtn := False; end; end; procedure TORComboBox.DropButtonUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); { shift the focus back to the editbox so the focus rectangle doesn't clutter the button } begin if FDroppedDown then FListBox.MouseCapture := True; // do here so 1st buttonup not captured FEditBox.SetFocus; end; procedure TORComboBox.DoEnter; {var key : word;} { select all the text in the editbox when recieve focus - done first so OnEnter can deselect } begin //FEditBox.SelectAll; //Fix For ClearQuest: HDS00001576 //This fix has been commented out, becuase it causes problems { with FListBox do if (Items.Count > 0) and (Not IsAMouseButtonDown()) and (ItemIndex = -1) then begin key := VK_UP; FwdKeyDown(Self,key,[]); //Calling keyUp after key down creates a better mimic of a Keystroke. FwdKeyUp(Self,key,[]); //fixes clearquest: HDS00001418 end; } inherited DoEnter; PostMessage(Handle, UM_GOTFOCUS, 0, 0) end; procedure TORComboBox.UMGotFocus(var Message: TMessage); begin FEditBox.SetFocus; if AutoSelect then FEditBox.SelectAll; end; procedure TORComboBox.DoExit; { make sure DropDown list is raised when losing focus } begin DroppedDown := False; if FKeyTimerActive then begin StopKeyTimer; if FListBox.LongList and FChangePending then FwdChangeDelayed; end; inherited DoExit; end; procedure TORComboBox.Loaded; { we need to call the loaded method for the listbox child (it's not called automatically) } begin inherited Loaded; FListBox.Loaded; end; procedure TORComboBox.FwdChange(Sender: TObject); { allow timer to call FwdChangeDelayed if long list, otherwise call directly } begin if FFromSelf then Exit; FChangePending := True; if FListBox.LongList and FKeyIsDown then Exit; FwdChangeDelayed; end; procedure TORComboBox.FwdChangeDelayed; { when user types in the editbox, find a partial match in the listbox & set into editbox } var SelectIndex: Integer; x: string; begin FChangePending := False; if (not FListItemsOnly) and (Length(FEditBox.Text) > 0) and (FEditBox.SelStart = 0) then Exit; // **KCM** test this! with FEditBox do x := Copy(Text, 1, SelStart); FLastInput := x; SelectIndex := -1; if Length(x) >= CharsNeedMatch then SelectIndex := FListBox.SelectString(x); if (Length(x) < CharsNeedMatch) and (FListBox.ItemIndex > -1) then SelectIndex := FListBox.SelectString(x); if UniqueAutoComplete then SelectIndex := FListBox.VerifyUnique(SelectIndex,x); if FListItemsOnly and (SelectIndex < 0) and (x <> '') then begin FFromSelf := True; x := FLastFound; SelectIndex := FListBox.SelectString(x); FEditBox.Text := GetEditBoxText(SelectIndex); if(not FListBox.FCheckBoxes) then SendMessage(FEditBox.Handle, EM_SETSEL, Length(FEditBox.Text), Length(x)); FFromSelf := False; Exit; // OnChange not called in this case end; FFromSelf := True; if SelectIndex > -1 then begin FEditBox.Text := GetEditBoxText(SelectIndex); FLastFound := x; if(not FListBox.FCheckBoxes) then SendMessage(FEditBox.Handle, EM_SETSEL, Length(FEditBox.Text), Length(x)); end else begin if(FListBox.CheckBoxes) then FEditBox.Text := GetEditBoxText(SelectIndex) else FEditBox.Text := x; // no match, so don't set FLastFound FEditBox.SelStart := Length(x); end; FFromSelf := False; if(not FListBox.FCheckBoxes) then if Assigned(FOnChange) then FOnChange(Self); end; (* procedure TORComboBox.FwdChangeDelayed; { when user types in the editbox, find a partial match in the listbox & set into editbox } var SelectIndex: Integer; x: string; begin FChangePending := False; with FEditBox do x := Copy(Text, 1, SelStart); if x = FLastInput then Exit; // this change event is just removing the selected text FLastInput := x; SelectIndex := FListBox.SelectString(x); FFromSelf := True; if SelectIndex > -1 then begin FEditBox.Text := GetEditBoxText(SelectIndex); if(not FListBox.FCheckBoxes) then SendMessage(FEditBox.Handle, EM_SETSEL, Length(FEditBox.Text), Length(x)); end else begin FEditBox.Text := x; FEditBox.SelStart := Length(x); end; FFromSelf := False; if(not FListBox.FCheckBoxes) then if Assigned(FOnChange) then FOnChange(Self); end; *) procedure TORComboBox.FwdClick(Sender: TObject); { places the text of the item that was selected from the listbox into the editbox } begin if FListBox.ItemIndex > -1 then begin FFromSelf := True; FListBox.FFocusIndex := FListBox.ItemIndex; // FFocusIndex used so ItemTip doesn't flash FEditBox.Text := GetEditBoxText(FListBox.ItemIndex); FLastFound := FEditBox.Text; FFromSelf := False; // not sure why this must be posted (put at the back of the message queue), but for some // reason FEditBox.SelectAll selects successfully then deselects on exiting this procedure if(not FListBox.FCheckBoxes) then PostMessage(FEditBox.Handle, EM_SETSEL, 0, Length(FEditBox.Text)); FEditBox.SetFocus; end; if Assigned(FOnClick) then FOnClick(Self); if(not FListBox.FCheckBoxes) then if Assigned(FOnChange) then FOnChange(Self); // click causes both click & change events end; procedure TORComboBox.FwdDblClick(Sender: TObject); { surfaces the double click event from the listbox so it is available as a combobox property } begin if Assigned(FOnDblClick) then FOnDblClick(Self); end; procedure TORComboBox.FwdKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); { passed selected navigation keys to listbox, applies special handling to backspace and F4 } var i,iPos: Integer; x,AString: string; begin // special case: when default action taken (RETURN) make sure FwdChangeDelayed is called first if (Key = VK_RETURN) and FListBox.LongList and FChangePending then FwdChangeDelayed; StopKeyTimer; // stop timer after control keys so in case an exit event is triggered if Assigned(FOnKeyDown) then FOnKeyDown(Self, Key, Shift); if Key in [VK_PRIOR, VK_NEXT, VK_UP, VK_DOWN] then // navigation begin if (FStyle = orcsDropDown) and not DroppedDown then DroppedDown := True; // handle special case of FocusIndex, WM_KEYDOWN will increment from -1 to 0 if FListBox.ItemIndex = -1 then begin FListBox.FFocusIndex := -1; //Move to correct position when Unique AutoComplete is on. if UniqueAutoComplete then begin AString := Copy(FEditBox.Text, 1, SelStart); iPos := SendMessage(FListBox.Handle, LB_FINDSTRING, -1, Longint(PChar(AString))); if iPos = LB_ERR then iPos := -1; if iPos > -1 then begin FListBox.FFocusIndex := iPos-1; FListBox.ItemIndex := FListBox.FFocusIndex; end; end; end; FListBox.Perform(WM_KEYDOWN, Key, 1); end; if Key in [VK_LBUTTON, VK_RETURN, VK_PRIOR, VK_NEXT, VK_UP, VK_DOWN] then // select item begin FListBox.Perform(WM_KEYDOWN, VK_LBUTTON, 1); FFromSelf := True; if FListBox.ItemIndex > -1 then begin FEditBox.Text := GetEditBoxText(FListBox.ItemIndex); FLastFound := FEditBox.Text; //kcm end; FFromSelf := False; end; // tell parent about RETURN, ESCAPE so that the default action is taken if Key in [VK_RETURN, VK_ESCAPE, VK_TAB] then SendMessage(Parent.Handle, CN_KEYDOWN, Key, 0); if Key = VK_BACK then // backspace begin FFromSelf := True; x := FEditBox.Text; i := FEditBox.SelStart; Delete(x, i + 1, Length(x)); if(FListBox.FCheckBoxes) then FEditBox.Text := GetEditBoxText(ItemIndex) else FEditBox.Text := x; FLastFound := x; FEditBox.SelStart := i; FFromSelf := False; end; if (FStyle = orcsDropDown) and (Key = VK_F4) then DroppedDown := not DroppedDown; // drop if (Key = VK_SPACE) and (FListBox.FCheckBoxes) and (FListBox.ItemIndex > -1) then FListBox.ToggleCheckBox(FListBox.ItemIndex); if (FStyle = orcsDropDown) and (FListBox.FCheckBoxes) then begin if Key = VK_RETURN then DropPanelBtnPressed(TRUE, TRUE); if Key = VK_ESCAPE then DropPanelBtnPressed(FALSE, TRUE); end; FKeyIsDown := True; end; procedure TORComboBox.FwdKeyPress(Sender: TObject; var Key: Char); { prevents return from being used by editbox (otherwise sends a newline & text vanishes) } begin // may want to make the tab beep if tab key (#9) - can't tab until list raised if (Key in [#9, #13]) or (FListBox.FCheckBoxes and (Key = #32)) then begin Key := #0; Exit; end; if Assigned(FOnKeyPress) then FOnKeyPress(Self, Key); end; procedure TORComboBox.FwdKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); { surfaces the key up event from the editbox so it is available as a combobox property } begin FKeyIsDown := False; // tell parent about RETURN, ESCAPE so that the default action is taken if Key in [VK_RETURN, VK_ESCAPE, VK_TAB] then SendMessage(Parent.Handle, CN_KEYUP, Key, 0); if Assigned(FOnKeyUp) then FOnKeyUp(Self, Key, Shift); StartKeyTimer; end; procedure TORComboBox.FwdMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if Assigned(FOnMouseClick) then FOnMouseClick(Self); end; procedure TORComboBox.FwdNeedData(Sender: TObject; const StartFrom: string; Direction, InsertAt: Integer); { surfaces the need data event from the (long) listbox so it is available as a property } begin if Assigned(FOnNeedData) then FOnNeedData(Self, copy(StartFrom, 1, MaxNeedDataLen), Direction, InsertAt); end; procedure TORComboBox.SetDropDownCount(Value: Integer); { when the listbox is dropped, it's sized according to Value (ItemHeight * DropDownCount) } begin if Value > 0 then FDropDownCount := Value; end; procedure TORComboBox.SetDroppedDown(Value: Boolean); { for DropDown combo, display the listbox at the appropriate full screen coordinates } const MIN_ITEMS = 3; // minimum visible items for long list var ScreenPoint: TPoint; DropDownCnt: Integer; PnlHeight: integer; begin if (Value = FDroppedDown) or (FStyle <> orcsDropDown) then Exit; FDroppedDown := Value; if FDroppedDown = True then begin if Assigned(FOnDropDown) then FOnDropDown(Self); if FListBox.LongList then DropDownCnt := HigherOf(FDropDownCount, MIN_ITEMS) else DropDownCnt := LowerOf(FDropDownCount, FListBox.Items.Count); FListBox.SetBounds(0, 0, Width, (FListBox.ItemHeight * DropDownCnt) + CBO_CXFRAME); // need to make this smart enough to drop the list UP when necessary *** ScreenPoint := Self.ClientToScreen(Point(0, EditControl.Height)); PnlHeight := FListBox.Height; if(FListBox.FCheckBoxes) then inc(PnlHeight, CheckComboBtnHeight); FDropPanel.SetBounds(ScreenPoint.X, ScreenPoint.Y, FListBox.Width, PnlHeight); if(FListBox.FCheckBoxes) then begin FDropPanel.ResetButtons; FCheckedState := FListBox.GetCheckedString; end; FDropPanel.Visible := True; FDropPanel.BringToFront; if FListBox.FScrollBar <> nil then FListBox.FScrollBar.BringToFront; if not FFromDropBtn then FListBox.MouseCapture := True; // otherwise ButtonUp captures end else begin if Assigned(FOnDropDownClose) then FOnDropDownClose(Self); FListBox.MouseCapture := False; uItemTip.Hide; FDropPanel.Hide; if(FListBox.FCheckBoxes) and (assigned(FOnChange)) and (FCheckedState <> FListBox.GetCheckedString) then FOnChange(Self); end; end; procedure TORComboBox.SetEditRect; { change the edit rectangle to not hide the dropdown button - taken from SPIN.PAS sample } var Loc: TRect; begin SendMessage(FEditBox.Handle, EM_GETRECT, 0, LongInt(@Loc)); Loc.Bottom := ClientHeight + 1; // +1 is workaround for windows paint bug if FStyle = orcsDropDown then begin Loc.Right := ClientWidth - FDropBtn.Width - CBO_CXFRAME; // edit up to button if(FTemplateField) then inc(Loc.Right,3); end else Loc.Right := ClientWidth - CBO_CXFRAME; // edit in full edit box Loc.Top := 0; if(FTemplateField) then Loc.Left := 2 else Loc.Left := 0; SendMessage(FEditBox.Handle, EM_SETRECTNP, 0, LongInt(@Loc)); end; procedure TORComboBox.SetEditText(const Value: string); { allows the text to change when ItemIndex is changed without triggering a change event } begin FFromSelf := True; FEditBox.Text := Value; FLastFound := FEditBox.Text; FFromSelf := False; PostMessage(FEditBox.Handle, EM_SETSEL, 0, Length(FEditBox.Text)); end; procedure TORComboBox.SetItemIndex(Value: Integer); { set the ItemIndex in the listbox and update the editbox to show the DisplayText } begin with FListBox do begin ItemIndex := Value; { should Value = -1 be handled in the SetFocusIndex procedure itself? or should it be handled by the setting of the ItemIndex property? } if Value = -1 then FFocusIndex := -1 else FocusIndex := Value; uItemTip.Hide; if(FListBox.CheckBoxes) then SetEditText(GetEditBoxText(ItemIndex)) else begin if ItemIndex > -1 then SetEditText(GetEditBoxText(ItemIndex)) else SetEditText(''); end; end; end; function TORComboBox.SelectByIEN(AnIEN: Int64): Integer; begin Result := FListBox.SelectByIEN(AnIEN); SetItemIndex(Result); end; function TORComboBox.SelectByID(const AnID: string): Integer; begin Result := FListBox.SelectByID(AnID); SetItemIndex(Result); end; function TORComboBox.SetExactByIEN(AnIEN: Int64; const AnItem: string): Integer; begin Result := FListBox.SetExactByIEN(AnIEN, AnItem); SetItemIndex(Result); end; procedure TORComboBox.SetStyle(Value: TORComboStyle); { Simple: get rid of dropdown button & panel, make combobox parent of listbox DropDown: create dropdown button & panel, transfer listbox parent to dropdown panel this allows the dropped list to overlap other windows } begin if Value <> FStyle then begin FStyle := Value; if FStyle = orcsSimple then begin if FDropBtn <> nil then FDropBtn.Free; if FDropPanel <> nil then FDropPanel.Free; FDropBtn := nil; FDropPanel := nil; FListBox.FParentCombo := nil; FListBox.Parent := Self; if FListBox.FScrollBar <> nil then FListBox.FScrollBar.Parent := Self; // if long FListBox.Visible := True; end else begin FDropBtn := TBitBtn.Create(Self); if(assigned(FEditPanel) and (csDesigning in ComponentState)) then FEditPanel.ControlStyle := FEditPanel.ControlStyle + [csAcceptsControls]; FDropBtn.Parent := FEditBox; if(assigned(FEditPanel) and (csDesigning in ComponentState)) then FEditPanel.ControlStyle := FEditPanel.ControlStyle - [csAcceptsControls]; FDropBtn.Glyph.LoadFromResourceName(hInstance, ComboBoxImages[inherited Enabled]); FDropBtn.OnMouseDown := DropButtonDown; FDropBtn.OnMouseUp := DropButtonUp; FDropBtn.TabStop := False; FDropBtn.Visible := True; FDropBtn.BringToFront; if not (csDesigning in ComponentState) then begin FDropPanel := TORDropPanel.Create(Self); FDropPanel.Parent := Self; // parent is really the desktop - see CreateParams FListBox.FParentCombo := Self; FListBox.Parent := FDropPanel; if FListBox.FScrollBar <> nil then FListBox.FScrollBar.Parent := FDropPanel; // if long end else begin FListBox.Visible := False; end; Height := EditControl.Height; end; AdjustSizeOfSelf; end; end; procedure TORComboBox.StartKeyTimer; { start (or restart) a timer (done on keyup to delay before calling OnKeyPause) } var ATimerID: Integer; begin if FListBox.LongList or Assigned(FOnKeyPause) then begin StopKeyTimer; ATimerID := SetTimer(Handle, KEY_TIMER_ID, KEY_TIMER_DELAY, nil); FKeyTimerActive := ATimerID > 0; // if can't get a timer, just call the OnKeyPause event immediately if not FKeyTimerActive then Perform(WM_TIMER, KEY_TIMER_ID, 0); end; end; procedure TORComboBox.StopKeyTimer; { stop the timer (done whenever a key is pressed or the combobox no longer has focus) } begin if FKeyTimerActive then begin KillTimer(Handle, KEY_TIMER_ID); FKeyTimerActive := False; end; end; // Since TORComboBox is composed of several controls (FEditBox, FListBox, FDropBtn), the // following functions and procedures map public and published properties to their related // subcomponents. function TORComboBox.AddReference(const S: string; AReference: Variant): Integer; begin Result := FListBox.AddReference(S, AReference); end; procedure TORComboBox.Clear; begin FListBox.Clear; FEditBox.Clear; end; procedure TORComboBox.ClearTop; begin FListBox.ClearTop; end; procedure TORComboBox.ForDataUse(Strings: TStrings); begin FListBox.ForDataUse(Strings); end; procedure TORComboBox.InitLongList(S: string); begin FListBox.InitLongList(S); end; function TORComboBox.IndexOfReference(AReference: Variant): Integer; begin Result := FListBox.IndexOfReference(AReference); end; procedure TORComboBox.InsertReference(Index: Integer; const S: string; AReference: Variant); begin FListBox.InsertReference(Index, S, AReference); end; procedure TORComboBox.InsertSeparator; begin FListBox.InsertSeparator; end; function TORComboBox.GetAutoSelect: Boolean; begin Result := FEditBox.AutoSelect; end; function TORComboBox.GetColor: TColor; begin Result := FListBox.Color; end; function TORComboBox.GetDelimiter: Char; begin Result := FListBox.Delimiter; end; function TORComboBox.GetDisplayText(Index: Integer): string; begin Result := FListBox.DisplayText[Index]; end; function TORComboBox.GetItemHeight: Integer; begin Result := FListBox.ItemHeight; end; function TORComboBox.GetIEN(AnIndex: Integer): Int64; begin Result := FListBox.GetIEN(AnIndex); end; function TORComboBox.GetItemID: Variant; begin Result := FListBox.ItemID; end; function TORComboBox.GetItemIEN: Int64; begin Result := FListBox.ItemIEN; end; function TORComboBox.GetItemIndex: Integer; begin Result := FListBox.ItemIndex; end; function TORComboBox.GetItemTipEnable: Boolean; begin Result := FListBox.ItemTipEnable; end; function TORComboBox.GetItemTipColor: TColor; begin Result := FListBox.ItemTipColor; end; function TORComboBox.GetLongList: Boolean; begin Result := FListBox.LongList; end; function TORComboBox.GetMaxLength: Integer; begin Result := FEditBox.MaxLength; end; function TORComboBox.GetPieces: string; begin Result := FListBox.Pieces; end; function TORComboBox.GetReference(Index: Integer): Variant; begin Result := FListBox.References[Index]; end; function TORComboBox.GetSelLength: Integer; begin Result := FEditBox.SelLength; end; function TORComboBox.GetSelStart: Integer; begin Result := FEditBox.SelStart; end; function TORComboBox.GetSelText: string; begin Result := FEditBox.SelText; end; function TORComboBox.GetShortCount: Integer; begin Result := FListBox.ShortCount; end; function TORComboBox.GetSorted: Boolean; begin Result := FListBox.Sorted; end; function TORComboBox.GetHideSynonyms: boolean; begin Result := FListBox.HideSynonyms; end; function TORComboBox.GetSynonymChars: string; begin result := FListBox.SynonymChars; end; procedure TORComboBox.SetHideSynonyms(Value: boolean); begin FListBox.HideSynonyms := Value; end; procedure TORComboBox.SetSynonymChars(Value: string); begin FListBox.SynonymChars := Value; end; function TORComboBox.GetTabPositions: string; begin Result := FListBox.TabPositions; end; function TORComboBox.GetTabPosInPixels: boolean; begin Result := FListBox.TabPosInPixels; end; function TORComboBox.GetText: string; begin Result := FEditBox.Text; end; procedure TORComboBox.SelectAll; begin FEditBox.SelectAll; end; procedure TORComboBox.SetAutoSelect(Value: Boolean); begin FEditBox.AutoSelect := Value; end; procedure TORComboBox.SetColor(Value: TColor); begin if(not FListBox.CheckBoxes) then FEditBox.Color := Value; FListBox.Color := Value; end; procedure TORComboBox.SetDelimiter(Value: Char); begin FListBox.Delimiter := Value; end; procedure TORComboBox.SetItemHeight(Value: Integer); begin FListBox.ItemHeight := Value; end; procedure TORComboBox.SetItemTipEnable(Value: Boolean); begin FListBox.ItemTipEnable := Value; end; procedure TORComboBox.SetItemTipColor(Value: TColor); begin FListBox.ItemTipColor := Value; end; procedure TORComboBox.SetLongList(Value: Boolean); begin FListBox.LongList := Value; end; procedure TORComboBox.SetMaxLength(Value: Integer); begin FEditBox.MaxLength := Value; end; procedure TORComboBox.SetPieces(const Value: string); begin FListBox.Pieces := Value; end; procedure TORComboBox.SetReference(Index: Integer; AReference: Variant); begin FListBox.References[Index] := AReference; end; procedure TORComboBox.SetSelLength(Value: Integer); begin FEditBox.SelLength := Value; end; procedure TORComboBox.SetSelStart(Value: Integer); begin FEditBox.SelStart := Value; end; procedure TORComboBox.SetSelText(const Value: string); begin FEditBox.SelText := Value; end; procedure TORComboBox.SetSorted(Value: Boolean); begin FListBox.Sorted := Value; end; procedure TORComboBox.SetTabPositions(const Value: string); begin FListBox.TabPositions := Value; end; procedure TORComboBox.SetTabPosInPixels(const Value: boolean); begin FListBox.TabPosInPixels := Value; end; procedure TORComboBox.SetText(const Value: string); begin FEditBox.Text := Value; // kcm ??? end; procedure TORComboBox.SetItems(const Value: TStrings); begin FItems.Assign(Value); end; function TORComboBox.GetCheckBoxes: boolean; begin Result := FListBox.FCheckBoxes; end; function TORComboBox.GetChecked(Index: Integer): Boolean; begin Result := FListBox.GetChecked(Index); end; function TORComboBox.GetCheckEntireLine: boolean; begin Result := FListBox.FCheckEntireLine; end; function TORComboBox.GetFlatCheckBoxes: boolean; begin Result := FListBox.FFlatCheckBoxes; end; procedure TORComboBox.SetCheckBoxes(const Value: boolean); begin if(FListBox.FCheckBoxes <> Value) then begin FListBox.SetCheckBoxes(Value); if(assigned(FDropPanel)) then FDropPanel.UpdateButtons; FEditBox.Visible := FALSE; try if(Value) then begin SetListItemsOnly(TRUE); SetAutoSelect(FALSE); FEditBox.Color := FCheckBoxEditColor; FEditBox.Text := GetEditBoxText(-1); FEditBox.BorderStyle := bsNone; FEditPanel := TORComboPanelEdit.Create(Self); FEditPanel.Parent := Self; FEditPanel.BevelOuter := bvRaised; FEditPanel.BorderWidth := 1; FEditBox.Parent := FEditPanel; if(csDesigning in ComponentState) then FEditPanel.ControlStyle := FEditPanel.ControlStyle - [csAcceptsControls]; end else begin FEditBox.Parent := Self; FEditBox.Color := FListBox.Color; FEditBox.BorderStyle := bsSingle; FEditPanel.Free; FEditPanel := nil; end; finally FEditBox.Visible := TRUE; end; AdjustSizeOfSelf; end; end; procedure TORComboBox.SetChecked(Index: Integer; const Value: Boolean); begin FListBox.SetChecked(Index, Value); if(assigned(FDropPanel)) then FDropPanel.UpdateButtons; if(Value) then SetListItemsOnly(TRUE); end; procedure TORComboBox.SetCheckEntireLine(const Value: boolean); begin FListBox.FCheckEntireLine := Value; end; procedure TORComboBox.SetFlatCheckBoxes(const Value: boolean); begin FListBox.SetFlatCheckBoxes(Value); end; procedure TORComboBox.DropPanelBtnPressed(OKBtn, AutoClose: boolean); var btn: TSpeedButton; begin if(assigned(FDropPanel)) then begin btn := FDropPanel.GetButton(OKBtn); if(assigned(Btn)) then Btn.Down := TRUE; end; if(not OKBtn) then FListBox.SetCheckedString(FCheckedState); if(AutoClose) then begin FListBox.FDontClose := FALSE; DroppedDown := False; end; UpdateCheckEditBoxText; end; function TORComboBox.GetCheckedString: string; begin Result := FListBox.GetCheckedString; end; procedure TORComboBox.SetCheckedString(const Value: string); begin FListBox.SetCheckedString(Value); end; procedure TORComboBox.SetCheckBoxEditColor(const Value: TColor); begin if(FCheckBoxEditColor <> Value) then begin FCheckBoxEditColor := Value; if(FListBox.FCheckBoxes) then FEditBox.Color := FCheckBoxEditColor; end; end; procedure TORComboBox.SetListItemsOnly(const Value: Boolean); begin if(FListItemsOnly <> Value) then begin FListItemsOnly := Value; if(not Value) then SetCheckBoxes(FALSE); end; end; procedure TORComboBox.SetOnCheckedText(const Value: TORCheckComboTextEvent); begin FOnCheckedText := Value; FEditBox.Text := GetEditBoxText(-1); end; procedure TORComboBox.SetTemplateField(const Value: boolean); begin if(FTemplateField <> Value) then begin FTemplateField := Value; if(Value) then begin SetStyle(orcsDropDown); FEditBox.BorderStyle := bsNone end else FEditBox.BorderStyle := bsSingle; AdjustSizeOfSelf; end; end; function TORComboBox.GetOnSynonymCheck: TORSynonymCheckEvent; begin Result := FListBox.FOnSynonymCheck; end; procedure TORComboBox.SetOnSynonymCheck(const Value: TORSynonymCheckEvent); begin FListBox.FOnSynonymCheck := Value; end; function TORComboBox.GetEnabled: boolean; begin Result := inherited GetEnabled; end; procedure TORComboBox.SetEnabled(Value: boolean); begin if (inherited GetEnabled <> Value) then begin inherited SetEnabled(Value); if assigned(FDropBtn) then FDropBtn.Glyph.LoadFromResourceName(hInstance, ComboBoxImages[Value]); end; end; function TORComboBox.GetEditBoxText(Index: Integer): string; var i, cnt: integer; begin if(FListBox.FCheckBoxes) then begin Result := ''; cnt := 0; for i := 0 to FListBox.Items.Count-1 do begin if(FListBox.Checked[i]) then begin inc(cnt); if(Result <> '') then Result := Result + ', '; Result := Result + FListBox.GetDisplayText(i); end; end; if(assigned(FOnCheckedText)) then FOnCheckedText(FListBox, cnt, Result); end else Result := FListBox.GetDisplayText(Index); end; procedure TORComboBox.UpdateCheckEditBoxText; begin if(FListBox.FCheckBoxes) then begin FFromSelf := TRUE; FEditBox.Text := GetEditBoxText(-1); FEditBox.SelLength := 0; FFromSelf := FALSE; end; end; procedure TORComboBox.CheckBoxSelected(Sender: TObject; Index: integer); begin UpdateCheckEditBoxText; if(FStyle <> orcsDropDown) and (assigned(FOnChange)) then FOnChange(Self); end; function TORComboBox.GetMItems: TStrings; begin result := FMItems; end; procedure TORComboBox.SetCaption(const Value: string); begin FListBox.Caption := Value; end; function TORComboBox.GetCaption: string; begin result := FListBox.Caption; end; function TORComboBox.MakeAccessible(Accessible: IAccessible): TORListBox; begin FListBox.MakeAccessible(Accessible); result := FListBox; end; function TORComboBox.GetCaseChanged: boolean; begin result := FListBox.CaseChanged; end; procedure TORComboBox.SetCaseChanged(const Value: boolean); begin FListBox.CaseChanged := Value; end; function TORComboBox.GetLookupPiece: integer; begin result := FListBox.LookupPiece; end; procedure TORComboBox.SetLookupPiece(const Value: integer); begin FListBox.LookupPiece := Value; end; { TSizeRatio methods } constructor TSizeRatio.Create(ALeft, ATop, AWidth, AHeight: Extended); { creates an object that records the initial relative size & position of a control } begin CLeft := ALeft; CTop := ATop; CWidth := AWidth; CHeight := AHeight; end; { TORAutoPanel ----------------------------------------------------------------------------- } destructor TORAutoPanel.Destroy; { destroy objects used to record size and position information for controls } var SizeRatio: TSizeRatio; i: Integer; begin if FSizes <> nil then with FSizes do for i := 0 to Count - 1 do begin SizeRatio := Items[i]; SizeRatio.Free; end; FSizes.Free; inherited Destroy; end; procedure TORAutoPanel.BuildSizes( Control: TWinControl); var i,H,W: Integer; SizeRatio: TSizeRatio; Child: TControl; begin H := ClientHeight; W := ClientWidth; if (H = 0) or (W = 0) then exit; for i := 0 to Control.ControlCount - 1 do begin Child := Control.Controls[i]; with Child do SizeRatio := TSizeRatio.Create(Left/W, Top/H, Width/W, Height/H); FSizes.Add(SizeRatio); //FSizes is in tree traversal order. //TGroupBox is currently the only type of container that is having these //resize problems if Child is TGroupBox then BuildSizes(TWinControl(Child)); end; end; procedure TORAutoPanel.Loaded; { record initial size & position info for resizing logic } begin inherited Loaded; if csDesigning in ComponentState then Exit; // only want auto-resizing at run time FSizes := TList.Create; BuildSizes(Self); end; procedure TORAutoPanel.DoResize( Control: TWinControl; var CurrentIndex: Integer); var i,H,W: Integer; SizeRatio: TSizeRatio; Child: TControl; begin H := ClientHeight; W := ClientWidth; for i := 0 to Control.ControlCount - 1 do begin Child := Control.Controls[i]; if CurrentIndex = FSizes.Count then break; // raise Exception.Create('Error while Sizing Auto-Size Panel'); SizeRatio := FSizes[CurrentIndex]; inc(CurrentIndex); with SizeRatio do begin if (Child is TLabel) or (Child is TStaticText) then Child.SetBounds(Round(CLeft*W), Round(CTop*H), Child.Width, Child.Height) else Child.SetBounds(Round(CLeft*W), Round(CTop*H), Round(CWidth*W), Round(CHeight*H)); end; if Child is TGroupBox then DoResize(TwinControl(Child), CurrentIndex); end; end; procedure TORAutoPanel.Resize; { resize child controls using their design time proportions } var i: Integer; begin inherited Resize; if csDesigning in ComponentState then Exit; // only want auto-resizing at run time i := 0; DoResize( Self, i); end; { TOROffsetLabel --------------------------------------------------------------------------- } constructor TOROffsetLabel.Create(AOwner: TComponent); { create the label with the default of Transparent = False and Offset = 2} begin inherited Create(AOwner); ControlStyle := ControlStyle + [csOpaque]; FHorzOffset := 2; FVertOffset := 2; end; procedure TOROffsetLabel.CMTextChanged(var Message: TMessage); { resize whenever the label caption changes } begin inherited; AdjustSizeOfSelf; end; procedure TOROffsetLabel.CMFontChanged(var Message: TMessage); { resize whenever the label font changes } begin inherited; AdjustSizeOfSelf; end; procedure TOROffsetLabel.AdjustSizeOfSelf; { using the current font, call DrawText to calculate the rectangle size for the label } var DC: HDC; Flags: Word; ARect: TRect; begin if not (csReading in ComponentState) then begin DC := GetDC(0); Canvas.Handle := DC; ARect := ClientRect; Flags := DT_EXPANDTABS or DT_CALCRECT; if FWordWrap then Flags := Flags or DT_WORDBREAK; DoDrawText(ARect, Flags); // returns size of text rect Canvas.Handle := 0; ReleaseDC(0, DC); // add alignment property later? SetBounds(Left, Top, ARect.Right + FHorzOffset, ARect.Bottom + FVertOffset); // add offsets end; end; procedure TOROffsetLabel.DoDrawText(var Rect: TRect; Flags: Word); { call drawtext to paint or calculate the size of the text in the caption property } var Text: string; begin Text := Caption; Canvas.Font := Font; if not Enabled then Canvas.Font.Color := clGrayText; DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags); end; procedure TOROffsetLabel.Paint; { set the background characterictics, add the offsets, and paint the text } var ARect: TRect; Flags: Word; begin with Canvas do begin if not Transparent then begin Brush.Color := Self.Color; Brush.Style := bsSolid; FillRect(ClientRect); end; Brush.Style := bsClear; ARect := ClientRect; Inc(ARect.Left, FHorzOffset); Inc(ARect.Top, FVertOffset); Flags := DT_EXPANDTABS or DT_NOPREFIX or DT_LEFT; if FWordWrap then Flags := Flags or DT_WORDBREAK; DoDrawText(ARect, Flags); end; end; function TOROffsetLabel.GetTransparent: Boolean; { returns true if the control style is not opaque } begin if csOpaque in ControlStyle then Result := False else Result := True; end; procedure TOROffsetLabel.SetTransparent(Value: Boolean); { if true, removes Opaque from the control style } begin if Value <> Transparent then begin if Value then ControlStyle := ControlStyle - [csOpaque] // transparent = true else ControlStyle := ControlStyle + [csOpaque]; // transparent = false Invalidate; end; end; procedure TOROffsetLabel.SetVertOffset(Value: Integer); { adjusts the size of the label whenever the vertical offset of the label changes } begin FVertOffset := Value; AdjustSizeOfSelf; end; procedure TOROffsetLabel.SetHorzOffset(Value: Integer); { adjusts the size of the label whenever the horizontal offset of the label changes } begin FHorzOffset := Value; AdjustSizeOfSelf; end; procedure TOROffsetLabel.SetWordWrap(Value: Boolean); { adjusts the size of the label whenever the word wrap property changes } begin if FWordWrap <> Value then begin FWordWrap := Value; AdjustSizeOfSelf; end; end; (* { TORCalendar } procedure TORCalendar.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); { uses the Calendar that is part of Samples and highlights the current date } var TheText: string; CurMonth, CurYear, CurDay: Word; begin TheText := CellText[ACol, ARow]; with ARect, Canvas do begin DecodeDate(Date, CurYear, CurMonth, CurDay); if (CurYear = Year) and (CurMonth = Month) and (IntToStr(CurDay) = TheText) then begin TheText := '[' + TheText + ']'; Font.Style := [fsBold]; end; TextRect(ARect, Left + (Right - Left - TextWidth(TheText)) div 2, Top + (Bottom - Top - TextHeight(TheText)) div 2, TheText); end; end; *) { TORAlignButton } constructor TORAlignButton.Create(AOwner: TComponent); begin inherited; FAlignment := taCenter; FLayout := tlCenter; FWordWrap := FALSE; end; procedure TORAlignButton.CreateParams(var Params: TCreateParams); const ButtonAlignment: array[TAlignment] of DWORD = (BS_LEFT, BS_RIGHT, BS_CENTER); ButtonWordWrap: array[boolean] of DWORD = (0, BS_MULTILINE); ButtonLayout: array[TTextLayout] of DWORD = (BS_TOP, BS_VCENTER, BS_BOTTOM); begin inherited CreateParams(Params); Params.Style := Params.Style or ButtonAlignment[FAlignment] or ButtonLayout[FLayout] or ButtonWordWrap[FWordWrap]; end; procedure TORAlignButton.SetAlignment(const Value: TAlignment); begin if(FAlignment <> Value) then begin FAlignment := Value; RecreateWnd; end; end; procedure TORAlignButton.SetLayout(const Value: TTextLayout); begin if(FLayout <> Value) then begin FLayout := Value; RecreateWnd; end; end; procedure TORAlignButton.SetWordWrap(const Value: boolean); begin if(FWordWrap <> Value) then begin FWordWrap := Value; RecreateWnd; end; end; { TORTreeNode } procedure TORTreeNode.EnsureVisible; var R: TRect; DY, LH: integer; begin MakeVisible; R := DisplayRect(FALSE); if(R.Top < 0) then TreeView.TopItem := Self else if(R.Bottom > TreeView.ClientHeight) then begin DY := R.Bottom - TreeView.ClientHeight; LH := R.Bottom - R.Top + 1; DY := (DY div LH) + 1; GetORTreeView.SetVertScrollPos(GetORTreeView.GetVertScrollPos + DY); end; end; function TORTreeNode.GetBold: boolean; var Item: TTVItem; begin Result := False; with Item do begin mask := TVIF_STATE; hItem := ItemId; if TreeView_GetItem(Handle, Item) then Result := (state and TVIS_BOLD) <> 0; end; end; function TORTreeNode.GetORTreeView: TORTreeView; begin Result := ((inherited TreeView) as TORTreeView); end; function TORTreeNode.GetParent: TORTreeNode; begin Result := ((inherited Parent) as TORTreeNode); end; function TORTreeNode.GetText: string; begin Result := Inherited Text; end; procedure TORTreeNode.SetBold(const Value: boolean); var Item: TTVItem; Template: DWORD; begin if Value then Template := DWORD(-1) else Template := 0; with Item do begin mask := TVIF_STATE; hItem := ItemId; stateMask := TVIS_BOLD; state := stateMask and Template; end; TreeView_SetItem(Handle, Item); end; procedure TORTreeNode.SetPiece(PieceNum: Integer; const NewPiece: string); begin with GetORTreeView do begin ORCtrls.SetPiece(FStringData, FDelim, PieceNum, NewPiece); if(PieceNum = FPiece) then Text := NewPiece; end; end; procedure TORTreeNode.SetStringData(const Value: string); begin if(FStringData <> Value) then begin FStringData := Value; with GetORTreeView do if (FDelim <> #0) and (FPiece > 0) then inherited Text := Piece(FStringData, FDelim, FPiece); end; Caption := Text; end; procedure TORTreeNode.SetText(const Value: string); begin UpdateText(Value, TRUE); end; procedure TORTreeNode.UpdateText(const Value: string; UpdateData: boolean); begin Inherited Text := Value; Caption := Text; if(UpdateData) then with GetORTreeView do begin if (FDelim <> #0) and (FPiece > 0) then ORCtrls.SetPiece(FStringData, FDelim, FPiece, Value); end; end; procedure TORTreeNode.MakeAccessible(Accessible: IAccessible); begin if Assigned(FAccessible) and Assigned(Accessible) then raise Exception.Create(Text + ' Tree Node is already Accessible!') else begin FAccessible := Accessible; end; end; procedure TORTreeNode.WMGetObject(var Message: TMessage); begin if (Message.LParam = integer(OBJID_CLIENT)) and Assigned(FAccessible) then Message.Result := GetLResult(Message.wParam, FAccessible) else inherited; end; function CalcShortName( LongName: string; PrevLongName: string): string; var WordBorder: integer; j: integer; begin WordBorder := 1; for j := 1 to Length(LongName) do begin if (LongName[j] = ' ') or ((j > 1) and (LongName[j-1] = ' ')) or ((j = Length(LongName)) and (j = Length(PrevLongName)) and (LongName[j] = PrevLongName[j])) then WordBorder := j; if (j > Length(PrevLongName)) or (LongName[j] <> PrevLongName[j]) then break; end; if WordBorder = 1 then result := LongName else if WordBorder = Length(LongName) then result := 'Same as above ('+LongName+')' else result := Copy(LongName,WordBorder,Length(LongName)) + ' ('+Trim(Copy(LongName,1,WordBorder -1)) + ')'; end; procedure TORTreeNode.SetCaption(const Value: string); var TheCaption: string; begin TheCaption := Value; with GetORTreeView do begin if assigned(OnNodeCaptioning) then OnNodeCaptioning(self, TheCaption); if ShortNodeCaptions and (Self.GetPrevSibling <> nil) then TheCaption := CalcShortName( TheCaption, Self.GetPrevSibling.Text); end; FCaption := TheCaption; end; { TORTreeView } procedure TORTreeView.CNNotify(var Message: TWMNotify); var DNode: TTreeNode; DoInh: boolean; begin DoInh := TRUE; if(assigned(FOnDragging)) then begin with Message do begin case NMHdr^.code of TVN_BEGINDRAG: begin with PNMTreeView(Message.NMHdr)^.ItemNew do begin if (state and TVIF_PARAM) <> 0 then DNode := Pointer(lParam) else DNode := Items.GetNode(hItem); end; FOnDragging(Self, DNode, DoInh); if(not DoInh) then begin Message.Result := 1; Selected := DNode; end; end; end; end; end; if(DoInh) then inherited; end; constructor TORTreeView.Create(AOwner: TComponent); begin inherited; FDelim := '^'; end; function TORTreeView.CreateNode: TTreeNode; begin Result := TORTreeNode.Create(Items); if Assigned( OnAddition ) then OnAddition(self, Result); end; function TORTreeView.FindPieceNode(Value: string; ParentDelim: Char = #0; StartNode: TTreeNode = nil): TORTreeNode; begin Result := FindPieceNode(Value, FPiece, ParentDelim, StartNode); end; function TORTreeView.FindPieceNode(Value: string; APiece: integer; ParentDelim: Char = #0; StartNode: TTreeNode = nil): TORTreeNode; var StartIdx, i: integer; Node: TORTreeNode; begin if assigned(StartNode) then StartIdx := StartNode.AbsoluteIndex+1 else StartIdx := 0; Result := nil; for i := StartIdx to Items.Count-1 do begin Node := (Items[i] as TORTreeNode); if(GetNodeID(Node, APiece, ParentDelim) = Value) then begin Result := Node; break; end; end; end; function TORTreeView.GetExpandedIDStr(APiece: integer; ParentDelim: char = #0): string; var i: integer; begin Result := ''; for i := 0 to Items.Count-1 do begin with (Items[i] as TORTreeNode) do begin if(Expanded) then begin if(Result <> '') then Result := Result + FDelim; Result := Result + GetNodeID(TORTreeNode(Items[i]), APiece, ParentDelim); end; end; end; end; procedure TORTreeView.SetExpandedIDStr(APiece: integer; const Value: string); begin SetExpandedIDStr(APiece, #0, Value); end; procedure TORTreeView.SetExpandedIDStr(APiece: integer; ParentDelim: char; const Value: string); var i: integer; Top, Sel: TTreeNode; Node: TORTreeNode; NList: string; Srch: string; begin Items.BeginUpdate; try Top := TopItem; Sel := Selected; FullCollapse; Selected := Sel; NList := Value; repeat i := pos(FDelim, NList); if(i = 0) then i := length(NList)+1; Srch := copy(NList,1,i-1); Node := FindPieceNode(Srch, APiece, ParentDelim); if(assigned(Node)) then Node.Expand(FALSE); Nlist := copy(NList,i+1,MaxInt); until(NList = ''); TopItem := Top; Selected := Sel; finally Items.EndUpdate; end; end; function TORTreeView.GetHorzScrollPos: integer; begin Result := GetScrollPos(Handle, SB_HORZ); end; function TORTreeView.GetVertScrollPos: integer; begin Result := GetScrollPos(Handle, SB_VERT); end; procedure TORTreeView.RenameNodes; var i:integer; begin if(FDelim <> #0) and (FPiece > 0) then begin for i := 0 to Items.Count-1 do with (Items[i] as TORTreeNode) do UpdateText(Piece(FStringData, FDelim, FPiece), FALSE); end; end; procedure TORTreeView.SetNodeDelim(const Value: Char); begin if(FDelim <> Value) then begin FDelim := Value; RenameNodes; end; end; procedure TORTreeView.SetHorzScrollPos(Value: integer); begin if(Value < 0) then Value := 0; Perform(WM_HSCROLL,MakeWParam(SB_THUMBPOSITION, Value),0); end; procedure TORTreeView.SetNodePiece(const Value: integer); begin if(FPiece <> Value) then begin FPiece := Value; RenameNodes; end; end; procedure TORTreeView.SetVertScrollPos(Value: integer); begin if(Value < 0) then Value := 0; Perform(WM_VSCROLL,MakeWParam(SB_THUMBPOSITION, Value),0); end; function TORTreeView.GetNodeID(Node: TORTreeNode; ParentDelim: Char): string; begin Result := GetNodeID(Node, FPiece, ParentDelim); end; function TORTreeView.GetNodeID(Node: TORTreeNode; APiece: integer; ParentDelim: Char): string; begin if(assigned(Node)) then begin Result := Piece(Node.FStringData, FDelim, APiece); if((ParentDelim <> #0) and (ParentDelim <> FDelim) and (assigned(Node.Parent))) then Result := Result + ParentDelim + GetNodeID(Node.Parent, APiece, ParentDelim); end else Result := ''; end; procedure TORTreeView.MakeAccessible(Accessible: IAccessible); begin if Assigned(FAccessible) and Assigned(Accessible) then raise Exception.Create(Text + ' Tree View is already Accessible!') else begin FAccessible := Accessible; end; end; procedure TORTreeView.WMGetObject(var Message: TMessage); begin if (Message.LParam = integer(OBJID_CLIENT)) and Assigned(FAccessible) then Message.Result := GetLResult(Message.wParam, FAccessible) else inherited; end; procedure TORTreeView.SetShortNodeCaptions(const Value: boolean); begin FShortNodeCaptions := Value; RenameNodes; end; { TORCBImageIndexes } constructor TORCBImageIndexes.Create(AOwner: TComponent); begin inherited; FCheckedEnabledIndex := -1; FCheckedDisabledIndex := -1; FGrayedEnabledIndex := -1; FGrayedDisabledIndex := -1; FUncheckedEnabledIndex := -1; FUncheckedDisabledIndex := -1; FImageChangeLink := TChangeLink.Create; FImageChangeLink.OnChange := ImageListChanged; end; destructor TORCBImageIndexes.Destroy; begin FImageChangeLink.Free; inherited; end; procedure TORCBImageIndexes.SetImages(const Value: TCustomImageList); begin if FImages <> nil then FImages.UnRegisterChanges(FImageChangeLink); FImages := Value; if FImages <> nil then begin FImages.RegisterChanges(FImageChangeLink); FImages.FreeNotification(Self); end; ImageListChanged(Self); end; function TORCBImageIndexes.IdxString: string; function RStr(Value: integer): string; begin if(Value <> -1) then Result := IntToStr(Value) else Result := ''; Result := Result + ','; end; begin Result := RStr(FCheckedEnabledIndex) + RStr(FGrayedEnabledIndex) + RStr(FUncheckedEnabledIndex) + RStr(FCheckedDisabledIndex) + RStr(FGrayedDisabledIndex) + RStr(FUncheckedDisabledIndex); delete(Result,length(Result),1); if(Result = ',,,,,') then Result := ''; end; procedure TORCBImageIndexes.SetIdxString(Value: string); var i,j,v: integer; Sub: String; begin if(Value = '') then begin FCheckedEnabledIndex := -1; FGrayedEnabledIndex := -1; FUncheckedEnabledIndex := -1; FCheckedDisabledIndex := -1; FGrayedDisabledIndex := -1; FUncheckedDisabledIndex := -1; end else begin i := 0; Sub := Value; repeat j := pos(',',Sub); if(j = 0) then j := length(Sub)+1; v := StrToIntDef(copy(Sub,1,j-1),-1); case i of 0: FCheckedEnabledIndex := v; 1: FGrayedEnabledIndex := v; 2: FUncheckedEnabledIndex := v; 3: FCheckedDisabledIndex := v; 4: FGrayedDisabledIndex := v; 5: FUncheckedDisabledIndex := v; end; inc(i); Sub := copy(Sub,j+1,MaxInt); until(Sub = ''); end; end; procedure TORCBImageIndexes.ImageListChanged(Sender: TObject); begin if(Owner is TWinControl) then (Owner as TWinControl).Invalidate; end; procedure TORCBImageIndexes.Notification(AComponent: TComponent; Operation: TOperation); begin inherited Notification(AComponent, Operation); if (AComponent = FImages) and (Operation = opRemove) then SetImages(nil); end; procedure TORCBImageIndexes.SetCheckedDisabledIndex(const Value: integer); begin if(FCheckedDisabledIndex <> Value) then begin FCheckedDisabledIndex := Value; ImageListChanged(Self); end; end; procedure TORCBImageIndexes.SetCheckedEnabledIndex(const Value: integer); begin if(FCheckedEnabledIndex <> Value) then begin FCheckedEnabledIndex := Value; ImageListChanged(Self); end; end; procedure TORCBImageIndexes.SetGrayedDisabledIndex(const Value: integer); begin if(FGrayedDisabledIndex <> Value) then begin FGrayedDisabledIndex := Value; ImageListChanged(Self); end; end; procedure TORCBImageIndexes.SetGrayedEnabledIndex(const Value: integer); begin if(FGrayedEnabledIndex <> Value) then begin FGrayedEnabledIndex := Value; ImageListChanged(Self); end; end; procedure TORCBImageIndexes.SetUncheckedDisabledIndex(const Value: integer); begin if(FUncheckedDisabledIndex <> Value) then begin FUncheckedDisabledIndex := Value; ImageListChanged(Self); end; end; procedure TORCBImageIndexes.SetUncheckedEnabledIndex(const Value: integer); begin if(FUncheckedEnabledIndex <> Value) then begin FUncheckedEnabledIndex := Value; ImageListChanged(Self); end; end; { TORCheckBox } constructor TORCheckBox.Create(AOwner: TComponent); begin CreateCommon(AOwner); FCustomImages := TORCBImageIndexes.Create(Self); FCustomImagesOwned := TRUE; FAllowAllUnchecked := TRUE; end; constructor TORCheckBox.ListViewCreate(AOwner: TComponent; ACustomImages: TORCBImageIndexes); begin CreateCommon(AOwner); FCustomImages := ACustomImages; FCustomImagesOwned := FALSE; end; procedure TORCheckBox.CreateCommon(AOwner: TComponent); begin inherited Create(AOwner); FGrayedToChecked := TRUE; FCanvas := TCanvas.Create; end; destructor TORCheckBox.Destroy; begin if(FCustomImagesOwned) then FCustomImages.Free; FCanvas.Free; inherited; end; function TORCheckBox.GetImageIndexes: string; begin Result := FCustomImages.IdxString; end; function TORCheckBox.GetImageList: TCustomImageList; begin Result := FCustomImages.FImages; end; procedure TORCheckBox.SetImageIndexes(const Value: string); begin FCustomImages.SetIdxString(Value); end; procedure TORCheckBox.SetImageList(const Value: TCustomImageList); begin FCustomImages.SetImages(Value); end; procedure TORCheckBox.Toggle; begin if(FGrayedToChecked) then begin case State of cbUnchecked: if AllowGrayed then State := cbGrayed else State := cbChecked; cbChecked: State := cbUnchecked; cbGrayed: State := cbChecked; end; end else begin case State of cbUnchecked: State := cbChecked; cbChecked: if AllowGrayed then State := cbGrayed else State := cbUnchecked; cbGrayed: State := cbUnchecked; end; end; end; procedure TORCheckBox.CreateParams(var Params: TCreateParams); begin inherited CreateParams(Params); Params.Style := (Params.Style and (not BS_3STATE)) or BS_OWNERDRAW; end; procedure TORCheckBox.CMEnabledChanged(var Message: TMessage); begin inherited; Invalidate; end; procedure TORCheckBox.CMFontChanged(var Message: TMessage); begin inherited; Invalidate; end; procedure TORCheckBox.CNDrawItem(var Message: TWMDrawItem); begin DrawItem(Message.DrawItemStruct^); end; procedure TORCheckBox.CNMeasureItem(var Message: TWMMeasureItem); begin with Message.MeasureItemStruct^ do begin itemWidth := Width; itemHeight := Height; end; end; procedure TORCheckBox.GetDrawData(CanvasHandle: HDC; var Bitmap: TBitmap; var FocRect, Rect: TRect; var DrawOptions: UINT; var TempBitMap: boolean); var i, l, TxtHeight, TxtWidth, AWidth: Integer; ImgIdx: TORCBImgIdx; CustomImgIdx: integer; begin BitMap := nil; TempBitMap := FALSE; DrawOptions := DT_LEFT; FSingleLine := TRUE; if(not (csDestroying in ComponentState)) then begin with FCustomImages do begin FCanvas.Handle := CanvasHandle; try Rect := ClientRect; with FCanvas do begin CustomImgIdx := -1; if(assigned(FImages)) then begin if(Enabled or (csDesigning in ComponentState)) then begin case State of cbChecked: CustomImgIdx := FCheckedEnabledIndex; cbUnChecked: CustomImgIdx := FUncheckedEnabledIndex; cbGrayed: CustomImgIdx := FGrayedEnabledIndex; end; end else begin case State of cbChecked: CustomImgIdx := FCheckedDisabledIndex; cbUnChecked: CustomImgIdx := FUncheckedDisabledIndex; cbGrayed: CustomImgIdx := FGrayedDisabledIndex; end; end; if((CustomImgIdx < 0) or (CustomImgIdx >= FImages.Count)) then CustomImgIdx := -1; end; if(CustomImgIdx < 0) then begin ImgIdx := iiChecked; if(Enabled or (csDesigning in ComponentState)) then begin if(FRadioStyle) then begin if State = cbChecked then ImgIdx := iiRadioChecked else ImgIdx := iiRadioUnchecked; end else begin case State of cbChecked: ImgIdx := iiChecked; cbUnChecked: ImgIdx := iiUnchecked; cbGrayed: begin case FGrayedStyle of gsNormal: ImgIdx := iiGrayed; gsQuestionMark: ImgIdx := iiQMark; gsBlueQuestionMark: ImgIdx := iiBlueQMark; end; end; end; end; end else begin if(FRadioStyle) then begin if State = cbChecked then ImgIdx := iiRadioDisChecked else ImgIdx := iiRadioDisUnchecked; end else begin case State of cbChecked: ImgIdx := iiDisChecked; cbUnChecked: ImgIdx := iiDisUnchecked; cbGrayed: begin if(FGrayedStyle = gsNormal) then ImgIdx := iiDisGrayed else ImgIdx := iiDisQMark; end; end; end; end; Bitmap := GetORCBBitmap(ImgIdx); end else begin Bitmap := TBitmap.Create; FImages.GetBitmap(CustomImgIdx, Bitmap); TempBitMap := TRUE; end; Brush.Style := bsClear; Font := Self.Font; if Alignment = taLeftJustify then Rect.Left := 2 else Rect.Left := Bitmap.Width + 5; if(FWordWrap) then DrawOptions := DrawOptions or DT_WORDBREAK else DrawOptions := DrawOptions or DT_VCENTER or DT_SINGLELINE; if(FWordWrap) then begin if Alignment = taLeftJustify then Rect.Right := Width - Bitmap.Width - 3 else Rect.Right := Width; Rect.Top := 1; Rect.Bottom := Height+1; dec(Rect.Right); FocRect := Rect; TxtHeight := DrawText(Handle, PChar(Caption), Length(Caption), FocRect, DrawOptions or DT_CALCRECT); FSingleLine := (TxtHeight = TextHeight(Caption)); Rect.Bottom := Rect.Top + TxtHeight + 1; FocRect := Rect; end else begin TxtWidth := TextWidth(Caption); //Get rid of ampersands that turn into underlines i := 0; l := length(Caption); AWidth := TextWidth('&'); while(i < l) do begin inc(i); // '&&' is an escape char that should display one '&' wide. // This next part preserves the first '&' but drops all the others if (Copy(Caption,i,2)<>'&&') and (Copy(Caption,i,1)='&') then dec(TxtWidth,AWidth); end; Rect.Right := Rect.Left + TxtWidth; TxtHeight := TextHeight(Caption); if(TxtHeight < Bitmap.Height) then TxtHeight := Bitmap.Height; Rect.Top := ((((ClientHeight - TxtHeight) * 5) - 5) div 10); Rect.Bottom := Rect.Top + TxtHeight + 1; IntersectRect(FocRect, Rect, ClientRect); end; end; finally FCanvas.Handle := 0; end; end; end; end; procedure TORCheckBox.DrawItem(const DrawItemStruct: TDrawItemStruct); var R, FocusRect, TempRect: TRect; Bitmap: TBitmap; OldColor: TColor; DrawOptions: UINT; TempBitMap: boolean; begin if(not (csDestroying in ComponentState)) then begin GetDrawData(DrawItemStruct.hDC, Bitmap, FocusRect, R, DrawOptions, TempBitMap); try FCanvas.Handle := DrawItemStruct.hDC; try with FCanvas do begin Brush.Color := Self.Color; Brush.Style := bsSolid; InflateRect(R, 1, 1); FillRect(R); InflateRect(R, -1, -1); Brush.Style := bsClear; Font := Self.Font; if(Enabled or (csDesigning in ComponentState)) then begin DrawText(Handle, PChar(Caption), Length(Caption), FocusRect, DrawOptions); end else begin OldColor:=Font.Color; try if Ctl3D then begin OffsetRect(FocusRect, 1, 1); Font.Color := clBtnHighlight; DrawText(Handle, PChar(Caption), Length(Caption), FocusRect, DrawOptions); OffsetRect(FocusRect, -1, -1); end; Font.Color:=clGrayText; DrawText(Handle, PChar(Caption), Length(Caption), FocusRect, DrawOptions); finally Font.Color:=OldColor; end; Brush.Color := Self.Color; Brush.Style := bsSolid; end; if((DrawItemStruct.itemState and ODS_FOCUS) <> 0) then begin InflateRect(FocusRect, 1, 1); if(FFocusOnBox) then //TempRect := Rect(0, 0, CheckWidth - 1, CheckWidth - 1) TempRect := Rect(0, 0, CheckWidth + 2, CheckWidth + 5) else TempRect := FocusRect; //UnionRect(Temp2Rect,ClipRect,TempRect); //ClipRect := Temp2Rect; Pen.Color := clWindowFrame; Brush.Color := clBtnFace; DrawFocusRect(TempRect); InflateRect(FocusRect, -1, -1); end; if Alignment = taLeftJustify then R.Left := ClientWidth - Bitmap.Width else R.Left := 0; if(FWordWrap) then R.Top:= FocusRect.Top else R.Top:= ((ClientHeight - Bitmap.Height + 1) div 2) - 1; Draw(R.Left, R.Top, Bitmap); end; finally FCanvas.Handle := 0; end; finally if(TempBitMap) then Bitmap.Free; end; end; end; procedure TORCheckBox.SetGrayedStyle(Value: TGrayedStyle); begin if(FGrayedStyle <> Value) then begin FGrayedStyle := Value; if(State = cbGrayed) then Invalidate; end; end; procedure TORCheckBox.WMLButtonDblClk(var Message: TWMLButtonDblClk); begin Perform(WM_LBUTTONDOWN, Message.Keys, Longint(Message.Pos)); end; procedure TORCheckBox.WMSize(var Message: TWMSize); begin inherited; if(FSizable) and (csDesigning in ComponentState) then AutoAdjustSize; end; procedure TORCheckBox.BMSETCHECK(var Message: TMessage); var cnt, i: integer; cb: TORCheckBox; Chk: boolean; begin Message.Result := 0; if(assigned(Parent) and (FGroupIndex <> 0)) then begin Chk := Checked; if(Chk or (not FAllowAllUnchecked)) then begin cnt := 0; for i := 0 to Parent.ControlCount-1 do begin if(Parent.Controls[i] is TORCheckBox) then begin cb := TORCheckBox(Parent.Controls[i]); if(cb <> Self) then begin if(cb.Checked and (cb.FGroupIndex = FGroupIndex)) then begin if Chk then cb.Checked := FALSE else inc(cnt); end; end; end; end; if(not Chk) and (Cnt = 0) then Checked := TRUE; end; end; UpdateAssociate; Invalidate; end; procedure TORCheckBox.SetWordWrap(const Value: boolean); begin if(FWordWrap <> Value) then begin FWordWrap := Value; AutoAdjustSize; invalidate; end; end; procedure TORCheckBox.SetAutoSize(Value: boolean); begin if(FAutoSize <> Value) then begin FAutoSize := Value; AutoAdjustSize; invalidate; end; end; procedure TORCheckBox.AutoAdjustSize; var R, FocusRect: TRect; Bitmap: TBitmap; DrawOptions: UINT; TempBitMap: boolean; DC: HDC; SaveFont: HFont; begin if(FAutoSize and (([csDestroying, csLoading] * ComponentState) = [])) then begin FSizable := TRUE; DC := GetDC(0); try SaveFont := SelectObject(DC, Font.Handle); try GetDrawData(DC, Bitmap, FocusRect, R, DrawOptions, TempBitMap); finally SelectObject(DC, SaveFont); end; finally ReleaseDC(0, DC); end; if(FocusRect.Left <> R.Left ) or (FocusRect.Right <> R.Right ) or (FocusRect.Top <> R.Top ) or (FocusRect.Bottom <> R.Bottom) or (R.Right <> ClientRect.Right) or (R.Bottom <> ClientRect.Bottom) then begin FocusRect := R; if Alignment = taLeftJustify then begin dec(R.Left,2); inc(R.Right,Bitmap.Width + 3); end else dec(R.Left,Bitmap.Width + 5); Width := R.Right-R.Left+1; Height := R.Bottom-R.Top+2; end; end; end; function TORCheckBox.GetCaption: TCaption; begin Result := inherited Caption; end; procedure TORCheckBox.SetCaption(const Value: TCaption); begin if(inherited Caption <> Value) then begin inherited Caption := Value; AutoAdjustSize; invalidate; end; end; procedure TORCheckBox.SetAllowAllUnchecked(const Value: boolean); begin FAllowAllUnchecked := Value; SyncAllowAllUnchecked; end; procedure TORCheckBox.SetGroupIndex(const Value: integer); begin FGroupIndex := Value; if(Value <> 0) and (csDesigning in ComponentState) and (not (csLoading in ComponentState)) then SetRadioStyle(TRUE); SyncAllowAllUnchecked; end; procedure TORCheckBox.SyncAllowAllUnchecked; var i: integer; cb: TORCheckBox; begin if(assigned(Parent) and (FGroupIndex <> 0)) then begin for i := 0 to Parent.ControlCount-1 do begin if(Parent.Controls[i] is TORCheckBox) then begin cb := TORCheckBox(Parent.Controls[i]); if((cb <> Self) and (cb.FGroupIndex = FGroupIndex)) then cb.FAllowAllUnchecked := FAllowAllUnchecked; end; end; end; end; procedure TORCheckBox.SetParent(AParent: TWinControl); begin inherited; SyncAllowAllUnchecked; end; procedure TORCheckBox.SetRadioStyle(const Value: boolean); begin FRadioStyle := Value; Invalidate; end; procedure TORCheckBox.SetAssociate(const Value: TControl); begin if(FAssociate <> Value) then begin if(assigned(FAssociate)) then FAssociate.RemoveFreeNotification(Self); FAssociate := Value; if(assigned(FAssociate)) then begin FAssociate.FreeNotification(Self); UpdateAssociate; end; end; end; procedure TORCheckBox.UpdateAssociate; procedure EnableCtrl(Ctrl: TControl; DoCtrl: boolean); var i: integer; DoIt: boolean; begin if DoCtrl then Ctrl.Enabled := Checked; if(Ctrl is TWinControl) then begin for i := 0 to TWinControl(Ctrl).ControlCount-1 do begin if DoCtrl then DoIt := TRUE else DoIt := (TWinControl(Ctrl).Controls[i] is TWinControl); if DoIt then EnableCtrl(TWinControl(Ctrl).Controls[i], TRUE); end; end; end; begin if(assigned(FAssociate)) then EnableCtrl(FAssociate, FALSE); end; procedure TORCheckBox.Notification(AComponent: TComponent; Operation: TOperation); begin inherited; if(AComponent = FAssociate) and (Operation = opRemove) then FAssociate := nil; end; procedure TORCheckBox.SetFocusOnBox(value: boolean); begin FFocusOnBox := value; invalidate; end; procedure TORCheckBox.BMGetCheck(var Message: TMessage); begin {This Allows JAWS to report the state when tabbed into or using the read object keys (Ins+Tab)} {if Self.GrayedStyle = gsBlueQuestionMark then Message.Result := BST_INDETERMINATE else} if Self.Checked then Message.Result := BST_CHECKED else Message.Result := BST_UNCHECKED; end; procedure TORCheckBox.BMGetState(var Message: TMessage); begin //This gives JAWS ability to read state when spacebar is pressed. //Commented out because JAWS reads states, but inversly. Working with freedom... { if Self.Checked then Message.Result := BST_CHECKED else Message.Result := BST_UNCHECKED;} end; { TORListView } procedure TORListView.WMNotify(var Message: TWMNotify); begin inherited; with Message.NMHdr^ do case code of HDN_BEGINTRACK, HDN_TRACK, HDN_ENDTRACK: with PHDNotify(Pointer(Message.NMHdr))^, PItem^ do if (Mask and HDI_WIDTH) <> 0 then begin if(Column[Item].MinWidth > 0) and (cxy < Column[Item].MinWidth) then cxy := Column[Item].MinWidth; if(Column[Item].MaxWidth > 0) and (cxy > Column[Item].MaxWidth) then cxy := Column[Item].MaxWidth; Column[Item].Width := cxy; end; end; end; procedure TORListView.LVMSetColumn(var Message: TMessage); var Changed: boolean; NewW, idx: integer; begin Changed := FALSE; NewW := 0; idx := 0; with Message, TLVColumn(pointer(LParam)^) do begin if(cx < Column[WParam].MinWidth) then begin NewW := Column[WParam].MinWidth; Changed := TRUE; idx := WParam; end; if(cx > Column[WParam].MaxWidth) then begin NewW := Column[WParam].MaxWidth; Changed := TRUE; idx := WParam; end; end; inherited; if(Changed) then Column[idx].Width := NewW; end; procedure TORListView.LVMSetColumnWidth(var Message: TMessage); var Changed: boolean; NewW, idx: integer; begin Changed := FALSE; NewW := 0; idx := 0; with Message do begin if(LParam < Column[WParam].MinWidth) then begin LParam := Column[WParam].MinWidth; Changed := TRUE; NewW := LParam; idx := WParam; end; if(LParam > Column[WParam].MaxWidth) then begin LParam := Column[WParam].MaxWidth; Changed := TRUE; NewW := LParam; idx := WParam; end; end; inherited; if(Changed) then Column[idx].Width := NewW; end; { TORComboPanelEdit } destructor TORComboPanelEdit.Destroy; begin if(assigned(FCanvas)) then FCanvas.Free; inherited; end; procedure TORComboPanelEdit.Paint; var DC: HDC; R: TRect; begin inherited; if(FFocused) then begin if(not assigned(FCanvas)) then FCanvas := TControlCanvas.Create; DC := GetWindowDC(Handle); try FCanvas.Handle := DC; R := ClientRect; InflateRect(R, -1, -1); FCanvas.DrawFocusRect(R); finally ReleaseDC(Handle, DC); end; end; end; { TKeyClickPanel ----------------------------------------------------------------------------- } procedure TKeyClickPanel.KeyDown(var Key: Word; Shift: TShiftState); begin case Key of VK_LBUTTON, VK_RETURN, VK_SPACE: Click; end; end; { TKeyClickRadioGroup } procedure TKeyClickRadioGroup.Click; begin inherited; TabStop := Enabled and Visible and (ItemIndex = -1); end; constructor TKeyClickRadioGroup.Create(AOwner: TComponent); begin inherited; TabStop := Enabled and Visible and (ItemIndex = -1); end; procedure TKeyClickRadioGroup.KeyDown(var Key: Word; Shift: TShiftState); begin inherited; case Key of VK_RETURN, VK_SPACE: if ItemIndex = -1 then begin ItemIndex := 0; Click; if ControlCount > 0 then begin TWinControl(Controls[0]).SetFocus; end; Key := 0; end; end; end; { TCaptionListBox } procedure TCaptionListBox.DoEnter; begin inherited; if HintOnItem then FHoverItemPos := -1; //CQ: 7178 & 9911 - used as last item index for ListBox end; function TCaptionListBox.GetCaption: string; begin if not Assigned(FCaptionComponent) then result := '' else result := FCaptionComponent.Caption; end; procedure TCaptionListBox.MakeAccessible(Accessible: IAccessible); begin if Assigned(FAccessible) and Assigned(Accessible) then raise Exception.Create(Caption + ' List Box is already Accessible!') else FAccessible := Accessible; end; procedure TCaptionListBox.SetCaption(const Value: string); begin if not Assigned(FCaptionComponent) then begin FCaptionComponent := TStaticText.Create(self); FCaptionComponent.AutoSize := False; FCaptionComponent.Height := 0; FCaptionComponent.Width := 0; FCaptionComponent.Visible := True; FCaptionComponent.Parent := Parent; FCaptionComponent.BringToFront; end; FCaptionComponent.Caption := Value; end; procedure TCaptionListBox.WMGetObject(var Message: TMessage); begin if (Message.LParam = integer(OBJID_CLIENT)) and Assigned(FAccessible) then Message.Result := GetLResult(Message.wParam, FAccessible) else inherited; end; procedure TCaptionListBox.WMMouseMove(var Message: TWMMouseMove); var i : integer; begin inherited; //CQ: 7178 & 9911 - FHoverItemPos should be set to -1 in OnEnter //Make the TListBox's hint contain the contents of the listbox Item the mouse is currently over if HintOnItem then begin i := ItemAtPos(Point(Message.XPos, Message.YPos), true); if i <> FHoverItemPos then Application.CancelHint; if i = -1 then Hint := '' else Hint := Items[i]; FHoverItemPos := i; end; end; procedure TCaptionListBox.WMRButtonUp(var Message: TWMRButtonUp); { When the RightClickSelect property is true, this routine is used to select an item } var APoint: TPoint; i: integer; begin if FRightClickSelect then with Message do begin APoint := Point(XPos, YPos); // if the mouse was clicked in the client area set ItemIndex... if PtInRect(ClientRect, APoint) then begin ItemIndex := ItemAtPos(APoint,True); // ...but not if its just going to deselect the current item if ItemIndex > -1 then begin Items.BeginUpdate; try if not Selected[ItemIndex] then for i := 0 to Items.Count-1 do Selected[i] := False; Selected[ItemIndex] := True; finally Items.EndUpdate; end; end; end; end; inherited; end; { TCaptionCheckListBox } function TCaptionCheckListBox.GetCaption: string; begin if not Assigned(FCaptionComponent) then result := '' else result := FCaptionComponent.Caption; end; procedure TCaptionCheckListBox.SetCaption(const Value: string); begin if not Assigned(FCaptionComponent) then begin FCaptionComponent := TStaticText.Create(self); FCaptionComponent.AutoSize := False; FCaptionComponent.Height := 0; FCaptionComponent.Width := 0; FCaptionComponent.Visible := True; FCaptionComponent.Parent := Parent; FCaptionComponent.BringToFront; end; FCaptionComponent.Caption := Value; end; { TCaptionMemo } function TCaptionMemo.GetCaption: string; begin if not Assigned(FCaptionComponent) then result := '' else result := FCaptionComponent.Caption; end; procedure TCaptionMemo.SetCaption(const Value: string); begin if not Assigned(FCaptionComponent) then begin FCaptionComponent := TStaticText.Create(self); FCaptionComponent.AutoSize := False; FCaptionComponent.Height := 0; FCaptionComponent.Width := 0; FCaptionComponent.Visible := True; FCaptionComponent.Parent := Parent; FCaptionComponent.BringToFront; end; FCaptionComponent.Caption := Value; end; { TCaptionEdit } function TCaptionEdit.GetCaption: string; begin if not Assigned(FCaptionComponent) then result := '' else result := FCaptionComponent.Caption; end; procedure TCaptionEdit.SetCaption(const Value: string); begin if not Assigned(FCaptionComponent) then begin FCaptionComponent := TStaticText.Create(self); FCaptionComponent.AutoSize := False; FCaptionComponent.Height := 0; FCaptionComponent.Width := 0; FCaptionComponent.Visible := True; FCaptionComponent.Parent := Parent; FCaptionComponent.BringToFront; end; FCaptionComponent.Caption := Value; end; { TCaptionRichEdit } procedure TCaptionRichEdit.MakeAccessible(Accessible: IAccessible); begin if Assigned(FAccessible) and Assigned(Accessible) then raise Exception.Create(Caption + ' Rich Edit is already Accessible!') else FAccessible := Accessible; end; procedure TCaptionRichEdit.WMGetObject(var Message: TMessage); begin if (Message.LParam = integer(OBJID_CLIENT)) and Assigned(FAccessible) then Message.Result := GetLResult(Message.wParam, FAccessible) else inherited; end; { TCaptionTreeView} function TCaptionTreeView.GetCaption: string; begin result := inherited Caption; end; procedure TCaptionTreeView.SetCaption(const Value: string); begin if not Assigned(FCaptionComponent) then begin FCaptionComponent := TStaticText.Create(self); FCaptionComponent.AutoSize := False; FCaptionComponent.Height := 0; FCaptionComponent.Width := 0; FCaptionComponent.Visible := True; FCaptionComponent.Parent := Parent; FCaptionComponent.BringToFront; end; FCaptionComponent.Caption := Value; inherited Caption := Value; end; { TCaptionComboBox } function TCaptionComboBox.GetCaption: string; begin if not Assigned(FCaptionComponent) then result := '' else result := FCaptionComponent.Caption; end; procedure TCaptionComboBox.SetCaption(const Value: string); begin if not Assigned(FCaptionComponent) then begin FCaptionComponent := TStaticText.Create(self); FCaptionComponent.AutoSize := False; FCaptionComponent.Height := 0; FCaptionComponent.Width := 0; FCaptionComponent.Visible := True; FCaptionComponent.Parent := Parent; FCaptionComponent.BringToFront; end; FCaptionComponent.Caption := Value; end; { TORAlignSpeedButton } procedure TORAlignSpeedButton.Paint; var Rect: TRect; begin inherited; if (Parent <> nil) and (Parent is TKeyClickPanel) and TKeyClickPanel(Parent).Focused then begin Rect := ClientRect; InflateRect(Rect, -3, -3); Canvas.Brush.Color := Color; Canvas.DrawFocusRect(Rect); end; end; { TCaptionStringGrid } {I may have messed up my Windows.pas file, but mine defines NotifyWinEvent without a stdcall.} procedure GoodNotifyWinEvent; external user32 name 'NotifyWinEvent'; function TCaptionStringGrid.ColRowToIndex(Col, Row: Integer): integer; begin result := (ColCount - FixedCols) * (Row - FixedRows) + (Col - FixedCols) + 1; end; procedure TCaptionStringGrid.IndexToColRow(index: integer; var Col, Row: integer); begin Row := (index-1) div (ColCount - FixedCols) + FixedRows; Col := (index-1) mod (ColCount - FixedCols) + FixedCols; end; procedure TCaptionStringGrid.KeyUp(var Key: Word; Shift: TShiftState); begin inherited; {Look for all of the grid navigation keys} if (Key in [VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN]) and (Shift = []) or (Key = VK_TAB) and (Shift <= [ssShift]) then GoodNotifyWinEvent(EVENT_OBJECT_FOCUS, Handle, integer(OBJID_CLIENT), ColRowToIndex(Col,Row)); end; procedure TCaptionStringGrid.MakeAccessible(Accessible: IAccessible); begin if Assigned(FAccessible) and Assigned(Accessible) then raise Exception.Create(Caption + 'String Grid is already Accessible!') else FAccessible := Accessible; end; procedure TCaptionStringGrid.WMGetObject(var Message: TMessage); begin if (Message.LParam = integer(OBJID_CLIENT)) and Assigned(FAccessible) then Message.Result := GetLResult(Message.wParam, FAccessible) else inherited; end; function IsAMouseButtonDown : boolean; begin if Boolean(Hi(GetKeyState(VK_MBUTTON))) or Boolean(Hi(GetKeyState(VK_LBUTTON))) or Boolean(Hi(GetKeyState(VK_RBUTTON))) then Result := true else Result := false; end; procedure TORComboBox.SetNumForMatch(const NumberForMatch: integer); begin if NumberForMatch < 1 then FCharsNeedMatch := 1 else if NumberForMatch > 15 then FCharsNeedMatch := 15 else FCharsNeedMatch := NumberForMatch; end; procedure TORComboBox.SetUniqueAutoComplete(const Value: Boolean); begin FUniqueAutoComplete := Value; end; function TORListBox.VerifyUnique(SelectIndex: Integer; iText: String): integer; var i : integer; counter : integer; begin Result := SelectIndex; if LongList then begin //Currently Do nothing for LongLists { if CompareText(iText, Copy(DisplayText[SelectIndex+1], 1, Length(iText))) = 0 then Result := -1;} end else //Not a LongList begin counter := 0; for i := 0 to Items.Count-1 do if CompareText(iText, Copy(DisplayText[i], 1, Length(iText))) = 0 then Inc(counter); if counter > 1 then Result := -1; end; FFocusIndex := Result; ItemIndex := Result; end; //This procedure sets the Text property equal to the TextToMatch parameter, then calls //FwdChangeDelayed which will perform an auto-completion on the text. procedure TORComboBox.SetTextAutoComplete(TextToMatch: String); begin Text := TextToMatch; SelStart := Length(Text); FwdChangeDelayed; end; initialization //uItemTip := TItemTip.Create(Application); // all listboxes share a single ItemTip window uItemTipCount := 0; uNewStyle := Lo(GetVersion) >= 4; // True = Win95 interface, otherwise old interface FillChar(ORCBImages, SizeOf(ORCBImages), 0); finalization //uItemTip.Free; // don't seem to need this - called by Application DestroyORCBBitmaps; end.