source: cprs/trunk/CPRS-Lib/ORCtrls.pas@ 1482

Last change on this file since 1482 was 829, checked in by Kevin Toppenberg, 14 years ago

Upgrade to version 27
File size: 226.2 KB
Line 
1unit ORCtrls; // Oct 26, 1997 @ 10:00am
2
3// To Do: eliminate topindex itemtip on mousedown (seen when choosing clinic pts)
4
5interface // --------------------------------------------------------------------------------
6
7uses Windows, Messages, SysUtils, Classes, Graphics, Controls, StdCtrls, Forms,
8 ComCtrls, Commctrl, Buttons, ExtCtrls, Grids, ImgList, Menus, CheckLst,
9 Variants, VAClasses;
10
11const
12 UM_SHOWTIP = (WM_USER + 9436); // message id to display item tip **was 300
13 UM_GOTFOCUS = (WM_USER + 9437); // message to post when combo gets focus **was 301
14 MAX_TABS = 40; // maximum number of tab stops or pieces
15 LL_REVERSE = -1; // long list scrolling in reverse direction
16 LL_POSITION = 0; // long list thumb moved
17 LL_FORWARD = 1; // long list scrolling in forward direction
18 LLS_LINE = '^____________________________________________________________________________';
19 LLS_DASH = '^----------------------------------------------------------------------------';
20 LLS_SPACE = '^ ';
21
22type
23 IORBlackColorModeCompatible = interface(IInterface)
24 ['{3554985C-F524-45FA-8C27-4CDD8357DB08}']
25 procedure SetBlackColorMode(Value: boolean);
26 end;
27
28 TORComboBox = class; // forward declaration for FParentCombo
29
30 TTranslator = function (MString: string): string of object;
31
32 TORStrings = class(TStrings)
33 private
34 MList: TStringList;
35 FPlainText: TStrings;
36 FTranslator: TTranslator;
37 FVerification: boolean;
38 procedure Verify;
39 protected
40 function Get( index:integer): string; override;
41 function GetCount: integer; override;
42 function GetObject(index:integer): TObject; override;
43 procedure Put(Index: Integer; const S: string); override;
44 procedure PutObject(index:integer; Value: TObject); override;
45 procedure SetUpdateState( Value: boolean); override;
46 public
47 function Add(const S: string): integer; override;
48 constructor Create(PlainText: TStrings; Translator: TTranslator);
49 destructor Destroy; override;
50 procedure Clear; override;
51 procedure Delete( index: integer); override;
52 procedure Insert(Index: Integer; const S: string); override;
53 function IndexOf(const S: string): Integer; override;
54 property PlainText: TStrings read FPlainText;
55 property Translator: TTranslator read FTranslator;
56 property Verification: boolean read FVerification write FVerification;
57 end;
58
59 TORDirection = -1..1; // for compatibility, type is now integer
60 TORNeedDataEvent = procedure(Sender: TObject; const StartFrom: string;
61 Direction, InsertAt: Integer) of object;
62 TORBeforeDrawEvent = procedure(Sender: TObject; Index: Integer; Rect: TRect;
63 State: TOwnerDrawState) of object;
64 TORItemNotifyEvent = procedure(Sender: TObject; Index: integer) of object;
65 TORCheckComboTextEvent = procedure(Sender: TObject; NumChecked: integer; var Text: string) of object;
66 TORSynonymCheckEvent = procedure(Sender: TObject; const Text: string;
67 var IsSynonym: boolean) of object;
68
69 PItemRec = ^TItemRec;
70 TItemRec = record
71 Reference: Variant; // variant value associated with item
72 UserObject: TObject; // Objects[n] property of listbox item
73 CheckedState: TCheckBoxState; // Used to indicate check box values
74 end;
75
76 TORListBox = class(TListBox, IVADynamicProperty, IORBlackColorModeCompatible)
77 private
78 FFocusIndex: Integer; // item with focus when using navigation keys
79 FLargeChange: Integer; // visible items less one
80 FTipItem: Integer; // item currently displaying ItemTip
81 FItemTipActive: Boolean; // used to delay appearance of the ItemTip
82 FItemTipColor: TColor; // background color for ItemTip window
83 FItemTipEnable: Boolean; // allows display of ItemTips over items
84 FLastMouseX: Integer; // mouse X position on last MouseMove event
85 FLastMouseY: Integer; // mouse Y position on last MouseMove event
86 FLastItemIndex: Integer; // used for the OnChange event
87 FFromSelf: Boolean; // true if listbox message sent from this unit
88 FDelimiter: Char; // delimiter used by Pieces property
89 FWhiteSpace: Char; // may be space or tab (between pieces)
90 FTabPosInPixels: boolean; // determines if TabPosition is Pixels or Chars
91 FTabPos: array[0..MAX_TABS] of Integer; // character based positions of tab stops
92 FTabPix: array[0..MAX_TABS] of Integer; // pixel positions of tab stops
93 FPieces: array[0..MAX_TABS] of Integer; // pieces that should be displayed for item
94 FLongList: Boolean; // if true, enables special LongList properties
95 FScrollBar: TScrollBar; // scrollbar used when in LongList mode
96 FFirstLoad: Boolean; // true if NeedData has never been called
97 FFromNeedData: Boolean; // true means items added to LongList part
98 FDataAdded: Boolean; // true if items added during NeedData call
99 FCurrentTop: Integer; // TopIndex, changes when inserting to LongList
100 FWaterMark: Integer; // first LongList item after the short list
101 FDirection: Integer; // direction of the current NeedData call
102 FInsertAt: Integer; // insert point for the current NeedData call
103 FParentCombo: TORComboBox; // used when listbox is part of dropdown combo
104 FOnChange: TNotifyEvent; // event called when ItemIndex changes
105 FOnNeedData: TORNeedDataEvent; // event called when LongList needs more items
106 FHideSynonyms: boolean; // Hides Synonyms from the list
107 FSynonymChars: string; // Chars a string must contain to be considered a synonym
108 FOnSynonymCheck: TORSynonymCheckEvent; // Event that allows for custom synonym checking
109 FCreatingItem: boolean; // Used by Synonyms to prevent errors when adding new items
110 FCreatingText: string; // Used by Synonyms to prevent errors when adding new items
111 FOnBeforeDraw: TORBeforeDrawEvent; // event called prior to drawing an item
112 FRightClickSelect: boolean; // When true, a right click selects teh item
113 FCheckBoxes: boolean; // When true, list box contains check boxes
114 FFlatCheckBoxes: boolean; // When true, list box check boxes are flat
115 FCheckEntireLine: boolean; // When checked, clicking anywhere on the line checks the checkbox
116 FOnClickCheck: TORItemNotifyEvent; // Event notifying of checkbox change
117 FDontClose: boolean; // Used to keep drop down open when checkboxes
118 FItemsDestroyed: boolean; // Used to make sure items are not destroyed multiple times
119 FAllowGrayed: boolean;
120 FMItems: TORStrings; // Used to save corresponding M strings ("the pieces")
121 FCaption: TStaticText; // Used to supply a title to IAccessible interface
122 FCaseChanged: boolean; // If true, the names are stored in the database as all caps, but loaded and displayed in mixed-case
123 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
124 FIsPartOfComboBox: boolean;
125 FBlackColorMode: boolean;
126 FHideSelection: boolean;
127 procedure AdjustScrollBar;
128 procedure CreateScrollBar;
129 procedure FreeScrollBar;
130 function GetDisplayText(Index: Integer): string;
131 function GetItemID: Variant;
132 function GetItemIEN: Int64;
133 function GetPieces: string;
134 function GetReference(Index: Integer): Variant;
135 function GetTabPositions: string;
136 function GetStyle: TListBoxStyle;
137 procedure NeedData(Direction: Integer; StartFrom: string);
138 function PositionThumb: Integer;
139 procedure ResetItems;
140 procedure ScrollTo(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer);
141 function GetStringIndex(const AString: string): Integer;
142 function SelectString(const AString: string): Integer;
143 procedure SetCheckBoxes(const Value: boolean);
144 procedure SetDelimiter(Value: Char);
145 procedure SetFlatCheckBoxes(const Value: boolean);
146 procedure SetFocusIndex(Value: Integer);
147 procedure SetLongList(Value: Boolean);
148 procedure SetPieces(const Value: string);
149 procedure SetReference(Index: Integer; AReference: Variant);
150 procedure SetTabPositions(const Value: string);
151 procedure SetTabPosInPixels(const Value: boolean);
152 procedure SetTabStops;
153 procedure SetHideSynonyms(Value: boolean);
154 procedure SetSynonymChars(Value: string);
155 procedure SetStyle(Value: TListBoxStyle);
156 function IsSynonym(const TestStr: string): boolean;
157 function TextToShow(S: string): string;
158 procedure LBGetText (var Message: TMessage); message LB_GETTEXT;
159 procedure LBGetTextLen (var Message: TMessage); message LB_GETTEXTLEN;
160 procedure LBGetItemData (var Message: TMessage); message LB_GETITEMDATA;
161 procedure LBSetItemData (var Message: TMessage); message LB_SETITEMDATA;
162 procedure LBAddString (var Message: TMessage); message LB_ADDSTRING;
163 procedure LBInsertString (var Message: TMessage); message LB_INSERTSTRING;
164 procedure LBDeleteString (var Message: TMessage); message LB_DELETESTRING;
165 procedure LBResetContent (var Message: TMessage); message LB_RESETCONTENT;
166 procedure LBSetCurSel (var Message: TMessage); message LB_SETCURSEL;
167 procedure CMFontChanged (var Message: TMessage); message CM_FONTCHANGED;
168 procedure CNDrawItem (var Message: TWMDrawItem); message CN_DRAWITEM;
169 procedure WMDestroy (var Message: TWMDestroy); message WM_DESTROY;
170 procedure WMKeyDown (var Message: TWMKeyDown); message WM_KEYDOWN;
171 procedure WMLButtonDown (var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
172 procedure WMLButtonUp (var Message: TWMLButtonUp); message WM_LBUTTONUP;
173 procedure WMRButtonUp (var Message: TWMRButtonUp); message WM_RBUTTONUP;
174 procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
175 procedure WMCancelMode (var Message: TMessage); message WM_CANCELMODE;
176 procedure WMMove (var Message: TWMMove); message WM_MOVE;
177 procedure WMSize (var Message: TWMSize); message WM_SIZE;
178 procedure WMVScroll (var Message: TWMVScroll); message WM_VSCROLL;
179 procedure CMHintShow (var Message: TMessage); message CM_HINTSHOW;
180 procedure UMShowTip (var Message: TMessage); message UM_SHOWTIP;
181 function GetChecked(Index: Integer): Boolean;
182 procedure SetChecked(Index: Integer; const Value: Boolean);
183 function GetMultiSelect: boolean;
184 function GetCheckedString: string;
185 procedure SetCheckedString(const Value: string);
186 function GetCheckedState(Index: Integer): TCheckBoxState;
187 procedure SetCheckedState(Index: Integer; const Value: TCheckBoxState);
188 function GetMItems: TStrings;
189 procedure SetMItems( Value: TStrings);
190 procedure SetCaption(const Value: string);
191 function GetCaption: string;
192 protected
193 procedure SetMultiSelect(Value: boolean); override;
194 procedure CreateParams(var Params: TCreateParams); override;
195 procedure CreateWnd; override;
196 procedure DestroyWnd; override;
197 procedure Click; override;
198 procedure DoChange; virtual;
199 procedure DoEnter; override;
200 procedure DoExit; override;
201 procedure DestroyItems;
202 procedure Loaded; override;
203 procedure ToggleCheckBox(idx: integer);
204 procedure KeyPress(var Key: Char); override;
205 procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
206 procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
207 procedure MeasureItem(Index: Integer; var Height: Integer); override;
208 procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
209 function GetIndexFromY(YPos :integer) :integer;
210 property isPartOfComboBox: boolean read FIsPartOfComboBox write FIsPartOfComboBox default False;
211 property HideSynonyms: boolean read FHideSynonyms write SetHideSynonyms default FALSE;
212 property SynonymChars: string read FSynonymChars write SetSynonymChars;
213 public
214 constructor Create(AOwner: TComponent); override;
215 destructor Destroy; override;
216 procedure ClearTop;
217 function AddReference(const S: string; AReference: Variant): Integer;
218 procedure InsertReference(Index: Integer; const S: string; AReference: Variant);
219 function IndexOfReference(AReference: Variant): Integer;
220 procedure InsertSeparator;
221 procedure ForDataUse(Strings: TStrings);
222 procedure InitLongList(S: string);
223 function GetIEN(AnIndex: Integer): Int64;
224 function SelectByIEN(AnIEN: Int64): Integer;
225 function SelectByID(const AnID: string): Integer;
226 function SetExactByIEN(AnIEN: Int64; const AnItem: string): Integer;
227 procedure Clear; override;
228 property ItemID: Variant read GetItemID;
229 property ItemIEN: Int64 read GetItemIEN;
230 property FocusIndex: Integer read FFocusIndex write SetFocusIndex;
231 property DisplayText[Index: Integer]: string read GetDisplayText;
232 property References[Index: Integer]: Variant read GetReference write SetReference;
233 property ShortCount: Integer read FWaterMark;
234 property Checked[Index: Integer]: Boolean read GetChecked write SetChecked;
235 property CheckedString: string read GetCheckedString write SetCheckedString;
236 property CheckedState[Index: Integer]: TCheckBoxState read GetCheckedState write SetCheckedState;
237 property MItems: TStrings read GetMItems write SetMItems;
238 function VerifyUnique(SelectIndex: Integer; iText: String): integer;
239 procedure SetBlackColorMode(Value: boolean);
240 function SupportsDynamicProperty(PropertyID: integer): boolean;
241 function GetDynamicProperty(PropertyID: integer): string;
242 property HideSelection: boolean read FHideSelection write FHideSelection;
243 published
244 property AllowGrayed: boolean read FAllowGrayed write FAllowGrayed default FALSE;
245 property Caption: string read GetCaption write SetCaption;
246 property CaseChanged: boolean read FCaseChanged write FCaseChanged default TRUE;
247 property Delimiter: Char read FDelimiter write SetDelimiter default '^';
248 property ItemTipColor: TColor read FItemTipColor write FItemTipColor;
249 property ItemTipEnable: Boolean read FItemTipEnable write FItemTipEnable default True;
250 property LongList: Boolean read FLongList write SetLongList;
251 property LookupPiece: integer read FLookupPiece write FLookupPiece default 0;
252 property Pieces: string read GetPieces write SetPieces;
253 property TabPosInPixels: boolean read FTabPosInPixels write SetTabPosInPixels default False; // MUST be before TabPositions!
254 property TabPositions: string read GetTabPositions write SetTabPositions;
255 property OnChange: TNotifyEvent read FOnChange write FOnChange;
256 property OnNeedData: TORNeedDataEvent read FOnNeedData write FOnNeedData;
257 property OnBeforeDraw: TORBeforeDrawEvent read FOnBeforeDraw write FOnBeforeDraw;
258 property RightClickSelect: boolean read FRightClickSelect write FRightClickSelect default FALSE;
259 property CheckBoxes: boolean read FCheckBoxes write SetCheckBoxes default FALSE;
260 property Style: TListBoxStyle read GetStyle write SetStyle default lbStandard;
261 property FlatCheckBoxes: boolean read FFlatCheckBoxes write SetFlatCheckBoxes default TRUE;
262 property CheckEntireLine: boolean read FCheckEntireLine write FCheckEntireLine default FALSE;
263 property OnClickCheck: TORItemNotifyEvent read FOnClickCheck write FOnClickCheck;
264 property MultiSelect: boolean read GetMultiSelect write SetMultiSelect default FALSE;
265 property Items: TStrings read GetMItems write SetMItems;
266 end;
267
268 TORDropPanel = class(TPanel)
269 private
270 FButtons: boolean;
271 procedure WMActivateApp(var Message: TMessage); message WM_ACTIVATEAPP;
272 protected
273 procedure CreateParams(var Params: TCreateParams); override;
274 procedure Resize; override;
275 procedure UpdateButtons;
276 function GetButton(OKBtn: boolean): TSpeedButton;
277 procedure ResetButtons;
278 procedure BtnClicked(Sender: TObject);
279 public
280 constructor Create(AOwner: TComponent); override;
281 end;
282
283 TORComboStyle = (orcsDropDown, orcsSimple);
284
285 TORComboPanelEdit = class(TPanel)
286 private
287 FFocused: boolean;
288 FCanvas: TControlCanvas;
289 protected
290 procedure Paint; override;
291 public
292 destructor Destroy; override;
293 end;
294
295 TORComboEdit = class(TEdit)
296 private
297 procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
298 procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
299 protected
300 procedure CreateParams(var Params: TCreateParams); override;
301 end;
302
303 TORComboBox = class(TWinControl, IVADynamicProperty, IORBlackColorModeCompatible)
304 private
305 FItems: TStrings; // points to Items in FListBox
306 FMItems: TStrings; // points to MItems in FListBox
307 FListBox: TORListBox; // listbox control for the combobox
308 FEditBox: TORComboEdit; // edit control for the combobox
309 FEditPanel: TORComboPanelEdit; // Used to enable Multi-Select Combo Boxes
310 FDropBtn: TBitBtn; // drop down button for dropdown combo
311 FDropPanel: TORDropPanel; // panel for dropdown combo (parent=desktop)
312 FDroppedDown: Boolean; // true if the list part is dropped down
313 FStyle: TORComboStyle; // style is simple or dropdown for combo
314 FDropDownCount: Integer; // number of items to display when list appears
315 FFromSelf: Boolean; // prevents recursive calls to change event
316 FFromDropBtn: Boolean; // determines when to capture mouse on drop
317 FKeyTimerActive: Boolean; // true when timer running for OnKeyPause
318 FKeyIsDown: Boolean; // true between KeyDown & KeyUp events
319 FChangePending: Boolean;
320 FListItemsOnly: Boolean;
321 FLastFound: string;
322 FLastInput: string; // last thing the user typed into the edit box
323 FOnChange: TNotifyEvent; // maps to editbox change event
324 FOnClick: TNotifyEvent; // maps to listbox click event
325 FOnDblClick: TNotifyEvent; // maps to listbox double click event
326 FOnDropDown: TNotifyEvent; // event called when listbox appears
327 FOnDropDownClose: TNotifyEvent; // event called when listbox disappears
328 FOnKeyDown: TKeyEvent; // maps to editbox keydown event
329 FOnKeyPress: TKeyPressEvent; // maps to editbox keypress event
330 FOnKeyUp: TKeyEvent; // maps to editbox keyup event
331 FOnKeyPause: TNotifyEvent; // delayed change event when using keyboard
332 FOnMouseClick: TNotifyEvent; // called when click event triggered by mouse
333 FOnNeedData: TORNeedDataEvent; // called for longlist when more items needed
334 FCheckedState: string; // Used to refresh checkboxes when combo box cancel is pressed
335 FOnCheckedText: TORCheckComboTextEvent; // Used to modify the edit box display text when using checkboxes
336 FCheckBoxEditColor: TColor; // Edit Box color for Check Box Combo List, when not in Focus
337 FTemplateField: boolean;
338 FCharsNeedMatch: integer; // how many text need to be matched for auto selection
339 FUniqueAutoComplete: Boolean; // If true only perform autocomplete for unique list items.
340 FBlackColorMode: boolean;
341 FDisableHints: boolean; // true if hints have been disabled because drop down window was opened
342 FDropDownStatusChangedCount: integer; // prevents multiple calls to disabling hint window
343 procedure DropDownStatusChanged(opened: boolean);
344 procedure ClearDropDownStatus;
345 function EditControl: TWinControl;
346 procedure AdjustSizeOfSelf;
347 procedure DropButtonDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState;
348 X, Y: Integer);
349 procedure DropButtonUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState;
350 X, Y: Integer);
351 procedure FwdChange(Sender: TObject);
352 procedure FwdChangeDelayed;
353 procedure FwdClick(Sender: TObject);
354 procedure FwdDblClick(Sender: TObject);
355 procedure FwdKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
356 procedure FwdKeyPress(Sender: TObject; var Key: Char);
357 procedure FwdKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
358 procedure FwdMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState;
359 X, Y: Integer);
360 procedure FwdNeedData(Sender: TObject; const StartFrom: string;
361 Direction, InsertAt: Integer);
362 procedure SetNumForMatch(const NumberForMatch: integer);
363 function GetAutoSelect: Boolean;
364 function GetColor: TColor;
365 function GetDelimiter: Char;
366 function GetDisplayText(Index: Integer): string;
367 function GetItemHeight: Integer;
368 function GetItemID: Variant;
369 function GetItemIEN: Int64;
370 function GetItemIndex: Integer;
371 function GetItemTipEnable: Boolean;
372 function GetItemTipColor: TColor;
373 function GetLongList: Boolean;
374 function GetMaxLength: Integer;
375 function GetPieces: string;
376 function GetReference(Index: Integer): Variant;
377 function GetSelLength: Integer;
378 function GetSelStart: Integer;
379 function GetSelText: string;
380 function GetShortCount: Integer;
381 function GetSorted: Boolean;
382 function GetHideSynonyms: boolean;
383 function GetSynonymChars: string;
384 function GetTabPositions: string;
385 function GetTabPosInPixels: boolean;
386 function GetText: string;
387 procedure SetAutoSelect(Value: Boolean);
388 procedure SetColor(Value: TColor);
389 procedure SetDelimiter(Value: Char);
390 procedure SetDropDownCount(Value: Integer);
391 procedure SetDroppedDown(Value: Boolean);
392 procedure SetEditRect;
393 procedure SetEditText(const Value: string);
394 procedure SetItemIndex(Value: Integer);
395 procedure SetItemHeight(Value: Integer);
396 procedure SetItemTipEnable(Value: Boolean);
397 procedure SetItemTipColor(Value: TColor);
398 procedure SetLongList(Value: Boolean);
399 procedure SetMaxLength(Value: Integer);
400 procedure SetPieces(const Value: string);
401 procedure SetReference(Index: Integer; AReference: Variant);
402 procedure SetSelLength(Value: Integer);
403 procedure SetSelStart(Value: Integer);
404 procedure SetSelText(const Value: string);
405 procedure SetSorted(Value: Boolean);
406 procedure SetHideSynonyms(Value: boolean);
407 procedure SetSynonymChars(Value: string);
408 procedure SetStyle(Value: TORComboStyle);
409 procedure SetTabPositions(const Value: string);
410 procedure SetTabPosInPixels(const Value: boolean);
411 procedure SetText(const Value: string);
412 procedure SetItems(const Value: TStrings);
413 procedure StartKeyTimer;
414 procedure StopKeyTimer;
415 procedure WMDestroy (var Message: TWMDestroy); message WM_DESTROY;
416 procedure CMFontChanged (var Message: TMessage); message CM_FONTCHANGED;
417 procedure WMMove (var Message: TWMMove); message WM_MOVE;
418 procedure WMSize (var Message: TWMSize); message WM_SIZE;
419 procedure WMTimer (var Message: TWMTimer); message WM_TIMER;
420 procedure UMGotFocus (var Message: TMessage); message UM_GOTFOCUS;
421 function GetCheckBoxes: boolean;
422 function GetChecked(Index: Integer): Boolean;
423 function GetCheckEntireLine: boolean;
424 function GetFlatCheckBoxes: boolean;
425 procedure SetCheckBoxes(const Value: boolean);
426 procedure SetChecked(Index: Integer; const Value: Boolean);
427 procedure SetCheckEntireLine(const Value: boolean);
428 procedure SetFlatCheckBoxes(const Value: boolean);
429 function GetCheckedString: string;
430 procedure SetCheckedString(const Value: string);
431 procedure SetCheckBoxEditColor(const Value: TColor);
432 procedure SetListItemsOnly(const Value: Boolean);
433 procedure SetOnCheckedText(const Value: TORCheckComboTextEvent);
434 procedure SetTemplateField(const Value: boolean);
435 function GetOnSynonymCheck: TORSynonymCheckEvent;
436 procedure SetOnSynonymCheck(const Value: TORSynonymCheckEvent);
437 function GetMItems: TStrings;
438 procedure SetCaption(const Value: string);
439 function GetCaption: string;
440 function GetCaseChanged: boolean;
441 procedure SetCaseChanged(const Value: boolean);
442 function GetLookupPiece: integer;
443 procedure SetLookupPiece(const Value: integer);
444 procedure SetUniqueAutoComplete(const Value: Boolean);
445 procedure LoadComboBoxImage;
446 protected
447 procedure DropPanelBtnPressed(OKBtn, AutoClose: boolean);
448 function GetEditBoxText(Index: Integer): string;
449 procedure CheckBoxSelected(Sender: TObject; Index: integer);
450 procedure UpdateCheckEditBoxText;
451 procedure DoEnter; override;
452 procedure DoExit; override;
453 procedure Loaded; override;
454 function GetEnabled: boolean; override;
455 procedure SetEnabled(Value: boolean); override;
456 public
457 constructor Create(AOwner: TComponent); override;
458 destructor Destroy; override;
459 function AddReference(const S: string; AReference: Variant): Integer;
460 procedure Clear;
461 procedure ClearTop;
462 procedure ForDataUse(Strings: TStrings);
463 procedure InitLongList(S: string);
464 procedure InsertSeparator;
465 procedure Invalidate; override;
466 procedure SetTextAutoComplete(TextToMatch : String);
467 function GetIEN(AnIndex: Integer): Int64;
468 function SelectByIEN(AnIEN: Int64): Integer;
469 function SelectByID(const AnID: string): Integer;
470 function SetExactByIEN(AnIEN: Int64; const AnItem: string): Integer;
471 function IndexOfReference(AReference: Variant): Integer;
472 procedure InsertReference(Index: Integer; const S: string; AReference: Variant);
473 procedure SelectAll;
474 procedure SetBlackColorMode(Value: boolean);
475 function SupportsDynamicProperty(PropertyID: integer): boolean;
476 function GetDynamicProperty(PropertyID: integer): string;
477 property DisplayText[Index: Integer]: string read GetDisplayText;
478 property DroppedDown: Boolean read FDroppedDown write SetDroppedDown;
479 property ItemID: Variant read GetItemID;
480 property ItemIEN: Int64 read GetItemIEN;
481 property ItemIndex: Integer read GetItemIndex write SetItemIndex;
482 property References[Index: Integer]: Variant read GetReference write SetReference;
483 property SelLength: Integer read GetSelLength write SetSelLength;
484 property SelStart: Integer read GetSelStart write SetSelStart;
485 property SelText: string read GetSelText write SetSelText;
486 property ShortCount: Integer read GetShortCount;
487 property Checked[Index: Integer]: Boolean read GetChecked write SetChecked;
488 property CheckedString: string read GetCheckedString write SetCheckedString;
489 property TemplateField: boolean read FTemplateField write SetTemplateField;
490 property MItems: TStrings read GetMItems;
491 published
492 property Anchors;
493 property CaseChanged: boolean read GetCaseChanged write SetCaseChanged default TRUE;
494 property CheckBoxes: boolean read GetCheckBoxes write SetCheckBoxes default FALSE;
495 property Style: TORComboStyle read FStyle write SetStyle;
496 property Align;
497 property AutoSelect: Boolean read GetAutoSelect write SetAutoSelect;
498 property Caption: string read GetCaption write SetCaption;
499 property Color: TColor read GetColor write SetColor;
500 property Ctl3D;
501 property Delimiter: Char read GetDelimiter write SetDelimiter default '^';
502 property DropDownCount: Integer read FDropDownCount write SetDropDownCount;
503 property Enabled;
504 property Font;
505 property Items: TStrings read FItems write SetItems;
506 property ItemHeight: Integer read GetItemHeight write SetItemHeight;
507 property ItemTipColor: TColor read GetItemTipColor write SetItemTipColor;
508 property ItemTipEnable: Boolean read GetItemTipEnable write SetItemTipEnable;
509 property ListItemsOnly: Boolean read FListItemsOnly write SetListItemsOnly;
510 property LongList: Boolean read GetLongList write SetLongList;
511 property LookupPiece: Integer read GetLookupPiece write SetLookupPiece;
512 property MaxLength: Integer read GetMaxLength write SetMaxLength;
513 property ParentColor;
514 property ParentCtl3D;
515 property ParentFont;
516 property ParentShowHint;
517 property Pieces: string read GetPieces write SetPieces;
518 property PopupMenu;
519 property ShowHint;
520 property HideSynonyms: boolean read GetHideSynonyms write SetHideSynonyms default FALSE;
521 property Sorted: Boolean read GetSorted write SetSorted;
522 property SynonymChars: string read GetSynonymChars write SetSynonymChars;
523 property TabPosInPixels: boolean read GetTabPosInPixels write SetTabPosInPixels default False; // MUST be before TabPositions!
524 property TabPositions: string read GetTabPositions write SetTabPositions;
525 property TabOrder;
526 property TabStop;
527 property Text: string read GetText write SetText;
528 property Visible;
529 property FlatCheckBoxes: boolean read GetFlatCheckBoxes write SetFlatCheckBoxes default TRUE;
530 property CheckEntireLine: boolean read GetCheckEntireLine write SetCheckEntireLine default FALSE;
531 property CheckBoxEditColor: TColor read FCheckBoxEditColor write SetCheckBoxEditColor default clBtnFace;
532 property OnCheckedText: TORCheckComboTextEvent read FOnCheckedText write SetOnCheckedText;
533 property OnChange: TNotifyEvent read FOnChange write FOnChange;
534 property OnClick: TNotifyEvent read FOnClick write FOnClick;
535 property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;
536 property OnDragDrop;
537 property OnDragOver;
538 property OnDropDown: TNotifyEvent read FOnDropDown write FOnDropDown;
539 property OnDropDownClose: TNotifyEvent read FOnDropDownClose write FOnDropDownClose;
540 property OnEnter;
541 property OnExit;
542 property OnKeyDown: TKeyEvent read FOnKeyDown write FOnKeyDown;
543 property OnKeyPress: TKeyPressEvent read FOnKeyPress write FOnKeyPress;
544 property OnKeyUp: TKeyEvent read FOnKeyUp write FOnKeyUp;
545 property OnKeyPause: TNotifyEvent read FOnKeyPause write FOnKeyPause;
546 property OnMouseClick: TNotifyEvent read FOnMouseClick write FOnMouseClick;
547 property OnNeedData: TORNeedDataEvent read FOnNeedData write FOnNeedData;
548 property OnResize;
549 property OnSynonymCheck: TORSynonymCheckEvent read GetOnSynonymCheck write SetOnSynonymCheck;
550 property CharsNeedMatch: integer read FCharsNeedMatch write SetNumForMatch;
551{UniqueAutoComplete Was added as a result of the following defects:
552 7293 - PTM 85: Backspace and Dosage: Desired dosage does not populate if dosage is not in local dosage field
553 7337 - PTM 160 Meds: #8 IMO - Simple - Change Order in which Error generated if "Enter" is hit instead of "OK"
554 7278 - PTM 36 Meds: Select 40000 UNT/2ML and backspace to 4000 the dose selected remains 40000
555 7284 - Inconsistencies of pulling in a dose from the Possible Dose File }
556 property UniqueAutoComplete: Boolean read FUniqueAutoComplete write SetUniqueAutoComplete default False;
557 end;
558
559 TORAutoPanel = class(TPanel)
560 private
561 FSizes: TList;
562 procedure BuildSizes( Control: TWinControl);
563 procedure DoResize( Control: TWinControl; var CurrentIndex: Integer);
564 protected
565 procedure Loaded; override;
566 procedure Resize; override;
567 public
568 destructor Destroy; override;
569 end;
570
571 TOROffsetLabel = class(TGraphicControl) // see TCustomLabel in the VCL
572 private
573 FHorzOffset: Integer; // offset from left of label in pixels
574 FVertOffset: Integer; // offset from top of label in pixels
575 FWordWrap: Boolean; // true if word wrap should occur
576 function GetTransparent: Boolean;
577 procedure AdjustSizeOfSelf;
578 procedure DoDrawText(var Rect: TRect; Flags: Word);
579 procedure SetHorzOffset(Value: Integer);
580 procedure SetVertOffset(Value: Integer);
581 procedure SetTransparent(Value: Boolean);
582 procedure SetWordWrap(Value: Boolean);
583 procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
584 procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
585 protected
586 procedure Paint; override;
587 public
588 constructor Create(AOwner: TComponent); override;
589 published
590 property Align;
591 property Caption;
592 property Color;
593 property Enabled;
594 property Font;
595 property HorzOffset: Integer read FHorzOffset write SetHorzOffset;
596 property ParentColor;
597 property ParentFont;
598 property ParentShowHint;
599 property PopupMenu;
600 property ShowHint;
601 property Transparent: Boolean read GetTransparent write SetTransparent;
602 property VertOffset: Integer read FVertOffset write SetVertOffset;
603 property Visible;
604 property WordWrap: Boolean read FWordWrap write SetWordWrap;
605 property OnClick;
606 property OnDblClick;
607 property OnDragDrop;
608 property OnDragOver;
609 property OnEndDrag;
610 property OnMouseDown;
611 property OnMouseMove;
612 property OnMouseUp;
613 property OnStartDrag;
614 end;
615
616 TORAlignButton = class(TButton)
617 private
618 FAlignment: TAlignment;
619 FWordWrap: boolean;
620 FLayout: TTextLayout;
621 protected
622 procedure CreateParams(var Params: TCreateParams); override;
623 procedure SetAlignment(const Value: TAlignment);
624 procedure SetLayout(const Value: TTextLayout);
625 procedure SetWordWrap(const Value: boolean);
626 public
627 constructor Create(AOwner: TComponent); override;
628 published
629 property Align;
630 property Alignment: TAlignment read FAlignment write SetAlignment default taCenter;
631 property Layout: TTextLayout read FLayout write SetLayout default tlCenter;
632 property WordWrap: boolean read FWordWrap write SetWordWrap default FALSE;
633 end;
634
635{ TORAlignBitBtn = class(TBitBtn)
636 published
637 property Align;
638 end;}
639
640 TORAlignSpeedButton = class(TSpeedButton)
641 protected
642 procedure Paint; override;
643 public
644 property Canvas;
645 published
646 property Align;
647 property OnResize;
648 end;
649
650 TORAlignEdit = class(TEdit) //Depricated -- Use TCaptionEdit instead
651 published
652 property Align;
653 end;
654
655 TORDraggingEvent = procedure(Sender: TObject; Node: TTreeNode; var CanDrag: boolean) of object;
656
657
658 TCaptionTreeView = class(TTreeView, IVADynamicProperty)
659 private
660 procedure SetCaption(const Value: string);
661 function GetCaption: string;
662 protected
663 FCaptionComponent: TStaticText;
664 public
665 function SupportsDynamicProperty(PropertyID: integer): boolean;
666 function GetDynamicProperty(PropertyID: integer): string;
667 published
668 property Align;
669 property Caption: string read GetCaption write SetCaption;
670 end;
671
672 TORTreeView = class;
673
674 TORTreeNode = class(TTreeNode)
675 private
676 FTag: integer;
677 FStringData: string;
678 FCaption: string;
679 function GetParent: TORTreeNode;
680 procedure SetCaption(const Value: string);
681 protected
682 function GetText: string;
683 procedure SetText(const Value: string);
684 procedure UpdateText(const Value: string; UpdateData: boolean = TRUE);
685 function GetBold: boolean;
686 procedure SetBold(const Value: boolean);
687 procedure SetStringData(const Value: string);
688 function GetORTreeView: TORTreeView;
689 public
690 procedure SetPiece(PieceNum: Integer; const NewPiece: string);
691 procedure EnsureVisible;
692 property Bold: boolean read GetBold write SetBold;
693 property Tag: integer read FTag write FTag;
694 property StringData: string read FStringData write SetStringData;
695 property TreeView: TORTreeView read GetORTreeView;
696 property Text: string read GetText write SetText;
697 property Parent: TORTreeNode read GetParent;
698 property Caption: string read FCaption write SetCaption;
699 end;
700
701 TNodeCaptioningEvent = procedure(Sender: TObject; var Caption: string) of object;
702
703 TORTreeView = class(TCaptionTreeView)
704 private
705 FOnDragging: TORDraggingEvent;
706 FDelim: Char;
707 FPiece: integer;
708 FOnAddition: TTVExpandedEvent;
709 FShortNodeCaptions: boolean;
710 FOnNodeCaptioning: TNodeCaptioningEvent;
711 procedure SetShortNodeCaptions(const Value: boolean);
712 protected
713 procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
714 function CreateNode: TTreeNode; override;
715 function GetHorzScrollPos: integer;
716 procedure SetHorzScrollPos(Value: integer);
717 function GetVertScrollPos: integer;
718 procedure SetVertScrollPos(Value: integer);
719 procedure SetNodeDelim(const Value: Char);
720 procedure SetNodePiece(const Value: integer);
721 public
722 constructor Create(AOwner: TComponent); override;
723 function FindPieceNode(Value: string;
724 ParentDelim: Char = #0; StartNode: TTreeNode = nil): TORTreeNode; overload;
725 function FindPieceNode(Value: string; APiece: integer;
726 ParentDelim: Char = #0; StartNode: TTreeNode = nil): TORTreeNode; overload;
727 procedure RenameNodes;
728 function GetExpandedIDStr(APiece: integer; ParentDelim: char = #0): string;
729 procedure SetExpandedIDStr(APiece: integer; const Value: string); overload;
730 procedure SetExpandedIDStr(APiece: integer; ParentDelim: char;
731 const Value: string); overload;
732 function GetNodeID(Node: TORTreeNode; ParentDelim: Char = #0): string; overload;
733 function GetNodeID(Node: TORTreeNode; APiece: integer; ParentDelim: Char = #0): string; overload;
734 published
735 property Caption;
736 property NodeDelim: Char read FDelim write SetNodeDelim default '^';
737 property NodePiece: integer read FPiece write SetNodePiece;
738 property OnAddition: TTVExpandedEvent read FOnAddition write FOnAddition;
739 property OnDragging: TORDraggingEvent read FOnDragging write FOnDragging;
740 property HorzScrollPos: integer read GetHorzScrollPos write SetHorzScrollPos default 0;
741 property VertScrollPos: integer read GetVertScrollPos write SetVertScrollPos default 0;
742 property ShortNodeCaptions: boolean read FShortNodeCaptions write SetShortNodeCaptions default False;
743 property OnNodeCaptioning: TNodeCaptioningEvent read FOnNodeCaptioning write FOnNodeCaptioning;
744 end;
745
746 TORCBImageIndexes = class(TComponent)
747 private
748 FImages: TCustomImageList;
749 FImageChangeLink: TChangeLink;
750 FCheckedEnabledIndex: integer;
751 FGrayedEnabledIndex: integer;
752 FUncheckedEnabledIndex: integer;
753 FCheckedDisabledIndex: integer;
754 FGrayedDisabledIndex: integer;
755 FUncheckedDisabledIndex: integer;
756 protected
757 procedure SetCheckedDisabledIndex(const Value: integer);
758 procedure SetCheckedEnabledIndex(const Value: integer);
759 procedure SetGrayedDisabledIndex(const Value: integer);
760 procedure SetGrayedEnabledIndex(const Value: integer);
761 procedure SetUncheckedDisabledIndex(const Value: integer);
762 procedure SetUncheckedEnabledIndex(const Value: integer);
763 procedure ImageListChanged(Sender: TObject);
764 procedure Notification(AComponent: TComponent; Operation: TOperation); override;
765 function IdxString: string;
766 procedure SetIdxString(Value: string);
767 procedure SetImages(const Value: TCustomImageList);
768 public
769 constructor Create(AOwner: TComponent); override;
770 destructor Destroy; override;
771 published
772 property CheckedEnabledIndex: integer read FCheckedEnabledIndex write SetCheckedEnabledIndex;
773 property CheckedDisabledIndex: integer read FCheckedDisabledIndex write SetCheckedDisabledIndex;
774 property GrayedEnabledIndex: integer read FGrayedEnabledIndex write SetGrayedEnabledIndex;
775 property GrayedDisabledIndex: integer read FGrayedDisabledIndex write SetGrayedDisabledIndex;
776 property UncheckedEnabledIndex: integer read FUncheckedEnabledIndex write SetUncheckedEnabledIndex;
777 property UncheckedDisabledIndex: integer read FUncheckedDisabledIndex write SetUncheckedDisabledIndex;
778 end;
779
780 TGrayedStyle = (gsNormal, gsQuestionMark, gsBlueQuestionMark);
781
782 TORCheckBox = class(TCheckBox, IORBlackColorModeCompatible)
783 private
784 FStringData: string;
785 FCanvas: TCanvas;
786 FGrayedToChecked: boolean;
787 FCustomImagesOwned: boolean;
788 FCustomImages: TORCBImageIndexes;
789 FGrayedStyle: TGrayedStyle;
790 FWordWrap: boolean;
791 FAutoSize: boolean;
792 FSingleLine: boolean;
793 FSizable: boolean;
794 FGroupIndex: integer;
795 FAllowAllUnchecked: boolean;
796 FRadioStyle: boolean;
797 FAssociate: TControl;
798 FFocusOnBox: boolean;
799 FBlackColorMode: boolean;
800 procedure SetFocusOnBox(value: boolean);
801 procedure CNMeasureItem (var Message: TWMMeasureItem); message CN_MEASUREITEM;
802 procedure CNDrawItem (var Message: TWMDrawItem); message CN_DRAWITEM;
803 procedure CMFontChanged (var Message: TMessage); message CM_FONTCHANGED;
804 procedure CMEnabledChanged (var Message: TMessage); message CM_ENABLEDCHANGED;
805 procedure WMLButtonDblClk (var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
806 procedure WMSize (var Message: TWMSize); message WM_SIZE;
807 procedure BMSetCheck (var Message: TMessage); message BM_SETCHECK;
808 procedure BMGetCheck (var Message: TMessage); message BM_GETCHECK;
809 procedure BMGetState (var Message: TMessage); message BM_GETSTATE;
810 function GetImageList: TCustomImageList;
811 function GetImageIndexes: string;
812 procedure SetImageIndexes(const Value: string);
813 procedure SetImageList(const Value: TCustomImageList);
814 procedure SetWordWrap(const Value: boolean);
815 function GetCaption: TCaption;
816 procedure SetCaption(const Value: TCaption);
817 procedure SyncAllowAllUnchecked;
818 procedure SetAllowAllUnchecked(const Value: boolean);
819 procedure SetGroupIndex(const Value: integer);
820 procedure SetRadioStyle(const Value: boolean);
821 procedure SetAssociate(const Value: TControl);
822 protected
823 procedure SetAutoSize(Value: boolean); override;
824 procedure GetDrawData(CanvasHandle: HDC; var Bitmap: TBitmap;
825 var FocRect, Rect: TRect;
826 var DrawOptions: UINT;
827 var TempBitMap: boolean);
828 procedure DrawItem(const DrawItemStruct: TDrawItemStruct); dynamic;
829 procedure Toggle; override;
830 procedure CreateParams(var Params: TCreateParams); override;
831 procedure SetGrayedStyle(Value: TGrayedStyle);
832 constructor ListViewCreate(AOwner: TComponent; ACustomImages: TORCBImageIndexes);
833 procedure CreateCommon(AOwner: TComponent);
834 property CustomImages: TORCBImageIndexes read FCustomImages;
835 procedure SetParent(AParent: TWinControl); override;
836 procedure UpdateAssociate;
837 procedure Notification(AComponent: TComponent; Operation: TOperation); override;
838 public
839 constructor Create(AOwner: TComponent); override;
840 destructor Destroy; override;
841 procedure AutoAdjustSize;
842 procedure SetBlackColorMode(Value: boolean);
843 property SingleLine: boolean read FSingleLine;
844 property StringData: string read FStringData write FStringData;
845 published
846 property FocusOnBox: boolean read FFocusOnBox write SetFocusOnBox default false;
847 property GrayedStyle: TGrayedStyle read FGrayedStyle write SetGrayedStyle default gsNormal;
848 property GrayedToChecked: boolean read FGrayedToChecked write FGrayedToChecked default TRUE;
849 property ImageIndexes: string read GetImageIndexes write SetImageIndexes;
850 property ImageList: TCustomImageList read GetImageList write SetImageList;
851 property WordWrap: boolean read FWordWrap write SetWordWrap default FALSE;
852 property AutoSize: boolean read FAutoSize write SetAutoSize default FALSE;
853 property Caption: TCaption read GetCaption write SetCaption;
854 property AllowAllUnchecked: boolean read FAllowAllUnchecked write SetAllowAllUnchecked default TRUE;
855 property GroupIndex: integer read FGroupIndex write SetGroupIndex default 0;
856 property RadioStyle: boolean read FRadioStyle write SetRadioStyle default FALSE;
857 property Associate: TControl read FAssociate write SetAssociate;
858 property OnEnter;
859 property OnExit;
860 end;
861
862 TORListView = class(TListView)
863 private
864 protected
865 procedure WMNotify(var Message: TWMNotify); message WM_NOTIFY;
866 procedure LVMSetColumn(var Message: TMessage); message LVM_SETCOLUMN;
867 procedure LVMSetColumnWidth(var Message: TMessage); message LVM_SETCOLUMNWIDTH;
868 end;
869
870 { TORPopupMenu and TORMenuItem are not available at design time, since they
871 would offer little value there. They are currently used for dynamic menu
872 creation }
873 TORPopupMenu = class(TPopupMenu)
874 private
875 FData: string;
876 public
877 property Data: string read FData write FData;
878 end;
879
880 TORMenuItem = class(TMenuItem)
881 private
882 FData: string;
883 public
884 property Data: string read FData write FData;
885 end;
886
887 (*
888 TORCalendar = class(TCalendar)
889 protected
890 procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;
891 end;
892 *)
893
894 TKeyClickPanel = class(TPanel)
895 protected
896 procedure KeyDown(var Key: Word; Shift: TShiftState); override;
897 end;
898
899 TKeyClickRadioGroup = class(TRadioGroup)
900 protected
901 procedure KeyDown(var Key: Word; Shift: TShiftState); override;
902 procedure Click; override;
903 public
904 constructor Create(AOwner: TComponent); override;
905 end;
906
907 TCaptionListBox = class(TListBox, IVADynamicProperty)
908 private
909 FHoverItemPos: integer;
910 FRightClickSelect: boolean; // When true, a right click selects teh item
911 FHintOnItem: boolean;
912 procedure SetCaption(const Value: string);
913 function GetCaption: string;
914 procedure WMRButtonUp(var Message: TWMRButtonUp); message WM_RBUTTONUP;
915 procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
916 procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;
917 procedure MoveFocusDown;
918 procedure MoveFocusUp;
919 protected
920 FCaptionComponent: TStaticText;
921 procedure DoEnter; override;
922 public
923 function SupportsDynamicProperty(PropertyID: integer): boolean;
924 function GetDynamicProperty(PropertyID: integer): string;
925 published
926 property RightClickSelect: boolean read FRightClickSelect write FRightClickSelect default FALSE;
927 property Caption: string read GetCaption write SetCaption;
928 //Make the ListBox's hint contain the contents of the listbox Item the mouse is currently over.
929 property HintOnItem: boolean read FHintOnItem write FHintOnItem default FALSE;
930 end;
931
932 TCaptionCheckListBox = class(TCheckListBox, IVADynamicProperty)
933 private
934 procedure SetCaption(const Value: string);
935 function GetCaption: string;
936 protected
937 FCaptionComponent: TStaticText;
938 public
939 function SupportsDynamicProperty(PropertyID: integer): boolean;
940 function GetDynamicProperty(PropertyID: integer): string;
941 published
942 property Caption: string read GetCaption write SetCaption;
943 end;
944
945 TCaptionMemo = class(TMemo, IVADynamicProperty)
946 private
947 procedure SetCaption(const Value: string);
948 function GetCaption: string;
949 protected
950 FCaptionComponent: TStaticText;
951 public
952 function SupportsDynamicProperty(PropertyID: integer): boolean;
953 function GetDynamicProperty(PropertyID: integer): string;
954 published
955 property Caption: string read GetCaption write SetCaption;
956 end;
957
958 TCaptionEdit = class(TEdit, IVADynamicProperty)
959 private
960 procedure SetCaption(const Value: string);
961 function GetCaption: string;
962 protected
963 FCaptionComponent: TStaticText;
964 public
965 function SupportsDynamicProperty(PropertyID: integer): boolean;
966 function GetDynamicProperty(PropertyID: integer): string;
967 published
968 property Align;
969 property Caption: string read GetCaption write SetCaption;
970 end;
971
972 TCaptionRichEdit = class(TRichEdit, IVADynamicProperty)
973 private
974 protected
975 FCaption: string;
976 public
977 function SupportsDynamicProperty(PropertyID: integer): boolean;
978 function GetDynamicProperty(PropertyID: integer): string;
979 published
980 property Align;
981 property Caption: string read FCaption write FCaption;
982 end;
983
984 TCaptionComboBox = class(TComboBox, IVADynamicProperty)
985 private
986 procedure SetCaption(const Value: string);
987 function GetCaption: string;
988 protected
989 FCaptionComponent: TStaticText;
990 public
991 function SupportsDynamicProperty(PropertyID: integer): boolean;
992 function GetDynamicProperty(PropertyID: integer): string;
993 published
994 property Caption: string read GetCaption write SetCaption;
995 end;
996
997 TCaptionListView = class(TListView, IVADynamicProperty)
998 public
999 function SupportsDynamicProperty(PropertyID: integer): boolean;
1000 function GetDynamicProperty(PropertyID: integer): string;
1001 published
1002 property Caption;
1003 end;
1004
1005 TCaptionStringGrid = class(TStringGrid, IVADynamicProperty)
1006 private
1007 FJustToTab: boolean;
1008 FCaption: string;
1009 protected
1010 procedure KeyUp(var Key: Word; Shift: TShiftState); override;
1011 public
1012 procedure IndexToColRow( index: integer; var Col: integer; var Row: integer);
1013 function ColRowToIndex( Col: integer; Row: Integer): integer;
1014 function SupportsDynamicProperty(PropertyID: integer): boolean;
1015 function GetDynamicProperty(PropertyID: integer): string;
1016 published
1017 property Caption: string read FCaption write FCaption;
1018 property JustToTab: boolean read FJustToTab write FJustToTab default FALSE;
1019 end;
1020
1021function FontWidthPixel(FontHandle: THandle): Integer;
1022function FontHeightPixel(FontHandle: THandle): Integer;
1023function ItemTipKeyHook(Code: Integer; wParam: WPARAM; lParam: LPARAM): LRESULT; StdCall;
1024
1025{I may have messed up my Windows.pas file, but mine defines NotifyWinEvent without a stdcall.}
1026procedure GoodNotifyWinEvent(event: DWORD; hwnd: HWND; idObject, idChild: Longint); stdcall;
1027
1028function CalcShortName( LongName: string; PrevLongName: string): string;
1029
1030{Returns True if any one of 3 mouse buttons are down left, right, or middle}
1031function IsAMouseButtonDown : boolean;
1032
1033implementation // ---------------------------------------------------------------------------
1034
1035{$R ORCTRLS}
1036
1037uses
1038 VAUtils;
1039
1040const
1041 ALPHA_DISTRIBUTION: array[0..100] of string[3] = ('',' ','ACE','ADG','ALA','AMI','ANA','ANT',
1042 'ARE','ASU','AZO','BCP','BIC','BOO','BST','CAF','CAR','CD6','CHE','CHO','CMC','CON','CPD',
1043 'CVI','DAA','DEF','DEP','DIA','DIH','DIP','DP ','EAR','EM ','EPI','ETH','F2G','FIB','FML',
1044 'FUM','GEL','GLU','GPQ','HAL','HEM','HIS','HUN','HYL','IDS','IND','INT','ISO','KEX','LAN',
1045 'LEV','LOY','MAG','MAX','MER','MET','MIC','MON','MUD','NAI','NEU','NIT','NUC','OMP','OTH',
1046 'P42','PAR','PEN','PHA','PHO','PLA','POL','PRA','PRO','PSE','PYR','RAN','REP','RIB','SAA',
1047 'SCL','SFL','SMO','SPO','STR','SUL','TAG','TET','THI','TOL','TRI','TRY','UNC','VAR','VIT',
1048 'WRO','ZYM',#127#127#127);
1049
1050 CBO_CYMARGIN = 8; // vertical whitespace in the edit portion of combobox
1051 CBO_CXBTN = 13; // width of drop down button in combobox
1052 CBO_CXFRAME = 5; // offset to account for frame around the edit part of combobox
1053
1054 NOREDRAW = 0; // suspend screen updates
1055 DOREDRAW = 1; // allow screen updates
1056
1057 KEY_TIMER_DELAY = 500; // 500 ms delay after key up before OnKeyPause called
1058 KEY_TIMER_ID = 5800; // arbitrary, use high number in case TListBox uses timers
1059
1060 { use high word to pass positioning flags since listbox is limited to 32767 items }
1061 //SFI_TOP = $80000000; // top of listbox (decimal value: -2147483648)
1062 //SFI_END = $90000000; // end of listbox (decimal value: -1879048192)
1063 SFI_TOP = -2147483646; // top of listbox (hex value: $80000001)
1064 SFI_END = -1879048192; // end of listbox (hex value: $90000000)
1065
1066 CheckWidth = 15; // CheckBox Width space to reserve for TORListBox
1067 CheckComboBtnHeight = 21;
1068 MaxNeedDataLen = 64;
1069
1070type
1071 TItemTip = class(TCustomControl)
1072 private
1073 FShowing: Boolean; // true when itemtip is visible
1074 FListBox: TORListBox; // current listbox displaying itemtips
1075 FListItem: integer;
1076 FPoint: TPoint;
1077 FSelected: boolean;
1078 FTabs: array[0..MAX_TABS] of Integer; // Holds the pixel offsets for tabs
1079 procedure GetTabSettings;
1080 protected
1081 constructor Create(AOwner: TComponent); override;
1082 destructor Destroy; override;
1083 procedure CreateParams(var Params: TCreateParams); override;
1084 procedure Paint; override;
1085 procedure Hide;
1086 procedure UpdateText(CatchMouse: Boolean);
1087 procedure Show(AListBox: TORListBox; AnItem: Integer; APoint: TPoint; CatchMouse: Boolean);
1088 end;
1089
1090 TSizeRatio = class // relative sizes and positions for resizing
1091 CLeft: Extended;
1092 CTop: Extended;
1093 CWidth: Extended;
1094 CHeight: Extended;
1095 constructor Create(ALeft, ATop, AWidth, AHeight: Extended);
1096 end;
1097
1098var
1099 uKeyHookHandle: HHOOK; // handle to capture key events & hide ItemTip window
1100 uItemTip: TItemTip; // ItemTip window
1101 uItemTipCount: Integer; // number of ItemTip clients
1102 uNewStyle: Boolean; // True if using Windows 95 interface
1103
1104{ General functions and procedures --------------------------------------------------------- }
1105
1106function ClientWidthOfList(AListBox: TORListBox): Integer;
1107begin
1108 with AListBox do
1109 begin
1110 Result := Width;
1111 if BorderStyle = bsSingle then
1112 begin
1113 Dec(Result, 1);
1114 if Ctl3D then Dec(Result, 1);
1115 end;
1116 end;
1117 Dec(Result, GetSystemMetrics(SM_CXVSCROLL));
1118end;
1119
1120function FontWidthPixel(FontHandle: THandle): Integer;
1121{ return in pixels the average character width of the font passed in FontHandle }
1122var
1123 DC: HDC;
1124 SaveFont: HFont;
1125 Extent: TSize;
1126begin
1127 DC := GetDC(0);
1128 try
1129 SaveFont := SelectObject(DC, FontHandle);
1130 try
1131 GetTextExtentPoint32(DC, 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz', 52, Extent);
1132 Result := Trunc((Extent.cx / 26 + 1) / 2); // Round() doesn't line up with dialog units
1133 finally
1134 SelectObject(DC, SaveFont);
1135 end;
1136 finally
1137 ReleaseDC(0, DC);
1138 end;
1139end;
1140
1141function FontHeightPixel(FontHandle: THandle): Integer;
1142{ return in pixels the height of the font passed in FontHandle }
1143var
1144 DC: HDC;
1145 SaveFont: HFont;
1146 FontMetrics: TTextMetric;
1147begin
1148 DC := GetDC(0);
1149 SaveFont := SelectObject(DC, FontHandle);
1150 GetTextMetrics(DC, FontMetrics);
1151 Result := FontMetrics.tmHeight;
1152 SelectObject(DC, SaveFont);
1153 ReleaseDC(0, DC);
1154end;
1155
1156function HigherOf(i, j: Integer): Integer;
1157{ returns the greater of two integers }
1158begin
1159 Result := i;
1160 if j > i then Result := j;
1161end;
1162
1163function LowerOf(i, j: Integer): Integer;
1164{ returns the lesser of two integers }
1165begin
1166 Result := i;
1167 if j < i then Result := j;
1168end;
1169
1170function Piece(const S: string; Delim: char; PieceNum: Integer): string;
1171{ returns the Nth piece (PieceNum) of a string delimited by Delim }
1172var
1173 i: Integer;
1174 Strt, Next: PChar;
1175begin
1176 i := 1;
1177 Strt := PChar(S);
1178 Next := StrScan(Strt, Delim);
1179 while (i < PieceNum) and (Next <> nil) do
1180 begin
1181 Inc(i);
1182 Strt := Next + 1;
1183 Next := StrScan(Strt, Delim);
1184 end;
1185 if Next = nil then Next := StrEnd(Strt);
1186 if i < PieceNum then Result := '' else SetString(Result, Strt, Next - Strt);
1187end;
1188
1189procedure SetPiece(var x: string; Delim: Char; PieceNum: Integer; const NewPiece: string);
1190{ sets the Nth piece (PieceNum) of a string to NewPiece, adding delimiters as necessary }
1191var
1192 i: Integer;
1193 Strt, Next: PChar;
1194begin
1195 i := 1;
1196 Strt := PChar(x);
1197 Next := StrScan(Strt, Delim);
1198 while (i < PieceNum) and (Next <> nil) do
1199 begin
1200 Inc(i);
1201 Strt := Next + 1;
1202 Next := StrScan(Strt, Delim);
1203 end;
1204 if Next = nil then Next := StrEnd(Strt);
1205 if i < PieceNum
1206 then x := x + StringOfChar(Delim, PieceNum - i) + NewPiece
1207 else x := Copy(x, 1, Strt - PChar(x)) + NewPiece + StrPas(Next);
1208end;
1209
1210function IntArrayToString(const IntArray: array of Integer): string;
1211{ converts an array of integers to a comma delimited string, 0 element assumed to be count }
1212var
1213 i: Integer;
1214begin
1215 Result := '';
1216 for i := 1 to IntArray[0] do Result := Result + IntToStr(IntArray[i]) + ',';
1217 if Length(Result) > 0 then Delete(Result, Length(Result), 1);
1218end;
1219
1220procedure StringToIntArray(AString: string; var IntArray: array of Integer; AllowNeg: boolean = FALSE);
1221{ converts a string to an array of positive integers, count is kept in 0 element }
1222var
1223 ANum: Integer;
1224 APiece: string;
1225begin
1226 FillChar(IntArray, SizeOf(IntArray), 0);
1227 repeat
1228 if Pos(',', AString) > 0 then
1229 begin
1230 APiece := Copy(AString, 1, Pos(',', AString) - 1);
1231 Delete(AString, 1, Pos(',', AString));
1232 end else
1233 begin
1234 APiece := AString;
1235 AString := EmptyStr;
1236 end;
1237 ANum := StrToIntDef(Trim(APiece), 0);
1238 if(ANum > 0) or (AllowNeg and (ANum < 0)) then
1239 begin
1240 Inc(IntArray[0]);
1241 IntArray[IntArray[0]] := ANum;
1242 end;
1243 until (Length(AString) = 0) or (IntArray[0] = High(IntArray));
1244end;
1245
1246function StringBetween(const x, First, Last: string): Boolean;
1247{ returns true if x collates between the strings First and Last, not case sensitive }
1248begin
1249 Result := True;
1250 if (CompareText(x, First) < 0) or (CompareText(x, Last) > 0) then Result := False;
1251end;
1252
1253{ ItemTip callback ------------------------------------------------------------------------- }
1254
1255function ItemTipKeyHook(Code: Integer; wParam: WPARAM; lParam: LPARAM): LRESULT;
1256{ callback used to hide the item tip window whenever a key is pressed }
1257begin
1258 if lParam shr 31 = 0 then uItemTip.Hide; // hide only on key down
1259 Result := CallNextHookEx(uKeyHookHandle, Code, wParam, lParam);
1260end;
1261
1262{ TItemTip --------------------------------------------------------------------------------- }
1263
1264procedure AddItemTipRef; // kcm
1265begin
1266 if uItemTipCount = 0 then uItemTip := TItemTip.Create(Application); // all listboxes share a single ItemTip window
1267 Inc(uItemTipCount);
1268end;
1269
1270procedure RemoveItemTipRef; // kcm
1271begin
1272 Dec(uItemTipCount);
1273 if (uItemTipCount = 0) and (uItemTip <> nil) then uItemTip.Free;
1274end;
1275
1276constructor TItemTip.Create(AOwner: TComponent);
1277{ the windows hook allows the item tip window to be hidden whenever a key is pressed }
1278begin
1279 inherited Create(AOwner);
1280 uKeyHookHandle := SetWindowsHookEx(WH_KEYBOARD, ItemTipKeyHook, 0, GetCurrentThreadID);
1281end;
1282
1283destructor TItemTip.Destroy;
1284{ disconnects the windows hook (callback) for keyboard events }
1285begin
1286 UnhookWindowsHookEx(uKeyHookHandle);
1287 inherited Destroy;
1288 uItemTip := nil;
1289end;
1290
1291procedure TItemTip.CreateParams(var Params: TCreateParams);
1292{ makes the window so that is can be viewed but not activated (can't get events) }
1293begin
1294 inherited CreateParams(Params);
1295 Params.Style := WS_POPUP or WS_DISABLED or WS_BORDER;
1296 if uNewStyle then Params.ExStyle := WS_EX_TOOLWINDOW;
1297 Params.ExStyle := Params.ExStyle or WS_EX_TOPMOST; // - test this!!
1298end;
1299
1300procedure TItemTip.Paint;
1301{ displays the caption property for the window within the window }
1302var
1303 AString: string;
1304 y: integer;
1305
1306begin
1307 AString := Caption;
1308 with Canvas do
1309 begin
1310 SetBkMode(Handle, TRANSPARENT);
1311 FillRect(ClientRect);
1312 y := ((ClientRect.Bottom - ClientRect.Top) - FontHeightPixel(Canvas.Font.Handle)) div 2;
1313 //TextOut(ClientRect.Left + 1, ClientRect.Top - 1, AString);
1314// WARNING - Do NOT change the X pos or the tab starting pos - this will cause a missmatch
1315// between the hint window and what the control displayes
1316 TabbedTextOut(Handle, 0, y, PChar(AString), Length(AString), MAX_TABS+1, FTabs[0], 0);
1317 end;
1318end;
1319
1320procedure TItemTip.Hide;
1321{ hides the tip window and makes sure the listbox isn't still capturing the mouse }
1322begin
1323 if FShowing then
1324 begin
1325 { The listbox should retain mousecapture if the left mouse button is still down or it
1326 is the dropdown list for a combobox. Otherwise, click events don't get triggered. }
1327 with FListBox do if not (csLButtonDown in ControlState) and (FParentCombo = nil)
1328 then MouseCapture := False;
1329 ShowWindow(Handle, SW_HIDE);
1330 FShowing := False;
1331 end;
1332end;
1333
1334procedure TItemTip.GetTabSettings;
1335var
1336 DX, X, i, count: integer;
1337
1338begin
1339 Count := FListBox.FTabPix[0];
1340 FTabs[0] := 1; // Set first tab stop to location 1 for display purposes
1341 if(Count = 1) then
1342 begin
1343 DX := FListBox.FTabPix[1];
1344 X := (DX * 2) - 1;
1345 end
1346 else
1347 begin
1348 DX := FontWidthPixel(FListBox.Font.Handle) * 8; // windows tab default is 8 chars
1349 X := FListBox.FTabPix[Count];
1350 X := Trunc(X / DX) + 1;
1351 X := (X * DX) - 1; // get the next tab position after that which is specified
1352 end;
1353 for i := 1 to MAX_TABS do
1354 begin
1355 if(i <= Count) then
1356 FTabs[i] := FListBox.FTabPix[i] - 1
1357 else
1358 begin
1359 FTabs[i] := X;
1360 inc(X, DX);
1361 end;
1362 end;
1363end;
1364
1365procedure TItemTip.UpdateText(CatchMouse: Boolean);
1366var
1367 AWidth, ListClientWidth, X: Integer;
1368 sr: TRect;
1369
1370begin
1371 Cursor := FListBox.Cursor;
1372 Canvas.Font := FListBox.Font;
1373 if FSelected then
1374 begin
1375 Canvas.Brush.Color := clHighlight;
1376 Canvas.Font.Color := clHighlightText;
1377 end else // the item is not selected
1378 begin
1379 Canvas.Brush.Color := FListBox.ItemTipColor;
1380 Canvas.Font.Color := clWindowText;
1381 end;
1382 Caption := #9 + FListBox.DisplayText[FListItem];
1383 if Copy(Caption, 1, 2) = '__' then Caption := ' '; // so separators don't extend past window
1384
1385 GetTabSettings;
1386
1387 AWidth := LOWORD(GetTabbedTextExtent(Canvas.Handle, PChar(Caption), Length(Caption),
1388 MAX_TABS+1, FTabs[0]));
1389 // inherent scrollbar may not always be visible in a long list
1390 if FListBox.LongList
1391 then ListClientWidth := ClientWidthOfList(FListBox)
1392 else ListClientWidth := FListBox.ClientWidth;
1393 X := FPoint.X;
1394 if(FListBox.FCheckBoxes) then
1395 begin
1396 dec(ListClientWidth, CheckWidth);
1397 inc(X, CheckWidth);
1398 end;
1399 if AWidth > ListClientWidth then
1400 Inc(AWidth, 4)
1401 else
1402 AWidth := ListClientWidth;
1403 if SystemParametersInfo(SPI_GETWORKAREA, 0, @sr, 0) then
1404 begin
1405 if AWidth < (sr.Right - sr.Left) then
1406 begin
1407 if (X + AWidth) > sr.Right then
1408 X := sr.Right - AWidth;
1409 end
1410 else
1411 X := sr.Left;
1412 end;
1413 FShowing := True;
1414 if (GetCaptureControl = nil) and CatchMouse then FListBox.MouseCapture := True;
1415 SetWindowPos(Handle, HWND_TOP, X, FPoint.Y, AWidth, FListBox.ItemHeight,
1416 SWP_SHOWWINDOW or SWP_NOACTIVATE);
1417 Invalidate;
1418end;
1419
1420procedure TItemTip.Show(AListBox: TORListBox; AnItem: Integer; APoint: TPoint;
1421 CatchMouse: Boolean);
1422{ sets the canvas properties and window size and text depending on the item in the listbox }
1423begin
1424 if not AListBox.Visible then Exit; // added to support DropDown lists
1425 FListBox := AListBox;
1426 FListItem := AnItem;
1427 FPoint := APoint;
1428 FSelected := (FListBox.Perform(LB_GETSEL, FListItem, 0) > 0);
1429 UpdateText(CatchMouse);
1430end;
1431
1432type
1433 TORCBImgIdx = (iiUnchecked, iiChecked, iiGrayed, iiQMark, iiBlueQMark,
1434 iiDisUnchecked, iiDisChecked, iiDisGrayed, iiDisQMark,
1435 iiFlatUnChecked, iiFlatChecked, iiFlatGrayed,
1436 iiRadioUnchecked, iiRadioChecked, iiRadioDisUnchecked, iiRadioDisChecked);
1437
1438const
1439 CheckBoxImageResNames: array[TORCBImgIdx] of PChar = (
1440 'ORCB_UNCHECKED', 'ORCB_CHECKED', 'ORCB_GRAYED', 'ORCB_QUESTIONMARK',
1441 'ORCB_BLUEQUESTIONMARK', 'ORCB_DISABLED_UNCHECKED', 'ORCB_DISABLED_CHECKED',
1442 'ORCB_DISABLED_GRAYED', 'ORCB_DISABLED_QUESTIONMARK',
1443 'ORLB_FLAT_UNCHECKED', 'ORLB_FLAT_CHECKED', 'ORLB_FLAT_GRAYED',
1444 'ORCB_RADIO_UNCHECKED', 'ORCB_RADIO_CHECKED',
1445 'ORCB_RADIO_DISABLED_UNCHECKED', 'ORCB_RADIO_DISABLED_CHECKED');
1446
1447 BlackCheckBoxImageResNames: array[TORCBImgIdx] of PChar = (
1448 'BLACK_ORLB_FLAT_UNCHECKED', 'BLACK_ORLB_FLAT_CHECKED', 'BLACK_ORLB_FLAT_GRAYED',
1449 'BLACK_ORCB_QUESTIONMARK', 'BLACK_ORCB_BLUEQUESTIONMARK',
1450 'BLACK_ORCB_DISABLED_UNCHECKED', 'BLACK_ORCB_DISABLED_CHECKED',
1451 'BLACK_ORCB_DISABLED_GRAYED', 'BLACK_ORCB_DISABLED_QUESTIONMARK',
1452 'BLACK_ORLB_FLAT_UNCHECKED', 'BLACK_ORLB_FLAT_CHECKED', 'BLACK_ORLB_FLAT_GRAYED',
1453 'BLACK_ORCB_RADIO_UNCHECKED', 'BLACK_ORCB_RADIO_CHECKED',
1454 'BLACK_ORCB_RADIO_DISABLED_UNCHECKED', 'BLACK_ORCB_RADIO_DISABLED_CHECKED');
1455
1456var
1457 ORCBImages: array[TORCBImgIdx, Boolean] of TBitMap;
1458
1459function GetORCBBitmap(Idx: TORCBImgIdx; BlackMode: boolean): TBitmap;
1460var
1461 ResName: string;
1462begin
1463 if(not assigned(ORCBImages[Idx, BlackMode])) then
1464 begin
1465 ORCBImages[Idx, BlackMode] := TBitMap.Create;
1466 if BlackMode then
1467 ResName := BlackCheckBoxImageResNames[Idx]
1468 else
1469 ResName := CheckBoxImageResNames[Idx];
1470 ORCBImages[Idx, BlackMode].LoadFromResourceName(HInstance, ResName);
1471 end;
1472 Result := ORCBImages[Idx, BlackMode];
1473end;
1474
1475procedure DestroyORCBBitmaps; far;
1476var
1477 i: TORCBImgIdx;
1478 mode: boolean;
1479
1480begin
1481 for i := low(TORCBImgIdx) to high(TORCBImgIdx) do
1482 begin
1483 for Mode := false to true do
1484 begin
1485 if(assigned(ORCBImages[i, Mode])) then
1486 ORCBImages[i, Mode].Free;
1487 end;
1488 end;
1489end;
1490
1491{ TORStrings }
1492
1493function TORStrings.Add(const S: string): integer;
1494var
1495 RealVerification: Boolean;
1496begin
1497 RealVerification := Verification;
1498 Verification := False; //Disable verification while lists are not matched
1499 result := FPlainText.Add(Translator(S));
1500 Verification := RealVerification;
1501 MList.Insert(result, S); //Don't need to here because MList never gets custom handlers
1502end;
1503
1504procedure TORStrings.Clear;
1505var
1506 RealVerification: Boolean;
1507begin
1508 Verify;
1509 MList.Clear;
1510 RealVerification := Verification;
1511 Verification := False;
1512 FPlainText.Clear;
1513 Verification := RealVerification;
1514end;
1515
1516constructor TORStrings.Create(PlainText: TStrings; Translator: TTranslator);
1517begin
1518 MList := TStringList.Create;
1519 FPlainText := PlainText;
1520 FTranslator := Translator;
1521 FVerification := False;
1522end;
1523
1524procedure TORStrings.Delete(index: integer);
1525var
1526 RealVerification: Boolean;
1527begin
1528 Verify;
1529 MList.Delete(index);
1530 RealVerification := Verification;
1531 Verification := False;
1532 FPlainText.Delete(index);
1533 Verification := RealVerification;
1534end;
1535
1536destructor TORStrings.Destroy;
1537begin
1538 MList.Free;
1539 inherited;
1540end;
1541
1542function TORStrings.Get(index: integer): string;
1543begin
1544 Verify;
1545 result := MList[index];
1546end;
1547
1548function TORStrings.GetCount: integer;
1549begin
1550 Verify;
1551 result := MList.Count;
1552end;
1553
1554function TORStrings.GetObject(index: integer): TObject;
1555begin
1556 Verify;
1557 result := FPlainText.Objects[index];
1558end;
1559
1560function TORStrings.IndexOf(const S: string): Integer;
1561begin
1562 Verify;
1563 Result := FPlainText.IndexOf(S);
1564end;
1565
1566procedure TORStrings.Insert(Index: Integer; const S: string);
1567var
1568 RealVerification: Boolean;
1569begin
1570 Verify;
1571 MList.Insert(index, S);
1572 RealVerification := Verification;
1573 Verification := False;
1574 FPlainText.Insert(index, Translator(S));
1575 Verification := RealVerification;
1576end;
1577
1578
1579procedure TORStrings.Put(Index: Integer; const S: string);
1580var
1581 RealVerification: Boolean;
1582begin //If this method weren't overridden, the listbox would forget which item was selected.
1583 MList[Index] := S;
1584 RealVerification := Verification;
1585 Verification := False; //Disable verification while lists are not matched
1586 FPlainText[Index] := Translator(S);
1587 Verification := RealVerification;
1588end;
1589
1590procedure TORStrings.PutObject(index: integer; Value: TObject);
1591begin
1592 FPlainText.Objects[index] := Value;
1593end;
1594
1595procedure TORStrings.SetUpdateState(Value: boolean);
1596begin
1597 if Value then
1598 FPlainText.BeginUpdate
1599 else
1600 FPlainText.EndUpdate;
1601end;
1602
1603procedure TORStrings.Verify;
1604var
1605 Errors: TStringList;
1606 i: integer;
1607 M: string;
1608 Plain: string;
1609 TotalCount: integer;
1610begin
1611 if Verification then begin
1612 if not Assigned(FPlainText) then
1613 raise Exception.Create( 'ORStrings is missing PlainText property.');
1614 if not Assigned(FTranslator) then
1615 raise Exception.Create( 'ORStrings is missing Translator property.');
1616 Errors := TStringList.Create;
1617 try
1618 TotalCount := MList.Count;
1619 if MList.Count <> PlainText.Count then begin
1620 Errors.Add('M string count:'+IntToStr(MList.Count));
1621 Errors.Add('Plain string count:'+IntToStr(PlainText.Count));
1622 if PlainText.Count > TotalCount then
1623 TotalCount := PlainText.Count;
1624 end;
1625 for i := 0 to TotalCount - 1 do begin
1626 if i >= MList.Count then
1627 Errors.Add('PlainText['+IntToStr(i)+']: '+PlainText[i])
1628 else if i >= PlainText.Count then
1629 Errors.Add('ORStrings['+IntToStr(i)+']: '+Translator(MList[i]))
1630 else begin
1631 M := Translator(MList[i]);
1632 Plain := PlainText[i];
1633 if M <> Plain then begin
1634 if UpperCase(M) = UpperCase(Plain) then //Listboxes don't always sort cases right, so we give them a little help here.
1635 begin
1636 PlainText[i] := M;
1637 end
1638 else
1639 begin
1640 Errors.Add('PlainText['+IntToStr(i)+']: '+Plain);
1641 Errors.Add('ORStrings['+IntToStr(i)+']: '+M);
1642 end;
1643 end;
1644 end;
1645 end;
1646 if Errors.Count > 0 then begin
1647 Errors.Insert( 0, 'OR strings are out of sync with plain text strings :');
1648 raise Exception.Create( Errors.Text);
1649 end;
1650 finally
1651 Errors.Free;
1652 end;
1653 end;
1654end;
1655
1656{ TORListBox ------------------------------------------------------------------------------- }
1657
1658constructor TORListBox.Create(AOwner: TComponent);
1659{ sets initial values for fields used by added properties (ItemTip, Reference, Tab, LongList) }
1660begin
1661 inherited Create(AOwner);
1662 AddItemTipRef; // kcm
1663 FTipItem := -1;
1664 FItemTipColor := clWindow;
1665 FItemTipEnable := True;
1666 FLastItemIndex := -1;
1667 FFromSelf := False;
1668 FDelimiter := '^';
1669 FWhiteSpace := ' ';
1670 FLongList := False;
1671 FFromNeedData := False;
1672 FFirstLoad := True;
1673 FCurrentTop := -1;
1674 FFocusIndex := -1;
1675 ShowHint := True;
1676 FHideSynonyms := FALSE;
1677 FSynonymChars := '<>';
1678 FTabPosInPixels := False;
1679 FRightClickSelect := FALSE;
1680 FCheckBoxes := FALSE;
1681 FFlatCheckBoxes := TRUE;
1682 FCaseChanged := TRUE;
1683 FLookupPiece := 0;
1684 FIsPartOfComboBox := False;
1685end;
1686
1687destructor TORListBox.Destroy;
1688{ ensures that the special records associated with each listbox item are disposed }
1689begin
1690 FMItems.Free;
1691 if uItemTip <> nil then uItemTip.Hide;
1692 DestroyItems;
1693 RemoveItemTipRef; //kcm
1694 inherited Destroy;
1695end;
1696
1697procedure TORListBox.CreateParams(var Params: TCreateParams);
1698{ ensures that the listbox can support tab stops }
1699begin
1700 inherited CreateParams(Params);
1701 with Params do Style := Style or LBS_USETABSTOPS;
1702end;
1703
1704procedure TORListBox.CreateWnd;
1705{ makes sure that actual (rather than 'intercepted') values are restored from FSaveItems
1706 (FSaveItems is part of TCustomListBox), necessary if window is recreated by property change
1707 also gets the first bolus of data in the case of a LongList }
1708var
1709 RealVerification: Boolean;
1710begin
1711 FFromSelf := True;
1712 RealVerification := True;
1713 if Assigned( FMItems ) then
1714 begin
1715 RealVerification := FMItems.Verification;
1716 FMItems.Verification := False;
1717 end;
1718 inherited CreateWnd;
1719 if Assigned( FMItems ) then
1720 begin
1721 FMItems.Verification := RealVerification;
1722 FMItems.Verify;
1723 end;
1724 FFromSelf := False;
1725 if FTabPos[0] > 0 then SetTabStops;
1726end;
1727
1728procedure TORListBox.Loaded;
1729{ after the properties are loaded, get the first data bolus for a LongList }
1730begin
1731 inherited;
1732 if FLongList then FWaterMark := Items.Count;
1733 SetTabStops;
1734end;
1735
1736procedure TORListBox.DestroyWnd;
1737{ makes sure that actual (rather than 'intercepted') values are saved to FSaveItems
1738 (FSaveItems is part of TCustomListBox), necessary if window is recreated by property change }
1739begin
1740 FFromSelf := True;
1741 inherited DestroyWnd;
1742 FFromSelf := False;
1743end;
1744
1745function TORListBox.TextToShow(S: string): string;
1746{ returns the text that will be displayed based on the Pieces and TabPosition properties }
1747var
1748 i: Integer;
1749begin
1750 if FPieces[0] > 0 then
1751 begin
1752 Result := '';
1753 for i := 1 to FPieces[0] do
1754 Result := Result + Piece(S, FDelimiter, FPieces[i]) + FWhiteSpace;
1755 Result := TrimRight(Result);
1756 end
1757 else
1758 begin
1759 SetString(Result, PChar(S), Length(S));
1760 end;
1761end;
1762
1763function TORListBox.IsSynonym(const TestStr: string): boolean;
1764var
1765 i,cnt,len :integer;
1766
1767begin
1768 Result := FALSE;
1769 if((FHideSynonyms) and (FSynonymChars <> '')) then
1770 begin
1771 len := length(FSynonymChars);
1772 cnt := 0;
1773 for i := 1 to len do
1774 if(pos(FSynonymChars[i], TestStr)>0) then inc(cnt);
1775 if(cnt = len) then Result := TRUE;
1776 if assigned(FOnSynonymCheck) then
1777 FOnSynonymCheck(Self, TestStr, Result);
1778 end;
1779end;
1780
1781function TORListBox.GetDisplayText(Index: Integer): string;
1782{ get the item string actually displayed by the listbox rather than what is in Items[n] }
1783var
1784 Len: Integer;
1785 Buf: array[0..4095] of Char;
1786begin
1787 Result := '';
1788 FFromSelf := True;
1789 Len := SendMessage(Handle,LB_GETTEXT, Index, Integer(@Buf));
1790 FFromSelf := False;
1791 if Len > 0 then
1792 begin
1793 SetString(Result, Buf, Len);
1794 end;
1795end;
1796
1797function TORListBox.GetDynamicProperty(PropertyID: integer): string;
1798begin
1799 if PropertyID = DynaPropAccesibilityCaption then
1800 Result := GetCaption
1801 else
1802 Result := '';
1803end;
1804
1805// The following 7 message handling procedures essentially reimplement the TListBoxStrings
1806// object found in StdCtrls. They do this by intercepting the messages sent by the
1807// TListBoxStrings object and modifying the contents of WParam, LParam, and Result.
1808// This allows TORListBox to use the ItemData pointer that is part of each listbox item
1809// to store its own information yet let the application still use the Objects property
1810// of standard Delphi listboxes. It also makes it possible to implement the Pieces and
1811// TabPosition properties without forcing the listbox to be owner drawn.
1812
1813procedure TORListBox.LBGetItemData(var Message: TMessage);
1814{ intercept LB_GETITEMDATA and repoint to UserObject rather than internal value in ItemData }
1815var
1816 ItemRec: PItemRec;
1817begin
1818 inherited;
1819 if not FFromSelf then with Message do
1820 begin
1821 ItemRec := PItemRec(Result);
1822 if(assigned(ItemRec)) then
1823 Result := Integer(ItemRec^.UserObject)
1824 else
1825 Result := 0;
1826 end;
1827end;
1828
1829procedure TORListBox.LBSetItemData(var Message: TMessage);
1830{ intercept LB_SETITEMDATA as save object in UserObject since ItemData is used interally }
1831var
1832 ItemRec: PItemRec;
1833begin
1834 if not FFromSelf then with Message do
1835 begin
1836 FFromSelf := True;
1837 ItemRec := PItemRec(SendMessage(Handle,LB_GETITEMDATA, WParam, 0)); // WParam: list index
1838 FFromSelf := False;
1839 if(assigned(ItemRec)) then
1840 ItemRec^.UserObject := TObject(LParam);
1841 LParam := Integer(ItemRec);
1842 if uItemTip.FShowing and (uItemTip.FListBox = Self) and (uItemTip.FListItem = WParam) then
1843 uItemTip.UpdateText(FALSE);
1844 end;
1845 inherited;
1846end;
1847
1848procedure TORListBox.LBGetText(var Message: TMessage);
1849{ intercept LB_GETTEXT and repoint to full item string rather than what's visible in listbox }
1850var
1851 ItemRec: PItemRec;
1852 Text: string;
1853begin
1854 inherited;
1855 if (not FFromSelf) and (Message.Result <> LB_ERR) then with Message do
1856 begin
1857 FFromSelf := True;
1858 ItemRec := PItemRec(SendMessage(Handle,LB_GETITEMDATA, WParam, 0)); // WParam: list index
1859 FFromSelf := False;
1860 if(assigned(ItemRec)) then
1861 begin
1862 FFromSelf := True;
1863 Text := TListBox(self).Items[WParam];
1864 StrCopy(PChar(LParam), PChar(Text)); // LParam: points string buffer
1865 Result := Length(Text); // Result: length of string
1866 FFromSelf := False;
1867 end
1868 else
1869 begin
1870 StrPCopy(PChar(LParam),'');
1871 Result := 0;
1872 end;
1873 end;
1874end;
1875procedure TORListBox.LBGetTextLen(var Message: TMessage);
1876{ intercept LB_GETTEXTLEN and return true length of ItemRec^.FullText }
1877{ -- in response to HOU-0299-70576, Thanks to Stephen Kirby for this fix! }
1878var
1879 ItemRec: PItemRec;
1880begin
1881 inherited;
1882 if (not FFromSelf) and (Message.Result <> LB_ERR) then with Message do
1883 begin
1884 FFromSelf := True;
1885 ItemRec := PItemRec(SendMessage(Handle, LB_GETITEMDATA, WParam, 0));
1886 if(assigned(ItemRec)) then
1887 Result := Length(TListBox(self).Items[WParam]) // Result:length of string
1888 else
1889 Result := 0;
1890 FFromSelf := False;
1891 end;
1892end;
1893
1894procedure TORListBox.LBAddString(var Message: TMessage);
1895{ intercept LB_ADDSTRING and save full string in separate record. Then rebuild a string that
1896 has what's visible (based on Pieces, TabPosition properties) and substitute that in LParam }
1897var
1898 ItemRec: PItemRec;
1899begin
1900 if not FFromSelf then
1901 begin
1902 if FLongList then // -- special long list processing - begin
1903 begin
1904 if FFromNeedData then FDataAdded := True else with Message do
1905 begin
1906 WParam := FWaterMark;
1907 Result := Perform(LB_INSERTSTRING, WParam, LParam); // always insert into short list
1908 Exit;
1909 end;
1910 end; // -- special long list processing - end
1911 New(ItemRec);
1912 with ItemRec^, Message do
1913 begin
1914 UserObject := nil;
1915 CheckedState := cbUnchecked;
1916 FCreatingText := PChar(LParam);
1917 end;
1918 FCreatingItem := TRUE;
1919 inherited;
1920 FCreatingItem := FALSE;
1921 // insert into list AFTER calling inherited in case the listbox is sorted
1922 DoChange;
1923 with Message do if Result <> LB_ERR then
1924 begin
1925 FFromSelf := True;
1926 SendMessage(Handle,LB_SETITEMDATA, Result, Integer(ItemRec)); // Result: new item index
1927 FFromSelf := False;
1928 end
1929 else Dispose(ItemRec);
1930 end
1931 else inherited;
1932end;
1933
1934procedure TORListBox.LBInsertString(var Message: TMessage);
1935{ intercepts LB_INSERTSTRING, similar to LBAddString except for special long list processing }
1936var
1937 ItemRec: PItemRec;
1938begin
1939 if not FFromSelf then
1940 begin
1941 if FLongList then // -- special long list processing - begin
1942 begin
1943 if FFromNeedData then
1944 begin
1945 FDataAdded := True;
1946 Inc(FCurrentTop);
1947 end
1948 else with Message do
1949 begin
1950 if WParam > FWaterMark then
1951 begin // make sure insert above watermark
1952 FMItems.MList.Move(WParam,FWaterMark);
1953 WParam := FWaterMark;
1954 end;
1955 Inc(FWaterMark);
1956 end;
1957 end; // -- special long list processing - end
1958 New(ItemRec);
1959 with ItemRec^, Message do
1960 begin
1961 UserObject := nil;
1962 CheckedState := cbUnchecked;
1963 FCreatingText := PChar(LParam);
1964 end;
1965 FCreatingItem := TRUE;
1966 inherited;
1967 FCreatingItem := FALSE;
1968 DoChange;
1969 with Message do if Result <> LB_ERR then
1970 begin
1971 FFromSelf := True;
1972 SendMessage(Handle,LB_SETITEMDATA, Result, Integer(ItemRec)); // Result: new item index
1973 FFromSelf := False;
1974 end
1975 else Dispose(ItemRec);
1976 end
1977 else inherited;
1978end;
1979
1980procedure TORListBox.LBDeleteString(var Message: TMessage);
1981{ intercept LB_DELETESTRING and dispose the record associated with the item being deleted }
1982var
1983 ItemRec: PItemRec;
1984begin
1985 with Message do
1986 begin
1987 FFromSelf := True;
1988 ItemRec := PItemRec(SendMessage(Handle,LB_GETITEMDATA, WParam, 0)); // WParam: list index
1989 FFromSelf := False;
1990 if(assigned(ItemRec)) then
1991 begin
1992 if FLongList and not FFromNeedData then
1993 Dec(FWaterMark);
1994 Dispose(ItemRec);
1995 end;
1996 end;
1997 FFromSelf := True; // FFromSelf is set here because, under NT, LBResetContent is called
1998 inherited; // when deleting the last string from the listbox. Since ItemRec is
1999 FFromSelf := False; // already disposed, it shouldn't be disposed again.
2000 DoChange;
2001end;
2002
2003procedure TORListBox.LBResetContent(var Message: TMessage);
2004{ intercept LB_RESETCONTENT (list is being cleared) and dispose all records }
2005var
2006 ItemCount, i: Integer;
2007 ItemRec: PItemRec;
2008begin
2009 if not FFromSelf then
2010 begin
2011 ItemCount := Perform(LB_GETCOUNT, 0, 0);
2012 for i := 0 to ItemCount - 1 do
2013 begin
2014 FFromSelf := True;
2015 ItemRec := PItemRec(SendMessage(Handle,LB_GETITEMDATA, i, 0));
2016 FFromSelf := False;
2017 Dispose(ItemRec);
2018 end;
2019 Perform(LB_SETCOUNT, 0, 0);
2020 end;
2021 // This was casuing pain for ResetItems when FWaterMark was being cleared for short lists
2022 if FLongList then
2023 FWaterMark := 0;
2024 inherited;
2025end;
2026
2027procedure TORListBox.LBSetCurSel(var Message: TMessage);
2028{ call DoChange, which calls OnChange event whenever ItemIndex changes }
2029begin
2030 inherited;
2031 DoChange;
2032end;
2033
2034procedure TORListBox.CMFontChanged(var Message: TMessage);
2035{ make sure itemtip and tabs respond to characteristics of the new font }
2036begin
2037 inherited;
2038 FLargeChange := (Height div ItemHeight) - 1;
2039 SetTabStops;
2040end;
2041
2042procedure TORListBox.WMKeyDown(var Message: TWMKeyDown);
2043{ intercept the keydown messages so that the listbox can be navigated by using the arrow
2044 keys and shifting the focus rectangle rather than generating Click for each keypress }
2045var
2046 IsSelected: LongBool;
2047begin
2048 //if Message.CharCode in [VK_RETURN, VK_ESCAPE] then inherited; // ignore other keys
2049 case Message.CharCode of
2050 VK_LBUTTON, VK_RETURN, VK_SPACE:
2051 begin
2052 if (FocusIndex < 0) and (CheckBoxes or MultiSelect) and (Count > 0) then // JNM - 508 compliance
2053 SetFocusIndex(0);
2054 if FocusIndex > -1 then
2055 begin
2056 if MultiSelect then
2057 begin
2058 IsSelected := LongBool(Perform(LB_GETSEL, FocusIndex, 0));
2059 Perform(LB_SETSEL, Longint(not IsSelected), FocusIndex);
2060 end
2061 else Perform(LB_SETCURSEL, FocusIndex, 0);
2062 // Send WM_COMMAND here because LBN_SELCHANGE not triggered by LB_SETSEL
2063 // and LBN_SELCHANGE is what eventually triggers the Click event.
2064 // The LBN_SELCHANGE documentation implies we should send the control id, which is
2065 // 32 bits long, in the high word of WPARAM (16 bits). Since that won't work - we'll
2066 // try sending the item index instead.
2067 //PostMessage() not SendMessage() is Required here for checkboxes, SendMessage() doesn't
2068 //Allow the Checkbox state on the control to be updated
2069 if CheckBoxes then
2070 PostMessage(Parent.Handle, WM_COMMAND, MAKELONG(FocusIndex, LBN_SELCHANGE), LPARAM(Handle))
2071 else
2072 SendMessage(Parent.Handle, WM_COMMAND, MAKELONG(FocusIndex, LBN_SELCHANGE), LPARAM(Handle));
2073 end;
2074 end;
2075 VK_PRIOR: SetFocusIndex(FocusIndex - FLargeChange);
2076 VK_NEXT: SetFocusIndex(FocusIndex + FLargeChange);
2077 VK_END: SetFocusIndex(SFI_END);
2078 VK_HOME: SetFocusIndex(SFI_TOP);
2079 VK_LEFT, VK_UP: SetFocusIndex(FocusIndex - 1);
2080 VK_RIGHT, VK_DOWN: SetFocusIndex(FocusIndex + 1);
2081 else inherited;
2082 end;
2083 Message.Result := 0;
2084end;
2085
2086procedure TORListBox.WMLButtonDown(var Message: TWMLButtonDown);
2087{ work around for a very ugly problem when the listbox is used with a dropdown combobox
2088 when the listbox is used this way (parent=desktop) the click events seem to be ignored }
2089var
2090 AnItem: Integer;
2091 ScrollRect, ListRect: TRect;
2092 ScreenPoint: TSmallPoint;
2093 TmpRect: TRect;
2094begin
2095 if FParentCombo <> nil then with Message do
2096 begin
2097 FDontClose := FALSE;
2098 ListRect := ClientRect; //+
2099 if FLongList then ListRect.Right := ListRect.Left + ClientWidthOfList(Self); //+
2100 // if the mouse was clicked in the client area set ItemIndex ourselves
2101 if PtInRect(ListRect, Point(XPos, YPos)) then //~
2102 begin
2103 AnItem := GetIndexFromY(YPos);
2104 if AnItem < Items.Count then ItemIndex := AnItem;
2105 FParentCombo.FwdClick(FParentCombo);
2106 FDontClose := TRUE;
2107 end;
2108 // if the mouse was clicked on the scrollbar, send a message to make the scrolling happen
2109 // this is done with WM_NCLBUTTONDOWN, which is ignored if mousecapture is on, so we have
2110 // to turn mousecapture off, then back on since it's needed to hide the listbox
2111 with ListRect do ScrollRect := Rect(Right + 1, Top, Self.Width - 2, Bottom); //~
2112 if {(Items.Count > (FLargeChange + 1)) and} PtInRect(ScrollRect, Point(XPos, YPos)) then //~
2113 begin
2114 if FLongList then // for long lists
2115 begin
2116 ScreenPoint := PointToSmallPoint(FScrollBar.ScreenToClient(
2117 Self.ClientToScreen(Point(XPos, YPos))));
2118 MouseCapture := False;
2119 SendMessage(FScrollBar.Handle, WM_LBUTTONDOWN, Message.Keys,
2120 MakeLParam(ScreenPoint.X, ScreenPoint.Y));
2121 MouseCapture := True;
2122 end else // for normal lists
2123 begin
2124 ScreenPoint := PointToSmallPoint(Self.ClientToScreen(Point(XPos, YPos)));
2125 MouseCapture := False;
2126 SendMessage(Self.Handle, WM_NCLBUTTONDOWN, HTVSCROLL,
2127 MakeLParam(ScreenPoint.X, ScreenPoint.Y));
2128 MouseCapture := True;
2129 end;
2130 end
2131 else
2132 if(FCheckBoxes) then
2133 begin
2134 TmpRect := ListRect;
2135 TmpRect.Top := TmpRect.Bottom;
2136 TmpRect.Right := TmpRect.Left + Width;
2137 inc(TmpRect.Bottom, CheckComboBtnHeight);
2138 if PtInRect(TmpRect, Point(XPos, YPos)) then
2139 begin
2140 inc(TmpRect.Left, (TmpRect.right - TmpRect.Left) div 2);
2141 FParentCombo.DropPanelBtnPressed(XPos <= TmpRect.Left, FALSE);
2142 end;
2143 end;
2144 end;
2145 inherited;
2146end;
2147
2148procedure TORListBox.WMLButtonUp(var Message: TWMLButtonUp);
2149{ If the listbox is being used with a dropdown combo, hide the listbox whenever something is
2150 clicked. The mouse is captured at this point - this isn't called if clicking scrollbar. }
2151begin
2152 if (FParentCombo <> nil) and ((not FDontClose) or (not FCheckBoxes)) then FParentCombo.DroppedDown := False;
2153 FDontClose := FALSE;
2154 inherited;
2155end;
2156
2157procedure TORListBox.WMRButtonUp(var Message: TWMRButtonUp);
2158{ When the RightClickSelect property is true, this routine is used to select an item }
2159var
2160 AnItem: Integer;
2161 ListRect: TRect;
2162
2163begin
2164 if(FRightClickSelect and (FParentCombo = nil)) then with Message do // List Boxes only, not Combo Boxes
2165 begin
2166 ListRect := ClientRect; //+
2167 if FLongList then ListRect.Right := ListRect.Left + ClientWidthOfList(Self); //+
2168 // if the mouse was clicked in the client area set ItemIndex ourselves
2169 if PtInRect(ListRect, Point(XPos, YPos)) then //~
2170 begin
2171 AnItem := GetIndexFromY(YPos);
2172 if AnItem >= Items.Count then AnItem := -1;
2173 end
2174 else
2175 AnItem := -1;
2176 ItemIndex := AnItem;
2177 end;
2178 inherited;
2179end;
2180
2181procedure TORListBox.WMLButtonDblClk(var Message: TWMLButtonDblClk);
2182{ treat a doubleclick in the scroll region as if it were a single click - see WMLButtonDown }
2183var
2184 ScrollRect: TRect;
2185 ScreenPoint: TSmallPoint;
2186begin
2187 if FParentCombo <> nil then with Message do
2188 begin
2189 if(FCheckBoxes) then FDontClose := TRUE;
2190 // if the mouse was clicked on the scrollbar, send a message to make the scrolling happen
2191 // this is done with WM_NCLBUTTONDOWN, which is ignored if mousecapture is on, so we have
2192 // to turn mousecapture off, then back on since it's needed to hide the listbox
2193 with ClientRect do ScrollRect := Rect(Right + 1, Top, Self.Width - 2, Bottom);
2194 if (Items.Count > (FLargeChange + 1)) and PtInRect(ScrollRect, Point(XPos, YPos)) then
2195 begin
2196 if FLongList then // for long lists
2197 begin
2198 ScreenPoint := PointToSmallPoint(FScrollBar.ScreenToClient(
2199 Self.ClientToScreen(Point(XPos, YPos))));
2200 MouseCapture := False;
2201 SendMessage(FScrollBar.Handle, WM_LBUTTONDOWN, Message.Keys,
2202 MakeLParam(ScreenPoint.X, ScreenPoint.Y));
2203 MouseCapture := True;
2204 end else // for normal lists
2205 begin
2206 ScreenPoint := PointToSmallPoint(Self.ClientToScreen(Point(XPos, YPos)));
2207 MouseCapture := False;
2208 SendMessage(Self.Handle, WM_NCLBUTTONDOWN, HTVSCROLL,
2209 MakeLParam(ScreenPoint.X, ScreenPoint.Y));
2210 MouseCapture := True;
2211 end; {if FLongList}
2212 end; {if (Items.Count)}
2213 end; {if FParentCombo}
2214 inherited;
2215end;
2216
2217procedure TORListBox.WMCancelMode(var Message: TMessage);
2218{ This message is sent when focus shifts to another window - need to hide the listbox at this
2219 point if it is being used with a dropdown combobox. }
2220begin
2221 uItemTip.Hide;
2222 if FParentCombo <> nil then FParentCombo.DroppedDown := False;
2223 inherited;
2224end;
2225
2226procedure TORListBox.WMMove(var Message: TWMMove);
2227{ whenever in LongList mode we need to move the scrollbar along with the listbox }
2228begin
2229 inherited;
2230 if FScrollBar <> nil then AdjustScrollBar;
2231end;
2232
2233procedure TORListBox.WMSize(var Message: TWMSize);
2234{ calculate the number of visible items in the listbox whenever it is resized
2235 if in LongList mode, size the scrollbar to match the listbox }
2236begin
2237 inherited;
2238 FLargeChange := (Message.Height div ItemHeight) - 1;
2239 if FScrollBar <> nil then AdjustScrollBar;
2240end;
2241
2242procedure TORListBox.WMVScroll(var Message: TWMVScroll);
2243{ makes sure the itemtip is hidden whenever the listbox is scrolled }
2244// it would be better if this was done right away (before endscroll, but it seems to mess
2245// up mouse capture (SaveCaptureControl, HideItemTip, RestoreCaptureControl?)
2246begin
2247 inherited;
2248 if Message.ScrollCode = SB_ENDSCROLL then uItemTip.Hide;
2249end;
2250
2251procedure TORListBox.CMHintShow(var Message: TMessage);
2252{ if ShowHint is used to delay showing tip, starts showing ItemTip when hint timer expires }
2253var
2254 APoint: TPoint;
2255begin
2256 inherited;
2257 FItemTipActive := True;
2258 GetCursorPos(APoint);
2259 APoint := ScreenToClient(APoint);
2260 MouseMove([], APoint.X, APoint.Y); // assume nothing in ShiftState for now
2261end;
2262
2263procedure TORListBox.Click;
2264begin
2265 inherited Click;
2266 DoChange;
2267end;
2268
2269procedure TORListBox.DoChange;
2270{ call the OnChange Event if ItemIndex is changed }
2271begin
2272 if ItemIndex <> FLastItemIndex then
2273 begin
2274 FLastItemIndex := ItemIndex;
2275 if (not isPartOfComboBox) and (ItemIndex <> -1) then
2276 SetFocusIndex(ItemIndex);
2277 if Assigned(FOnChange) then FOnChange(Self);
2278 end;
2279end;
2280
2281procedure TORListBox.DoEnter;
2282{ display the item tip window when the listbox gets keyboard focus - if itemtip enabled }
2283begin
2284 //if Items.Count > 0 then SetFocusIndex(TopIndex); // this seems to cause problems
2285 //Fix For ClearQuest: HDS00001576
2286 //This fix has been commented out, becuase it causes problems
2287{ if (Items.Count > 0) and (Not IsAMouseButtonDown()) and (ItemIndex = -1) then
2288 SetFocusIndex(TopIndex);//ItemIndex := TopIndex; }
2289 if FHideSelection and (ItemIndex < 0) and (FFocusIndex >= 0) then
2290 ItemIndex := FFocusIndex;
2291 inherited DoEnter;
2292end;
2293
2294procedure TORListBox.DoExit;
2295var
2296 SaveIndex: integer;
2297{ make sure item tip is hidden for this listbox when focus shifts to something else }
2298begin
2299 if FHideSelection then
2300 begin
2301 SaveIndex := ItemIndex;
2302 ItemIndex := -1;
2303 FFocusIndex := SaveIndex;
2304 end;
2305
2306 uItemTip.Hide;
2307 FItemTipActive := False;
2308 inherited DoExit;
2309end;
2310
2311procedure TORListBox.DestroyItems;
2312var
2313 ItemCount,i: Integer;
2314 ItemRec: PItemRec;
2315
2316begin
2317 if(not FItemsDestroyed) then
2318 begin
2319 ItemCount := Perform(LB_GETCOUNT, 0, 0);
2320 for i := 0 to ItemCount - 1 do
2321 begin
2322 FFromSelf := True;
2323 ItemRec := PItemRec(SendMessage(Handle,LB_GETITEMDATA, i, 0));
2324 FFromSelf := False;
2325 if Assigned(ItemRec) then
2326 Dispose(ItemRec);
2327 end;
2328 FItemsDestroyed := TRUE;
2329
2330 end;
2331end;
2332
2333procedure TORListBox.ToggleCheckBox(idx: integer);
2334var
2335 ItemRec: PItemRec;
2336 OldFromSelf: boolean;
2337 Rect: TRect;
2338
2339begin
2340 if(not FCheckBoxes) or (idx < 0) or (idx >= Items.Count) then exit;
2341 OldFromSelf := FFromSelf;
2342 FFromSelf := True;
2343 ItemRec := PItemRec(SendMessage(Handle,LB_GETITEMDATA, idx, 0));
2344 FFromSelf := OldFromSelf;
2345 if(assigned(ItemRec)) then
2346 begin
2347 if(FAllowGrayed) then
2348 begin
2349 case ItemRec^.CheckedState of
2350 cbUnchecked: ItemRec^.CheckedState := cbGrayed;
2351 cbGrayed: ItemRec^.CheckedState := cbChecked;
2352 cbChecked: ItemRec^.CheckedState := cbUnchecked;
2353 end;
2354 end
2355 else
2356 begin
2357 if(ItemRec^.CheckedState = cbUnchecked) then
2358 ItemRec^.CheckedState := cbChecked
2359 else
2360 ItemRec^.CheckedState := cbUnChecked;
2361 end;
2362 end;
2363 Rect := ItemRect(Idx);
2364 InvalidateRect(Handle, @Rect, FALSE);
2365 if(assigned(FOnClickCheck)) then
2366 FOnClickCheck(Self, idx);
2367 if(assigned(FParentCombo)) then
2368 FParentCombo.UpdateCheckEditBoxText;
2369end;
2370
2371procedure TORListBox.KeyPress(var Key: Char);
2372begin
2373 {inherited KeyPress is changing the ' ' into #0, had to move conditional before inherited.}
2374 if (Key = ' ') then begin
2375 ToggleCheckBox(ItemIndex);
2376 {The space bar causes the focus to jump to an item in the list that starts with
2377 a space. Disable that function.}
2378 Key := #0;
2379 end;
2380 inherited;
2381end;
2382
2383procedure TORListBox.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
2384{ hide the item tip window whenever an item is clicked - ignored if itemtip not enabled}
2385var
2386 idx: integer;
2387
2388begin
2389 uItemTip.Hide;
2390 inherited MouseDown(Button, Shift, X, Y);
2391 if(FCheckBoxes) and (X >= 0) and (X <= Width) and (Y >= 0) and (Y <= Height) then
2392 begin
2393 idx := GetIndexFromY(Y);
2394 if(idx >= 0) then
2395 begin
2396 if(FCheckEntireLine) then
2397 ToggleCheckBox(idx)
2398 else
2399 if(X < CheckWidth) then ToggleCheckBox(idx);
2400 end;
2401 end;
2402end;
2403
2404procedure TORListBox.MouseMove(Shift: TShiftState; X, Y: Integer);
2405{ hide and show the appropriate item tip window as the mouse moves through the listbox }
2406const
2407 CATCH_MOUSE = True;
2408var
2409 AnItem: Integer;
2410 TrueOffset :integer;
2411 TipPos: TPoint;
2412begin
2413 inherited MouseMove(Shift, X, Y);
2414 if (not FItemTipEnable) or (not Application.Active) then Exit;
2415 { Make sure mouse really moved before continuing. For some reason, MouseMove gets called
2416 every time a navigation key is pressed. If FItemTipActive is true, mouse is pausing
2417 over the list.}
2418 if (not FItemTipActive) and (X = FLastMouseX) and (Y = FLastMouseY) then Exit;
2419 FLastMouseX := X;
2420 FLastMouseY := Y;
2421 // when captured mouse moving outside listbox
2422 if not PtInRect(ClientRect, Point(X, Y)) then
2423 begin
2424 uItemTip.Hide;
2425 FItemTipActive := False;
2426 FTipItem := -1;
2427 Exit;
2428 end;
2429 // borrow hint timer to delay first ItemTip
2430 if ShowHint and not FItemTipActive then Exit;
2431 // when mouse moving within listbox
2432 AnItem := GetIndexFromY(Y);
2433 TrueOffset := (Y div ItemHeight) + TopIndex;
2434 if AnItem <> FTipItem then
2435 begin
2436 if (AnItem < Items.Count) and ((TrueOffset - TopIndex + 1) * ItemHeight < Height) then
2437 begin
2438 TipPos := ClientToScreen(Point(0, (TrueOffset - TopIndex) * ItemHeight));
2439 uItemTip.Show(Self, AnItem, TipPos, CATCH_MOUSE);
2440 FTipItem := AnItem;
2441 end else
2442 begin
2443 uItemTip.Hide;
2444 FTipItem := -1;
2445 end;
2446 end;
2447end;
2448
2449procedure TORListBox.MeasureItem(Index: Integer; var Height: Integer);
2450var
2451 Txt:string;
2452
2453begin
2454 if(FHideSynonyms) and (fSynonymChars <> '') then
2455 begin
2456 if(FCreatingItem) then
2457 Txt := FCreatingText
2458 else
2459 Txt := Items[Index];
2460 if(IsSynonym(Txt)) then Height := 0;
2461 end;
2462 inherited MeasureItem(Index, Height);
2463end;
2464
2465procedure TORListBox.WMDestroy(var Message: TWMDestroy);
2466begin
2467 if(assigned(Owner)) and (csDestroying in Owner.ComponentState) then
2468 DestroyItems;
2469 inherited;
2470end;
2471
2472procedure TORListBox.CNDrawItem(var Message: TWMDrawItem);
2473begin
2474 if(FCheckBoxes) then
2475 with Message.DrawItemStruct^ do
2476 inc(rcItem.Left, CheckWidth);
2477 inherited;
2478end;
2479
2480procedure TORListBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
2481var
2482 Flags: Longint;
2483 ItemRec: PItemRec;
2484 OldFromSelf :boolean;
2485 BMap: TBitMap;
2486 i, DY: integer;
2487 TmpR: TRect;
2488 Neg: boolean;
2489 ShowText: string;
2490begin
2491 if(assigned(FOnBeforeDraw)) then
2492 FOnBeforeDraw(Self, Index, Rect, State);
2493 if Assigned(OnDrawItem) then OnDrawItem(Self, Index, Rect, State)
2494 else
2495 begin
2496 Canvas.FillRect(Rect);
2497 if Index < Items.Count then
2498 begin
2499 Flags := DrawTextBiDiModeFlags(DT_SINGLELINE or DT_VCENTER);
2500 if not UseRightToLeftAlignment then
2501 Inc(Rect.Left, 2)
2502 else
2503 Dec(Rect.Right, 2);
2504 OldFromSelf := FFromSelf;
2505 FFromSelf := True;
2506 ItemRec := PItemRec(SendMessage(Handle,LB_GETITEMDATA, Index, 0)); // WParam: list index
2507 FFromSelf := OldFromSelf;
2508
2509 if(FCheckBoxes) then
2510 begin
2511 if(assigned(ItemRec)) then
2512 begin
2513 case ItemRec^.CheckedState of
2514 cbUnchecked:
2515 begin
2516 if(FFlatCheckBoxes) then
2517 BMap := GetORCBBitmap(iiFlatUnChecked, FBlackColorMode)
2518 else
2519 BMap := GetORCBBitmap(iiUnchecked, FBlackColorMode);
2520 end;
2521 cbChecked:
2522 begin
2523 if(FFlatCheckBoxes) then
2524 BMap := GetORCBBitmap(iiFlatChecked, FBlackColorMode)
2525 else
2526 BMap := GetORCBBitmap(iiChecked, FBlackColorMode);
2527 end;
2528 else // cbGrayed:
2529 begin
2530 if(FFlatCheckBoxes) then
2531 BMap := GetORCBBitmap(iiFlatGrayed, FBlackColorMode)
2532 else
2533 BMap := GetORCBBitmap(iiGrayed, FBlackColorMode);
2534 end;
2535 end;
2536 end
2537 else
2538 begin
2539 if(FFlatCheckBoxes) then
2540 BMap := GetORCBBitmap(iiFlatGrayed, FBlackColorMode)
2541 else
2542 BMap := GetORCBBitmap(iiGrayed, FBlackColorMode);
2543 end;
2544 TmpR := Rect;
2545 TmpR.Right := TmpR.Left;
2546 dec(TmpR.Left, CheckWidth+1);
2547 DY := ((TmpR.Bottom - TmpR.Top) - BMap.Height) div 2;
2548 Canvas.Draw(TmpR.Left, TmpR.Top + DY, BMap);
2549 end;
2550
2551 if(FTabPos[0] > 0) then
2552 Flags := (FTabPos[1] * 256) or Flags or DT_TABSTOP or DT_EXPANDTABS;
2553
2554 ShowText := GetDisplayText(Index);
2555 if(Style <> lbStandard) and (FTabPos[0] > 0) then
2556 begin
2557 for i := 1 to FTabPix[0] do
2558 begin
2559 Neg := (FTabPix[i] < 0);
2560 if Neg then FTabPix[i] := -FTabPix[i];
2561 inc(FTabPix[i],Rect.Left-1);
2562 if Neg then FTabPix[i] := -FTabPix[i];
2563 end;
2564 TabbedTextOut(Canvas.Handle, Rect.Left, Rect.Top+1, PChar(ShowText), Length(ShowText),
2565 FTabPix[0], FTabPix[1], -1);
2566 for i := 1 to FTabPix[0] do
2567 begin
2568 Neg := (FTabPix[i] < 0);
2569 if Neg then FTabPix[i] := -FTabPix[i];
2570 dec(FTabPix[i],Rect.Left-1);
2571 if Neg then FTabPix[i] := -FTabPix[i];
2572 end;
2573 end
2574 else
2575 DrawText(Canvas.Handle, PChar(ShowText), Length(ShowText), Rect, Flags);
2576 end;
2577 end;
2578end;
2579
2580function TORListBox.GetIndexFromY(YPos :integer) :integer;
2581begin
2582 if(FHideSynonyms) then
2583 begin
2584 Result := TopIndex-1;
2585 repeat
2586 inc(Result);
2587 if(Perform(LB_GETITEMHEIGHT, Result, 0) > 0) then
2588 dec(YPos,ItemHeight);
2589 until((YPos < 0) or (Result >= Items.Count));
2590 end
2591 else
2592 Result := (YPos div ItemHeight) + TopIndex;
2593end;
2594
2595procedure TORListBox.SetFocusIndex(Value: Integer);
2596{ move the focus rectangle to an item and show the item tip window if enabled
2597 in the case of a LongList, scroll the list so that new items are loaded appropriately }
2598const
2599 CATCH_MOUSE = True;
2600 NO_CATCH_MOUSE = False;
2601var
2602 ScrollCount, ScrollPos, InitialTop, i: Integer;
2603begin
2604 if FLongList then // -- special long list processing - begin
2605 begin
2606 if (Value = SFI_TOP) or (Value = SFI_END) then // scroll to top or bottom
2607 begin
2608 if Value = SFI_TOP then ScrollPos := 0 else ScrollPos := 100;
2609 ScrollTo(Self, scPosition, ScrollPos); // ScrollTo is scrollbar event
2610 FScrollBar.Position := ScrollPos;
2611 if ScrollPos = 0 then Value := FFocusIndex else Value := FFocusIndex + FLargeChange;
2612 end else
2613 begin
2614 InitialTop := TopIndex;
2615 ScrollCount := Value - InitialTop;
2616 ScrollPos := 50; // arbitrary, can be anything from 1-99
2617 if ScrollCount < 0 then // scroll backwards
2618 begin
2619 if ScrollCount = -FLargeChange then ScrollTo(Self, scPageUp, ScrollPos) else
2620 for i := 1 to Abs(ScrollCount) do ScrollTo(Self, scLineUp, ScrollPos);
2621 FScrollBar.Position := ScrollPos;
2622 Value := Value + (FCurrentTop - InitialTop);
2623 end;
2624 if ScrollCount > FLargeChange then // scroll forwards
2625 begin
2626 if ScrollCount = (FLargeChange * 2) then ScrollTo(Self, scPageDown, ScrollPos) else
2627 for i := FLargeChange + 1 to ScrollCount do ScrollTo(Self, scLineDown, ScrollPos);
2628 FScrollBar.Position := ScrollPos;
2629 end;
2630 if(FHideSynonyms) then
2631 begin
2632 while((Perform(LB_GETITEMHEIGHT, Value, 0) = 0) and (Value >= 0) and (value < Items.Count)) do
2633 begin
2634 if(Value < FFocusIndex) then
2635 dec(Value)
2636 else
2637 inc(Value);
2638 end;
2639 end;
2640 end;
2641 end; // -- special long list processing - end
2642 if (Value = SFI_END) or (not (Value < Items.Count)) then Value := Items.Count - 1;
2643 if (Value = SFI_TOP) or (Value < 0) then Value := 0;
2644 FFocusIndex := Value;
2645 if Focused or (not FHideSelection) then
2646 ItemIndex := Value;
2647 if MultiSelect then Perform(LB_SETCARETINDEX, FFocusIndex, 0) // LPARAM=0, scrolls into view
2648 else
2649 begin
2650 // LB_SETCARETINDEX doesn't scroll with single select so we have to do it ourselves
2651 // ( a LongList should always come through here - it should never be MultiSelect )
2652 if FocusIndex < TopIndex
2653 then TopIndex := FocusIndex
2654 else if FocusIndex > (TopIndex + FLargeChange)
2655 then TopIndex := HigherOf(FocusIndex - FLargeChange, 0);
2656 end;
2657 // need to have a way to move the focus rectangle for single select listboxs w/o itemtips
2658 // if FItemTipEnable or not MultiSelect then ... Show: if not ItemTipEnable then AWidth := 0?
2659 //
2660 // can't show the item tip from keyboard input for dropdown combo without causing problems
2661 // with mouse capture, post the message to allow the selected attribute to be posted
2662 if FItemTipEnable {and (FParentCombo = nil)}
2663 then PostMessage(Self.Handle, UM_SHOWTIP, Value, 0);
2664end;
2665
2666procedure TORListBox.UMShowTip(var Message: TMessage);
2667{ show item tip, Tip Position in parameters: wParam=X and lParam=Y }
2668const
2669 NO_CATCH_MOUSE = False;
2670var
2671 TipPos: TPoint;
2672 TrueOffset :integer;
2673 TmpIdx :integer;
2674begin
2675 // if listbox is dropdown combo but control is not focused -
2676 if (Parent is TORComboBox) and (FParentCombo <> nil) and (Screen.ActiveControl <> Parent)
2677 then Exit;
2678 // if listbox is dropdown combo and list is not dropped down -
2679 if (FParentCombo <> nil) and (FParentCombo.DroppedDown = False) then Exit;
2680 // if control is not focused -
2681 if (Screen.ActiveControl <> Self) and (Screen.ActiveControl <> Parent) then Exit;
2682 if(FHideSynonyms) then
2683 begin
2684 TrueOffset := TopIndex;
2685 TmpIdx := TopIndex;
2686 while((TmpIdx < Message.wParam) and (TmpIdx < Items.Count)) do
2687 begin
2688 if(Perform(LB_GETITEMHEIGHT, TmpIdx, 0) > 0) then
2689 inc(TrueOffset);
2690 inc(TmpIdx);
2691 end;
2692 end
2693 else
2694 TrueOffset := Message.wParam;
2695 TipPos := ClientToScreen(Point(0, (TrueOffset - TopIndex) * ItemHeight));
2696 //uItemTip.Show(Self, FFocusIndex, TipPos, NO_CATCH_MOUSE);
2697 uItemTip.Show(Self, FFocusIndex, TipPos, FParentCombo = nil); // if DropDown, no mousecapture
2698end;
2699
2700function TORListBox.GetIEN(AnIndex: Integer): Int64;
2701{ return as an integer the first piece of the Item identified by AnIndex }
2702begin
2703 if (AnIndex < Items.Count) and (AnIndex > -1)
2704 then Result := StrToInt64Def(Piece(Items[AnIndex], FDelimiter, 1), 0)
2705 else Result := 0;
2706end;
2707
2708function TORListBox.GetItemIEN: Int64;
2709{ return as an integer the first piece of the currently selected item }
2710begin
2711 if ItemIndex > -1
2712 then Result := StrToInt64Def(Piece(Items[ItemIndex], FDelimiter, 1), 0)
2713 else Result := 0;
2714end;
2715
2716function TORListBox.SelectByIEN(AnIEN: Int64): Integer;
2717{ cause the item where the first piece = AnIEN to be selected (sets ItemIndex) }
2718var
2719 i: Integer;
2720begin
2721 Result := -1;
2722 for i := 0 to Items.Count - 1 do
2723 if GetIEN(i) = AnIEN then
2724 begin
2725 ItemIndex := i;
2726 Result := i;
2727 break;
2728 end;
2729end;
2730
2731function TORListBox.SetExactByIEN(AnIEN: Int64; const AnItem: string): Integer;
2732{ finds an exact entry (matches IEN) in a list or a long list and returns ItemIndex }
2733var
2734 ItemFound: Boolean;
2735 i, ListEnd: Integer;
2736begin
2737 ItemFound := False;
2738 Result := -1;
2739 if FLongList then ListEnd := FWaterMark - 1 else ListEnd := Items.Count - 1;
2740 for i := 0 to ListEnd do if (GetIEN(i) = AnIEN) and (GetDisplayText(i) = AnItem) then
2741 begin
2742 ItemIndex := i;
2743 Result := i;
2744 ItemFound := True;
2745 break;
2746 end;
2747 if FLongList and not ItemFound then
2748 begin
2749 InitLongList(AnItem);
2750 Result := SelectByIEN(AnIEN);
2751 end;
2752end;
2753
2754function TORListBox.GetItemID: Variant;
2755{ return as a variant the first piece of the currently selected item }
2756begin
2757 if ItemIndex > -1 then Result := Piece(Items[ItemIndex], FDelimiter, 1) else Result := '';
2758end;
2759
2760function TORListBox.SelectByID(const AnID: string): Integer;
2761{ cause the item where the first piece = AnID to be selected (sets ItemIndex) }
2762var
2763 i: Integer;
2764begin
2765 Result := -1;
2766 for i := 0 to Items.Count - 1 do
2767 if Piece(Items[i], FDelimiter, 1) = AnID then
2768 begin
2769 ItemIndex := i;
2770 Result := i;
2771 break;
2772 end;
2773end;
2774
2775function TORListBox.GetReference(Index: Integer): Variant;
2776{ retrieves a variant value that is associated with an item in a listbox }
2777var
2778 ItemRec: PItemRec;
2779begin
2780 if (Index < 0) or (Index >= Items.Count) then
2781 raise Exception.Create('List Index Out of Bounds');
2782 FFromSelf := True;
2783 ItemRec := PItemRec(SendMessage(Handle,LB_GETITEMDATA, Index, 0));
2784 FFromSelf := False;
2785 if(assigned(ItemRec)) then
2786 Result := ItemRec^.Reference
2787 else
2788 Result := Null;
2789end;
2790
2791procedure TORListBox.SetReference(Index: Integer; AReference: Variant);
2792{ stores a variant value that is associated with an item in a listbox }
2793var
2794 ItemRec: PItemRec;
2795begin
2796 if (Index < 0) or (Index >= Items.Count) then
2797 raise Exception.Create('List Index Out of Bounds');
2798 FFromSelf := True;
2799 ItemRec := PItemRec(SendMessage(Handle,LB_GETITEMDATA, Index, 0));
2800 FFromSelf := False;
2801 if(assigned(ItemRec)) then
2802 ItemRec^.Reference := AReference;
2803end;
2804
2805function TORListBox.AddReference(const S: string; AReference: Variant): Integer;
2806{ adds a string to a listbox, along with a variant value to be associated with the string }
2807begin
2808 Result := Items.Add(S);
2809 SetReference(Result, AReference);
2810end;
2811
2812procedure TORListBox.InsertReference(Index: Integer; const S: string; AReference: Variant);
2813{ inserts a string at a position into a listbox, along with its associated variant value }
2814begin
2815 Items.Insert(Index, S);
2816 SetReference(Index, AReference);
2817end;
2818
2819function TORListBox.IndexOfReference(AReference: Variant): Integer;
2820{ looks through the list of References (variants) and returns the index of the first match }
2821var
2822 i: Integer;
2823begin
2824 Result := -1;
2825 for i := 0 to Items.Count - 1 do
2826 if GetReference(i) = AReference then
2827 begin
2828 Result := i;
2829 Break;
2830 end;
2831end;
2832
2833function TORListBox.GetTabPositions: string;
2834{ returns the character based tab stops that are currently set, if any }
2835begin
2836 if(FTabPosInPixels) then
2837 Result := IntArrayToString(FTabPix)
2838 else
2839 Result := IntArrayToString(FTabPos);
2840end;
2841
2842procedure TORListBox.SetTabPositions(const Value: string);
2843{ converts a string of character position tab stops to an array of integer & sets now tabs }
2844var
2845 TabTmp: array[0..MAX_TABS] of Integer;
2846 i: Integer;
2847begin
2848 StringToIntArray(Value, TabTmp, TRUE);
2849 for i := 2 to TabTmp[0] do
2850 if (abs(TabTmp[i]) < abs(TabTmp[i - 1])) or
2851 (TabTmp[i] = TabTmp[i - 1]) then
2852 raise Exception.Create('Tab positions must be in ascending order');
2853 if(FTabPosInPixels) then
2854 begin
2855 for i := 0 to TabTmp[0] do FTabPix[i] := TabTmp[i];
2856 end
2857 else
2858 begin
2859 for i := 0 to TabTmp[0] do FTabPos[i] := TabTmp[i];
2860 end;
2861 SetTabStops;
2862 if FTabPos[0] > 0 then FWhiteSpace := #9 else FWhiteSpace := ' ';
2863 ResetItems;
2864end;
2865
2866procedure TORListBox.SetTabPosInPixels(const Value: boolean);
2867begin
2868 if(FTabPosInPixels <> Value) then
2869 begin
2870 FTabPosInPixels := Value;
2871 SetTabStops;
2872 end;
2873end;
2874
2875procedure TORListBox.SetTabStops;
2876{ sets new tabs stops based on dialog units, FTabPix array also used by ItemTip }
2877var
2878 TabDlg: array[0..MAX_TABS] of Integer;
2879 i, AveWidth: Integer;
2880begin
2881 FillChar(TabDlg, SizeOf(TabDlg), 0);
2882 AveWidth := FontWidthPixel(Self.Font.Handle);
2883 if(FTabPosInPixels) then
2884 begin
2885 FillChar(FTabPos, SizeOf(FTabPos), 0);
2886 FTabPos[0] := FTabPix[0];
2887 for i := 1 to FTabPix[0] do
2888 begin
2889 FTabPos[i] := FTabPix[i] div AveWidth;
2890 TabDlg[i] := (FTabPix[i] * 4) div AveWidth;
2891 end;
2892 end
2893 else
2894 begin
2895 FillChar(FTabPix, SizeOf(FTabPix), 0);
2896 FTabPix[0] := FTabPos[0];
2897 for i := 1 to FTabPos[0] do
2898 begin
2899 // do dialog units first so that pixels gets the same rounding error
2900 TabDlg[i] := FTabPos[i] * 4; // 4 dialog units per character
2901 FTabPix[i] := (TabDlg[i] * AveWidth) div 4;
2902 end;
2903 end;
2904 TabDlg[0] := FTabPos[0];
2905 Perform(LB_SETTABSTOPS, TabDlg[0], Integer(@TabDlg[1]));
2906 Refresh;
2907end;
2908
2909function TORListBox.SupportsDynamicProperty(PropertyID: integer): boolean;
2910begin
2911 Result := (PropertyID = DynaPropAccesibilityCaption);
2912end;
2913
2914procedure TORListBox.SetHideSynonyms(Value :boolean);
2915var
2916 TmpIH :integer;
2917
2918begin
2919 if(FHideSynonyms <> Value) then
2920 begin
2921 if((Value) and (not FLongList)) then
2922 raise Exception.Create('Hide Synonyms only allowed on Long Lists');
2923 FHideSynonyms := Value;
2924 if(not FHideSynonyms) then
2925 begin
2926 Style := lbStandard;
2927 end
2928 else
2929 begin
2930 if(FSynonymChars = '') then
2931 FSynonymChars := '<>';
2932 TmpIH := ItemHeight;
2933 Style := lbOwnerDrawVariable;
2934 ItemHeight := TmpIH;
2935 end;
2936 end;
2937end;
2938
2939procedure TORListBox.SetSynonymChars(Value :string);
2940begin
2941 if(FSynonymChars <> Value) then
2942 begin
2943 FSynonymChars := Value;
2944 if((Value = '') and (FHideSynonyms)) then
2945 SetHideSynonyms(FALSE);
2946 if(FHideSynonyms) then
2947 begin
2948 SetHideSynonyms(FALSE);
2949 SetHideSynonyms(TRUE);
2950 end;
2951 end;
2952end;
2953
2954function TORListBox.GetStyle: TListBoxStyle;
2955begin
2956 Result := inherited Style;
2957end;
2958
2959procedure TORListBox.SetStyle(Value: TListBoxStyle);
2960begin
2961 if(Value <> lbOwnerDrawVariable) and (FHideSynonyms) then
2962 FHideSynonyms := FALSE;
2963 if(FCheckBoxes) and (Value = lbStandard) then
2964 FCheckBoxes := FALSE;
2965 inherited Style := Value;
2966end;
2967
2968procedure TORListBox.SetDelimiter(Value: Char);
2969{ change the delimiter used in conjunction with the pieces property (default = '^') }
2970begin
2971 FDelimiter := Value;
2972 ResetItems;
2973end;
2974
2975function TORListBox.GetPieces: string;
2976{ returns the pieces of an item currently selected for display }
2977begin
2978 Result := IntArrayToString(FPieces);
2979end;
2980
2981procedure TORListBox.SetPieces(const Value: string);
2982{ converts a string of comma-delimited integers into an array of string pieces to display }
2983begin
2984 StringToIntArray(Value, FPieces);
2985 ResetItems;
2986end;
2987
2988procedure TORListBox.ResetItems;
2989{ saves listbox objects then rebuilds listbox including references and user objects }
2990var
2991 SaveItems: TList;
2992 Strings: TStringList;
2993 i, Pos: Integer;
2994 ItemRec, ItemRec2: PItemRec;
2995 SaveListMode: Boolean;
2996 RealVerify: Boolean;
2997begin
2998 SaveListMode := False;
2999 Strings := nil;
3000 SaveItems := nil;
3001 RealVerify := TORStrings(Items).Verification;
3002 try
3003 TORStrings(Items).Verification := False;
3004 HandleNeeded; // ensures that Items is valid if in the middle of RecreateWnd
3005 SaveListMode := FLongList;
3006 Strings := TStringList.Create;
3007 SaveItems := TList.Create;
3008 FLongList := False; // so don't have to track WaterMark
3009 FFromSelf := True;
3010 for i := 0 to Items.Count - 1 do // put pointers to TItemRec in SaveItems
3011 begin
3012 ItemRec := PItemRec(SendMessage(Handle, LB_GETITEMDATA, i, 0));
3013 SaveItems.Add(ItemRec);
3014 end;
3015 Strings.Assign(Items);
3016 Items.Clear; // still FromSelf so don't dispose recs
3017 FFromSelf := False;
3018 for i := 0 to SaveItems.Count - 1 do // use saved ItemRecs to rebuild listbox
3019 begin
3020 ItemRec := SaveItems[i];
3021 if(assigned(ItemRec)) then
3022 begin
3023 Pos := Items.AddObject(Strings[i], ItemRec^.UserObject);
3024 // CQ 11491 - Changing TabPositions, etc. was wiping out check box status.
3025 FFromSelf := True;
3026 ItemRec2 := PItemRec(SendMessage(Handle,LB_GETITEMDATA, Pos, 0));
3027 FFromSelf := False;
3028 if(assigned(ItemRec2)) then
3029 begin
3030 ItemRec2^.Reference := ItemRec^.Reference;
3031 ItemRec2^.CheckedState := ItemRec^.CheckedState;
3032 end;
3033 end;
3034 end;
3035 finally
3036 SaveItems.Free;
3037 Strings.Free;
3038 TORStrings(Items).Verification := RealVerify;
3039 FLongList := SaveListMode;
3040 end;
3041end;
3042
3043procedure TORListBox.SetLongList(Value: Boolean);
3044{ changes the list box so that it runs in LongList mode (calls OnNeedData) }
3045begin
3046 if Value <> FLongList then
3047 begin
3048 if Value = True then
3049 CreateScrollBar
3050 else
3051 begin
3052 FreeScrollBar;
3053 if(FHideSynonyms) then
3054 SetHideSynonyms(FALSE);
3055 end;
3056 end;
3057end;
3058
3059procedure TORListBox.AdjustScrollBar;
3060{ ensures that the scrollbar used for a long list is placed properly within the listbox }
3061var
3062 L, T, W, H, OffsetLT, OffsetWH: Integer;
3063begin
3064 if uNewStyle then begin OffsetLT := 2; OffsetWH := 4; end // Win95
3065 else begin OffsetLT := 0; OffsetWH := 0; end; // Win3.1
3066 W := GetSystemMetrics(SM_CXVSCROLL);
3067 L := Left + Width - W - OffsetLT;
3068 T := Top + OffsetLT;
3069 H := Height - OffsetWH;
3070 FScrollBar.SetBounds(L, T, W, H);
3071 FScrollBar.Invalidate;
3072end;
3073
3074procedure TORListBox.CreateScrollBar;
3075{ a long list uses it's own scrollbar (mapped to APLHA_DISTRIBUTION, rather than the listbox's }
3076begin
3077 FLongList := True;
3078 if MultiSelect then MultiSelect := False; // LongLists do not support multiple selections
3079 FScrollBar := TScrollBar.Create(Self);
3080 FScrollBar.Kind := sbVertical;
3081 FScrollBar.TabStop := False;
3082 FScrollBar.ControlStyle := FScrollBar.ControlStyle - [csCaptureMouse];
3083 AdjustScrollBar;
3084 FScrollBar.OnScroll := ScrollTo;
3085 if FParentCombo = nil
3086 then FScrollBar.Parent := Parent
3087 else FScrollBar.Parent := FParentCombo.FDropPanel;
3088end;
3089
3090procedure TORListBox.FreeScrollBar;
3091{ frees the scrollbar for a longlist (called when LongList property becomes false) }
3092begin
3093 FLongList := False;
3094 FScrollBar.Free; // don't call from destroy because scrollbar may already be free
3095 FScrollBar := nil;
3096end;
3097
3098procedure TORListBox.ForDataUse(Strings: TStrings);
3099{ adds or inserts items into a list box after determining the proper collating sequence }
3100var
3101 Ascend: Boolean;
3102 FirstItem, LastItem: string;
3103 i: Integer;
3104begin
3105 if Strings.Count = 0 then Exit;
3106 { To prevent the problem where the initial list item(s) are returned repeatedly because the
3107 DisplayText is longer than the subscript in a cross-reference, compare the last item
3108 returned with the first item in the long list. If they are the same, assume the long
3109 list is already scrolled to the first item. }
3110 if (FDirection = LL_REVERSE) and (FWaterMark < Items.Count) and
3111 (CompareText(Strings[Strings.Count - 1], Items[FWaterMark]) = 0) then Exit;
3112
3113 FirstItem := TextToShow(Strings[0]);
3114 LastItem := TextToShow(Strings[Strings.Count-1]);
3115 Ascend := True;
3116 case FDirection of
3117 LL_REVERSE: if CompareText(FirstItem, LastItem) < 0 then Ascend := False;
3118 LL_FORWARD: if CompareText(FirstItem, LastItem) > 0 then Ascend := False;
3119 end;
3120 case Ascend of // should call AddObject & InsertObject instead?
3121 False: case FDirection of
3122 LL_REVERSE: for i := Strings.Count - 1 downto 0 do Items.Insert(FInsertAt, Strings[i]);
3123 LL_FORWARD: for i := Strings.Count - 1 downto 0 do Items.Add(Strings[i]);
3124 end;
3125 True: case FDirection of
3126 LL_REVERSE: for i := 0 to Strings.Count - 1 do Items.Insert(FInsertAt, Strings[i]);
3127 LL_FORWARD: for i := 0 to Strings.Count - 1 do Items.Add(Strings[i]);
3128 end;
3129 end;
3130end;
3131
3132procedure TORListBox.InitLongList(S: string);
3133{ clears the listbox starting at FWaterMark and makes the initial NeedData call }
3134var
3135 index: integer;
3136begin
3137 if FLongList then
3138 begin
3139 if LookUpPiece <> 0 then
3140 begin
3141 index := GetStringIndex(S);
3142 if index > -1 then
3143 S := Piece(Items[index],Delimiter,LookUpPiece);
3144 end;
3145 if CaseChanged then
3146 S := UpperCase(S);
3147 // decrement last char & concat '~' for $ORDER
3148 if Length(S) > 0 then S := Copy(S, 1, Length(S) - 1) + Pred(S[Length(S)]) + '~';
3149 NeedData(LL_POSITION, S);
3150 if S = '' then TopIndex := 0 else TopIndex := FWaterMark;
3151 FScrollBar.Position := PositionThumb;
3152 end;
3153end;
3154
3155procedure TORListBox.InsertSeparator;
3156begin
3157 if FWaterMark > 0 then
3158 begin
3159 Items.Insert(FWaterMark,LLS_LINE);
3160 Items.Insert(FWaterMark,LLS_SPACE);
3161 end;
3162end;
3163
3164procedure TORListBox.ClearTop;
3165{ clears a long listbox up to FWaterMark (doesn't clear long list) }
3166var
3167 i: Integer;
3168begin
3169 SendMessage(Handle, WM_SETREDRAW, NOREDRAW, 0);
3170 for i := FWaterMark - 1 downto 0 do Items.Delete(i);
3171 SendMessage(Handle, WM_SETREDRAW, DOREDRAW, 0);
3172 Invalidate;
3173end;
3174
3175procedure TORListBox.NeedData(Direction: Integer; StartFrom: string);
3176{ called whenever the longlist needs more data inserted at a certain point into the listbox }
3177var
3178 CtrlPos, CharPos, index: Integer;
3179
3180 procedure ClearLong;
3181 { clears a portion or all of the longlist to conserve the memory it occupies }
3182 var
3183 i: Integer;
3184 begin
3185 case FDirection of
3186 LL_REVERSE: for i := Items.Count - 1 downto
3187 HigherOf(FCurrentTop + FLargeChange, FWaterMark) do Items.Delete(i);
3188 LL_POSITION: for i := Items.Count - 1 downto FWaterMark do Items.Delete(i);
3189 LL_FORWARD: for i := FCurrentTop - 1 downto FWaterMark do Items.Delete(i);
3190 end;
3191 end;
3192
3193begin {NeedData}
3194 FFromNeedData := True;
3195 FFirstLoad := False;
3196 FDataAdded := False;
3197 FDirection := Direction;
3198 SendMessage(Handle, WM_SETREDRAW, NOREDRAW, 0);
3199 if Items.Count > 1000 then ClearLong;
3200 case FDirection of
3201 LL_REVERSE: if FWaterMark < Items.Count then StartFrom := DisplayText[FWaterMark];
3202 LL_POSITION: begin
3203 ClearLong;
3204 if StartFrom = #127#127#127 then
3205 begin
3206 FDirection := LL_REVERSE;
3207 StartFrom := '';
3208 end
3209 else FDirection := LL_FORWARD;
3210 end;
3211 LL_FORWARD: if (FWaterMark < Items.Count) and (Items.Count > 0)
3212 then StartFrom := DisplayText[Items.Count - 1];
3213 end;
3214 if LookupPiece <> 0 then
3215 begin
3216 index := GetStringIndex(StartFrom);
3217 if index > -1 then
3218 StartFrom := Piece(Items[index],Delimiter,LookUpPiece);
3219 end;
3220 if CaseChanged then
3221 StartFrom := Uppercase(StartFrom);
3222 StartFrom := Copy(StartFrom, 1, 128); // limit length to 128 characters
3223 CtrlPos := 0; // make sure no ctrl characters
3224 for CharPos := 1 to Length(StartFrom) do if StartFrom[CharPos] in [#0..#31] then
3225 begin
3226 CtrlPos := CharPos;
3227 break;
3228 end;
3229 if CtrlPos > 0 then StartFrom := Copy(StartFrom, 1, CtrlPos - 1);
3230 if FDirection = LL_FORWARD then FInsertAt := Items.Count else FInsertAt := FWaterMark;
3231 if Assigned(FOnNeedData) then FOnNeedData(Self, copy(StartFrom, 1, MaxNeedDataLen), FDirection, FInsertAt);
3232 SendMessage(Handle, WM_SETREDRAW, DOREDRAW, 0);
3233 FFromNeedData := False;
3234 Invalidate;
3235end;
3236
3237function TORListBox.PositionThumb: Integer;
3238{ returns the proper thumb position for the TopIndex item relative to ALPHA_DISTRIBUTION }
3239var
3240 x: string;
3241begin
3242 Result := 1;
3243 x := DisplayText[TopIndex];
3244 if (FWaterMark > 0) and (TopIndex < FWaterMark)
3245 then Result := 0 // short list visible
3246 else while (CompareText(ALPHA_DISTRIBUTION[Result], x) < 0) and (Result < 100) do
3247 Inc(Result); // only long list visible
3248end;
3249
3250procedure TORListBox.ScrollTo(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer);
3251{ event code for the longlist scrollbar, adjusts TopIndex & calls OnNeedData as necessary }
3252var
3253 Count, Goal, Dir :integer;
3254 Done :boolean;
3255
3256begin
3257 uItemTip.Hide;
3258 FCurrentTop := TopIndex;
3259 if(ScrollCode = scPosition) then
3260 begin
3261 NeedData(LL_POSITION, ALPHA_DISTRIBUTION[ScrollPos]);
3262 case ScrollPos of
3263 0: TopIndex := 0;
3264 1..99: TopIndex := FWaterMark;
3265 100: TopIndex := HigherOf(Items.Count - FLargeChange, 0);
3266 end;
3267 FFocusIndex := TopIndex;
3268 end
3269 else
3270 if(HideSynonyms) then
3271 begin
3272 Count := 0;
3273 case ScrollCode of
3274 scLineUp: begin Dir := -1; Goal := 1; end;
3275 scLineDown: begin Dir := 1; Goal := 1; end;
3276 scPageUp: begin Dir := -1; Goal := FLargeChange; end;
3277 scPageDown: begin Dir := 1; Goal := FLargeChange; end;
3278 else
3279 exit;
3280 end;
3281 repeat
3282 Done := FALSE;
3283 if(Dir > 0) then
3284 begin
3285 if (FCurrentTop + (FLargeChange * 2)) > (Items.Count - 1) then
3286 NeedData(LL_FORWARD, '');
3287 if(FCurrentTop >= Items.Count - 1) then
3288 begin
3289 FCurrentTop := Items.Count - 1;
3290 Done := TRUE;
3291 end;
3292 end
3293 else
3294 begin
3295 if (FCurrentTop - FLargeChange) < FWaterMark then NeedData(LL_REVERSE, '');
3296 if(FCurrentTop <= 0) then
3297 begin
3298 FCurrentTop := 0;
3299 Done := TRUE;
3300 end;
3301 end;
3302 if(not Done) then
3303 begin
3304 FCurrentTop := FCurrentTop + Dir;
3305 if(Perform(LB_GETITEMHEIGHT, FCurrentTop, 0) > 0) then
3306 begin
3307 inc(Count);
3308 Done := (Count >= Goal);
3309 end;
3310 end;
3311 until Done;
3312 TopIndex := FCurrentTop;
3313 end
3314 else
3315 begin
3316 case ScrollCode of
3317 scLineUp: begin
3318 if (FCurrentTop - FLargeChange) < FWaterMark then NeedData(LL_REVERSE, '');
3319 TopIndex := HigherOf(FCurrentTop - 1, 0);
3320 end;
3321 scLineDown: begin
3322 if (FCurrentTop + (FLargeChange * 2)) > (Items.Count - 1)
3323 then NeedData(LL_FORWARD, '');
3324 TopIndex := LowerOf(FCurrentTop + 1, Items.Count - 1);
3325 end;
3326 scPageUp: begin
3327 if (FCurrentTop - FLargeChange) < FWaterMark then NeedData(LL_REVERSE, '');
3328 TopIndex := HigherOf(FCurrentTop - FLargeChange, 0);
3329 end;
3330 scPageDown: begin
3331 if (FCurrentTop + (FLargeChange * 2)) > (Items.Count - 1)
3332 then NeedData(LL_FORWARD, '');
3333 TopIndex := LowerOf(FCurrentTop + FLargeChange, Items.Count - 1);
3334 end;
3335 end;
3336 end;
3337 if (ScrollPos > 0) and (ScrollPos < 100) then ScrollPos := PositionThumb;
3338end;
3339
3340function TORListBox.GetStringIndex(const AString: string): Integer;
3341{returns the index of the first string that partially matches AString}
3342var
3343 i: Integer;
3344begin
3345 Result := -1;
3346 if Length(AString) > 0 then {*KCM*}
3347 begin
3348 if not FLongList then // Normal List
3349 begin
3350 Result := SendMessage(Handle, LB_FINDSTRING, -1, Longint(PChar(AString)));
3351 if Result = LB_ERR then Result := -1;
3352 end else // Long List
3353 begin
3354 if FScrollBar.Position = 0 then for i := 0 to FWatermark - 1 do
3355 begin
3356 if CompareText(AString, Copy(DisplayText[i], 1, Length(AString))) = 0 then
3357 begin
3358 Result := i;
3359 break;
3360 end;
3361 end;
3362 if Result < 0 then
3363 begin
3364 Result := SendMessage(Handle, LB_FINDSTRING, FWaterMark - 1, Longint(PChar(AString)));
3365 if Result < FWaterMark then Result := -1;
3366 end; {if Result}
3367 end; {if not FLongList}
3368 end; {if Length(AString)}
3369end;
3370
3371function TORListBox.SelectString(const AString: string): Integer;
3372{ causes the first string that partially matches AString to be selected & returns the index }
3373var
3374 x: string;
3375 i: Integer;
3376 index: integer;
3377begin
3378 Result := -1;
3379 if Length(AString) > 0 then {*KCM*}
3380 begin
3381 if not FLongList then // Normal List
3382 begin
3383 Result := SendMessage(Handle, LB_FINDSTRING, -1, Longint(PChar(AString)));
3384 if Result = LB_ERR then Result := -1;
3385 // use FFocusIndex instead of FocusIndex to reduce flashing
3386 FFocusIndex := Result;
3387 end else // Long List
3388 begin
3389 if FScrollBar.Position = 0 then for i := 0 to FWatermark - 1 do
3390 begin
3391 if CompareText(AString, Copy(DisplayText[i], 1, Length(AString))) = 0 then
3392 begin
3393 Result := i;
3394 break;
3395 end;
3396 end;
3397 if not StringBetween(AString, DisplayText[FWaterMark], DisplayText[Items.Count - 1]) then
3398 begin
3399 x := AString;
3400 if LookupPiece <> 0 then
3401 begin
3402 index := GetStringIndex(x);
3403 if index > -1 then
3404 x := Piece(Items[index],Delimiter,LookUpPiece);
3405 end;
3406 if CaseChanged then
3407 x := UpperCase(x);
3408 // decrement last char & concat '~' for $ORDER
3409 if Length(x) > 0 then x := Copy(x, 1, Length(x) - 1) + Pred(x[Length(x)]) + '~';
3410 NeedData(LL_POSITION, x);
3411 end;
3412 if Result < 0 then
3413 begin
3414 Result := SendMessage(Handle, LB_FINDSTRING, FWaterMark - 1, Longint(PChar(AString)));
3415 if Result < FWaterMark then Result := -1;
3416 if Result >= FWatermark then FocusIndex := Result;
3417 uItemTip.Hide;
3418 end; {if Result}
3419 end; {if not FLongList}
3420 end; {if Length(AString)}
3421 ItemIndex := Result;
3422 FFocusIndex := Result;
3423 if Result > -1 then TopIndex := Result; // will scroll item into view
3424 if FLongList then FScrollBar.Position := PositionThumb; // done after topindex set
3425end;
3426
3427procedure TORListBox.SetCheckBoxes(const Value: boolean);
3428begin
3429 if(FCheckBoxes <> Value) then
3430 begin
3431 FCheckBoxes := Value;
3432 if(Value) then
3433 begin
3434 if(GetStyle = lbStandard) then
3435 SetStyle(lbOwnerDrawFixed);
3436 if(inherited MultiSelect) then
3437 SetMultiSelect(FALSE);
3438 end;
3439 invalidate;
3440 end;
3441end;
3442
3443procedure TORListBox.SetFlatCheckBoxes(const Value: boolean);
3444begin
3445 if(FFlatCheckBoxes <> Value) then
3446 begin
3447 FFlatCheckBoxes := Value;
3448 invalidate;
3449 end;
3450end;
3451
3452function TORListBox.GetChecked(Index: Integer): Boolean;
3453var
3454 ItemRec: PItemRec;
3455
3456begin
3457 Result := False;
3458 if Index < 0 then exit;
3459 FFromSelf := True;
3460 ItemRec := PItemRec(SendMessage(Handle,LB_GETITEMDATA, Index, 0));
3461 FFromSelf := FALSE;
3462 if(assigned(ItemRec)) then
3463 Result := (ItemRec^.CheckedState = cbChecked)
3464 else
3465 Result := False;
3466end;
3467
3468procedure TORListBox.SetChecked(Index: Integer; const Value: Boolean);
3469var
3470 ItemRec: PItemRec;
3471 Rect: TRect;
3472
3473begin
3474 FFromSelf := True;
3475 ItemRec := PItemRec(SendMessage(Handle,LB_GETITEMDATA, Index, 0));
3476 FFromSelf := False;
3477 if (assigned(ItemRec)) and (Value <> (ItemRec^.CheckedState = cbChecked)) then
3478 begin
3479 if(Value) then
3480 ItemRec^.CheckedState := cbChecked
3481 else
3482 ItemRec^.CheckedState := cbUnChecked;
3483 Rect := ItemRect(Index);
3484 InvalidateRect(Handle, @Rect, FALSE);
3485 if(assigned(FOnClickCheck)) then
3486 FOnClickCheck(Self, Index);
3487 end;
3488end;
3489
3490function TORListBox.GetCheckedState(Index: Integer): TCheckBoxState;
3491var
3492 ItemRec: PItemRec;
3493
3494begin
3495 FFromSelf := True;
3496 ItemRec := PItemRec(SendMessage(Handle,LB_GETITEMDATA, Index, 0));
3497 FFromSelf := FALSE;
3498 if(assigned(ItemRec)) then
3499 Result := ItemRec^.CheckedState
3500 else
3501 Result := cbGrayed;
3502end;
3503
3504procedure TORListBox.SetCheckedState(Index: Integer;
3505 const Value: TCheckBoxState);
3506var
3507 ItemRec: PItemRec;
3508 Rect: TRect;
3509
3510begin
3511 FFromSelf := True;
3512 ItemRec := PItemRec(SendMessage(Handle,LB_GETITEMDATA, Index, 0));
3513 FFromSelf := False;
3514 if (assigned(ItemRec)) and (Value <> ItemRec^.CheckedState) then
3515 begin
3516 ItemRec^.CheckedState := Value;
3517 Rect := ItemRect(Index);
3518 InvalidateRect(Handle, @Rect, FALSE);
3519 if(assigned(FOnClickCheck)) then
3520 FOnClickCheck(Self, Index);
3521 end;
3522end;
3523
3524function TORListBox.GetMultiSelect: boolean;
3525begin
3526 result := inherited MultiSelect;
3527end;
3528
3529procedure TORListBox.SetMultiSelect(Value: boolean);
3530begin
3531 inherited SetMultiSelect(Value);
3532 if(Value) then SetCheckBoxes(FALSE);
3533end;
3534
3535function TORListBox.GetCheckedString: string;
3536var
3537 i: integer;
3538
3539begin
3540 Result := '';
3541 if(FCheckBoxes) then
3542 begin
3543 for i := 0 to Items.Count-1 do
3544 Result := Result + Char(ord('0') + Ord(GetCheckedState(i)));
3545 end;
3546end;
3547
3548procedure TORListBox.SetCheckedString(const Value: string);
3549var
3550 i: integer;
3551
3552begin
3553 for i := 0 to Items.Count-1 do
3554 SetCheckedState(i, TCheckBoxState(StrToIntDef(copy(Value,i+1,1),0)));
3555end;
3556
3557function TORListBox.GetMItems: TStrings;
3558begin
3559 if not Assigned(FMItems) then
3560 FMItems := TORStrings.Create(Tlistbox(Self).Items,TextToShow);
3561 result := FMItems;
3562end;
3563
3564procedure TORListBox.SetMItems( Value: TStrings);
3565begin
3566 if not Assigned(FMItems) then
3567 FMItems := TORStrings.Create(Tlistbox(Self).Items,TextToShow);
3568 FMItems.Assign( Value );
3569end;
3570
3571procedure TORListBox.Clear;
3572begin
3573 Items.Clear;
3574 inherited;
3575end;
3576
3577procedure TORListBox.SetBlackColorMode(Value: boolean);
3578begin
3579 FBlackColorMode := Value;
3580end;
3581
3582procedure TORListBox.SetCaption(const Value: string);
3583begin
3584 if not Assigned(FCaption) then begin
3585 FCaption := TStaticText.Create(self);
3586 FCaption.AutoSize := False;
3587 FCaption.Height := 0;
3588 FCaption.Width := 0;
3589 FCaption.Visible := True;
3590 if Assigned (FParentCombo) then
3591 FCaption.Parent := FParentCombo
3592 else
3593 FCaption.Parent := Parent;
3594 FCaption.BringToFront;
3595 end;
3596 FCaption.Caption := Value;
3597end;
3598
3599function TORListBox.GetCaption: string;
3600begin
3601 result := FCaption.Caption;
3602end;
3603
3604// In Delphi 2006, hint windows will cause the TORComboBox drop down list to
3605// move behind a Stay on Top form. Hints are also problematic with item tips in
3606// the drop down list, so we disable them when ever a drop down list is open,
3607// on all forms, not just stay on top forms.
3608var
3609 uDropPanelOpenCount: integer = 0;
3610 uOldShowHintsSetting: boolean;
3611
3612procedure DropDownPanelOpened;
3613begin
3614 if uDropPanelOpenCount=0 then
3615 uOldShowHintsSetting := Application.ShowHint;
3616 Application.ShowHint := FALSE;
3617 inc(uDropPanelOpenCount);
3618end;
3619
3620procedure DropDownPanelClosed;
3621begin
3622 dec(uDropPanelOpenCount);
3623 if uDropPanelOpenCount<=0 then
3624 begin
3625 uDropPanelOpenCount := 0;
3626 if not Application.ShowHint then
3627 Application.ShowHint := uOldShowHintsSetting
3628 end;
3629end;
3630
3631{ TORDropPanel ----------------------------------------------------------------------------- }
3632const
3633 OKBtnTag = 1;
3634 CancelBtnTag = 2;
3635
3636procedure TORDropPanel.BtnClicked(Sender: TObject);
3637begin
3638 (Owner as TORComboBox).DropPanelBtnPressed((Sender as TSpeedButton).Tag = OKBtnTag, TRUE);
3639end;
3640
3641constructor TORDropPanel.Create(AOwner: TComponent);
3642{ Creates a panel the contains the listbox portion of a combobox when the combobox style is
3643 orcsDropDown. This is necessary for the combobox to scroll the list properly. The panel
3644 acts as the parent for the list, which recieves the scroll events. If the panel is not
3645 used, the scroll events to the the Desktop and are not received by the application }
3646begin
3647 inherited Create(AOwner);
3648 BevelInner := bvNone;
3649 BevelOuter := bvNone;
3650 BorderStyle := bsNone;
3651 Caption :='';
3652 Ctl3D := False;
3653 Visible := False;
3654 UpdateButtons;
3655end;
3656
3657procedure TORDropPanel.CreateParams(var Params: TCreateParams);
3658{ changes parent of panel to desktop so when list is dropped it can overlap other windows }
3659begin
3660 inherited CreateParams(Params);
3661 if not (csDesigning in ComponentState) then with Params do
3662 begin
3663 if uNewStyle then Params.ExStyle := Params.ExStyle or WS_EX_TOOLWINDOW;
3664 Params.ExStyle := Params.ExStyle or WS_EX_TOPMOST; // - incompatible with ItemTip
3665 WindowClass.Style := WindowClass.Style or CS_SAVEBITS;
3666 WndParent := GetDesktopWindow;
3667 end;
3668end;
3669
3670function TORDropPanel.GetButton(OKBtn: boolean): TSpeedButton;
3671var
3672 i: integer;
3673
3674begin
3675 Result := nil;
3676 if(FButtons) then
3677 begin
3678 for i := 0 to ControlCount-1 do
3679 if(Controls[i] is TSpeedButton) then
3680 begin
3681 if((OKBtn and ((Controls[i] as TSpeedButton).Tag = OKBtnTag)) or
3682 ((not OKBtn) and ((Controls[i] as TSpeedButton).Tag = CancelBtnTag))) then
3683 begin
3684 Result := TSpeedButton(Controls[i]);
3685 break;
3686 end;
3687 end;
3688 end;
3689end;
3690
3691procedure TORDropPanel.ResetButtons;
3692var
3693 sb: TSpeedButton;
3694
3695begin
3696 sb := GetButton(TRUE);
3697 if(assigned(sb)) then sb.Down := FALSE;
3698 sb := GetButton(FALSE);
3699 if(assigned(sb)) then sb.Down := FALSE;
3700end;
3701
3702procedure TORDropPanel.Resize;
3703var
3704 half: integer;
3705 btn: TSpeedButton;
3706
3707begin
3708 inherited;
3709 if(FButtons) then
3710 begin
3711 btn := GetButton(TRUE);
3712 if(assigned(btn)) then
3713 begin
3714 half := width div 2;
3715 btn.Left := 0;
3716 btn.Width := Half;
3717 btn.Top := Height-btn.Height;
3718 btn := GetButton(FALSE);
3719 btn.Left := Half;
3720 btn.Width := Width - Half;
3721 btn.Top := Height-btn.Height;
3722 end;
3723 end;
3724end;
3725
3726procedure TORDropPanel.UpdateButtons;
3727var
3728 btn: TSpeedButton;
3729 cbo: TORComboBox;
3730 i:integer;
3731
3732begin
3733 cbo := (Owner as TORComboBox);
3734 if(cbo.FListBox.FCheckBoxes) then
3735 begin
3736 if(not FButtons) then
3737 begin
3738 btn := TSpeedButton.Create(Self);
3739 btn.Parent := Self;
3740 btn.Caption := 'OK';
3741 btn.Height := CheckComboBtnHeight;
3742 btn.Tag := OKBtnTag;
3743 btn.AllowAllUp := TRUE;
3744 btn.GroupIndex := 1;
3745 btn.OnClick := BtnClicked;
3746 btn := TSpeedButton.Create(Self);
3747 btn.Parent := Self;
3748 btn.Caption := 'Cancel';
3749 btn.Height := CheckComboBtnHeight;
3750 btn.Tag := CancelBtnTag;
3751 btn.AllowAllUp := TRUE;
3752 btn.GroupIndex := 1;
3753 btn.OnClick := BtnClicked;
3754 FButtons := TRUE;
3755 Resize;
3756 end;
3757 end
3758 else
3759 if(FButtons) then
3760 begin
3761 for i := ControlCount-1 downto 0 do
3762 if(Controls[i] is TButton) then
3763 Controls[i].Free;
3764 FButtons := FALSE;
3765 Resize;
3766 end;
3767end;
3768
3769procedure TORDropPanel.WMActivateApp(var Message: TMessage);
3770{ causes drop down list to be hidden when another application is activated (i.e., Alt-Tab) }
3771begin
3772 if BOOL(Message.wParam) = False then with Owner as TORComboBox do DroppedDown := False;
3773end;
3774
3775{ TORComboEdit ----------------------------------------------------------------------------- }
3776const
3777 ComboBoxImages: array[boolean] of string = ('BMP_CBODOWN_DISABLED', 'BMP_CBODOWN');
3778 BlackComboBoxImages: array[boolean] of string = ('BLACK_BMP_CBODOWN_DISABLED', 'BLACK_BMP_CBODOWN');
3779
3780procedure TORComboEdit.CreateParams(var Params: TCreateParams);
3781{ sets a one line edit box to multiline style so the editing rectangle can be changed }
3782begin
3783 inherited CreateParams(Params);
3784 Params.Style := Params.Style or ES_MULTILINE or WS_CLIPCHILDREN;
3785end;
3786
3787procedure TORComboEdit.WMKillFocus(var Message: TWMKillFocus);
3788begin
3789 inherited;
3790 with (Owner as TORComboBox) do
3791 begin
3792 if (FListBox.FCheckBoxes) and assigned(FEditPanel) and
3793 (Message.FocusedWnd <> FListBox.Handle) and
3794 ((not assigned(FDropBtn)) or (Message.FocusedWnd <> FDropBtn.Handle)) then
3795 begin
3796 FEditPanel.FFocused := FALSE;
3797 FEditPanel.Invalidate;
3798 end;
3799 end;
3800end;
3801
3802procedure TORComboEdit.WMSetFocus(var Message: TWMSetFocus);
3803begin
3804 inherited;
3805 with (Owner as TORComboBox) do
3806 begin
3807 if FListBox.FCheckBoxes and assigned(FEditPanel) then
3808 begin
3809 HideCaret(Self.Handle);
3810 FEditPanel.FFocused := TRUE;
3811 FEditPanel.Invalidate;
3812 end;
3813 end;
3814end;
3815
3816{ TORComboBox ------------------------------------------------------------------------------ }
3817
3818constructor TORComboBox.Create(AOwner: TComponent);
3819{ create the editbox and listbox used for the combobox - the default style is Simple }
3820begin
3821 inherited Create(AOwner);
3822 Width := 121;
3823 Height := 97;
3824 FLastInput := '';
3825 FDropDownCount := 8;
3826 FStyle := orcsSimple;
3827 FCheckBoxEditColor := clBtnFace;
3828 FListBox := TORListBox.Create(Self);
3829 FListBox.isPartOfComboBox := True;
3830 FListBox.Parent := Self;
3831 FListBox.TabStop := False;
3832 FListBox.OnClick := FwdClick;
3833 FListBox.OnDblClick := FwdDblClick;
3834 FListBox.OnMouseUp := FwdMouseUp;
3835 FListBox.OnNeedData := FwdNeedData;
3836 FListBox.OnClickCheck := CheckBoxSelected;
3837 FListBox.Visible := True;
3838 FItems := FListBox.Items;
3839 FMItems := FListBox.MItems;
3840 FEditBox := TORComboEdit.Create(Self);
3841 FEditBox.Parent := Self;
3842 FEditBox.OnChange := FwdChange;
3843 FEditBox.OnKeyDown := FwdKeyDown;
3844 FEditBox.OnKeyPress := FwdKeyPress;
3845 FEditBox.OnKeyUp := FwdKeyUp;
3846 FEditBox.Visible := True;
3847 fCharsNeedMatch := 1;
3848end;
3849
3850procedure TORComboBox.WMDestroy(var Message: TWMDestroy);
3851begin
3852 if(assigned(Owner)) and (csDestroying in Owner.ComponentState) then
3853 FListBox.DestroyItems;
3854 inherited;
3855end;
3856
3857procedure TORComboBox.CMFontChanged(var Message: TMessage);
3858{ resize the edit portion of the combobox to match the font }
3859begin
3860 inherited;
3861 AdjustSizeOfSelf;
3862end;
3863
3864procedure TORComboBox.WMMove(var Message: TWMMove);
3865{ for DropDown style, need to hide listbox whenever control moves (since listbox isn't child) }
3866begin
3867 inherited;
3868 DroppedDown := False;
3869end;
3870
3871procedure TORComboBox.WMSize(var Message: TWMSize);
3872{ whenever control is resized, adjust the components (edit, list, button) within it }
3873begin
3874 inherited;
3875 AdjustSizeOfSelf;
3876end;
3877
3878procedure TORComboBox.WMTimer(var Message: TWMTimer);
3879begin
3880 inherited;
3881 if (Message.TimerID = KEY_TIMER_ID) then
3882 begin
3883 StopKeyTimer;
3884 if FListBox.LongList and FChangePending then FwdChangeDelayed;
3885 if Assigned(FOnKeyPause) then FOnKeyPause(Self);
3886 end;
3887end;
3888
3889function TORComboBox.EditControl: TWinControl;
3890begin
3891 if(assigned(FEditPanel)) then
3892 Result := FEditPanel
3893 else
3894 Result := FEditBox;
3895end;
3896
3897procedure TORComboBox.AdjustSizeOfSelf;
3898{ adjusts the components of the combobox to fit within the control boundaries }
3899var
3900 FontHeight: Integer;
3901 cboBtnX,cboBtnY: integer;
3902 cboYMargin: integer;
3903
3904begin
3905 DroppedDown := False;
3906 FontHeight := FontHeightPixel(Self.Font.Handle);
3907 if FTemplateField then
3908 begin
3909 cboYMargin := 0;
3910 cboBtnX := 1;
3911 cboBtnY := 1;
3912 end
3913 else
3914 begin
3915 cboYMargin := CBO_CYMARGIN;
3916 cboBtnX := CBO_CXFRAME;
3917 cboBtnY := CBO_CXFRAME;
3918 end;
3919 Height := HigherOf(FontHeight + cboYMargin, Height); // must be at least as high as text
3920 EditControl.SetBounds(0, 0, Width, FontHeight + cboYMargin);
3921 if(assigned(FEditPanel)) then
3922 FEditBox.SetBounds(2, 3, FEditPanel.Width - 4, FEditPanel.Height - 5);
3923 if FStyle = orcsDropDown then
3924 begin
3925 Height := FontHeight + cboYMargin; // DropDown can only be text height
3926 FDropBtn.SetBounds(EditControl.Width - CBO_CXBTN - cboBtnX, 0,
3927 CBO_CXBTN, EditControl.Height - cboBtnY);
3928 end else
3929 begin
3930 FListBox.SetBounds(0, FontHeight + CBO_CYMARGIN,
3931 Width, Height - FontHeight - CBO_CYMARGIN);
3932 end;
3933 SetEditRect;
3934end;
3935
3936procedure TORComboBox.DropButtonDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState;
3937 X, Y: Integer);
3938{ display the listbox for a DropDown style combobox whenever the drop down button is pressed }
3939begin
3940 if (Button = mbLeft) then
3941 begin
3942 FFromDropBtn := True;
3943 DroppedDown := not FDroppedDown;
3944 FFromDropBtn := False;
3945 end;
3946end;
3947
3948procedure TORComboBox.DropButtonUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState;
3949 X, Y: Integer);
3950{ shift the focus back to the editbox so the focus rectangle doesn't clutter the button }
3951begin
3952 if FDroppedDown then FListBox.MouseCapture := True; // do here so 1st buttonup not captured
3953 FEditBox.SetFocus;
3954end;
3955
3956procedure TORComboBox.DropDownStatusChanged(opened: boolean);
3957begin
3958 if opened then
3959 begin
3960 if not FDropPanel.Visible then
3961 begin
3962 if FDropDownStatusChangedCount = 0 then
3963 begin
3964 FDisableHints := TRUE;
3965 DropDownPanelOpened;
3966 end;
3967 inc(FDropDownStatusChangedCount);
3968 end;
3969 end
3970 else
3971 begin
3972 dec(FDropDownStatusChangedCount);
3973 if FDropDownStatusChangedCount <= 0 then
3974 begin
3975 if FDisableHints then
3976 begin
3977 DropDownPanelClosed;
3978 FDisableHints := FALSE;
3979 end;
3980 FDropDownStatusChangedCount := 0;
3981 end;
3982 end;
3983end;
3984
3985procedure TORComboBox.ClearDropDownStatus;
3986begin
3987 FDropDownStatusChangedCount := 1;
3988 DropDownStatusChanged(FALSE);
3989end;
3990
3991destructor TORComboBox.Destroy;
3992begin
3993 ClearDropDownStatus;
3994 inherited;
3995end;
3996
3997procedure TORComboBox.DoEnter;
3998{var
3999 key : word;}
4000{ select all the text in the editbox when recieve focus - done first so OnEnter can deselect }
4001begin
4002 //FEditBox.SelectAll;
4003 //Fix For ClearQuest: HDS00001576
4004 //This fix has been commented out, becuase it causes problems
4005{ with FListBox do
4006 if (Items.Count > 0) and (Not IsAMouseButtonDown()) and (ItemIndex = -1) then
4007 begin
4008 key := VK_UP;
4009 FwdKeyDown(Self,key,[]);
4010 //Calling keyUp after key down creates a better mimic of a Keystroke.
4011 FwdKeyUp(Self,key,[]); //fixes clearquest: HDS00001418
4012 end; }
4013 inherited DoEnter;
4014 PostMessage(Handle, UM_GOTFOCUS, 0, 0)
4015end;
4016
4017procedure TORComboBox.UMGotFocus(var Message: TMessage);
4018begin
4019 FEditBox.SetFocus;
4020 if AutoSelect then FEditBox.SelectAll;
4021end;
4022
4023procedure TORComboBox.DoExit;
4024{ make sure DropDown list is raised when losing focus }
4025begin
4026 DroppedDown := False;
4027 if FKeyTimerActive then
4028 begin
4029 StopKeyTimer;
4030 if FListBox.LongList and FChangePending then FwdChangeDelayed;
4031 end;
4032 inherited DoExit;
4033end;
4034
4035procedure TORComboBox.LoadComboBoxImage;
4036var
4037 imageName: string;
4038begin
4039 if assigned(FDropBtn) then
4040 begin
4041 if FBlackColorMode then
4042 imageName := BlackComboBoxImages[inherited Enabled]
4043 else
4044 imageName := ComboBoxImages[inherited Enabled];
4045 FDropBtn.Glyph.LoadFromResourceName(hInstance, imageName);
4046 end;
4047end;
4048
4049procedure TORComboBox.Loaded;
4050{ we need to call the loaded method for the listbox child (it's not called automatically) }
4051begin
4052 inherited Loaded;
4053 FListBox.Loaded;
4054end;
4055
4056procedure TORComboBox.FwdChange(Sender: TObject);
4057{ allow timer to call FwdChangeDelayed if long list, otherwise call directly }
4058begin
4059 if FFromSelf then Exit;
4060 FChangePending := True;
4061 if FListBox.LongList and FKeyIsDown then Exit;
4062 FwdChangeDelayed;
4063end;
4064
4065procedure TORComboBox.FwdChangeDelayed;
4066{ when user types in the editbox, find a partial match in the listbox & set into editbox }
4067var
4068 SelectIndex: Integer;
4069 x: string;
4070begin
4071 FChangePending := False;
4072 if (not FListItemsOnly) and (Length(FEditBox.Text) > 0) and (FEditBox.SelStart = 0) then Exit; // **KCM** test this!
4073 with FEditBox do x := Copy(Text, 1, SelStart);
4074 FLastInput := x;
4075 SelectIndex := -1;
4076 if Length(x) >= CharsNeedMatch then
4077 SelectIndex := FListBox.SelectString(x);
4078 if (Length(x) < CharsNeedMatch) and (FListBox.ItemIndex > -1) then
4079 SelectIndex := FListBox.SelectString(x);
4080 if UniqueAutoComplete then
4081 SelectIndex := FListBox.VerifyUnique(SelectIndex,x);
4082 if FListItemsOnly and (SelectIndex < 0) and (x <> '') then
4083 begin
4084 FFromSelf := True;
4085 x := FLastFound;
4086 SelectIndex := FListBox.SelectString(x);
4087 FEditBox.Text := GetEditBoxText(SelectIndex);
4088 if(not FListBox.FCheckBoxes) then
4089 SendMessage(FEditBox.Handle, EM_SETSEL, Length(FEditBox.Text), Length(x));
4090 FFromSelf := False;
4091 Exit; // OnChange not called in this case
4092 end;
4093 FFromSelf := True;
4094 if SelectIndex > -1 then
4095 begin
4096 FEditBox.Text := GetEditBoxText(SelectIndex);
4097 FLastFound := x;
4098 if(not FListBox.FCheckBoxes) then
4099 SendMessage(FEditBox.Handle, EM_SETSEL, Length(FEditBox.Text), Length(x));
4100 end else
4101 begin
4102 if(FListBox.CheckBoxes) then
4103 FEditBox.Text := GetEditBoxText(SelectIndex)
4104 else
4105 FEditBox.Text := x; // no match, so don't set FLastFound
4106 FEditBox.SelStart := Length(x);
4107 end;
4108 FFromSelf := False;
4109 if(not FListBox.FCheckBoxes) then
4110 if Assigned(FOnChange) then FOnChange(Self);
4111end;
4112
4113(*
4114procedure TORComboBox.FwdChangeDelayed;
4115{ when user types in the editbox, find a partial match in the listbox & set into editbox }
4116var
4117 SelectIndex: Integer;
4118 x: string;
4119begin
4120 FChangePending := False;
4121 with FEditBox do x := Copy(Text, 1, SelStart);
4122 if x = FLastInput then Exit; // this change event is just removing the selected text
4123 FLastInput := x;
4124 SelectIndex := FListBox.SelectString(x);
4125 FFromSelf := True;
4126 if SelectIndex > -1 then
4127 begin
4128 FEditBox.Text := GetEditBoxText(SelectIndex);
4129 if(not FListBox.FCheckBoxes) then
4130 SendMessage(FEditBox.Handle, EM_SETSEL, Length(FEditBox.Text), Length(x));
4131 end else
4132 begin
4133 FEditBox.Text := x;
4134 FEditBox.SelStart := Length(x);
4135 end;
4136 FFromSelf := False;
4137 if(not FListBox.FCheckBoxes) then
4138 if Assigned(FOnChange) then FOnChange(Self);
4139end;
4140*)
4141
4142procedure TORComboBox.FwdClick(Sender: TObject);
4143{ places the text of the item that was selected from the listbox into the editbox }
4144begin
4145 if FListBox.ItemIndex > -1 then
4146 begin
4147 FFromSelf := True;
4148 FListBox.FFocusIndex := FListBox.ItemIndex; // FFocusIndex used so ItemTip doesn't flash
4149 FEditBox.Text := GetEditBoxText(FListBox.ItemIndex);
4150 FLastFound := FEditBox.Text;
4151 FFromSelf := False;
4152 // not sure why this must be posted (put at the back of the message queue), but for some
4153 // reason FEditBox.SelectAll selects successfully then deselects on exiting this procedure
4154 if(not FListBox.FCheckBoxes) then
4155 PostMessage(FEditBox.Handle, EM_SETSEL, 0, Length(FEditBox.Text));
4156 FEditBox.SetFocus;
4157 end;
4158 if Assigned(FOnClick) then FOnClick(Self);
4159 if(not FListBox.FCheckBoxes) then
4160 if Assigned(FOnChange) then FOnChange(Self); // click causes both click & change events
4161end;
4162
4163procedure TORComboBox.FwdDblClick(Sender: TObject);
4164{ surfaces the double click event from the listbox so it is available as a combobox property }
4165begin
4166 if Assigned(FOnDblClick) then FOnDblClick(Self);
4167end;
4168
4169procedure TORComboBox.FwdKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
4170{ passed selected navigation keys to listbox, applies special handling to backspace and F4 }
4171var
4172 i,iPos: Integer;
4173 x,AString: string;
4174begin
4175 // special case: when default action taken (RETURN) make sure FwdChangeDelayed is called first
4176 if (Key = VK_RETURN) and FListBox.LongList and FChangePending then FwdChangeDelayed;
4177 StopKeyTimer; // stop timer after control keys so in case an exit event is triggered
4178 if Assigned(FOnKeyDown) then FOnKeyDown(Self, Key, Shift);
4179 if Key in [VK_PRIOR, VK_NEXT, VK_UP, VK_DOWN] then // navigation
4180 begin
4181 if (FStyle = orcsDropDown) and not DroppedDown then DroppedDown := True;
4182 // handle special case of FocusIndex, WM_KEYDOWN will increment from -1 to 0
4183 if FListBox.ItemIndex = -1 then
4184 begin
4185 FListBox.FFocusIndex := -1;
4186 //Move to correct position when Unique AutoComplete is on.
4187 if UniqueAutoComplete then
4188 begin
4189 AString := Copy(FEditBox.Text, 1, SelStart);
4190 iPos := SendMessage(FListBox.Handle, LB_FINDSTRING, -1, Longint(PChar(AString)));
4191 if iPos = LB_ERR then iPos := -1;
4192 if iPos > -1 then
4193 begin
4194 FListBox.FFocusIndex := iPos-1;
4195 FListBox.ItemIndex := FListBox.FFocusIndex;
4196 end;
4197 end;
4198 end;
4199 FListBox.Perform(WM_KEYDOWN, Key, 1);
4200 end;
4201 if Key in [VK_LBUTTON, VK_RETURN, VK_PRIOR, VK_NEXT, VK_UP, VK_DOWN] then // select item
4202 begin
4203 FListBox.Perform(WM_KEYDOWN, VK_LBUTTON, 1);
4204 FFromSelf := True;
4205 if FListBox.ItemIndex > -1 then
4206 begin
4207 FEditBox.Text := GetEditBoxText(FListBox.ItemIndex);
4208 FLastFound := FEditBox.Text; //kcm
4209 end;
4210 FFromSelf := False;
4211 end;
4212 // tell parent about RETURN, ESCAPE so that the default action is taken
4213 if Key in [VK_RETURN, VK_ESCAPE, VK_TAB] then SendMessage(Parent.Handle, CN_KEYDOWN, Key, 0);
4214 if Key = VK_BACK then // backspace
4215 begin
4216 FFromSelf := True;
4217 x := FEditBox.Text;
4218 i := FEditBox.SelStart;
4219 Delete(x, i + 1, Length(x));
4220 if(FListBox.FCheckBoxes) then
4221 FEditBox.Text := GetEditBoxText(ItemIndex)
4222 else
4223 FEditBox.Text := x;
4224 FLastFound := x;
4225 FEditBox.SelStart := i;
4226 FFromSelf := False;
4227 end;
4228 if (FStyle = orcsDropDown) and (Key = VK_F4) then DroppedDown := not DroppedDown; // drop
4229
4230 if (Key = VK_SPACE) and (FListBox.FCheckBoxes) and (FListBox.ItemIndex > -1) then
4231 FListBox.ToggleCheckBox(FListBox.ItemIndex);
4232
4233 if (FStyle = orcsDropDown) and (FListBox.FCheckBoxes) then
4234 begin
4235 if Key = VK_RETURN then DropPanelBtnPressed(TRUE, TRUE);
4236 if Key = VK_ESCAPE then DropPanelBtnPressed(FALSE, TRUE);
4237 end;
4238
4239 FKeyIsDown := True;
4240end;
4241
4242procedure TORComboBox.FwdKeyPress(Sender: TObject; var Key: Char);
4243var
4244 KeyCode: integer;
4245{ prevents return from being used by editbox (otherwise sends a newline & text vanishes) }
4246begin
4247 KeyCode := ord(Key);
4248 if (KeyCode = VK_RETURN) and (Style = orcsDropDown) and DroppedDown then
4249 begin
4250 DroppedDown := FALSE;
4251 Key := #0;
4252 end
4253 else
4254 begin
4255 // may want to make the tab beep if tab key (#9) - can't tab until list raised
4256 if (KeyCode = VK_RETURN) or (KeyCode = VK_TAB) or (FListBox.FCheckBoxes and (KeyCode = VK_SPACE)) then
4257 begin
4258 Key := #0;
4259 Exit;
4260 end;
4261 if Assigned(FOnKeyPress) then FOnKeyPress(Self, Key);
4262 end;
4263end;
4264
4265procedure TORComboBox.FwdKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
4266{ surfaces the key up event from the editbox so it is available as a combobox property }
4267begin
4268 FKeyIsDown := False;
4269 // tell parent about RETURN, ESCAPE so that the default action is taken
4270 if Key in [VK_RETURN, VK_ESCAPE, VK_TAB] then SendMessage(Parent.Handle, CN_KEYUP, Key, 0);
4271 if Assigned(FOnKeyUp) then FOnKeyUp(Self, Key, Shift);
4272 StartKeyTimer;
4273end;
4274
4275procedure TORComboBox.FwdMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState;
4276 X, Y: Integer);
4277begin
4278 if Assigned(FOnMouseClick) then FOnMouseClick(Self);
4279end;
4280
4281procedure TORComboBox.FwdNeedData(Sender: TObject; const StartFrom: string;
4282 Direction, InsertAt: Integer);
4283{ surfaces the need data event from the (long) listbox so it is available as a property }
4284begin
4285 if Assigned(FOnNeedData) then FOnNeedData(Self, copy(StartFrom, 1, MaxNeedDataLen), Direction, InsertAt);
4286end;
4287
4288procedure TORComboBox.SetDropDownCount(Value: Integer);
4289{ when the listbox is dropped, it's sized according to Value (ItemHeight * DropDownCount) }
4290begin
4291 if Value > 0 then FDropDownCount := Value;
4292end;
4293
4294procedure TORComboBox.SetDroppedDown(Value: Boolean);
4295{ for DropDown combo, display the listbox at the appropriate full screen coordinates }
4296const
4297 MIN_ITEMS = 3; // minimum visible items for long list
4298var
4299 ScreenPoint: TPoint;
4300 DropDownCnt: Integer;
4301 PnlHeight: integer;
4302begin
4303 if (Value = FDroppedDown) or (FStyle <> orcsDropDown) then Exit;
4304 FDroppedDown := Value;
4305 if FDroppedDown = True then
4306 begin
4307 if Assigned(FOnDropDown) then FOnDropDown(Self);
4308 if FListBox.LongList
4309 then DropDownCnt := HigherOf(FDropDownCount, MIN_ITEMS)
4310 else DropDownCnt := LowerOf(FDropDownCount, FListBox.Items.Count);
4311 FListBox.SetBounds(0, 0, Width, (FListBox.ItemHeight * DropDownCnt) + CBO_CXFRAME);
4312 // need to make this smart enough to drop the list UP when necessary ***
4313 ScreenPoint := Self.ClientToScreen(Point(0, EditControl.Height));
4314
4315 PnlHeight := FListBox.Height;
4316 if(FListBox.FCheckBoxes) then
4317 inc(PnlHeight, CheckComboBtnHeight);
4318 FDropPanel.SetBounds(ScreenPoint.X, ScreenPoint.Y, FListBox.Width, PnlHeight);
4319 if(FListBox.FCheckBoxes) then
4320 begin
4321 FDropPanel.ResetButtons;
4322 FCheckedState := FListBox.GetCheckedString;
4323 end;
4324 DropDownStatusChanged(TRUE);
4325 FDropPanel.Visible := True;
4326 FDropPanel.BringToFront;
4327 if FListBox.FScrollBar <> nil then FListBox.FScrollBar.BringToFront;
4328 if not FFromDropBtn then FListBox.MouseCapture := True; // otherwise ButtonUp captures
4329 end else
4330 begin
4331 if Assigned(FOnDropDownClose) then FOnDropDownClose(Self);
4332 FListBox.MouseCapture := False;
4333 uItemTip.Hide;
4334 FDropPanel.Hide;
4335 DropDownStatusChanged(FALSE);
4336 if(FListBox.FCheckBoxes) and (assigned(FOnChange)) and
4337 (FCheckedState <> FListBox.GetCheckedString) then
4338 FOnChange(Self);
4339 end;
4340end;
4341
4342procedure TORComboBox.SetEditRect;
4343{ change the edit rectangle to not hide the dropdown button - taken from SPIN.PAS sample }
4344var
4345 Loc: TRect;
4346begin
4347 SendMessage(FEditBox.Handle, EM_GETRECT, 0, LongInt(@Loc));
4348 Loc.Bottom := ClientHeight + 1; // +1 is workaround for windows paint bug
4349 if FStyle = orcsDropDown then
4350 begin
4351 Loc.Right := ClientWidth - FDropBtn.Width - CBO_CXFRAME; // edit up to button
4352 if(FTemplateField) then
4353 inc(Loc.Right,3);
4354 end
4355 else
4356 Loc.Right := ClientWidth - CBO_CXFRAME; // edit in full edit box
4357 Loc.Top := 0;
4358 if(FTemplateField) then
4359 Loc.Left := 2
4360 else
4361 Loc.Left := 0;
4362 SendMessage(FEditBox.Handle, EM_SETRECTNP, 0, LongInt(@Loc));
4363end;
4364
4365procedure TORComboBox.SetEditText(const Value: string);
4366{ allows the text to change when ItemIndex is changed without triggering a change event }
4367begin
4368 FFromSelf := True;
4369 FEditBox.Text := Value;
4370 FLastFound := FEditBox.Text;
4371 FFromSelf := False;
4372 PostMessage(FEditBox.Handle, EM_SETSEL, 0, Length(FEditBox.Text));
4373end;
4374
4375procedure TORComboBox.SetItemIndex(Value: Integer);
4376{ set the ItemIndex in the listbox and update the editbox to show the DisplayText }
4377begin
4378 with FListBox do
4379 begin
4380 ItemIndex := Value;
4381 { should Value = -1 be handled in the SetFocusIndex procedure itself? or should it be
4382 handled by the setting of the ItemIndex property? }
4383 if Value = -1 then FFocusIndex := -1 else FocusIndex := Value;
4384 uItemTip.Hide;
4385 if(FListBox.CheckBoxes) then
4386 SetEditText(GetEditBoxText(ItemIndex))
4387 else
4388 begin
4389 if ItemIndex > -1 then SetEditText(GetEditBoxText(ItemIndex)) else SetEditText('');
4390 end;
4391 end;
4392end;
4393
4394function TORComboBox.SelectByIEN(AnIEN: Int64): Integer;
4395begin
4396 Result := FListBox.SelectByIEN(AnIEN);
4397 SetItemIndex(Result);
4398end;
4399
4400function TORComboBox.SelectByID(const AnID: string): Integer;
4401begin
4402 Result := FListBox.SelectByID(AnID);
4403 SetItemIndex(Result);
4404end;
4405
4406function TORComboBox.SetExactByIEN(AnIEN: Int64; const AnItem: string): Integer;
4407begin
4408 Result := FListBox.SetExactByIEN(AnIEN, AnItem);
4409 SetItemIndex(Result);
4410end;
4411
4412procedure TORComboBox.SetStyle(Value: TORComboStyle);
4413{ Simple: get rid of dropdown button & panel, make combobox parent of listbox
4414 DropDown: create dropdown button & panel, transfer listbox parent to dropdown panel
4415 this allows the dropped list to overlap other windows }
4416begin
4417 if Value <> FStyle then
4418 begin
4419 FStyle := Value;
4420 if FStyle = orcsSimple then
4421 begin
4422 if FDropBtn <> nil then FDropBtn.Free;
4423 if FDropPanel <> nil then
4424 begin
4425 ClearDropDownStatus;
4426 FDropPanel.Free;
4427 end;
4428 FDropBtn := nil;
4429 FDropPanel := nil;
4430 FListBox.FParentCombo := nil;
4431 FListBox.Parent := Self;
4432 if FListBox.FScrollBar <> nil then FListBox.FScrollBar.Parent := Self; // if long
4433 FListBox.Visible := True;
4434 end else
4435 begin
4436 FDropBtn := TBitBtn.Create(Self);
4437 if(assigned(FEditPanel) and (csDesigning in ComponentState)) then
4438 FEditPanel.ControlStyle := FEditPanel.ControlStyle + [csAcceptsControls];
4439 FDropBtn.Parent := FEditBox;
4440 if(assigned(FEditPanel) and (csDesigning in ComponentState)) then
4441 FEditPanel.ControlStyle := FEditPanel.ControlStyle - [csAcceptsControls];
4442 LoadComboBoxImage;
4443// FDropBtn.Glyph.LoadFromResourceName(hInstance, ComboBoxImages[inherited Enabled]);
4444 FDropBtn.OnMouseDown := DropButtonDown;
4445 FDropBtn.OnMouseUp := DropButtonUp;
4446 FDropBtn.TabStop := False;
4447 FDropBtn.Visible := True;
4448 FDropBtn.BringToFront;
4449 if not (csDesigning in ComponentState) then
4450 begin
4451 FDropPanel := TORDropPanel.Create(Self);
4452 FDropPanel.Parent := Self; // parent is really the desktop - see CreateParams
4453 FListBox.FParentCombo := Self;
4454 FListBox.Parent := FDropPanel;
4455 ClearDropDownStatus;
4456 if FListBox.FScrollBar <> nil then FListBox.FScrollBar.Parent := FDropPanel; // if long
4457 end else
4458 begin
4459 FListBox.Visible := False;
4460 end;
4461 Height := EditControl.Height;
4462 end;
4463 AdjustSizeOfSelf;
4464 end;
4465end;
4466
4467procedure TORComboBox.StartKeyTimer;
4468{ start (or restart) a timer (done on keyup to delay before calling OnKeyPause) }
4469var
4470 ATimerID: Integer;
4471begin
4472 if FListBox.LongList or Assigned(FOnKeyPause) then
4473 begin
4474 StopKeyTimer;
4475 ATimerID := SetTimer(Handle, KEY_TIMER_ID, KEY_TIMER_DELAY, nil);
4476 FKeyTimerActive := ATimerID > 0;
4477 // if can't get a timer, just call the OnKeyPause event immediately
4478 if not FKeyTimerActive then Perform(WM_TIMER, KEY_TIMER_ID, 0);
4479 end;
4480end;
4481
4482procedure TORComboBox.StopKeyTimer;
4483{ stop the timer (done whenever a key is pressed or the combobox no longer has focus) }
4484begin
4485 if FKeyTimerActive then
4486 begin
4487 KillTimer(Handle, KEY_TIMER_ID);
4488 FKeyTimerActive := False;
4489 end;
4490end;
4491
4492function TORComboBox.SupportsDynamicProperty(PropertyID: integer): boolean;
4493begin
4494 Result := (PropertyID = DynaPropAccesibilityCaption);
4495end;
4496
4497// Since TORComboBox is composed of several controls (FEditBox, FListBox, FDropBtn), the
4498// following functions and procedures map public and published properties to their related
4499// subcomponents.
4500
4501function TORComboBox.AddReference(const S: string; AReference: Variant): Integer;
4502begin
4503 Result := FListBox.AddReference(S, AReference);
4504end;
4505
4506procedure TORComboBox.Clear;
4507begin
4508 FListBox.Clear;
4509 FEditBox.Clear;
4510end;
4511
4512procedure TORComboBox.ClearTop;
4513begin
4514 FListBox.ClearTop;
4515end;
4516
4517procedure TORComboBox.ForDataUse(Strings: TStrings);
4518begin
4519 FListBox.ForDataUse(Strings);
4520end;
4521
4522procedure TORComboBox.InitLongList(S: string);
4523begin
4524 FListBox.InitLongList(S);
4525end;
4526
4527function TORComboBox.IndexOfReference(AReference: Variant): Integer;
4528begin
4529 Result := FListBox.IndexOfReference(AReference);
4530end;
4531
4532procedure TORComboBox.InsertReference(Index: Integer; const S: string; AReference: Variant);
4533begin
4534 FListBox.InsertReference(Index, S, AReference);
4535end;
4536
4537procedure TORComboBox.InsertSeparator;
4538begin
4539 FListBox.InsertSeparator;
4540end;
4541
4542procedure TORComboBox.Invalidate;
4543begin
4544 inherited;
4545 FEditBox.Invalidate;
4546 FListBox.Invalidate;
4547 if assigned(FEditPanel) then
4548 FEditPanel.Invalidate;
4549 if assigned(FDropBtn) then
4550 FDropBtn.Invalidate;
4551 if assigned(FDropPanel) then
4552 FDropPanel.Invalidate;
4553end;
4554
4555function TORComboBox.GetAutoSelect: Boolean;
4556begin
4557 Result := FEditBox.AutoSelect;
4558end;
4559
4560function TORComboBox.GetColor: TColor;
4561begin
4562 Result := FListBox.Color;
4563end;
4564
4565function TORComboBox.GetDelimiter: Char;
4566begin
4567 Result := FListBox.Delimiter;
4568end;
4569
4570function TORComboBox.GetDisplayText(Index: Integer): string;
4571begin
4572 Result := FListBox.DisplayText[Index];
4573end;
4574
4575function TORComboBox.GetDynamicProperty(PropertyID: integer): string;
4576begin
4577 if PropertyID = DynaPropAccesibilityCaption then
4578 Result := GetCaption
4579 else
4580 Result := '';
4581end;
4582
4583function TORComboBox.GetItemHeight: Integer;
4584begin
4585 Result := FListBox.ItemHeight;
4586end;
4587
4588function TORComboBox.GetIEN(AnIndex: Integer): Int64;
4589begin
4590 Result := FListBox.GetIEN(AnIndex);
4591end;
4592
4593function TORComboBox.GetItemID: Variant;
4594begin
4595 Result := FListBox.ItemID;
4596end;
4597
4598function TORComboBox.GetItemIEN: Int64;
4599begin
4600 Result := FListBox.ItemIEN;
4601end;
4602
4603function TORComboBox.GetItemIndex: Integer;
4604begin
4605 Result := FListBox.ItemIndex;
4606end;
4607
4608function TORComboBox.GetItemTipEnable: Boolean;
4609begin
4610 Result := FListBox.ItemTipEnable;
4611end;
4612
4613function TORComboBox.GetItemTipColor: TColor;
4614begin
4615 Result := FListBox.ItemTipColor;
4616end;
4617
4618function TORComboBox.GetLongList: Boolean;
4619begin
4620 Result := FListBox.LongList;
4621end;
4622
4623function TORComboBox.GetMaxLength: Integer;
4624begin
4625 Result := FEditBox.MaxLength;
4626end;
4627
4628function TORComboBox.GetPieces: string;
4629begin
4630 Result := FListBox.Pieces;
4631end;
4632
4633function TORComboBox.GetReference(Index: Integer): Variant;
4634begin
4635 Result := FListBox.References[Index];
4636end;
4637
4638function TORComboBox.GetSelLength: Integer;
4639begin
4640 Result := FEditBox.SelLength;
4641end;
4642
4643function TORComboBox.GetSelStart: Integer;
4644begin
4645 Result := FEditBox.SelStart;
4646end;
4647
4648function TORComboBox.GetSelText: string;
4649begin
4650 Result := FEditBox.SelText;
4651end;
4652
4653function TORComboBox.GetShortCount: Integer;
4654begin
4655 Result := FListBox.ShortCount;
4656end;
4657
4658function TORComboBox.GetSorted: Boolean;
4659begin
4660 Result := FListBox.Sorted;
4661end;
4662
4663function TORComboBox.GetHideSynonyms: boolean;
4664begin
4665 Result := FListBox.HideSynonyms;
4666end;
4667
4668function TORComboBox.GetSynonymChars: string;
4669begin
4670 result := FListBox.SynonymChars;
4671end;
4672
4673procedure TORComboBox.SetHideSynonyms(Value: boolean);
4674begin
4675 FListBox.HideSynonyms := Value;
4676end;
4677
4678procedure TORComboBox.SetSynonymChars(Value: string);
4679begin
4680 FListBox.SynonymChars := Value;
4681end;
4682
4683function TORComboBox.GetTabPositions: string;
4684begin
4685 Result := FListBox.TabPositions;
4686end;
4687
4688function TORComboBox.GetTabPosInPixels: boolean;
4689begin
4690 Result := FListBox.TabPosInPixels;
4691end;
4692
4693function TORComboBox.GetText: string;
4694begin
4695 Result := FEditBox.Text;
4696end;
4697
4698procedure TORComboBox.SelectAll;
4699begin
4700 FEditBox.SelectAll;
4701end;
4702
4703procedure TORComboBox.SetAutoSelect(Value: Boolean);
4704begin
4705 FEditBox.AutoSelect := Value;
4706end;
4707
4708procedure TORComboBox.SetBlackColorMode(Value: boolean);
4709begin
4710 if FBlackColorMode <> Value then
4711 begin
4712 FBlackColorMode := Value;
4713 FListBox.SetBlackColorMode(Value);
4714 LoadComboBoxImage;
4715 end;
4716end;
4717
4718procedure TORComboBox.SetColor(Value: TColor);
4719begin
4720 if(not FListBox.CheckBoxes) then
4721 FEditBox.Color := Value;
4722 FListBox.Color := Value;
4723end;
4724
4725procedure TORComboBox.SetDelimiter(Value: Char);
4726begin
4727 FListBox.Delimiter := Value;
4728end;
4729
4730procedure TORComboBox.SetItemHeight(Value: Integer);
4731begin
4732 FListBox.ItemHeight := Value;
4733end;
4734
4735procedure TORComboBox.SetItemTipEnable(Value: Boolean);
4736begin
4737 FListBox.ItemTipEnable := Value;
4738end;
4739
4740procedure TORComboBox.SetItemTipColor(Value: TColor);
4741begin
4742 FListBox.ItemTipColor := Value;
4743end;
4744
4745procedure TORComboBox.SetLongList(Value: Boolean);
4746begin
4747 FListBox.LongList := Value;
4748end;
4749
4750procedure TORComboBox.SetMaxLength(Value: Integer);
4751begin
4752 FEditBox.MaxLength := Value;
4753end;
4754
4755procedure TORComboBox.SetPieces(const Value: string);
4756begin
4757 FListBox.Pieces := Value;
4758end;
4759
4760procedure TORComboBox.SetReference(Index: Integer; AReference: Variant);
4761begin
4762 FListBox.References[Index] := AReference;
4763end;
4764
4765procedure TORComboBox.SetSelLength(Value: Integer);
4766begin
4767 FEditBox.SelLength := Value;
4768end;
4769
4770procedure TORComboBox.SetSelStart(Value: Integer);
4771begin
4772 FEditBox.SelStart := Value;
4773end;
4774
4775procedure TORComboBox.SetSelText(const Value: string);
4776begin
4777 FEditBox.SelText := Value;
4778end;
4779
4780procedure TORComboBox.SetSorted(Value: Boolean);
4781begin
4782 FListBox.Sorted := Value;
4783end;
4784
4785procedure TORComboBox.SetTabPositions(const Value: string);
4786begin
4787 FListBox.TabPositions := Value;
4788end;
4789
4790procedure TORComboBox.SetTabPosInPixels(const Value: boolean);
4791begin
4792 FListBox.TabPosInPixels := Value;
4793end;
4794
4795procedure TORComboBox.SetText(const Value: string);
4796begin
4797 FEditBox.Text := Value; // kcm ???
4798end;
4799
4800procedure TORComboBox.SetItems(const Value: TStrings);
4801begin
4802 FItems.Assign(Value);
4803end;
4804
4805function TORComboBox.GetCheckBoxes: boolean;
4806begin
4807 Result := FListBox.FCheckBoxes;
4808end;
4809
4810function TORComboBox.GetChecked(Index: Integer): Boolean;
4811begin
4812 Result := FListBox.GetChecked(Index);
4813end;
4814
4815function TORComboBox.GetCheckEntireLine: boolean;
4816begin
4817 Result := FListBox.FCheckEntireLine;
4818end;
4819
4820function TORComboBox.GetFlatCheckBoxes: boolean;
4821begin
4822 Result := FListBox.FFlatCheckBoxes;
4823end;
4824
4825procedure TORComboBox.SetCheckBoxes(const Value: boolean);
4826begin
4827 if(FListBox.FCheckBoxes <> Value) then
4828 begin
4829 FListBox.SetCheckBoxes(Value);
4830 if(assigned(FDropPanel)) then
4831 FDropPanel.UpdateButtons;
4832 FEditBox.Visible := FALSE;
4833 try
4834 if(Value) then
4835 begin
4836 SetListItemsOnly(TRUE);
4837 SetAutoSelect(FALSE);
4838 FEditBox.Color := FCheckBoxEditColor;
4839 FEditBox.Text := GetEditBoxText(-1);
4840 FEditBox.BorderStyle := bsNone;
4841 FEditPanel := TORComboPanelEdit.Create(Self);
4842 FEditPanel.Parent := Self;
4843 FEditPanel.BevelOuter := bvRaised;
4844 FEditPanel.BorderWidth := 1;
4845 FEditBox.Parent := FEditPanel;
4846 if(csDesigning in ComponentState) then
4847 FEditPanel.ControlStyle := FEditPanel.ControlStyle - [csAcceptsControls];
4848 end
4849 else
4850 begin
4851 FEditBox.Parent := Self;
4852 FEditBox.Color := FListBox.Color;
4853 FEditBox.BorderStyle := bsSingle;
4854 FEditPanel.Free;
4855 FEditPanel := nil;
4856 end;
4857 finally
4858 FEditBox.Visible := TRUE;
4859 end;
4860 AdjustSizeOfSelf;
4861 end;
4862end;
4863
4864procedure TORComboBox.SetChecked(Index: Integer; const Value: Boolean);
4865begin
4866 FListBox.SetChecked(Index, Value);
4867 if(assigned(FDropPanel)) then
4868 FDropPanel.UpdateButtons;
4869 if(Value) then
4870 SetListItemsOnly(TRUE);
4871end;
4872
4873procedure TORComboBox.SetCheckEntireLine(const Value: boolean);
4874begin
4875 FListBox.FCheckEntireLine := Value;
4876end;
4877
4878procedure TORComboBox.SetFlatCheckBoxes(const Value: boolean);
4879begin
4880 FListBox.SetFlatCheckBoxes(Value);
4881end;
4882
4883procedure TORComboBox.DropPanelBtnPressed(OKBtn, AutoClose: boolean);
4884var
4885 btn: TSpeedButton;
4886
4887begin
4888 if(assigned(FDropPanel)) then
4889 begin
4890 btn := FDropPanel.GetButton(OKBtn);
4891 if(assigned(Btn)) then
4892 Btn.Down := TRUE;
4893 end;
4894 if(not OKBtn) then FListBox.SetCheckedString(FCheckedState);
4895 if(AutoClose) then
4896 begin
4897 FListBox.FDontClose := FALSE;
4898 DroppedDown := False;
4899 end;
4900 UpdateCheckEditBoxText;
4901end;
4902
4903function TORComboBox.GetCheckedString: string;
4904begin
4905 Result := FListBox.GetCheckedString;
4906end;
4907
4908procedure TORComboBox.SetCheckedString(const Value: string);
4909begin
4910 FListBox.SetCheckedString(Value);
4911end;
4912
4913procedure TORComboBox.SetCheckBoxEditColor(const Value: TColor);
4914begin
4915 if(FCheckBoxEditColor <> Value) then
4916 begin
4917 FCheckBoxEditColor := Value;
4918 if(FListBox.FCheckBoxes) then
4919 FEditBox.Color := FCheckBoxEditColor;
4920 end;
4921end;
4922
4923procedure TORComboBox.SetListItemsOnly(const Value: Boolean);
4924begin
4925 if(FListItemsOnly <> Value) then
4926 begin
4927 FListItemsOnly := Value;
4928 if(not Value) then
4929 SetCheckBoxes(FALSE);
4930 end;
4931end;
4932
4933procedure TORComboBox.SetOnCheckedText(const Value: TORCheckComboTextEvent);
4934begin
4935 FOnCheckedText := Value;
4936 FEditBox.Text := GetEditBoxText(-1);
4937end;
4938
4939procedure TORComboBox.SetTemplateField(const Value: boolean);
4940begin
4941 if(FTemplateField <> Value) then
4942 begin
4943 FTemplateField := Value;
4944 if(Value) then
4945 begin
4946 SetStyle(orcsDropDown);
4947 FEditBox.BorderStyle := bsNone
4948 end
4949 else
4950 FEditBox.BorderStyle := bsSingle;
4951 AdjustSizeOfSelf;
4952 end;
4953end;
4954
4955function TORComboBox.GetOnSynonymCheck: TORSynonymCheckEvent;
4956begin
4957 Result := FListBox.FOnSynonymCheck;
4958end;
4959
4960procedure TORComboBox.SetOnSynonymCheck(const Value: TORSynonymCheckEvent);
4961begin
4962 FListBox.FOnSynonymCheck := Value;
4963end;
4964
4965function TORComboBox.GetEnabled: boolean;
4966begin
4967 Result := inherited GetEnabled;
4968end;
4969
4970procedure TORComboBox.SetEnabled(Value: boolean);
4971begin
4972 if (inherited GetEnabled <> Value) then
4973 begin
4974 DroppedDown := FALSE;
4975 inherited SetEnabled(Value);
4976 if assigned(FDropBtn) then
4977 LoadComboBoxImage;
4978// FDropBtn.Glyph.LoadFromResourceName(hInstance, ComboBoxImages[Value]);
4979 end;
4980end;
4981
4982function TORComboBox.GetEditBoxText(Index: Integer): string;
4983var
4984 i, cnt: integer;
4985
4986begin
4987 if(FListBox.FCheckBoxes) then
4988 begin
4989 Result := '';
4990 cnt := 0;
4991 for i := 0 to FListBox.Items.Count-1 do
4992 begin
4993 if(FListBox.Checked[i]) then
4994 begin
4995 inc(cnt);
4996 if(Result <> '') then
4997 Result := Result + ', ';
4998 Result := Result + FListBox.GetDisplayText(i);
4999 end;
5000 end;
5001 if(assigned(FOnCheckedText)) then
5002 FOnCheckedText(FListBox, cnt, Result);
5003 end
5004 else
5005 Result := FListBox.GetDisplayText(Index);
5006end;
5007
5008procedure TORComboBox.UpdateCheckEditBoxText;
5009begin
5010 if(FListBox.FCheckBoxes) then
5011 begin
5012 FFromSelf := TRUE;
5013 FEditBox.Text := GetEditBoxText(-1);
5014 FEditBox.SelLength := 0;
5015 FFromSelf := FALSE;
5016 end;
5017end;
5018
5019procedure TORComboBox.CheckBoxSelected(Sender: TObject; Index: integer);
5020begin
5021 UpdateCheckEditBoxText;
5022 if(FStyle <> orcsDropDown) and (assigned(FOnChange)) then
5023 FOnChange(Self);
5024end;
5025
5026function TORComboBox.GetMItems: TStrings;
5027begin
5028 result := FMItems;
5029end;
5030
5031procedure TORComboBox.SetCaption(const Value: string);
5032begin
5033 FListBox.Caption := Value;
5034end;
5035
5036function TORComboBox.GetCaption: string;
5037begin
5038 result := FListBox.Caption;
5039end;
5040
5041function TORComboBox.GetCaseChanged: boolean;
5042begin
5043 result := FListBox.CaseChanged;
5044end;
5045
5046procedure TORComboBox.SetCaseChanged(const Value: boolean);
5047begin
5048 FListBox.CaseChanged := Value;
5049end;
5050
5051function TORComboBox.GetLookupPiece: integer;
5052begin
5053 result := FListBox.LookupPiece;
5054end;
5055
5056procedure TORComboBox.SetLookupPiece(const Value: integer);
5057begin
5058 FListBox.LookupPiece := Value;
5059end;
5060
5061{ TSizeRatio methods }
5062
5063constructor TSizeRatio.Create(ALeft, ATop, AWidth, AHeight: Extended);
5064{ creates an object that records the initial relative size & position of a control }
5065begin
5066 CLeft := ALeft; CTop := ATop; CWidth := AWidth; CHeight := AHeight;
5067end;
5068
5069{ TORAutoPanel ----------------------------------------------------------------------------- }
5070
5071destructor TORAutoPanel.Destroy;
5072{ destroy objects used to record size and position information for controls }
5073var
5074 SizeRatio: TSizeRatio;
5075 i: Integer;
5076begin
5077 if FSizes <> nil then with FSizes do for i := 0 to Count - 1 do
5078 begin
5079 SizeRatio := Items[i];
5080 SizeRatio.Free;
5081 end;
5082 FSizes.Free;
5083 inherited Destroy;
5084end;
5085
5086procedure TORAutoPanel.BuildSizes( Control: TWinControl);
5087var
5088 i,H,W: Integer;
5089 SizeRatio: TSizeRatio;
5090 Child: TControl;
5091begin
5092 H := ClientHeight;
5093 W := ClientWidth;
5094 if (H = 0) or (W = 0) then exit;
5095 for i := 0 to Control.ControlCount - 1 do
5096 begin
5097 Child := Control.Controls[i];
5098 with Child do
5099 SizeRatio := TSizeRatio.Create(Left/W, Top/H, Width/W, Height/H);
5100 FSizes.Add(SizeRatio); //FSizes is in tree traversal order.
5101 //TGroupBox is currently the only type of container that is having these
5102 //resize problems
5103 if Child is TGroupBox then
5104 BuildSizes(TWinControl(Child));
5105 end;
5106end;
5107
5108procedure TORAutoPanel.Loaded;
5109{ record initial size & position info for resizing logic }
5110begin
5111 inherited Loaded;
5112 if csDesigning in ComponentState then Exit; // only want auto-resizing at run time
5113 FSizes := TList.Create;
5114 BuildSizes(Self);
5115end;
5116
5117procedure TORAutoPanel.DoResize( Control: TWinControl; var CurrentIndex: Integer);
5118var
5119 i,H,W: Integer;
5120 SizeRatio: TSizeRatio;
5121 Child: TControl;
5122begin
5123 H := ClientHeight;
5124 W := ClientWidth;
5125 for i := 0 to Control.ControlCount - 1 do
5126 begin
5127 Child := Control.Controls[i];
5128 if CurrentIndex = FSizes.Count then break;
5129// raise Exception.Create('Error while Sizing Auto-Size Panel');
5130 SizeRatio := FSizes[CurrentIndex];
5131 inc(CurrentIndex);
5132 with SizeRatio do begin
5133 if (Child is TLabel) or (Child is TStaticText) then
5134 Child.SetBounds(Round(CLeft*W), Round(CTop*H), Child.Width, Child.Height)
5135 else
5136 Child.SetBounds(Round(CLeft*W), Round(CTop*H), Round(CWidth*W), Round(CHeight*H));
5137 end;
5138 if Child is TGroupBox then
5139 DoResize(TwinControl(Child), CurrentIndex);
5140 end;
5141end;
5142
5143procedure TORAutoPanel.Resize;
5144{ resize child controls using their design time proportions }
5145var
5146 i: Integer;
5147begin
5148 inherited Resize;
5149 if csDesigning in ComponentState then Exit; // only want auto-resizing at run time
5150 i := 0;
5151 DoResize( Self, i);
5152end;
5153
5154{ TOROffsetLabel --------------------------------------------------------------------------- }
5155
5156constructor TOROffsetLabel.Create(AOwner: TComponent);
5157{ create the label with the default of Transparent = False and Offset = 2}
5158begin
5159 inherited Create(AOwner);
5160 ControlStyle := ControlStyle + [csOpaque];
5161 FHorzOffset := 2;
5162 FVertOffset := 2;
5163end;
5164
5165procedure TOROffsetLabel.CMTextChanged(var Message: TMessage);
5166{ resize whenever the label caption changes }
5167begin
5168 inherited;
5169 AdjustSizeOfSelf;
5170end;
5171
5172procedure TOROffsetLabel.CMFontChanged(var Message: TMessage);
5173{ resize whenever the label font changes }
5174begin
5175 inherited;
5176 AdjustSizeOfSelf;
5177end;
5178
5179procedure TOROffsetLabel.AdjustSizeOfSelf;
5180{ using the current font, call DrawText to calculate the rectangle size for the label }
5181var
5182 DC: HDC;
5183 Flags: Word;
5184 ARect: TRect;
5185begin
5186 if not (csReading in ComponentState) then
5187 begin
5188 DC := GetDC(0);
5189 Canvas.Handle := DC;
5190 ARect := ClientRect;
5191 Flags := DT_EXPANDTABS or DT_CALCRECT;
5192 if FWordWrap then Flags := Flags or DT_WORDBREAK;
5193 DoDrawText(ARect, Flags); // returns size of text rect
5194 Canvas.Handle := 0;
5195 ReleaseDC(0, DC);
5196 // add alignment property later?
5197 SetBounds(Left, Top, ARect.Right + FHorzOffset, ARect.Bottom + FVertOffset); // add offsets
5198 end;
5199end;
5200
5201procedure TOROffsetLabel.DoDrawText(var Rect: TRect; Flags: Word);
5202{ call drawtext to paint or calculate the size of the text in the caption property }
5203var
5204 Text: string;
5205begin
5206 Text := Caption;
5207 Canvas.Font := Font;
5208 if not Enabled then Canvas.Font.Color := clGrayText;
5209 DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
5210end;
5211
5212procedure TOROffsetLabel.Paint;
5213{ set the background characterictics, add the offsets, and paint the text }
5214var
5215 ARect: TRect;
5216 Flags: Word;
5217begin
5218 with Canvas do
5219 begin
5220 if not Transparent then
5221 begin
5222 Brush.Color := Self.Color;
5223 Brush.Style := bsSolid;
5224 FillRect(ClientRect);
5225 end;
5226 Brush.Style := bsClear;
5227 ARect := ClientRect;
5228 Inc(ARect.Left, FHorzOffset);
5229 Inc(ARect.Top, FVertOffset);
5230 Flags := DT_EXPANDTABS or DT_NOPREFIX or DT_LEFT;
5231 if FWordWrap then Flags := Flags or DT_WORDBREAK;
5232 DoDrawText(ARect, Flags);
5233 end;
5234end;
5235
5236function TOROffsetLabel.GetTransparent: Boolean;
5237{ returns true if the control style is not opaque }
5238begin
5239 if csOpaque in ControlStyle then Result := False else Result := True;
5240end;
5241
5242procedure TOROffsetLabel.SetTransparent(Value: Boolean);
5243{ if true, removes Opaque from the control style }
5244begin
5245 if Value <> Transparent then
5246 begin
5247 if Value
5248 then ControlStyle := ControlStyle - [csOpaque] // transparent = true
5249 else ControlStyle := ControlStyle + [csOpaque]; // transparent = false
5250 Invalidate;
5251 end;
5252end;
5253
5254procedure TOROffsetLabel.SetVertOffset(Value: Integer);
5255{ adjusts the size of the label whenever the vertical offset of the label changes }
5256begin
5257 FVertOffset := Value;
5258 AdjustSizeOfSelf;
5259end;
5260
5261procedure TOROffsetLabel.SetHorzOffset(Value: Integer);
5262{ adjusts the size of the label whenever the horizontal offset of the label changes }
5263begin
5264 FHorzOffset := Value;
5265 AdjustSizeOfSelf;
5266end;
5267
5268procedure TOROffsetLabel.SetWordWrap(Value: Boolean);
5269{ adjusts the size of the label whenever the word wrap property changes }
5270begin
5271 if FWordWrap <> Value then
5272 begin
5273 FWordWrap := Value;
5274 AdjustSizeOfSelf;
5275 end;
5276end;
5277
5278(*
5279{ TORCalendar }
5280
5281procedure TORCalendar.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);
5282{ uses the Calendar that is part of Samples and highlights the current date }
5283var
5284 TheText: string;
5285 CurMonth, CurYear, CurDay: Word;
5286begin
5287 TheText := CellText[ACol, ARow];
5288 with ARect, Canvas do
5289 begin
5290 DecodeDate(Date, CurYear, CurMonth, CurDay);
5291 if (CurYear = Year) and (CurMonth = Month) and (IntToStr(CurDay) = TheText) then
5292 begin
5293 TheText := '[' + TheText + ']';
5294 Font.Style := [fsBold];
5295 end;
5296 TextRect(ARect, Left + (Right - Left - TextWidth(TheText)) div 2,
5297 Top + (Bottom - Top - TextHeight(TheText)) div 2, TheText);
5298 end;
5299end;
5300*)
5301
5302{ TORAlignButton }
5303
5304constructor TORAlignButton.Create(AOwner: TComponent);
5305begin
5306 inherited;
5307 FAlignment := taCenter;
5308 FLayout := tlCenter;
5309 FWordWrap := FALSE;
5310end;
5311
5312procedure TORAlignButton.CreateParams(var Params: TCreateParams);
5313const
5314 ButtonAlignment: array[TAlignment] of DWORD = (BS_LEFT, BS_RIGHT, BS_CENTER);
5315 ButtonWordWrap: array[boolean] of DWORD = (0, BS_MULTILINE);
5316 ButtonLayout: array[TTextLayout] of DWORD = (BS_TOP, BS_VCENTER, BS_BOTTOM);
5317begin
5318 inherited CreateParams(Params);
5319 Params.Style := Params.Style or ButtonAlignment[FAlignment] or
5320 ButtonLayout[FLayout] or
5321 ButtonWordWrap[FWordWrap];
5322end;
5323
5324procedure TORAlignButton.SetAlignment(const Value: TAlignment);
5325begin
5326 if(FAlignment <> Value) then
5327 begin
5328 FAlignment := Value;
5329 RecreateWnd;
5330 end;
5331end;
5332
5333procedure TORAlignButton.SetLayout(const Value: TTextLayout);
5334begin
5335 if(FLayout <> Value) then
5336 begin
5337 FLayout := Value;
5338 RecreateWnd;
5339 end;
5340end;
5341
5342procedure TORAlignButton.SetWordWrap(const Value: boolean);
5343begin
5344 if(FWordWrap <> Value) then
5345 begin
5346 FWordWrap := Value;
5347 RecreateWnd;
5348 end;
5349end;
5350
5351{ TORTreeNode }
5352
5353procedure TORTreeNode.EnsureVisible;
5354var
5355 R: TRect;
5356 DY, LH: integer;
5357
5358begin
5359 MakeVisible;
5360 R := DisplayRect(FALSE);
5361 if(R.Top < 0) then
5362 TreeView.TopItem := Self
5363 else
5364 if(R.Bottom > TreeView.ClientHeight) then
5365 begin
5366 DY := R.Bottom - TreeView.ClientHeight;
5367 LH := R.Bottom - R.Top + 1;
5368 DY := (DY div LH) + 1;
5369 GetORTreeView.SetVertScrollPos(GetORTreeView.GetVertScrollPos + DY);
5370 end;
5371end;
5372
5373function TORTreeNode.GetBold: boolean;
5374var
5375 Item: TTVItem;
5376begin
5377 Result := False;
5378 with Item do
5379 begin
5380 mask := TVIF_STATE;
5381 hItem := ItemId;
5382 if TreeView_GetItem(Handle, Item) then
5383 Result := (state and TVIS_BOLD) <> 0;
5384 end;
5385end;
5386
5387function TORTreeNode.GetORTreeView: TORTreeView;
5388begin
5389 Result := ((inherited TreeView) as TORTreeView);
5390end;
5391
5392function TORTreeNode.GetParent: TORTreeNode;
5393begin
5394 Result := ((inherited Parent) as TORTreeNode);
5395end;
5396
5397function TORTreeNode.GetText: string;
5398begin
5399 Result := Inherited Text;
5400end;
5401
5402procedure TORTreeNode.SetBold(const Value: boolean);
5403var
5404 Item: TTVItem;
5405 Template: DWORD;
5406
5407begin
5408 if Value then Template := DWORD(-1)
5409 else Template := 0;
5410 with Item do
5411 begin
5412 mask := TVIF_STATE;
5413 hItem := ItemId;
5414 stateMask := TVIS_BOLD;
5415 state := stateMask and Template;
5416 end;
5417 TreeView_SetItem(Handle, Item);
5418end;
5419
5420procedure TORTreeNode.SetPiece(PieceNum: Integer; const NewPiece: string);
5421begin
5422 with GetORTreeView do
5423 begin
5424 ORCtrls.SetPiece(FStringData, FDelim, PieceNum, NewPiece);
5425 if(PieceNum = FPiece) then
5426 Text := NewPiece;
5427 end;
5428end;
5429
5430procedure TORTreeNode.SetStringData(const Value: string);
5431begin
5432 if(FStringData <> Value) then
5433 begin
5434 FStringData := Value;
5435 with GetORTreeView do
5436 if (FDelim <> #0) and (FPiece > 0) then
5437 inherited Text := Piece(FStringData, FDelim, FPiece);
5438 end;
5439 Caption := Text;
5440end;
5441
5442procedure TORTreeNode.SetText(const Value: string);
5443begin
5444 UpdateText(Value, TRUE);
5445end;
5446
5447procedure TORTreeNode.UpdateText(const Value: string; UpdateData: boolean);
5448begin
5449 Inherited Text := Value;
5450 Caption := Text;
5451 if(UpdateData) then
5452 with GetORTreeView do
5453 begin
5454 if (FDelim <> #0) and (FPiece > 0) then
5455 ORCtrls.SetPiece(FStringData, FDelim, FPiece, Value);
5456 end;
5457end;
5458
5459function CalcShortName( LongName: string; PrevLongName: string): string;
5460var
5461 WordBorder: integer;
5462 j: integer;
5463begin
5464 WordBorder := 1;
5465 for j := 1 to Length(LongName) do
5466 begin
5467 if (LongName[j] = ' ') or ((j > 1) and (LongName[j-1] = ' ')) or
5468 ((j = Length(LongName)) and (j = Length(PrevLongName)) and (LongName[j] = PrevLongName[j])) then
5469 WordBorder := j;
5470 if (j > Length(PrevLongName)) or (LongName[j] <> PrevLongName[j]) then
5471 break;
5472 end;
5473 if WordBorder = 1 then
5474 result := LongName
5475 else if WordBorder = Length(LongName) then
5476 result := 'Same as above ('+LongName+')'
5477 else
5478 result := Copy(LongName,WordBorder,Length(LongName)) + ' ('+Trim(Copy(LongName,1,WordBorder -1)) + ')';
5479end;
5480
5481procedure TORTreeNode.SetCaption(const Value: string);
5482var
5483 TheCaption: string;
5484begin
5485 TheCaption := Value;
5486 with GetORTreeView do
5487 begin
5488 if assigned(OnNodeCaptioning) then
5489 OnNodeCaptioning(self, TheCaption);
5490 if ShortNodeCaptions and (Self.GetPrevSibling <> nil) then
5491 TheCaption := CalcShortName( TheCaption, Self.GetPrevSibling.Text);
5492 end;
5493 FCaption := TheCaption;
5494end;
5495
5496{ TORTreeView }
5497
5498procedure TORTreeView.CNNotify(var Message: TWMNotify);
5499var
5500 DNode: TTreeNode;
5501 DoInh: boolean;
5502
5503begin
5504 DoInh := TRUE;
5505 if(assigned(FOnDragging)) then
5506 begin
5507 with Message do
5508 begin
5509 case NMHdr^.code of
5510 TVN_BEGINDRAG:
5511 begin
5512 with PNMTreeView(Message.NMHdr)^.ItemNew do
5513 begin
5514 if (state and TVIF_PARAM) <> 0 then DNode := Pointer(lParam)
5515 else DNode := Items.GetNode(hItem);
5516 end;
5517 FOnDragging(Self, DNode, DoInh);
5518 if(not DoInh) then
5519 begin
5520 Message.Result := 1;
5521 Selected := DNode;
5522 end;
5523 end;
5524 end;
5525 end;
5526 end;
5527 if(DoInh) then inherited;
5528end;
5529
5530constructor TORTreeView.Create(AOwner: TComponent);
5531begin
5532 inherited;
5533 FDelim := '^';
5534end;
5535
5536function TORTreeView.CreateNode: TTreeNode;
5537begin
5538 Result := TORTreeNode.Create(Items);
5539 if Assigned( OnAddition ) then
5540 OnAddition(self, Result);
5541end;
5542
5543function TORTreeView.FindPieceNode(Value: string;
5544 ParentDelim: Char = #0; StartNode: TTreeNode = nil): TORTreeNode;
5545begin
5546 Result := FindPieceNode(Value, FPiece, ParentDelim, StartNode);
5547end;
5548
5549function TORTreeView.FindPieceNode(Value: string; APiece: integer;
5550 ParentDelim: Char = #0; StartNode: TTreeNode = nil): TORTreeNode;
5551var
5552 StartIdx, i: integer;
5553 Node: TORTreeNode;
5554
5555begin
5556 if assigned(StartNode) then
5557 StartIdx := StartNode.AbsoluteIndex+1
5558 else
5559 StartIdx := 0;
5560 Result := nil;
5561 for i := StartIdx to Items.Count-1 do
5562 begin
5563 Node := (Items[i] as TORTreeNode);
5564 if(GetNodeID(Node, APiece, ParentDelim) = Value) then
5565 begin
5566 Result := Node;
5567 break;
5568 end;
5569 end;
5570end;
5571
5572function TORTreeView.GetExpandedIDStr(APiece: integer; ParentDelim: char = #0): string;
5573var
5574 i: integer;
5575
5576begin
5577 Result := '';
5578 for i := 0 to Items.Count-1 do
5579 begin
5580 with (Items[i] as TORTreeNode) do
5581 begin
5582 if(Expanded) then
5583 begin
5584 if(Result <> '') then
5585 Result := Result + FDelim;
5586 Result := Result + GetNodeID(TORTreeNode(Items[i]), APiece, ParentDelim);
5587 end;
5588 end;
5589 end;
5590end;
5591
5592procedure TORTreeView.SetExpandedIDStr(APiece: integer; const Value: string);
5593begin
5594 SetExpandedIDStr(APiece, #0, Value);
5595end;
5596
5597procedure TORTreeView.SetExpandedIDStr(APiece: integer; ParentDelim: char;
5598 const Value: string);
5599var
5600 i: integer;
5601 Top, Sel: TTreeNode;
5602 Node: TORTreeNode;
5603 NList: string;
5604 Srch: string;
5605
5606begin
5607 Items.BeginUpdate;
5608 try
5609 Top := TopItem;
5610 Sel := Selected;
5611 FullCollapse;
5612 Selected := Sel;
5613 NList := Value;
5614 repeat
5615 i := pos(FDelim, NList);
5616 if(i = 0) then i := length(NList)+1;
5617 Srch := copy(NList,1,i-1);
5618 Node := FindPieceNode(Srch, APiece, ParentDelim);
5619 if(assigned(Node)) then
5620 Node.Expand(FALSE);
5621 Nlist := copy(NList,i+1,MaxInt);
5622 until(NList = '');
5623 TopItem := Top;
5624 Selected := Sel;
5625 finally
5626 Items.EndUpdate;
5627 end;
5628end;
5629
5630function TORTreeView.GetHorzScrollPos: integer;
5631begin
5632 Result := GetScrollPos(Handle, SB_HORZ);
5633end;
5634
5635function TORTreeView.GetVertScrollPos: integer;
5636begin
5637 Result := GetScrollPos(Handle, SB_VERT);
5638end;
5639
5640procedure TORTreeView.RenameNodes;
5641var
5642 i:integer;
5643
5644begin
5645 if(FDelim <> #0) and (FPiece > 0) then
5646 begin
5647 for i := 0 to Items.Count-1 do
5648 with (Items[i] as TORTreeNode) do
5649 UpdateText(Piece(FStringData, FDelim, FPiece), FALSE);
5650 end;
5651end;
5652
5653procedure TORTreeView.SetNodeDelim(const Value: Char);
5654begin
5655 if(FDelim <> Value) then
5656 begin
5657 FDelim := Value;
5658 RenameNodes;
5659 end;
5660end;
5661
5662procedure TORTreeView.SetHorzScrollPos(Value: integer);
5663begin
5664 if(Value < 0) then Value := 0;
5665 Perform(WM_HSCROLL,MakeWParam(SB_THUMBPOSITION, Value),0);
5666end;
5667
5668procedure TORTreeView.SetNodePiece(const Value: integer);
5669begin
5670 if(FPiece <> Value) then
5671 begin
5672 FPiece := Value;
5673 RenameNodes;
5674 end;
5675end;
5676
5677procedure TORTreeView.SetVertScrollPos(Value: integer);
5678begin
5679 if(Value < 0) then Value := 0;
5680 Perform(WM_VSCROLL,MakeWParam(SB_THUMBPOSITION, Value),0);
5681end;
5682
5683function TORTreeView.GetNodeID(Node: TORTreeNode;
5684 ParentDelim: Char): string;
5685begin
5686 Result := GetNodeID(Node, FPiece, ParentDelim);
5687end;
5688
5689function TORTreeView.GetNodeID(Node: TORTreeNode; APiece: integer;
5690 ParentDelim: Char): string;
5691begin
5692 if(assigned(Node)) then
5693 begin
5694 Result := Piece(Node.FStringData, FDelim, APiece);
5695 if((ParentDelim <> #0) and (ParentDelim <> FDelim) and (assigned(Node.Parent))) then
5696 Result := Result + ParentDelim + GetNodeID(Node.Parent, APiece, ParentDelim);
5697 end
5698 else
5699 Result := '';
5700end;
5701
5702procedure TORTreeView.SetShortNodeCaptions(const Value: boolean);
5703begin
5704 FShortNodeCaptions := Value;
5705 RenameNodes;
5706end;
5707
5708{ TORCBImageIndexes }
5709
5710constructor TORCBImageIndexes.Create(AOwner: TComponent);
5711begin
5712 inherited;
5713 FCheckedEnabledIndex := -1;
5714 FCheckedDisabledIndex := -1;
5715 FGrayedEnabledIndex := -1;
5716 FGrayedDisabledIndex := -1;
5717 FUncheckedEnabledIndex := -1;
5718 FUncheckedDisabledIndex := -1;
5719 FImageChangeLink := TChangeLink.Create;
5720 FImageChangeLink.OnChange := ImageListChanged;
5721end;
5722
5723destructor TORCBImageIndexes.Destroy;
5724begin
5725 FImageChangeLink.Free;
5726 inherited;
5727end;
5728
5729procedure TORCBImageIndexes.SetImages(const Value: TCustomImageList);
5730begin
5731 if FImages <> nil then FImages.UnRegisterChanges(FImageChangeLink);
5732 FImages := Value;
5733 if FImages <> nil then
5734 begin
5735 FImages.RegisterChanges(FImageChangeLink);
5736 FImages.FreeNotification(Self);
5737 end;
5738 ImageListChanged(Self);
5739end;
5740
5741function TORCBImageIndexes.IdxString: string;
5742 function RStr(Value: integer): string;
5743 begin
5744 if(Value <> -1) then
5745 Result := IntToStr(Value)
5746 else
5747 Result := '';
5748 Result := Result + ',';
5749 end;
5750
5751begin
5752 Result := RStr(FCheckedEnabledIndex) +
5753 RStr(FGrayedEnabledIndex) +
5754 RStr(FUncheckedEnabledIndex) +
5755 RStr(FCheckedDisabledIndex) +
5756 RStr(FGrayedDisabledIndex) +
5757 RStr(FUncheckedDisabledIndex);
5758 delete(Result,length(Result),1);
5759 if(Result = ',,,,,') then Result := '';
5760end;
5761
5762procedure TORCBImageIndexes.SetIdxString(Value: string);
5763var
5764 i,j,v: integer;
5765 Sub: String;
5766
5767begin
5768 if(Value = '') then
5769 begin
5770 FCheckedEnabledIndex := -1;
5771 FGrayedEnabledIndex := -1;
5772 FUncheckedEnabledIndex := -1;
5773 FCheckedDisabledIndex := -1;
5774 FGrayedDisabledIndex := -1;
5775 FUncheckedDisabledIndex := -1;
5776 end
5777 else
5778 begin
5779 i := 0;
5780 Sub := Value;
5781 repeat
5782 j := pos(',',Sub);
5783 if(j = 0) then j := length(Sub)+1;
5784 v := StrToIntDef(copy(Sub,1,j-1),-1);
5785 case i of
5786 0: FCheckedEnabledIndex := v;
5787 1: FGrayedEnabledIndex := v;
5788 2: FUncheckedEnabledIndex := v;
5789 3: FCheckedDisabledIndex := v;
5790 4: FGrayedDisabledIndex := v;
5791 5: FUncheckedDisabledIndex := v;
5792 end;
5793 inc(i);
5794 Sub := copy(Sub,j+1,MaxInt);
5795 until(Sub = '');
5796 end;
5797end;
5798
5799procedure TORCBImageIndexes.ImageListChanged(Sender: TObject);
5800begin
5801 if(Owner is TWinControl) then
5802 (Owner as TWinControl).Invalidate;
5803end;
5804
5805procedure TORCBImageIndexes.Notification(AComponent: TComponent; Operation: TOperation);
5806begin
5807 inherited Notification(AComponent, Operation);
5808 if (AComponent = FImages) and (Operation = opRemove) then SetImages(nil);
5809end;
5810
5811procedure TORCBImageIndexes.SetCheckedDisabledIndex(const Value: integer);
5812begin
5813 if(FCheckedDisabledIndex <> Value) then
5814 begin
5815 FCheckedDisabledIndex := Value;
5816 ImageListChanged(Self);
5817 end;
5818end;
5819
5820procedure TORCBImageIndexes.SetCheckedEnabledIndex(const Value: integer);
5821begin
5822 if(FCheckedEnabledIndex <> Value) then
5823 begin
5824 FCheckedEnabledIndex := Value;
5825 ImageListChanged(Self);
5826 end;
5827end;
5828
5829procedure TORCBImageIndexes.SetGrayedDisabledIndex(const Value: integer);
5830begin
5831 if(FGrayedDisabledIndex <> Value) then
5832 begin
5833 FGrayedDisabledIndex := Value;
5834 ImageListChanged(Self);
5835 end;
5836end;
5837
5838procedure TORCBImageIndexes.SetGrayedEnabledIndex(const Value: integer);
5839begin
5840 if(FGrayedEnabledIndex <> Value) then
5841 begin
5842 FGrayedEnabledIndex := Value;
5843 ImageListChanged(Self);
5844 end;
5845end;
5846
5847procedure TORCBImageIndexes.SetUncheckedDisabledIndex(const Value: integer);
5848begin
5849 if(FUncheckedDisabledIndex <> Value) then
5850 begin
5851 FUncheckedDisabledIndex := Value;
5852 ImageListChanged(Self);
5853 end;
5854end;
5855
5856procedure TORCBImageIndexes.SetUncheckedEnabledIndex(const Value: integer);
5857begin
5858 if(FUncheckedEnabledIndex <> Value) then
5859 begin
5860 FUncheckedEnabledIndex := Value;
5861 ImageListChanged(Self);
5862 end;
5863end;
5864
5865{ TORCheckBox }
5866
5867constructor TORCheckBox.Create(AOwner: TComponent);
5868begin
5869 CreateCommon(AOwner);
5870 FCustomImages := TORCBImageIndexes.Create(Self);
5871 FCustomImagesOwned := TRUE;
5872 FAllowAllUnchecked := TRUE;
5873end;
5874
5875constructor TORCheckBox.ListViewCreate(AOwner: TComponent; ACustomImages: TORCBImageIndexes);
5876begin
5877 CreateCommon(AOwner);
5878 FCustomImages := ACustomImages;
5879 FCustomImagesOwned := FALSE;
5880end;
5881
5882procedure TORCheckBox.CreateCommon(AOwner: TComponent);
5883begin
5884 inherited Create(AOwner);
5885 FGrayedToChecked := TRUE;
5886 FCanvas := TCanvas.Create;
5887end;
5888
5889destructor TORCheckBox.Destroy;
5890begin
5891 if(FCustomImagesOwned) then FCustomImages.Free;
5892 FCanvas.Free;
5893 inherited;
5894end;
5895
5896
5897function TORCheckBox.GetImageIndexes: string;
5898begin
5899 Result := FCustomImages.IdxString;
5900end;
5901
5902function TORCheckBox.GetImageList: TCustomImageList;
5903begin
5904 Result := FCustomImages.FImages;
5905end;
5906
5907procedure TORCheckBox.SetImageIndexes(const Value: string);
5908begin
5909 FCustomImages.SetIdxString(Value);
5910end;
5911
5912procedure TORCheckBox.SetImageList(const Value: TCustomImageList);
5913begin
5914 FCustomImages.SetImages(Value);
5915end;
5916
5917procedure TORCheckBox.Toggle;
5918begin
5919 if(FGrayedToChecked) then
5920 begin
5921 case State of
5922 cbUnchecked:
5923 if AllowGrayed then State := cbGrayed else State := cbChecked;
5924 cbChecked: State := cbUnchecked;
5925 cbGrayed: State := cbChecked;
5926 end;
5927 end
5928 else
5929 begin
5930 case State of
5931 cbUnchecked: State := cbChecked;
5932 cbChecked: if AllowGrayed then State := cbGrayed else State := cbUnchecked;
5933 cbGrayed: State := cbUnchecked;
5934 end;
5935 end;
5936end;
5937
5938procedure TORCheckBox.CreateParams(var Params: TCreateParams);
5939begin
5940 inherited CreateParams(Params);
5941 Params.Style := (Params.Style and (not BS_3STATE)) or BS_OWNERDRAW;
5942end;
5943
5944procedure TORCheckBox.CMEnabledChanged(var Message: TMessage);
5945begin
5946 inherited;
5947 Invalidate;
5948end;
5949
5950procedure TORCheckBox.CMFontChanged(var Message: TMessage);
5951begin
5952 inherited;
5953 Invalidate;
5954end;
5955
5956procedure TORCheckBox.CNDrawItem(var Message: TWMDrawItem);
5957begin
5958 DrawItem(Message.DrawItemStruct^);
5959end;
5960
5961procedure TORCheckBox.CNMeasureItem(var Message: TWMMeasureItem);
5962begin
5963 with Message.MeasureItemStruct^ do
5964 begin
5965 itemWidth := Width;
5966 itemHeight := Height;
5967 end;
5968end;
5969
5970procedure TORCheckBox.GetDrawData(CanvasHandle: HDC; var Bitmap: TBitmap;
5971 var FocRect, Rect: TRect;
5972 var DrawOptions: UINT;
5973 var TempBitMap: boolean);
5974var
5975 i, l, TxtHeight, TxtWidth, AWidth: Integer;
5976 ImgIdx: TORCBImgIdx;
5977 CustomImgIdx: integer;
5978
5979begin
5980 BitMap := nil;
5981 TempBitMap := FALSE;
5982 DrawOptions := DT_LEFT;
5983 FSingleLine := TRUE;
5984
5985 if(not (csDestroying in ComponentState)) then
5986 begin
5987 with FCustomImages do
5988 begin
5989 FCanvas.Handle := CanvasHandle;
5990 try
5991 Rect := ClientRect;
5992 with FCanvas do
5993 begin
5994 CustomImgIdx := -1;
5995 if(assigned(FImages)) then
5996 begin
5997 if(Enabled or (csDesigning in ComponentState)) then
5998 begin
5999 case State of
6000 cbChecked: CustomImgIdx := FCheckedEnabledIndex;
6001 cbUnChecked: CustomImgIdx := FUncheckedEnabledIndex;
6002 cbGrayed: CustomImgIdx := FGrayedEnabledIndex;
6003 end;
6004 end
6005 else
6006 begin
6007 case State of
6008 cbChecked: CustomImgIdx := FCheckedDisabledIndex;
6009 cbUnChecked: CustomImgIdx := FUncheckedDisabledIndex;
6010 cbGrayed: CustomImgIdx := FGrayedDisabledIndex;
6011 end;
6012 end;
6013 if((CustomImgIdx < 0) or (CustomImgIdx >= FImages.Count)) then
6014 CustomImgIdx := -1;
6015 end;
6016 if(CustomImgIdx < 0) then
6017 begin
6018 ImgIdx := iiChecked;
6019 if(Enabled or (csDesigning in ComponentState)) then
6020 begin
6021 if(FRadioStyle) then
6022 begin
6023 if State = cbChecked then
6024 ImgIdx := iiRadioChecked
6025 else
6026 ImgIdx := iiRadioUnchecked;
6027 end
6028 else
6029 begin
6030 case State of
6031 cbChecked: ImgIdx := iiChecked;
6032 cbUnChecked: ImgIdx := iiUnchecked;
6033 cbGrayed:
6034 begin
6035 case FGrayedStyle of
6036 gsNormal: ImgIdx := iiGrayed;
6037 gsQuestionMark: ImgIdx := iiQMark;
6038 gsBlueQuestionMark: ImgIdx := iiBlueQMark;
6039 end;
6040 end;
6041 end;
6042 end;
6043 end
6044 else
6045 begin
6046 if(FRadioStyle) then
6047 begin
6048 if State = cbChecked then
6049 ImgIdx := iiRadioDisChecked
6050 else
6051 ImgIdx := iiRadioDisUnchecked;
6052 end
6053 else
6054 begin
6055 case State of
6056 cbChecked: ImgIdx := iiDisChecked;
6057 cbUnChecked: ImgIdx := iiDisUnchecked;
6058 cbGrayed:
6059 begin
6060 if(FGrayedStyle = gsNormal) then
6061 ImgIdx := iiDisGrayed
6062 else
6063 ImgIdx := iiDisQMark;
6064 end;
6065 end;
6066 end;
6067 end;
6068 Bitmap := GetORCBBitmap(ImgIdx, FBlackColorMode);
6069 end
6070 else
6071 begin
6072 Bitmap := TBitmap.Create;
6073 FImages.GetBitmap(CustomImgIdx, Bitmap);
6074 TempBitMap := TRUE;
6075 end;
6076 Brush.Style := bsClear;
6077 Font := Self.Font;
6078
6079 if Alignment = taLeftJustify then
6080 Rect.Left := 2
6081 else
6082 Rect.Left := Bitmap.Width + 5;
6083
6084 if(FWordWrap) then
6085 DrawOptions := DrawOptions or DT_WORDBREAK
6086 else
6087 DrawOptions := DrawOptions or DT_VCENTER or DT_SINGLELINE;
6088
6089 if(FWordWrap) then
6090 begin
6091 if Alignment = taLeftJustify then
6092 Rect.Right := Width - Bitmap.Width - 3
6093 else
6094 Rect.Right := Width;
6095 Rect.Top := 1;
6096 Rect.Bottom := Height+1;
6097 dec(Rect.Right);
6098 FocRect := Rect;
6099 TxtHeight := DrawText(Handle, PChar(Caption), Length(Caption), FocRect,
6100 DrawOptions or DT_CALCRECT);
6101 FSingleLine := (TxtHeight = TextHeight(Caption));
6102 Rect.Bottom := Rect.Top + TxtHeight + 1;
6103 FocRect := Rect;
6104 end
6105 else
6106 begin
6107 TxtWidth := TextWidth(Caption);
6108 //Get rid of ampersands that turn into underlines
6109 i := 0;
6110 l := length(Caption);
6111 AWidth := TextWidth('&');
6112 while(i < l) do
6113 begin
6114 inc(i);
6115 // '&&' is an escape char that should display one '&' wide.
6116 // This next part preserves the first '&' but drops all the others
6117 if (Copy(Caption,i,2)<>'&&') and (Copy(Caption,i,1)='&') then
6118 dec(TxtWidth,AWidth);
6119 end;
6120 Rect.Right := Rect.Left + TxtWidth;
6121 TxtHeight := TextHeight(Caption);
6122 if(TxtHeight < Bitmap.Height) then
6123 TxtHeight := Bitmap.Height;
6124 Rect.Top := ((((ClientHeight - TxtHeight) * 5) - 5) div 10);
6125 Rect.Bottom := Rect.Top + TxtHeight + 1;
6126 IntersectRect(FocRect, Rect, ClientRect);
6127 end;
6128 end;
6129 finally
6130 FCanvas.Handle := 0;
6131 end;
6132 end;
6133 end;
6134end;
6135
6136procedure TORCheckBox.DrawItem(const DrawItemStruct: TDrawItemStruct);
6137var
6138 R, FocusRect, TempRect: TRect;
6139 Bitmap: TBitmap;
6140 OldColor: TColor;
6141 DrawOptions: UINT;
6142 TempBitMap: boolean;
6143
6144begin
6145 if(not (csDestroying in ComponentState)) then
6146 begin
6147 GetDrawData(DrawItemStruct.hDC, Bitmap, FocusRect, R, DrawOptions, TempBitMap);
6148 try
6149 FCanvas.Handle := DrawItemStruct.hDC;
6150 try
6151 with FCanvas do
6152 begin
6153 Brush.Color := Self.Color;
6154 Brush.Style := bsSolid;
6155 InflateRect(R, 1, 1);
6156 FillRect(R);
6157 InflateRect(R, -1, -1);
6158
6159 Brush.Style := bsClear;
6160 Font := Self.Font;
6161
6162 if(Enabled or (csDesigning in ComponentState)) then
6163 begin
6164 DrawText(Handle, PChar(Caption), Length(Caption), FocusRect, DrawOptions);
6165 end
6166 else
6167 begin
6168 OldColor:=Font.Color;
6169 try
6170 if Ctl3D then
6171 begin
6172 OffsetRect(FocusRect, 1, 1);
6173 Font.Color := clBtnHighlight;
6174 DrawText(Handle, PChar(Caption), Length(Caption), FocusRect, DrawOptions);
6175 OffsetRect(FocusRect, -1, -1);
6176 end;
6177 Font.Color:=clGrayText;
6178 DrawText(Handle, PChar(Caption), Length(Caption), FocusRect, DrawOptions);
6179 finally
6180 Font.Color:=OldColor;
6181 end;
6182
6183 Brush.Color := Self.Color;
6184 Brush.Style := bsSolid;
6185 end;
6186
6187 if((DrawItemStruct.itemState and ODS_FOCUS) <> 0) then
6188 begin
6189 InflateRect(FocusRect, 1, 1);
6190 if(FFocusOnBox) then
6191 //TempRect := Rect(0, 0, CheckWidth - 1, CheckWidth - 1)
6192 TempRect := Rect(0, 0, CheckWidth + 2, CheckWidth + 5)
6193 else
6194 TempRect := FocusRect;
6195 //UnionRect(Temp2Rect,ClipRect,TempRect);
6196 //ClipRect := Temp2Rect;
6197 Pen.Color := clWindowFrame;
6198 Brush.Color := clBtnFace;
6199 DrawFocusRect(TempRect);
6200 InflateRect(FocusRect, -1, -1);
6201 end;
6202
6203 if Alignment = taLeftJustify then
6204 R.Left := ClientWidth - Bitmap.Width
6205 else
6206 R.Left := 0;
6207 if(FWordWrap) then
6208 R.Top:= FocusRect.Top
6209 else
6210 begin
6211 R.Top:= ((ClientHeight - Bitmap.Height + 1) div 2) - 1;
6212 if R.Top < 0 then R.Top := 0
6213 end;
6214 Draw(R.Left, R.Top, Bitmap);
6215 end;
6216 finally
6217 FCanvas.Handle := 0;
6218 end;
6219 finally
6220 if(TempBitMap) then
6221 Bitmap.Free;
6222 end;
6223 end;
6224end;
6225
6226procedure TORCheckBox.SetGrayedStyle(Value: TGrayedStyle);
6227begin
6228 if(FGrayedStyle <> Value) then
6229 begin
6230 FGrayedStyle := Value;
6231 if(State = cbGrayed) then Invalidate;
6232 end;
6233end;
6234
6235procedure TORCheckBox.WMLButtonDblClk(var Message: TWMLButtonDblClk);
6236begin
6237 Perform(WM_LBUTTONDOWN, Message.Keys, Longint(Message.Pos));
6238end;
6239
6240procedure TORCheckBox.WMSize(var Message: TWMSize);
6241begin
6242 inherited;
6243 if(FSizable) and (csDesigning in ComponentState) then
6244 AutoAdjustSize;
6245end;
6246
6247procedure TORCheckBox.BMSETCHECK(var Message: TMessage);
6248var
6249 cnt, i: integer;
6250 cb: TORCheckBox;
6251 Chk: boolean;
6252
6253begin
6254 Message.Result := 0;
6255
6256 if(assigned(Parent) and (FGroupIndex <> 0)) then
6257 begin
6258 Chk := Checked;
6259 if(Chk or (not FAllowAllUnchecked)) then
6260 begin
6261 cnt := 0;
6262 for i := 0 to Parent.ControlCount-1 do
6263 begin
6264 if(Parent.Controls[i] is TORCheckBox) then
6265 begin
6266 cb := TORCheckBox(Parent.Controls[i]);
6267 if(cb <> Self) then
6268 begin
6269 if(cb.Checked and (cb.FGroupIndex = FGroupIndex)) then
6270 begin
6271 if Chk then
6272 cb.Checked := FALSE
6273 else
6274 inc(cnt);
6275 end;
6276 end;
6277 end;
6278 end;
6279 if(not Chk) and (Cnt = 0) then
6280 Checked := TRUE;
6281 end;
6282 end;
6283 UpdateAssociate;
6284 Invalidate;
6285end;
6286
6287procedure TORCheckBox.SetWordWrap(const Value: boolean);
6288begin
6289 if(FWordWrap <> Value) then
6290 begin
6291 FWordWrap := Value;
6292 AutoAdjustSize;
6293 invalidate;
6294 end;
6295end;
6296
6297procedure TORCheckBox.SetAutoSize(Value: boolean);
6298begin
6299 if(FAutoSize <> Value) then
6300 begin
6301 FAutoSize := Value;
6302 AutoAdjustSize;
6303 invalidate;
6304 end;
6305end;
6306
6307procedure TORCheckBox.SetBlackColorMode(Value: boolean);
6308begin
6309 if FBlackColorMode <> Value then
6310 begin
6311 FBlackColorMode := Value;
6312 Invalidate;
6313 end;
6314end;
6315
6316procedure TORCheckBox.AutoAdjustSize;
6317var
6318 R, FocusRect: TRect;
6319 Bitmap: TBitmap;
6320 DrawOptions: UINT;
6321 TempBitMap: boolean;
6322 DC: HDC;
6323 SaveFont: HFont;
6324
6325begin
6326 if(FAutoSize and (([csDestroying, csLoading] * ComponentState) = [])) then
6327 begin
6328 FSizable := TRUE;
6329 DC := GetDC(0);
6330 try
6331 SaveFont := SelectObject(DC, Font.Handle);
6332 try
6333 GetDrawData(DC, Bitmap, FocusRect, R, DrawOptions, TempBitMap);
6334 finally
6335 SelectObject(DC, SaveFont);
6336 end;
6337 finally
6338 ReleaseDC(0, DC);
6339 end;
6340 if(FocusRect.Left <> R.Left ) or
6341 (FocusRect.Right <> R.Right ) or
6342 (FocusRect.Top <> R.Top ) or
6343 (FocusRect.Bottom <> R.Bottom) or
6344 (R.Right <> ClientRect.Right) or
6345 (R.Bottom <> ClientRect.Bottom) then
6346 begin
6347 FocusRect := R;
6348 if Alignment = taLeftJustify then
6349 begin
6350 dec(R.Left,2);
6351 inc(R.Right,Bitmap.Width + 3);
6352 end
6353 else
6354 dec(R.Left,Bitmap.Width + 5);
6355 Width := R.Right-R.Left+1;
6356 Height := R.Bottom-R.Top+2;
6357 end;
6358 end;
6359end;
6360
6361function TORCheckBox.GetCaption: TCaption;
6362begin
6363 Result := inherited Caption;
6364end;
6365
6366procedure TORCheckBox.SetCaption(const Value: TCaption);
6367begin
6368 if(inherited Caption <> Value) then
6369 begin
6370 inherited Caption := Value;
6371 AutoAdjustSize;
6372 invalidate;
6373 end;
6374end;
6375
6376procedure TORCheckBox.SetAllowAllUnchecked(const Value: boolean);
6377begin
6378 FAllowAllUnchecked := Value;
6379 SyncAllowAllUnchecked;
6380end;
6381
6382procedure TORCheckBox.SetGroupIndex(const Value: integer);
6383begin
6384 FGroupIndex := Value;
6385 if(Value <> 0) and (csDesigning in ComponentState) and (not (csLoading in ComponentState)) then
6386 SetRadioStyle(TRUE);
6387 SyncAllowAllUnchecked;
6388end;
6389
6390procedure TORCheckBox.SyncAllowAllUnchecked;
6391var
6392 i: integer;
6393 cb: TORCheckBox;
6394
6395begin
6396 if(assigned(Parent) and (FGroupIndex <> 0)) then
6397 begin
6398 for i := 0 to Parent.ControlCount-1 do
6399 begin
6400 if(Parent.Controls[i] is TORCheckBox) then
6401 begin
6402 cb := TORCheckBox(Parent.Controls[i]);
6403 if((cb <> Self) and (cb.FGroupIndex = FGroupIndex)) then
6404 cb.FAllowAllUnchecked := FAllowAllUnchecked;
6405 end;
6406 end;
6407 end;
6408end;
6409
6410procedure TORCheckBox.SetParent(AParent: TWinControl);
6411begin
6412 inherited;
6413 SyncAllowAllUnchecked;
6414end;
6415
6416procedure TORCheckBox.SetRadioStyle(const Value: boolean);
6417begin
6418 FRadioStyle := Value;
6419 Invalidate;
6420end;
6421
6422procedure TORCheckBox.SetAssociate(const Value: TControl);
6423begin
6424 if(FAssociate <> Value) then
6425 begin
6426 if(assigned(FAssociate)) then
6427 FAssociate.RemoveFreeNotification(Self);
6428 FAssociate := Value;
6429 if(assigned(FAssociate)) then
6430 begin
6431 FAssociate.FreeNotification(Self);
6432 UpdateAssociate;
6433 end;
6434 end;
6435end;
6436
6437procedure TORCheckBox.UpdateAssociate;
6438
6439 procedure EnableCtrl(Ctrl: TControl; DoCtrl: boolean);
6440 var
6441 i: integer;
6442 DoIt: boolean;
6443
6444 begin
6445 if DoCtrl then
6446 Ctrl.Enabled := Checked;
6447
6448 // added (csAcceptsControls in Ctrl.ControlStyle) below to prevent disabling of
6449 // child sub controls, like the TBitBtn in the TORComboBox. If the combo box is
6450 // already disabled, we don't want to disable the button as well - when we do, we
6451 // lose the disabled glyph that is stored on that button for the combo box.
6452
6453 if(Ctrl is TWinControl) and (csAcceptsControls in Ctrl.ControlStyle) then
6454 begin
6455 for i := 0 to TWinControl(Ctrl).ControlCount-1 do
6456 begin
6457 if DoCtrl then
6458 DoIt := TRUE
6459 else
6460 DoIt := (TWinControl(Ctrl).Controls[i] is TWinControl);
6461 if DoIt then
6462 EnableCtrl(TWinControl(Ctrl).Controls[i], TRUE);
6463 end;
6464 end;
6465 end;
6466
6467begin
6468 if(assigned(FAssociate)) then
6469 EnableCtrl(FAssociate, FALSE);
6470end;
6471
6472procedure TORCheckBox.Notification(AComponent: TComponent;
6473 Operation: TOperation);
6474begin
6475 inherited;
6476 if(AComponent = FAssociate) and (Operation = opRemove) then
6477 FAssociate := nil;
6478end;
6479
6480procedure TORCheckBox.SetFocusOnBox(value: boolean);
6481begin
6482 FFocusOnBox := value;
6483 invalidate;
6484end;
6485
6486procedure TORCheckBox.BMGetCheck(var Message: TMessage);
6487begin
6488 {This Allows JAWS to report the state when tabbed into or using the read object
6489 keys (Ins+Tab)}
6490 {if Self.GrayedStyle = gsBlueQuestionMark then
6491 Message.Result := BST_INDETERMINATE
6492 else}
6493 if Self.Checked then
6494 Message.Result := BST_CHECKED
6495 else
6496 Message.Result := BST_UNCHECKED;
6497end;
6498
6499procedure TORCheckBox.BMGetState(var Message: TMessage);
6500begin
6501 //This gives JAWS ability to read state when spacebar is pressed.
6502 //Commented out because JAWS reads states, but inversly. Working with freedom...
6503{ if Self.Checked then
6504 Message.Result := BST_CHECKED
6505 else
6506 Message.Result := BST_UNCHECKED;}
6507end;
6508
6509{ TORListView }
6510
6511procedure TORListView.WMNotify(var Message: TWMNotify);
6512begin
6513 inherited;
6514 with Message.NMHdr^ do
6515 case code of
6516 HDN_BEGINTRACK, HDN_TRACK, HDN_ENDTRACK:
6517 with PHDNotify(Pointer(Message.NMHdr))^, PItem^ do
6518 if (Mask and HDI_WIDTH) <> 0 then
6519 begin
6520 if(Column[Item].MinWidth > 0) and (cxy < Column[Item].MinWidth) then
6521 cxy := Column[Item].MinWidth;
6522 if(Column[Item].MaxWidth > 0) and (cxy > Column[Item].MaxWidth) then
6523 cxy := Column[Item].MaxWidth;
6524 Column[Item].Width := cxy;
6525 end;
6526 end;
6527end;
6528
6529procedure TORListView.LVMSetColumn(var Message: TMessage);
6530var
6531 Changed: boolean;
6532 NewW, idx: integer;
6533
6534begin
6535 Changed := FALSE;
6536 NewW := 0;
6537 idx := 0;
6538 with Message, TLVColumn(pointer(LParam)^) do
6539 begin
6540 if(cx < Column[WParam].MinWidth) then
6541 begin
6542 NewW := Column[WParam].MinWidth;
6543 Changed := TRUE;
6544 idx := WParam;
6545 end;
6546 if(cx > Column[WParam].MaxWidth) then
6547 begin
6548 NewW := Column[WParam].MaxWidth;
6549 Changed := TRUE;
6550 idx := WParam;
6551 end;
6552 end;
6553 inherited;
6554 if(Changed) then
6555 Column[idx].Width := NewW;
6556end;
6557
6558procedure TORListView.LVMSetColumnWidth(var Message: TMessage);
6559var
6560 Changed: boolean;
6561 NewW, idx: integer;
6562
6563begin
6564 Changed := FALSE;
6565 NewW := 0;
6566 idx := 0;
6567 with Message do
6568 begin
6569 if(LParam < Column[WParam].MinWidth) then
6570 begin
6571 LParam := Column[WParam].MinWidth;
6572 Changed := TRUE;
6573 NewW := LParam;
6574 idx := WParam;
6575 end;
6576 if(LParam > Column[WParam].MaxWidth) then
6577 begin
6578 LParam := Column[WParam].MaxWidth;
6579 Changed := TRUE;
6580 NewW := LParam;
6581 idx := WParam;
6582 end;
6583 end;
6584 inherited;
6585 if(Changed) then
6586 Column[idx].Width := NewW;
6587end;
6588
6589{ TORComboPanelEdit }
6590
6591destructor TORComboPanelEdit.Destroy;
6592begin
6593 if(assigned(FCanvas)) then
6594 FCanvas.Free;
6595 inherited;
6596end;
6597
6598procedure TORComboPanelEdit.Paint;
6599var
6600 DC: HDC;
6601 R: TRect;
6602
6603begin
6604 inherited;
6605 if(FFocused) then
6606 begin
6607 if(not assigned(FCanvas)) then
6608 FCanvas := TControlCanvas.Create;
6609 DC := GetWindowDC(Handle);
6610 try
6611 FCanvas.Handle := DC;
6612 R := ClientRect;
6613 InflateRect(R, -1, -1);
6614 FCanvas.DrawFocusRect(R);
6615 finally
6616 ReleaseDC(Handle, DC);
6617 end;
6618 end;
6619end;
6620
6621{ TKeyClickPanel ----------------------------------------------------------------------------- }
6622procedure TKeyClickPanel.KeyDown(var Key: Word; Shift: TShiftState);
6623begin
6624 case Key of
6625 VK_LBUTTON, VK_RETURN, VK_SPACE:
6626 Click;
6627 end;
6628end;
6629
6630{ TKeyClickRadioGroup }
6631
6632procedure TKeyClickRadioGroup.Click;
6633begin
6634 inherited;
6635 TabStop := Enabled and Visible and (ItemIndex = -1);
6636end;
6637
6638constructor TKeyClickRadioGroup.Create(AOwner: TComponent);
6639begin
6640 inherited;
6641 TabStop := Enabled and Visible and (ItemIndex = -1);
6642end;
6643
6644procedure TKeyClickRadioGroup.KeyDown(var Key: Word; Shift: TShiftState);
6645begin
6646 inherited;
6647 case Key of
6648 VK_RETURN, VK_SPACE:
6649 if ItemIndex = -1 then begin
6650 ItemIndex := 0;
6651 Click;
6652 if ControlCount > 0 then begin
6653 TWinControl(Controls[0]).SetFocus;
6654 end;
6655 Key := 0;
6656 end;
6657 end;
6658end;
6659
6660{ TCaptionListBox }
6661
6662procedure TCaptionListBox.DoEnter;
6663begin
6664 inherited;
6665 if HintOnItem then
6666 FHoverItemPos := -1; //CQ: 7178 & 9911 - used as last item index for ListBox
6667end;
6668
6669function TCaptionListBox.GetCaption: string;
6670begin
6671 if not Assigned(FCaptionComponent) then
6672 result := ''
6673 else
6674 result := FCaptionComponent.Caption;
6675end;
6676
6677function TCaptionListBox.GetDynamicProperty(PropertyID: integer): string;
6678begin
6679 if PropertyID = DynaPropAccesibilityCaption then
6680 Result := GetCaption
6681 else
6682 Result := '';
6683end;
6684
6685
6686procedure TCaptionListBox.MoveFocusUp;
6687begin
6688 if ItemIndex > 0 then
6689 Perform(LB_SETCARETINDEX, ItemIndex - 1, 0);
6690end;
6691
6692procedure TCaptionListBox.MoveFocusDown;
6693begin
6694 if ItemIndex < (Items.Count-1) then
6695 Perform(LB_SETCARETINDEX, ItemIndex + 1, 0);
6696end;
6697
6698procedure TCaptionListBox.SetCaption(const Value: string);
6699begin
6700 if not Assigned(FCaptionComponent) then begin
6701 FCaptionComponent := TStaticText.Create(self);
6702 FCaptionComponent.AutoSize := False;
6703 FCaptionComponent.Height := 0;
6704 FCaptionComponent.Width := 0;
6705 FCaptionComponent.Visible := True;
6706 FCaptionComponent.Parent := Parent;
6707 FCaptionComponent.BringToFront;
6708 end;
6709 FCaptionComponent.Caption := Value;
6710end;
6711
6712function TCaptionListBox.SupportsDynamicProperty(PropertyID: integer): boolean;
6713begin
6714 Result := (PropertyID = DynaPropAccesibilityCaption);
6715end;
6716
6717procedure TCaptionListBox.WMKeyDown(var Message: TWMKeyDown);
6718var
6719 IsSelected: LongBool;
6720begin
6721 if Boolean(Hi(GetKeyState(VK_CONTROL))) and MultiSelect then
6722 case Message.CharCode of
6723 VK_SPACE:
6724 begin
6725 IsSelected := LongBool(Perform(LB_GETSEL, ItemIndex, 0));
6726 Perform(LB_SETSEL, Longint(not IsSelected), ItemIndex);
6727 end;
6728 VK_LEFT, VK_UP: MoveFocusUp;
6729 VK_RIGHT, VK_DOWN: MoveFocusDown;
6730 else inherited;
6731 end
6732 else inherited;
6733end;
6734
6735procedure TCaptionListBox.WMMouseMove(var Message: TWMMouseMove);
6736var
6737 i : integer;
6738begin
6739 inherited;
6740 //CQ: 7178 & 9911 - FHoverItemPos should be set to -1 in OnEnter
6741 //Make the TListBox's hint contain the contents of the listbox Item the mouse is currently over
6742 if HintOnItem then
6743 begin
6744 i := ItemAtPos(Point(Message.XPos, Message.YPos), true);
6745 if i <> FHoverItemPos then
6746 Application.CancelHint;
6747 if i = -1 then
6748 Hint := ''
6749 else
6750 Hint := Items[i];
6751 FHoverItemPos := i;
6752 end;
6753end;
6754
6755procedure TCaptionListBox.WMRButtonUp(var Message: TWMRButtonUp);
6756{ When the RightClickSelect property is true, this routine is used to select an item }
6757var
6758 APoint: TPoint;
6759 i: integer;
6760begin
6761 if FRightClickSelect then with Message do
6762 begin
6763 APoint := Point(XPos, YPos);
6764 // if the mouse was clicked in the client area set ItemIndex...
6765 if PtInRect(ClientRect, APoint) then
6766 begin
6767 ItemIndex := ItemAtPos(APoint,True);
6768 // ...but not if its just going to deselect the current item
6769 if ItemIndex > -1 then
6770 begin
6771 Items.BeginUpdate;
6772 try
6773 if not Selected[ItemIndex] then
6774 for i := 0 to Items.Count-1 do
6775 Selected[i] := False;
6776 Selected[ItemIndex] := True;
6777 finally
6778 Items.EndUpdate;
6779 end;
6780 end;
6781 end;
6782 end;
6783 inherited;
6784end;
6785
6786{ TCaptionCheckListBox }
6787
6788function TCaptionCheckListBox.GetCaption: string;
6789begin
6790 if not Assigned(FCaptionComponent) then
6791 result := ''
6792 else
6793 result := FCaptionComponent.Caption;
6794end;
6795
6796function TCaptionCheckListBox.GetDynamicProperty(PropertyID: integer): string;
6797begin
6798 if PropertyID = DynaPropAccesibilityCaption then
6799 Result := GetCaption
6800 else
6801 Result := '';
6802end;
6803
6804procedure TCaptionCheckListBox.SetCaption(const Value: string);
6805begin
6806 if not Assigned(FCaptionComponent) then begin
6807 FCaptionComponent := TStaticText.Create(self);
6808 FCaptionComponent.AutoSize := False;
6809 FCaptionComponent.Height := 0;
6810 FCaptionComponent.Width := 0;
6811 FCaptionComponent.Visible := True;
6812 FCaptionComponent.Parent := Parent;
6813 FCaptionComponent.BringToFront;
6814 end;
6815 FCaptionComponent.Caption := Value;
6816end;
6817
6818function TCaptionCheckListBox.SupportsDynamicProperty(
6819 PropertyID: integer): boolean;
6820begin
6821 Result := (PropertyID = DynaPropAccesibilityCaption);
6822end;
6823
6824{ TCaptionMemo }
6825
6826function TCaptionMemo.GetCaption: string;
6827begin
6828 if not Assigned(FCaptionComponent) then
6829 result := ''
6830 else
6831 result := FCaptionComponent.Caption;
6832end;
6833
6834function TCaptionMemo.GetDynamicProperty(PropertyID: integer): string;
6835begin
6836 if PropertyID = DynaPropAccesibilityCaption then
6837 Result := GetCaption
6838 else
6839 Result := '';
6840end;
6841
6842procedure TCaptionMemo.SetCaption(const Value: string);
6843begin
6844 if not Assigned(FCaptionComponent) then begin
6845 FCaptionComponent := TStaticText.Create(self);
6846 FCaptionComponent.AutoSize := False;
6847 FCaptionComponent.Height := 0;
6848 FCaptionComponent.Width := 0;
6849 FCaptionComponent.Visible := True;
6850 FCaptionComponent.Parent := Parent;
6851 FCaptionComponent.BringToFront;
6852 end;
6853 FCaptionComponent.Caption := Value;
6854end;
6855
6856function TCaptionMemo.SupportsDynamicProperty(PropertyID: integer): boolean;
6857begin
6858 Result := (PropertyID = DynaPropAccesibilityCaption);
6859end;
6860
6861{ TCaptionEdit }
6862
6863function TCaptionEdit.GetCaption: string;
6864begin
6865 if not Assigned(FCaptionComponent) then
6866 result := ''
6867 else
6868 result := FCaptionComponent.Caption;
6869end;
6870
6871function TCaptionEdit.GetDynamicProperty(PropertyID: integer): string;
6872begin
6873 if PropertyID = DynaPropAccesibilityCaption then
6874 Result := GetCaption
6875 else
6876 Result := '';
6877end;
6878
6879procedure TCaptionEdit.SetCaption(const Value: string);
6880begin
6881 if not Assigned(FCaptionComponent) then begin
6882 FCaptionComponent := TStaticText.Create(self);
6883 FCaptionComponent.AutoSize := False;
6884 FCaptionComponent.Height := 0;
6885 FCaptionComponent.Width := 0;
6886 FCaptionComponent.Visible := True;
6887 FCaptionComponent.Parent := Parent;
6888 FCaptionComponent.BringToFront;
6889 end;
6890 FCaptionComponent.Caption := Value;
6891end;
6892
6893function TCaptionEdit.SupportsDynamicProperty(PropertyID: integer): boolean;
6894begin
6895 Result := (PropertyID = DynaPropAccesibilityCaption);
6896end;
6897
6898{ TCaptionRichEdit }
6899
6900function TCaptionRichEdit.GetDynamicProperty(PropertyID: integer): string;
6901begin
6902 if PropertyID = DynaPropAccesibilityCaption then
6903 Result := FCaption
6904 else
6905 Result := '';
6906end;
6907
6908
6909function TCaptionRichEdit.SupportsDynamicProperty(PropertyID: integer): boolean;
6910begin
6911 Result := (PropertyID = DynaPropAccesibilityCaption);
6912end;
6913
6914{ TCaptionTreeView}
6915
6916function TCaptionTreeView.GetCaption: string;
6917begin
6918 result := inherited Caption;
6919end;
6920
6921function TCaptionTreeView.GetDynamicProperty(PropertyID: integer): string;
6922begin
6923 if PropertyID = DynaPropAccesibilityCaption then
6924 Result := GetCaption
6925 else
6926 Result := '';
6927end;
6928
6929procedure TCaptionTreeView.SetCaption(const Value: string);
6930begin
6931 if not Assigned(FCaptionComponent) then begin
6932 FCaptionComponent := TStaticText.Create(self);
6933 FCaptionComponent.AutoSize := False;
6934 FCaptionComponent.Height := 0;
6935 FCaptionComponent.Width := 0;
6936 FCaptionComponent.Visible := True;
6937 FCaptionComponent.Parent := Parent;
6938 FCaptionComponent.BringToFront;
6939 end;
6940 FCaptionComponent.Caption := Value;
6941 inherited Caption := Value;
6942end;
6943
6944function TCaptionTreeView.SupportsDynamicProperty(PropertyID: integer): boolean;
6945begin
6946 Result := (PropertyID = DynaPropAccesibilityCaption);
6947end;
6948
6949{ TCaptionComboBox }
6950
6951function TCaptionComboBox.GetCaption: string;
6952begin
6953 if not Assigned(FCaptionComponent) then
6954 result := ''
6955 else
6956 result := FCaptionComponent.Caption;
6957end;
6958
6959function TCaptionComboBox.GetDynamicProperty(PropertyID: integer): string;
6960begin
6961 if PropertyID = DynaPropAccesibilityCaption then
6962 Result := GetCaption
6963 else
6964 Result := '';
6965end;
6966
6967procedure TCaptionComboBox.SetCaption(const Value: string);
6968begin
6969 if not Assigned(FCaptionComponent) then begin
6970 FCaptionComponent := TStaticText.Create(self);
6971 FCaptionComponent.AutoSize := False;
6972 FCaptionComponent.Height := 0;
6973 FCaptionComponent.Width := 0;
6974 FCaptionComponent.Visible := True;
6975 FCaptionComponent.Parent := Parent;
6976 FCaptionComponent.BringToFront;
6977 end;
6978 FCaptionComponent.Caption := Value;
6979end;
6980
6981function TCaptionComboBox.SupportsDynamicProperty(PropertyID: integer): boolean;
6982begin
6983 Result := (PropertyID = DynaPropAccesibilityCaption);
6984end;
6985
6986{ TORAlignSpeedButton }
6987
6988procedure TORAlignSpeedButton.Paint;
6989var
6990 Rect: TRect;
6991begin
6992 inherited;
6993 if (Parent <> nil) and (Parent is TKeyClickPanel) and TKeyClickPanel(Parent).Focused then
6994 begin
6995 Rect := ClientRect;
6996 InflateRect(Rect, -3, -3);
6997 Canvas.Brush.Color := Color;
6998 Canvas.DrawFocusRect(Rect);
6999 end;
7000end;
7001
7002{ TCaptionStringGrid }
7003
7004{I may have messed up my Windows.pas file, but mine defines NotifyWinEvent without a stdcall.}
7005procedure GoodNotifyWinEvent; external user32 name 'NotifyWinEvent';
7006
7007function TCaptionStringGrid.ColRowToIndex(Col, Row: Integer): integer;
7008begin
7009 result := (ColCount - FixedCols) * (Row - FixedRows) +
7010 (Col - FixedCols) + 1;
7011end;
7012
7013function TCaptionStringGrid.GetDynamicProperty(PropertyID: integer): string;
7014begin
7015 if PropertyID = DynaPropAccesibilityCaption then
7016 Result := FCaption
7017 else
7018 Result := '';
7019end;
7020
7021procedure TCaptionStringGrid.IndexToColRow(index: integer; var Col,
7022 Row: integer);
7023begin
7024 Row := (index-1) div (ColCount - FixedCols) + FixedRows;
7025 Col := (index-1) mod (ColCount - FixedCols) + FixedCols;
7026end;
7027
7028procedure TCaptionStringGrid.KeyUp(var Key: Word; Shift: TShiftState);
7029begin
7030 inherited;
7031 {Look for all of the grid navigation keys}
7032 if (Key in [VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN]) and (Shift = []) or
7033 (Key = VK_TAB) and (Shift <= [ssShift]) then
7034 GoodNotifyWinEvent(EVENT_OBJECT_FOCUS, Handle, integer(OBJID_CLIENT),
7035 ColRowToIndex(Col,Row));
7036end;
7037
7038
7039function TCaptionStringGrid.SupportsDynamicProperty(
7040 PropertyID: integer): boolean;
7041begin
7042 Result := (PropertyID = DynaPropAccesibilityCaption);
7043end;
7044
7045function IsAMouseButtonDown : boolean;
7046begin
7047 if Boolean(Hi(GetKeyState(VK_MBUTTON))) or
7048 Boolean(Hi(GetKeyState(VK_LBUTTON))) or
7049 Boolean(Hi(GetKeyState(VK_RBUTTON))) then
7050 Result := true
7051 else
7052 Result := false;
7053end;
7054
7055procedure TORComboBox.SetNumForMatch(const NumberForMatch: integer);
7056begin
7057 if NumberForMatch < 1 then
7058 FCharsNeedMatch := 1
7059 else if NumberForMatch > 15 then
7060 FCharsNeedMatch := 15
7061 else
7062 FCharsNeedMatch := NumberForMatch;
7063end;
7064
7065procedure TORComboBox.SetUniqueAutoComplete(const Value: Boolean);
7066begin
7067 FUniqueAutoComplete := Value;
7068end;
7069
7070function TORListBox.VerifyUnique(SelectIndex: Integer; iText: String): integer;
7071var
7072 i : integer;
7073 counter : integer;
7074begin
7075 Result := SelectIndex;
7076 if LongList then
7077 begin
7078 //Implemented for CQ: 10092, PSI-04-057
7079 //asume long lists are alphabetically ordered...
7080 if CompareText(iText, Copy(DisplayText[SelectIndex+1], 1, Length(iText))) = 0 then
7081 Result := -1;
7082 end
7083 else //Not a LongList
7084 begin
7085 counter := 0;
7086 for i := 0 to Items.Count-1 do
7087 if CompareText(iText, Copy(DisplayText[i], 1, Length(iText))) = 0 then
7088 Inc(counter);
7089 if counter > 1 then
7090 Result := -1;
7091 end;
7092 FFocusIndex := Result;
7093 ItemIndex := Result;
7094end;
7095
7096//This procedure sets the Text property equal to the TextToMatch parameter, then calls
7097//FwdChangeDelayed which will perform an auto-completion on the text.
7098procedure TORComboBox.SetTextAutoComplete(TextToMatch: String);
7099begin
7100 Text := TextToMatch;
7101 SelStart := Length(Text);
7102 FwdChangeDelayed;
7103end;
7104
7105{ TCaptionListView }
7106
7107function TCaptionListView.GetDynamicProperty(PropertyID: integer): string;
7108begin
7109 if PropertyID = DynaPropAccesibilityCaption then
7110 Result := Caption
7111 else
7112 Result := '';
7113end;
7114
7115function TCaptionListView.SupportsDynamicProperty(PropertyID: integer): boolean;
7116begin
7117 Result := (PropertyID = DynaPropAccesibilityCaption);
7118end;
7119
7120initialization
7121 //uItemTip := TItemTip.Create(Application); // all listboxes share a single ItemTip window
7122 uItemTipCount := 0;
7123 uNewStyle := Lo(GetVersion) >= 4; // True = Win95 interface, otherwise old interface
7124 FillChar(ORCBImages, SizeOf(ORCBImages), 0);
7125
7126finalization
7127 //uItemTip.Free; // don't seem to need this - called by Application
7128 DestroyORCBBitmaps;
7129
7130end.
Note: See TracBrowser for help on using the repository browser.