source: cprs/branches/foia-cprs/CPRS-Lib/ORCtrls.pas@ 459

Last change on this file since 459 was 459, checked in by Kevin Toppenberg, 16 years ago

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