source: cprs/branches/GUI-config/CPRS-Lib/ORCtrls.pas@ 491

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

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