source: cprs/branches/tmg-cprs/CPRS-Lib/ORCtrls.pas@ 727

Last change on this file since 727 was 453, checked in by Kevin Toppenberg, 17 years ago

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