iSharkFly-Open
/
VistA-cprs
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
VistA-cprs/CPRS-Lib/ORCtrls.pas

7236 lines
226 KiB
Plaintext
Raw Permalink Blame History

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,
Variants, VAClasses, typinfo;
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
IORBlackColorModeCompatible = interface(IInterface)
['{3554985C-F524-45FA-8C27-4CDD8357DB08}']
procedure SetBlackColorMode(Value: boolean);
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;
THintRecords = record
ObjectName: string;
ObjectHint: string;
end;
TORListBox = class(TListBox, IVADynamicProperty, IORBlackColorModeCompatible)
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
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
FIsPartOfComboBox: boolean;
FBlackColorMode: boolean;
FHideSelection: boolean;
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 isPartOfComboBox: boolean read FIsPartOfComboBox write FIsPartOfComboBox default False;
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;
function VerifyUnique(SelectIndex: Integer; iText: string): integer;
procedure SetBlackColorMode(Value: boolean);
function SupportsDynamicProperty(PropertyID: integer): boolean;
function GetDynamicProperty(PropertyID: integer): string;
procedure SetHintProperties(Restore: Boolean; MainForm: TComponent);
property HideSelection: boolean read FHideSelection write FHideSelection;
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, IVADynamicProperty, IORBlackColorModeCompatible)
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.
FBlackColorMode: boolean;
FDisableHints: boolean; // true if hints have been disabled because drop down window was opened
FDropDownStatusChangedCount: integer; // prevents multiple calls to disabling hint window
fRpcCall: String;
procedure DropDownStatusChanged(opened: boolean);
procedure ClearDropDownStatus;
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);
procedure LoadComboBoxImage;
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;
destructor Destroy; override;
function AddReference(const S: string; AReference: Variant): Integer;
procedure Clear;
procedure ClearTop;
procedure ForDataUse(Strings: TStrings);
procedure InitLongList(S: string);
procedure InsertSeparator;
procedure Invalidate; override;
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;
procedure SetBlackColorMode(Value: boolean);
function SupportsDynamicProperty(PropertyID: integer): boolean;
function GetDynamicProperty(PropertyID: integer): string;
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 RpcCall :String read fRpcCall write fRpcCall;
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, IVADynamicProperty)
private
procedure SetCaption(const Value: string);
function GetCaption: string;
protected
FCaptionComponent: TStaticText;
public
function SupportsDynamicProperty(PropertyID: integer): boolean;
function GetDynamicProperty(PropertyID: integer): string;
published
property Align;
property Caption: string read GetCaption write SetCaption;
end;
TORTreeView = class;
TORTreeNode = class(TTreeNode)
private
FTag: integer;
FStringData: string;
FCaption: string;
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 SetPiece(PieceNum: Integer; const NewPiece: string);
procedure EnsureVisible;
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;
FShortNodeCaptions: boolean;
FOnNodeCaptioning: TNodeCaptioningEvent;
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;
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, IORBlackColorModeCompatible)
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;
FBlackColorMode: 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;
procedure SetBlackColorMode(Value: boolean);
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, IVADynamicProperty)
private
FHoverItemPos: integer;
FRightClickSelect: boolean; // When true, a right click selects teh item
FHintOnItem: boolean;
procedure SetCaption(const Value: string);
function GetCaption: string;
procedure WMRButtonUp(var Message: TWMRButtonUp); message WM_RBUTTONUP;
procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;
procedure MoveFocusDown;
procedure MoveFocusUp;
protected
FCaptionComponent: TStaticText;
procedure DoEnter; override;
public
function SupportsDynamicProperty(PropertyID: integer): boolean;
function GetDynamicProperty(PropertyID: integer): string;
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, IVADynamicProperty)
private
procedure SetCaption(const Value: string);
function GetCaption: string;
protected
FCaptionComponent: TStaticText;
public
function SupportsDynamicProperty(PropertyID: integer): boolean;
function GetDynamicProperty(PropertyID: integer): string;
published
property Caption: string read GetCaption write SetCaption;
Property CheckWidth: integer Read GetCheckWidth;
end;
TCaptionMemo = class(TMemo, IVADynamicProperty)
private
procedure SetCaption(const Value: string);
function GetCaption: string;
protected
FCaptionComponent: TStaticText;
public
function SupportsDynamicProperty(PropertyID: integer): boolean;
function GetDynamicProperty(PropertyID: integer): string;
published
property Caption: string read GetCaption write SetCaption;
end;
TCaptionEdit = class(TEdit, IVADynamicProperty)
private
procedure SetCaption(const Value: string);
function GetCaption: string;
protected
FCaptionComponent: TStaticText;
public
function SupportsDynamicProperty(PropertyID: integer): boolean;
function GetDynamicProperty(PropertyID: integer): string;
published
property Align;
property Caption: string read GetCaption write SetCaption;
end;
TCaptionRichEdit = class(TRichEdit, IVADynamicProperty)
private
protected
FCaption: string;
public
function SupportsDynamicProperty(PropertyID: integer): boolean;
function GetDynamicProperty(PropertyID: integer): string;
published
property Align;
property Caption: string read FCaption write FCaption;
end;
TCaptionComboBox = class(TComboBox, IVADynamicProperty)
private
procedure SetCaption(const Value: string);
function GetCaption: string;
protected
FCaptionComponent: TStaticText;
public
function SupportsDynamicProperty(PropertyID: integer): boolean;
function GetDynamicProperty(PropertyID: integer): string;
published
property Caption: string read GetCaption write SetCaption;
end;
TCaptionListView = class(TListView, IVADynamicProperty)
public
function SupportsDynamicProperty(PropertyID: integer): boolean;
function GetDynamicProperty(PropertyID: integer): string;
published
property Caption;
end;
TCaptionStringGrid = class(TStringGrid, IVADynamicProperty)
private
FJustToTab: boolean;
FCaption: string;
protected
procedure KeyUp(var Key: Word; Shift: TShiftState); override;
public
procedure IndexToColRow(index: integer; var Col: integer; var Row: integer);
function ColRowToIndex(Col: integer; Row: Integer): integer;
function SupportsDynamicProperty(PropertyID: integer): boolean;
function GetDynamicProperty(PropertyID: integer): string;
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
VAUtils;
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
HintArray: array of THintRecords;
{ 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);
//Find the average of the width then round up
Result := Trunc(Extent.cx / 52 ) + 1;
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');
BlackCheckBoxImageResNames: array[TORCBImgIdx] of PChar = (
'BLACK_ORLB_FLAT_UNCHECKED', 'BLACK_ORLB_FLAT_CHECKED', 'BLACK_ORLB_FLAT_GRAYED',
'BLACK_ORCB_QUESTIONMARK', 'BLACK_ORCB_BLUEQUESTIONMARK',
'BLACK_ORCB_DISABLED_UNCHECKED', 'BLACK_ORCB_DISABLED_CHECKED',
'BLACK_ORCB_DISABLED_GRAYED', 'BLACK_ORCB_DISABLED_QUESTIONMARK',
'BLACK_ORLB_FLAT_UNCHECKED', 'BLACK_ORLB_FLAT_CHECKED', 'BLACK_ORLB_FLAT_GRAYED',
'BLACK_ORCB_RADIO_UNCHECKED', 'BLACK_ORCB_RADIO_CHECKED',
'BLACK_ORCB_RADIO_DISABLED_UNCHECKED', 'BLACK_ORCB_RADIO_DISABLED_CHECKED');
var
ORCBImages: array[TORCBImgIdx, Boolean] of TBitMap;
function GetORCBBitmap(Idx: TORCBImgIdx; BlackMode: boolean): TBitmap;
var
ResName: string;
begin
if (not assigned(ORCBImages[Idx, BlackMode])) then
begin
ORCBImages[Idx, BlackMode] := TBitMap.Create;
if BlackMode then
ResName := BlackCheckBoxImageResNames[Idx]
else
ResName := CheckBoxImageResNames[Idx];
ORCBImages[Idx, BlackMode].LoadFromResourceName(HInstance, ResName);
end;
Result := ORCBImages[Idx, BlackMode];
end;
procedure DestroyORCBBitmaps; far;
var
i: TORCBImgIdx;
mode: boolean;
begin
for i := low(TORCBImgIdx) to high(TORCBImgIdx) do
begin
for Mode := false to true do
begin
if (assigned(ORCBImages[i, Mode])) then
ORCBImages[i, Mode].Free;
end;
end;
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;
FIsPartOfComboBox := False;
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;
function TORListBox.GetDynamicProperty(PropertyID: integer): string;
begin
if PropertyID = DynaPropAccesibilityCaption then
Result := GetCaption
else
Result := '';
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:
begin
if (FocusIndex < 0) and (CheckBoxes or MultiSelect) and (Count > 0) then // JNM - 508 compliance
SetFocusIndex(0);
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;
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 (not isPartOfComboBox) and (ItemIndex <> -1) then
SetFocusIndex(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; }
if FHideSelection and (ItemIndex < 0) and (FFocusIndex >= 0) then
ItemIndex := FFocusIndex;
inherited DoEnter;
end;
procedure TORListBox.DoExit;
var
SaveIndex: integer;
{ make sure item tip is hidden for this listbox when focus shifts to something else }
begin
if FHideSelection then
begin
SaveIndex := ItemIndex;
ItemIndex := -1;
FFocusIndex := SaveIndex;
end;
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 KeyPress is changing the ' ' into #0, had to move conditional before inherited.}
if (Key = ' ') then begin
ToggleCheckBox(ItemIndex);
{The space bar causes the focus to jump to an item in the list that starts with
a space. Disable that function.}
Key := #0;
end;
inherited;
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.SetHintProperties(Restore: Boolean; MainForm: TComponent);
var
i, x: integer;
Component: TComponent;
begin
//Clear the array if we are not restoring it
if not restore then SetLength(HintArray, 0);
//Loop through all the components on the form
for i := 0 to TForm(MainForm).ComponentCount - 1 do begin
Component := TForm(MainForm).Components[i];
if (Component is TControl) then begin
if not restore then begin
//Increase our array and set our record
SetLength(HintArray, Length(HintArray) + 1);
HintArray[high(HintArray)].ObjectName := Component.Name;
HintArray[high(HintArray)].ObjectHint := GetStrProp(Component, 'Hint');
//Now clear out the component's hint
SetStrProp(Component, 'Hint', '');
end else begin
//Loop through the array and find this component's hint
for x := Low(HintArray) to High(HintArray) do begin
if Component.Name = HintArray[x].ObjectName then begin
//Once found reset the hint and break out of the loop
SetStrProp(Component, 'Hint', HintArray[x].ObjectHint);
break;
end;
end;
end;
end;
end;
//Now deal with the form itself
if not restore then begin
//Increase our array and set our record
SetLength(HintArray, Length(HintArray) + 1);
HintArray[high(HintArray)].ObjectName := TForm(MainForm).Name;
HintArray[high(HintArray)].ObjectHint := TForm(MainForm).Hint;
//Now clear out the Forms's hint
TForm(MainForm).Hint := '';
end else begin
//Loop through the array and find this Forms's hint
for x := Low(HintArray) to High(HintArray) do begin
if TForm(MainForm).Name = HintArray[x].ObjectName then begin
//Once found reset the hint and break out of the loop
TForm(MainForm).Hint := HintArray[x].ObjectHint;
break;
end;
end;
//Now clear the arrau since we are done using it
SetLength(HintArray, 0);
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 the drop down is visible and the hint hasn't been changed then clear the hint and save the original hint
if assigned(FParentCombo) then begin
//agp change
//if (FParentCombo.FDropPanel.Visible) and (TForm(self.Owner.Owner).Hint <> '') then begin
if (FParentCombo.FDropPanel.Visible) and ((GetParentForm(self) <> nil) and (Length(HintArray) = 0)) then begin
SetHintProperties(False, GetParentForm(Self));
end;
end;
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
If FParentCombo = nil then MouseCapture := False;
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, FBlackColorMode)
else
BMap := GetORCBBitmap(iiUnchecked, FBlackColorMode);
end;
cbChecked:
begin
if (FFlatCheckBoxes) then
BMap := GetORCBBitmap(iiFlatChecked, FBlackColorMode)
else
BMap := GetORCBBitmap(iiChecked, FBlackColorMode);
end;
else // cbGrayed:
begin
if (FFlatCheckBoxes) then
BMap := GetORCBBitmap(iiFlatGrayed, FBlackColorMode)
else
BMap := GetORCBBitmap(iiGrayed, FBlackColorMode);
end;
end;
end
else
begin
if (FFlatCheckBoxes) then
BMap := GetORCBBitmap(iiFlatGrayed, FBlackColorMode)
else
BMap := GetORCBBitmap(iiGrayed, FBlackColorMode);
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_END) or (not (Value < Items.Count)) then Value := Items.Count - 1;
if (Value = SFI_TOP) or (Value < 0) then Value := 0;
FFocusIndex := Value;
if Focused or (not FHideSelection) then
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;
function TORListBox.SupportsDynamicProperty(PropertyID: integer): boolean;
begin
Result := (PropertyID = DynaPropAccesibilityCaption);
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, ItemRec2: 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);
// CQ 11491 - Changing TabPositions, etc. was wiping out check box status.
FFromSelf := True;
ItemRec2 := PItemRec(SendMessage(Handle, LB_GETITEMDATA, Pos, 0));
FFromSelf := False;
if (assigned(ItemRec2)) then
begin
ItemRec2^.Reference := ItemRec^.Reference;
ItemRec2^.CheckedState := ItemRec^.CheckedState;
end;
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;
DropDownPanel: TORListBox;
begin
If Length(HintArray) > 0 then begin
DropDownPanel := TORListBox.Create(nil);
try
DropDownPanel.SetHintProperties(True, GetParentForm(Self));
finally
DropDownPanel.Free;
end;
end;
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.SetBlackColorMode(Value: boolean);
begin
FBlackColorMode := Value;
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;
// In Delphi 2006, hint windows will cause the TORComboBox drop down list to
// move behind a Stay on Top form. Hints are also problematic with item tips in
// the drop down list, so we disable them when ever a drop down list is open,
// on all forms, not just stay on top forms.
var
uDropPanelOpenCount: integer = 0;
uOldShowHintsSetting: boolean;
procedure DropDownPanelOpened;
begin
if uDropPanelOpenCount = 0 then
uOldShowHintsSetting := Application.ShowHint;
// Application.ShowHint := FALSE;
inc(uDropPanelOpenCount);
end;
procedure DropDownPanelClosed;
begin
dec(uDropPanelOpenCount);
if uDropPanelOpenCount <= 0 then
begin
uDropPanelOpenCount := 0;
if not Application.ShowHint then
// Application.ShowHint := uOldShowHintsSetting
end;
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');
BlackComboBoxImages: array[boolean] of string = ('BLACK_BMP_CBODOWN_DISABLED', 'BLACK_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);
// JM - removed multi-line - broke lookup when MaxLength is set, besides, it didn't really
// seem to have an effect on the editing rectangle anyway.
// agp change cause tab characters to show on meds and lab order dialogs
// Params.Style := Params.Style {or ES_MULTILINE} or WS_CLIPCHILDREN;
if TForm(self.Owner.Owner) <> nil then Params.Style := Params.Style or ES_MULTILINE or WS_CLIPCHILDREN
else 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.isPartOfComboBox := True;
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.DropDownStatusChanged(opened: boolean);
var
DropDownPanel: TORListBox;
begin
DropDownPanel := TORListBox.Create(nil);
try
if opened then
begin
if not FDropPanel.Visible then
begin
if FDropDownStatusChangedCount = 0 then
begin
FDisableHints := TRUE;
DropDownPanelOpened;
end;
inc(FDropDownStatusChangedCount);
end;
end
else
begin
dec(FDropDownStatusChangedCount);
if FDropDownStatusChangedCount <= 0 then
begin
//agp change
//if FDisableHints then
if (FDisableHints) and (Self.Owner <> nil) then
begin
DropDownPanelClosed;
FDisableHints := FALSE;
If (GetParentForm(Self) <> nil) then
DropDownPanel.SetHintProperties(True, GetParentForm(Self));
end;
FDropDownStatusChangedCount := 0;
end;
end;
finally
DropDownPanel.Free;
end;
end;
procedure TORComboBox.ClearDropDownStatus;
begin
FDropDownStatusChangedCount := 1;
DropDownStatusChanged(FALSE);
end;
destructor TORComboBox.Destroy;
begin
ClearDropDownStatus;
inherited;
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.LoadComboBoxImage;
var
imageName: string;
begin
if assigned(FDropBtn) then
begin
if FBlackColorMode then
imageName := BlackComboBoxImages[inherited Enabled]
else
imageName := ComboBoxImages[inherited Enabled];
FDropBtn.Glyph.LoadFromResourceName(hInstance, imageName);
end;
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);
var
KeyCode: integer;
{ prevents return from being used by editbox (otherwise sends a newline & text vanishes) }
begin
KeyCode := ord(Key);
if (KeyCode = VK_RETURN) and (Style = orcsDropDown) and DroppedDown then
begin
DroppedDown := FALSE;
Key := #0;
end
else
begin
// may want to make the tab beep if tab key (#9) - can't tab until list raised
if (KeyCode = VK_RETURN) or (KeyCode = VK_TAB) or (FListBox.FCheckBoxes and (KeyCode = VK_SPACE)) then
begin
Key := #0;
Exit;
end;
if Assigned(FOnKeyPress) then FOnKeyPress(Self, Key);
end;
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;
DropDownStatusChanged(TRUE);
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;
DropDownStatusChanged(FALSE);
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
begin
ClearDropDownStatus;
FDropPanel.Free;
end;
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];
LoadComboBoxImage;
// 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;
ClearDropDownStatus;
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;
function TORComboBox.SupportsDynamicProperty(PropertyID: integer): boolean;
begin
Result := (PropertyID = DynaPropAccesibilityCaption);
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;
procedure TORComboBox.Invalidate;
begin
inherited;
FEditBox.Invalidate;
FListBox.Invalidate;
if assigned(FEditPanel) then
FEditPanel.Invalidate;
if assigned(FDropBtn) then
FDropBtn.Invalidate;
if assigned(FDropPanel) then
FDropPanel.Invalidate;
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.GetDynamicProperty(PropertyID: integer): string;
begin
if PropertyID = DynaPropAccesibilityCaption then
Result := GetCaption
else
Result := '';
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.SetBlackColorMode(Value: boolean);
begin
if FBlackColorMode <> Value then
begin
FBlackColorMode := Value;
FListBox.SetBlackColorMode(Value);
LoadComboBoxImage;
end;
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
DroppedDown := FALSE;
inherited SetEnabled(Value);
if assigned(FDropBtn) then
LoadComboBoxImage;
// 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.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;
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.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, FBlackColorMode);
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
begin
R.Top := ((ClientHeight - Bitmap.Height + 1) div 2) - 1;
if R.Top < 0 then R.Top := 0
end;
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.SetBlackColorMode(Value: boolean);
begin
if FBlackColorMode <> Value then
begin
FBlackColorMode := Value;
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;
// added (csAcceptsControls in Ctrl.ControlStyle) below to prevent disabling of
// child sub controls, like the TBitBtn in the TORComboBox. If the combo box is
// already disabled, we don't want to disable the button as well - when we do, we
// lose the disabled glyph that is stored on that button for the combo box.
if (Ctrl is TWinControl) and (csAcceptsControls in Ctrl.ControlStyle) 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;
function TCaptionListBox.GetDynamicProperty(PropertyID: integer): string;
begin
if PropertyID = DynaPropAccesibilityCaption then
Result := GetCaption
else
Result := '';
end;
procedure TCaptionListBox.MoveFocusUp;
begin
if ItemIndex > 0 then
Perform(LB_SETCARETINDEX, ItemIndex - 1, 0);
end;
procedure TCaptionListBox.MoveFocusDown;
begin
if ItemIndex < (Items.Count - 1) then
Perform(LB_SETCARETINDEX, ItemIndex + 1, 0);
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;
function TCaptionListBox.SupportsDynamicProperty(PropertyID: integer): boolean;
begin
Result := (PropertyID = DynaPropAccesibilityCaption);
end;
procedure TCaptionListBox.WMKeyDown(var Message: TWMKeyDown);
var
IsSelected: LongBool;
begin
if Boolean(Hi(GetKeyState(VK_CONTROL))) and MultiSelect then
case Message.CharCode of
VK_SPACE:
begin
IsSelected := LongBool(Perform(LB_GETSEL, ItemIndex, 0));
Perform(LB_SETSEL, Longint(not IsSelected), ItemIndex);
end;
VK_LEFT, VK_UP: MoveFocusUp;
VK_RIGHT, VK_DOWN: MoveFocusDown;
else inherited;
end
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;
function TCaptionCheckListBox.GetDynamicProperty(PropertyID: integer): string;
begin
if PropertyID = DynaPropAccesibilityCaption then
Result := GetCaption
else
Result := '';
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;
function TCaptionCheckListBox.SupportsDynamicProperty(
PropertyID: integer): boolean;
begin
Result := (PropertyID = DynaPropAccesibilityCaption);
end;
{ TCaptionMemo }
function TCaptionMemo.GetCaption: string;
begin
if not Assigned(FCaptionComponent) then
result := ''
else
result := FCaptionComponent.Caption;
end;
function TCaptionMemo.GetDynamicProperty(PropertyID: integer): string;
begin
if PropertyID = DynaPropAccesibilityCaption then
Result := GetCaption
else
Result := '';
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;
function TCaptionMemo.SupportsDynamicProperty(PropertyID: integer): boolean;
begin
Result := (PropertyID = DynaPropAccesibilityCaption);
end;
{ TCaptionEdit }
function TCaptionEdit.GetCaption: string;
begin
if not Assigned(FCaptionComponent) then
result := ''
else
result := FCaptionComponent.Caption;
end;
function TCaptionEdit.GetDynamicProperty(PropertyID: integer): string;
begin
if PropertyID = DynaPropAccesibilityCaption then
Result := GetCaption
else
Result := '';
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;
function TCaptionEdit.SupportsDynamicProperty(PropertyID: integer): boolean;
begin
Result := (PropertyID = DynaPropAccesibilityCaption);
end;
{ TCaptionRichEdit }
function TCaptionRichEdit.GetDynamicProperty(PropertyID: integer): string;
begin
if PropertyID = DynaPropAccesibilityCaption then
Result := FCaption
else
Result := '';
end;
function TCaptionRichEdit.SupportsDynamicProperty(PropertyID: integer): boolean;
begin
Result := (PropertyID = DynaPropAccesibilityCaption);
end;
{ TCaptionTreeView}
function TCaptionTreeView.GetCaption: string;
begin
result := inherited Caption;
end;
function TCaptionTreeView.GetDynamicProperty(PropertyID: integer): string;
begin
if PropertyID = DynaPropAccesibilityCaption then
Result := GetCaption
else
Result := '';
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;
function TCaptionTreeView.SupportsDynamicProperty(PropertyID: integer): boolean;
begin
Result := (PropertyID = DynaPropAccesibilityCaption);
end;
{ TCaptionComboBox }
function TCaptionComboBox.GetCaption: string;
begin
if not Assigned(FCaptionComponent) then
result := ''
else
result := FCaptionComponent.Caption;
end;
function TCaptionComboBox.GetDynamicProperty(PropertyID: integer): string;
begin
if PropertyID = DynaPropAccesibilityCaption then
Result := GetCaption
else
Result := '';
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;
function TCaptionComboBox.SupportsDynamicProperty(PropertyID: integer): boolean;
begin
Result := (PropertyID = DynaPropAccesibilityCaption);
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;
function TCaptionStringGrid.GetDynamicProperty(PropertyID: integer): string;
begin
if PropertyID = DynaPropAccesibilityCaption then
Result := FCaption
else
Result := '';
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;
function TCaptionStringGrid.SupportsDynamicProperty(
PropertyID: integer): boolean;
begin
Result := (PropertyID = DynaPropAccesibilityCaption);
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
//Implemented for CQ: 10092, PSI-04-057
//asume long lists are alphabetically ordered...
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;
{ TCaptionListView }
function TCaptionListView.GetDynamicProperty(PropertyID: integer): string;
begin
if PropertyID = DynaPropAccesibilityCaption then
Result := Caption
else
Result := '';
end;
function TCaptionListView.SupportsDynamicProperty(PropertyID: integer): boolean;
begin
Result := (PropertyID = DynaPropAccesibilityCaption);
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.
Reference in New Issue View Git Blame Copy Permalink