3569 lines
102 KiB
ObjectPascal
3569 lines
102 KiB
ObjectPascal
{-----------------------------------------------------------------------------
|
|
The contents of this file are subject to the Mozilla Public License
|
|
Version 1.1 (the "License"); you may not use this file except in compliance
|
|
with the License. You may obtain a copy of the License at
|
|
http://www.mozilla.org/MPL/MPL-1.1.html
|
|
|
|
Software distributed under the License is distributed on an "AS IS" basis,
|
|
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
|
|
the specific language governing rights and limitations under the License.
|
|
|
|
The Original Code is: JvComCtrls.PAS, released Oct 10, 1999.
|
|
|
|
The Initial Developer of the Original Code is Petr Vones (petr dott v att mujmail dott cz)
|
|
Portions created by Petr Vones are Copyright (C) 1999 Petr Vones.
|
|
Portions created by Microsoft are Copyright (C) 1998, 1999 Microsoft Corp.
|
|
All Rights Reserved.
|
|
|
|
Contributor(s):
|
|
Peter Below [100113 dott 1101 att compuserve dott com] - alternate TJvPageControl.OwnerDraw routine
|
|
Peter Thrnqvist [peter3 at sourceforge dot net] added TJvIPAddress.AddressValues and TJvPageControl.ReduceMemoryUse
|
|
Alfi [alioscia_alessi att onde dott net] alternate TJvPageControl.OwnerDraw routine
|
|
Rudy Velthuis - ShowRange in TJvTrackBar
|
|
Andreas Hausladen - TJvIPAddress designtime bug, components changed to JvExVCL
|
|
Kai Gossens - TJvIPAddress: changing Color, drawing bug on XP (fat frame on edits removed)
|
|
dejoy - TJvTreeView.MoveUp/MoveDown
|
|
|
|
You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
|
|
located at http://jvcl.sourceforge.net
|
|
|
|
Known Issues:
|
|
TJvTreeView:
|
|
When dragging an item and MultiSelect is True droptarget node is not painted
|
|
correctly.
|
|
-----------------------------------------------------------------------------}
|
|
// $Id: JvComCtrls.pas 11177 2007-02-05 12:43:36Z marquardt $
|
|
|
|
unit JvComCtrls;
|
|
|
|
{$I jvcl.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
{$IFDEF UNITVERSIONING}
|
|
JclUnitVersioning,
|
|
{$ENDIF UNITVERSIONING}
|
|
{$IFDEF CLR}
|
|
System.Runtime.InteropServices, System.Reflection, Borland.Vcl.WinUtils,
|
|
{$ENDIF CLR}
|
|
Windows, Messages, Contnrs, Graphics, Controls, Forms,
|
|
Classes, // (ahuser) "Classes" after "Forms" (D5 warning)
|
|
Menus, ComCtrls, ImgList, Buttons,
|
|
{$IFDEF HAS_UNIT_TYPES}
|
|
Types,
|
|
{$ENDIF HAS_UNIT_TYPES}
|
|
{$IFDEF VCL}
|
|
CommCtrl,
|
|
{$ENDIF VCL}
|
|
{$IFDEF VisualCLX}
|
|
Qt, QExtCtrls,
|
|
{$ENDIF VisualCLX}
|
|
JvJVCLUtils, JvComponentBase, JvComponent, JvExControls, JvExComCtrls, JvWin32,
|
|
JvToolEdit;
|
|
|
|
const
|
|
JvDefPageControlBorder = 4;
|
|
JvDefaultInactiveColorFrom = TColor($D7D7D7);
|
|
JvDefaultInactiveColorTo= TColor($ADADAD);
|
|
|
|
type
|
|
{$IFDEF VCL}
|
|
TJvIPAddress = class;
|
|
|
|
TJvIPAddressMinMax = record
|
|
Min: Byte;
|
|
Max: Byte;
|
|
end;
|
|
|
|
TJvIPEditControlHelper = class({$IFDEF CLR} TControl {$ELSE} TObject {$ENDIF})
|
|
private
|
|
FHandle: THandle;
|
|
FInstance: TFNWndProc;
|
|
FIPAddress: TJvIPAddress;
|
|
FOrgWndProc: TFarProc;
|
|
procedure SetHandle(const Value: THandle);
|
|
protected
|
|
procedure WndProc(var Msg: TMessage); {$IFDEF CLR}reintroduce;{$ENDIF} virtual;
|
|
property Handle: THandle read FHandle write SetHandle;
|
|
public
|
|
constructor Create(AIPAddress: TJvIPAddress); {$IFDEF CLR}reintroduce;{$ENDIF}
|
|
destructor Destroy; override;
|
|
|
|
procedure SetFocus;
|
|
function Focused: Boolean;
|
|
procedure DefaultHandler(var Msg); override;
|
|
end;
|
|
|
|
TJvIPAddressRange = class(TPersistent)
|
|
private
|
|
FControl: TWinControl;
|
|
FRange: array [0..3] of TJvIPAddressMinMax;
|
|
function GetMaxRange(Index: Integer): Byte;
|
|
function GetMinRange(Index: Integer): Byte;
|
|
procedure SetMaxRange(const Index: Integer; const Value: Byte);
|
|
procedure SetMinRange(const Index: Integer; const Value: Byte);
|
|
protected
|
|
procedure AssignTo(Dest: TPersistent); override;
|
|
procedure Change(Index: Integer);
|
|
public
|
|
constructor Create(Control: TWinControl);
|
|
published
|
|
property Field1Min: Byte index 0 read GetMinRange write SetMinRange default 0;
|
|
property Field1Max: Byte index 0 read GetMaxRange write SetMaxRange default 255;
|
|
property Field2Min: Byte index 1 read GetMinRange write SetMinRange default 0;
|
|
property Field2Max: Byte index 1 read GetMaxRange write SetMaxRange default 255;
|
|
property Field3Min: Byte index 2 read GetMinRange write SetMinRange default 0;
|
|
property Field3Max: Byte index 2 read GetMaxRange write SetMaxRange default 255;
|
|
property Field4Min: Byte index 3 read GetMinRange write SetMinRange default 0;
|
|
property Field4Max: Byte index 3 read GetMaxRange write SetMaxRange default 255;
|
|
end;
|
|
|
|
TJvIpAddrFieldChangeEvent = procedure(Sender: TJvIPAddress; FieldIndex: Integer;
|
|
FieldRange: TJvIPAddressMinMax; var Value: Integer) of object;
|
|
TJvIPAddressChanging = procedure(Sender: TObject; Index: Integer; Value: Byte; var AllowChange: Boolean) of object;
|
|
|
|
TJvIPAddressValues = class(TPersistent)
|
|
private
|
|
FValues: array [0..3] of Byte;
|
|
FOnChange: TNotifyEvent;
|
|
FOnChanging: TJvIPAddressChanging;
|
|
function GetValue: Cardinal;
|
|
procedure SetValue(const AValue: Cardinal);
|
|
procedure SetValues(Index: Integer; Value: Byte);
|
|
function GetValues(Index: Integer): Byte;
|
|
protected
|
|
procedure Change; virtual;
|
|
function Changing(Index: Integer; Value: Byte): Boolean; virtual;
|
|
public
|
|
property OnChange: TNotifyEvent read FOnChange write FOnChange;
|
|
property OnChanging: TJvIPAddressChanging read FOnChanging write FOnChanging;
|
|
published
|
|
property Address: Cardinal read GetValue write SetValue;
|
|
property Value1: Byte index 0 read GetValues write SetValues;
|
|
property Value2: Byte index 1 read GetValues write SetValues;
|
|
property Value3: Byte index 2 read GetValues write SetValues;
|
|
property Value4: Byte index 3 read GetValues write SetValues;
|
|
end;
|
|
|
|
TJvIPAddress = class(TJvCustomControl)
|
|
private
|
|
FEditControls: array [0..3] of TJvIPEditControlHelper;
|
|
FEditControlCount: Integer;
|
|
FAddress: LongWord;
|
|
FChanging: Boolean;
|
|
FRange: TJvIPAddressRange;
|
|
FAddressValues: TJvIPAddressValues;
|
|
FSaveBlank: Boolean;
|
|
FTabThroughFields: Boolean;
|
|
FLocalFont: HFONT;
|
|
FOnFieldChange: TJvIpAddrFieldChangeEvent;
|
|
FOnChange: TNotifyEvent;
|
|
FFocusFromField: Boolean;
|
|
procedure ClearEditControls;
|
|
procedure DestroyLocalFont;
|
|
procedure SetAddress(const Value: LongWord);
|
|
procedure SetAddressValues(const Value: TJvIPAddressValues);
|
|
procedure CNCommand(var Msg: TWMCommand); message CN_COMMAND;
|
|
procedure CNNotify(var Msg: TWMNotify); message CN_NOTIFY;
|
|
procedure WMDestroy(var Msg: TWMNCDestroy); message WM_DESTROY;
|
|
procedure WMParentNotify(var Msg: TWMParentNotify); message WM_PARENTNOTIFY;
|
|
procedure WMSetFont(var Msg: TWMSetFont); message WM_SETFONT;
|
|
procedure WMSetFocus(var Msg: TWMSetFocus); message WM_SETFOCUS;
|
|
procedure WMSetText(var Msg: TWMSetText); message WM_SETTEXT;
|
|
procedure WMGetText(var Msg: TWMGetText); message WM_GETTEXT;
|
|
procedure WMCtlColorEdit(var Msg: TWMCtlColorEdit); message WM_CTLCOLOREDIT;
|
|
procedure WMKeyDown(var Msg: TWMKeyDown); message WM_KEYDOWN;
|
|
procedure WMKeyUp(var Msg: TWMKeyUp); message WM_KEYUP;
|
|
procedure SelectTabControl(Previous: Boolean);
|
|
protected
|
|
procedure GetDlgCode(var Code: TDlgCodes); override;
|
|
procedure EnabledChanged; override;
|
|
procedure ColorChanged; override;
|
|
procedure FontChanged; override;
|
|
function DoEraseBackground(Canvas: TCanvas; Param: Integer): Boolean; override;
|
|
procedure AdjustHeight;
|
|
procedure AdjustSize; override;
|
|
procedure CreateParams(var Params: TCreateParams); override;
|
|
procedure CreateWnd; override;
|
|
procedure DestroyWnd; override;
|
|
procedure DoChange; dynamic;
|
|
procedure Paint; override;
|
|
|
|
procedure DoAddressChange(Sender: TObject); virtual;
|
|
procedure DoAddressChanging(Sender: TObject; Index: Integer;
|
|
Value: Byte; var AllowChange: Boolean); virtual;
|
|
procedure DoFieldChange(FieldIndex: Integer; var FieldValue: Integer); dynamic;
|
|
|
|
procedure UpdateValuesFromString(S: string);
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
procedure ClearAddress;
|
|
function IsBlank: Boolean;
|
|
published
|
|
property Address: LongWord read FAddress write SetAddress default 0;
|
|
property AddressValues: TJvIPAddressValues read FAddressValues write SetAddressValues;
|
|
property Anchors;
|
|
property AutoSize;
|
|
property Color;
|
|
property Constraints;
|
|
{$IFDEF VCL}
|
|
{$IFDEF COMPILER6_UP}
|
|
property BevelEdges;
|
|
property BevelInner;
|
|
property BevelKind default bkNone;
|
|
property BevelOuter;
|
|
{$ENDIF COMPILER6_UP}
|
|
property DragCursor;
|
|
property DragKind;
|
|
property OnStartDock;
|
|
property OnEndDock;
|
|
{$ENDIF VCL}
|
|
property DragMode;
|
|
property Enabled;
|
|
property Font;
|
|
property ParentColor;
|
|
property ParentFont;
|
|
property ParentShowHint;
|
|
property PopupMenu;
|
|
property Range: TJvIPAddressRange read FRange write FRange;
|
|
property ShowHint;
|
|
property TabOrder;
|
|
property TabStop default True;
|
|
property TabThroughFields: Boolean read FTabThroughFields write FTabThroughFields default True;
|
|
property Text;
|
|
property Visible;
|
|
property OnChange: TNotifyEvent read FOnChange write FOnChange;
|
|
property OnContextPopup;
|
|
property OnDblClick;
|
|
property OnDragDrop;
|
|
property OnDragOver;
|
|
property OnEndDrag;
|
|
property OnEnter;
|
|
property OnExit;
|
|
property OnFieldChange: TJvIpAddrFieldChangeEvent read FOnFieldChange write FOnFieldChange;
|
|
property OnKeyDown;
|
|
property OnKeyPress;
|
|
property OnKeyUp;
|
|
property OnStartDrag;
|
|
end;
|
|
{$ENDIF VCL}
|
|
|
|
// TJvHintSource is a hint enumeration type to describe how to display hints for
|
|
// controls that have hint properties both for the main control as well as
|
|
// for it's subitems (like a PageControl)
|
|
// TODO: (p3) this should really be moved to JvTypes or something...
|
|
TJvHintSource =
|
|
(
|
|
hsDefault, // use default hint behaviour (i.e as regular control)
|
|
hsForceMain, // use the main hint even if subitems have hints
|
|
hsForceChildren, // always use subitems hints even if empty
|
|
hsPreferMain, // use main control hint unless empty then use subitems hints
|
|
hsPreferChildren // use subitems hints unless empty then use main control hint
|
|
);
|
|
|
|
// painters that can be used to draw the tabs of a TPageControl or TTabControl
|
|
TJvTabControlPainter = class(TJvComponent)
|
|
private
|
|
FClients: TList;
|
|
protected
|
|
// descendants must override and implement this method
|
|
procedure DrawTab(AControl: TCustomTabControl; Canvas: TCanvas;
|
|
Images: TCustomImageList; ImageIndex: Integer; const Caption: string;
|
|
const Rect: TRect; Active, Enabled: Boolean); virtual; abstract;
|
|
procedure Change; virtual;
|
|
|
|
procedure RegisterChange(AControl: TCustomTabControl);
|
|
procedure UnRegisterChange(AControl: TCustomTabControl);
|
|
procedure Notification(AComponent: TComponent; Operation: TOperation);
|
|
override;
|
|
public
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
TJvTabDefaultPainter = class(TJvTabControlPainter)
|
|
private
|
|
FActiveFont: TFont;
|
|
FDisabledFont: TFont;
|
|
FInactiveFont: TFont;
|
|
FInactiveColorTo: TColor;
|
|
FActiveColorTo: TColor;
|
|
FDisabledColorTo: TColor;
|
|
FInactiveColorFrom: TColor;
|
|
FActiveColorFrom: TColor;
|
|
FDisabledColorFrom: TColor;
|
|
FActiveGradientDirection: TFillDirection;
|
|
FInactiveGradientDirection: TFillDirection;
|
|
FDisabledGradientDirection: TFillDirection;
|
|
FGlyphLayout: TButtonLayout;
|
|
FDivider: Boolean;
|
|
FShowFocus: Boolean;
|
|
procedure SetActiveFont(const Value: TFont);
|
|
procedure SetDisabledFont(const Value: TFont);
|
|
procedure SetInactiveFont(const Value: TFont);
|
|
procedure SetActiveColorFrom(const Value: TColor);
|
|
procedure SetActiveColorTo(const Value: TColor);
|
|
procedure SetActiveGradientDirection(const Value: TFillDirection);
|
|
procedure SetDisabledColorFrom(const Value: TColor);
|
|
procedure SetDisabledColorTo(const Value: TColor);
|
|
procedure SetDisabledGradientDirection(const Value: TFillDirection);
|
|
procedure SetInactiveColorFrom(const Value: TColor);
|
|
procedure SetInactiveColorTo(const Value: TColor);
|
|
procedure SetInactiveGradientDirection(const Value: TFillDirection);
|
|
function IsActiveFontStored: Boolean;
|
|
function IsInactiveFontStored: Boolean;
|
|
function IsDisabledFontStored: Boolean;
|
|
procedure SetGlyphLayout(const Value: TButtonLayout);
|
|
procedure SetDivider(const Value: Boolean);
|
|
procedure SetShowFocus(const Value: Boolean);
|
|
protected
|
|
procedure DrawTab(AControl: TCustomTabControl; Canvas: TCanvas;
|
|
Images: TCustomImageList; ImageIndex: Integer; const Caption: string;
|
|
const Rect: TRect; Active, Enabled: Boolean); override;
|
|
procedure DoFontChange(Sender: TObject);
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
published
|
|
property ActiveFont: TFont read FActiveFont write SetActiveFont stored IsActiveFontStored;
|
|
property ActiveColorFrom: TColor read FActiveColorFrom write SetActiveColorFrom default clWhite;
|
|
property ActiveColorTo: TColor read FActiveColorTo write SetActiveColorTo default clBtnFace;
|
|
property ActiveGradientDirection: TFillDirection read FActiveGradientDirection write SetActiveGradientDirection default fdTopToBottom;
|
|
property InactiveFont: TFont read FInactiveFont write SetInactiveFont stored IsInactiveFontStored;
|
|
property InactiveColorFrom: TColor read FInactiveColorFrom write SetInactiveColorFrom default JvDefaultInactiveColorFrom;
|
|
property InactiveColorTo: TColor read FInactiveColorTo write SetInactiveColorTo default JvDefaultInactiveColorTo;
|
|
property InactiveGradientDirection: TFillDirection read FInactiveGradientDirection write SetInactiveGradientDirection default fdTopToBottom;
|
|
property DisabledFont: TFont read FDisabledFont write SetDisabledFont stored IsDisabledFontStored;
|
|
property DisabledColorFrom: TColor read FDisabledColorFrom write SetDisabledColorFrom default clBtnFace;
|
|
property DisabledColorTo: TColor read FDisabledColorTo write SetDisabledColorTo default clBtnFace;
|
|
property DisabledGradientDirection: TFillDirection read FDisabledGradientDirection write SetDisabledGradientDirection default fdTopToBottom;
|
|
property GlyphLayout: TButtonLayout read FGlyphLayout write SetGlyphLayout default blGlyphLeft;
|
|
property Divider: Boolean read FDivider write SetDivider default False;
|
|
property ShowFocus: Boolean read FShowFocus write SetShowFocus default False;
|
|
end;
|
|
|
|
TJvTabControl = class(TJvExTabControl)
|
|
private
|
|
FTabPainter: TJvTabControlPainter;
|
|
FRightClickSelect: Boolean;
|
|
{$IFDEF VCL}
|
|
procedure CMDialogKey(var Msg: TWMKey); message CM_DIALOGKEY;
|
|
procedure WMRButtonDown(var Msg: TWMRButtonDown); message WM_RBUTTONDOWN;
|
|
{$ENDIF VCL}
|
|
procedure SetTabPainter(const Value: TJvTabControlPainter); // not WantKeys
|
|
protected
|
|
{$IFDEF VisualCLX}
|
|
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
|
|
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
|
|
function DrawTab(TabIndex: Integer; const Rect: TRect; Active: Boolean): Boolean; override;
|
|
{$ENDIF VisualCLX}
|
|
{$IFDEF VCL}
|
|
procedure DrawTab(TabIndex: Integer; const Rect: TRect; Active: Boolean); override;
|
|
{$ENDIF VCL}
|
|
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
published
|
|
property RightClickSelect: Boolean read FRightClickSelect write FRightClickSelect default False;
|
|
property TabPainter: TJvTabControlPainter read FTabPainter write SetTabPainter;
|
|
property HintColor;
|
|
property OnMouseEnter;
|
|
property OnMouseLeave;
|
|
property OnParentColorChange;
|
|
property Color;
|
|
end;
|
|
|
|
TJvPageControl = class(TJvExPageControl)
|
|
private
|
|
FClientBorderWidth: TBorderWidth;
|
|
FHideAllTabs: Boolean;
|
|
FHandleGlobalTab: Boolean;
|
|
FHintSource: TJvHintSource;
|
|
FReduceMemoryUse: Boolean;
|
|
FTabPainter: TJvTabControlPainter;
|
|
FRightClickSelect: Boolean;
|
|
procedure SetClientBorderWidth(const Value: TBorderWidth);
|
|
{$IFDEF VCL}
|
|
procedure TCMAdjustRect(var Msg: TMessage); message TCM_ADJUSTRECT;
|
|
{$ENDIF VCL}
|
|
procedure SetHideAllTabs(const Value: Boolean);
|
|
function FormKeyPreview: Boolean;
|
|
procedure SetReduceMemoryUse(const Value: Boolean);
|
|
procedure SetTabPainter(const Value: TJvTabControlPainter);
|
|
protected
|
|
function HintShow(var HintInfo: THintInfo): Boolean; override;
|
|
function WantKey(Key: Integer; Shift: TShiftState;
|
|
const KeyText: WideString): Boolean; override;
|
|
|
|
procedure Loaded; override;
|
|
function CanChange: Boolean; override;
|
|
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
|
|
{$IFDEF VisualCLX}
|
|
function DrawTab(TabIndex: Integer; const Rect: TRect; Active: Boolean): Boolean; override;
|
|
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
|
|
X, Y: Integer); override;
|
|
{$ENDIF VisualCLX}
|
|
{$IFDEF VCL}
|
|
procedure DrawTab(TabIndex: Integer; const Rect: TRect; Active: Boolean); override;
|
|
procedure WMLButtonDown(var Msg: TWMLButtonDown); message WM_LBUTTONDOWN;
|
|
procedure WMRButtonDown(var Msg: TWMRButtonDown); message WM_RBUTTONDOWN;
|
|
{$ENDIF VCL}
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
procedure UpdateTabImages;
|
|
published
|
|
property TabPainter: TJvTabControlPainter read FTabPainter write SetTabPainter;
|
|
property HintSource: TJvHintSource read FHintSource write FHintSource default hsDefault;
|
|
property HandleGlobalTab: Boolean read FHandleGlobalTab write FHandleGlobalTab default False;
|
|
property ClientBorderWidth: TBorderWidth read FClientBorderWidth write SetClientBorderWidth default JvDefPageControlBorder;
|
|
property ParentColor;
|
|
property RightClickSelect: Boolean read FRightClickSelect write FRightClickSelect default False;
|
|
property ReduceMemoryUse: Boolean read FReduceMemoryUse write SetReduceMemoryUse default False;
|
|
property HideAllTabs: Boolean read FHideAllTabs write SetHideAllTabs default False;
|
|
property HintColor;
|
|
property OnMouseEnter;
|
|
property OnMouseLeave;
|
|
property OnParentColorChange;
|
|
property Color;
|
|
end;
|
|
|
|
TJvTrackToolTipSide = (tsLeft, tsTop, tsRight, tsBottom);
|
|
TJvTrackToolTipEvent = procedure(Sender: TObject; var ToolTipText: string) of object;
|
|
|
|
TJvTrackBar = class(TJvExTrackBar)
|
|
private
|
|
FOnChanged: TNotifyEvent;
|
|
FShowRange: Boolean;
|
|
{$IFDEF VCL}
|
|
FToolTips: Boolean;
|
|
FToolTipSide: TJvTrackToolTipSide;
|
|
FToolTipText: WideString;
|
|
FOnToolTip: TJvTrackToolTipEvent;
|
|
procedure SetToolTips(const Value: Boolean);
|
|
procedure SetToolTipSide(const Value: TJvTrackToolTipSide);
|
|
procedure WMNotify(var Msg: TWMNotify); message WM_NOTIFY;
|
|
procedure CNHScroll(var Msg: TWMHScroll); message CN_HSCROLL;
|
|
procedure CNVScroll(var Msg: TWMVScroll); message CN_VSCROLL;
|
|
{$ENDIF VCL}
|
|
procedure SetShowRange(const Value: Boolean);
|
|
protected
|
|
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
|
|
{$IFDEF VCL}
|
|
procedure CreateParams(var Params: TCreateParams); override;
|
|
procedure CreateWnd; override;
|
|
procedure InternalSetToolTipSide;
|
|
{$ENDIF VCL}
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
published
|
|
property ShowRange: Boolean read FShowRange write SetShowRange default True;
|
|
{$IFDEF VCL}
|
|
property ToolTips: Boolean read FToolTips write SetToolTips default False;
|
|
property ToolTipSide: TJvTrackToolTipSide read FToolTipSide write SetToolTipSide default tsLeft;
|
|
{$ENDIF VCL}
|
|
property HintColor;
|
|
property OnMouseEnter;
|
|
property OnMouseLeave;
|
|
property OnParentColorChange;
|
|
property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;
|
|
property Color;
|
|
property OnMouseDown;
|
|
property OnMouseMove;
|
|
property OnMouseUp;
|
|
{$IFDEF VCL}
|
|
property OnToolTip: TJvTrackToolTipEvent read FOnToolTip write FOnToolTip;
|
|
{$ENDIF VCL}
|
|
end;
|
|
|
|
{$IFDEF VCL}
|
|
|
|
TJvTreeNode = class(TTreeNode)
|
|
private
|
|
FBold: Boolean;
|
|
FChecked: Boolean;
|
|
FPopupMenu: TPopupMenu;
|
|
FFont: TFont;
|
|
FBrush: TBrush;
|
|
FOnCheckedChange: TNotifyEvent;
|
|
function GetChecked: Boolean;
|
|
procedure SetChecked(Value: Boolean);
|
|
function GetBold: Boolean;
|
|
procedure SetBold(const Value: Boolean);
|
|
procedure SetPopupMenu(const Value: TPopupMenu);
|
|
procedure SetFont(const Value: TFont);
|
|
function GetFont: TFont;
|
|
function GetBrush: TBrush;
|
|
procedure SetBrush(const Value: TBrush);
|
|
protected
|
|
procedure Reinitialize; virtual;
|
|
procedure DoCheckedChange;
|
|
public
|
|
class function CreateEnh(AOwner: TTreeNodes): TJvTreeNode;
|
|
|
|
constructor Create(AOwner: TTreeNodes); {$IFDEF CLR}reintroduce;{$ENDIF} virtual;
|
|
destructor Destroy; override;
|
|
|
|
procedure MoveTo(Destination: TTreeNode; Mode: TNodeAttachMode); override;
|
|
|
|
procedure Assign(Source: TPersistent); override;
|
|
property Checked: Boolean read GetChecked write SetChecked;
|
|
property Bold: Boolean read GetBold write SetBold;
|
|
property Font: TFont read GetFont write SetFont;
|
|
property Brush: TBrush read GetBrush write SetBrush;
|
|
property PopupMenu: TPopupMenu read FPopupMenu write SetPopupMenu;
|
|
|
|
property OnCheckedChange: TNotifyEvent read FOnCheckedChange write FOnCheckedChange;
|
|
end;
|
|
|
|
TPageChangedEvent = procedure(Sender: TObject; Item: TTreeNode; Page: TTabSheet) of object;
|
|
TJvTreeViewComparePageEvent = procedure(Sender: TObject; Page: TTabSheet;
|
|
Node: TTreeNode; var Matches: Boolean) of object;
|
|
TJvTreeViewNodeCheckedChange = procedure(Sender: TObject; Node: TJvTreeNode) of object;
|
|
|
|
TJvTreeView = class(TJvExTreeView)
|
|
private
|
|
FAutoDragScroll: Boolean;
|
|
FClearBeforeSelect: Boolean;
|
|
{$IFDEF COMPILER5}
|
|
FMultiSelect: Boolean;
|
|
{$ENDIF COMPILER5}
|
|
FScrollDirection: Integer;
|
|
FSelectedList: TObjectList;
|
|
FSelectThisNode: Boolean;
|
|
FOnCustomDrawItem: TTVCustomDrawItemEvent;
|
|
FOnEditCancelled: TNotifyEvent;
|
|
FOnSelectionChange: TNotifyEvent;
|
|
FCheckBoxes: Boolean;
|
|
FOnHScroll: TNotifyEvent;
|
|
FOnVScroll: TNotifyEvent;
|
|
FPageControl: TPageControl;
|
|
FOnPage: TPageChangedEvent;
|
|
FOnComparePage: TJvTreeViewComparePageEvent;
|
|
FMenu: TMenu;
|
|
FOldMenuChange: TMenuChangeEvent;
|
|
FMenuDblClick: Boolean;
|
|
FReinitializeTreeNode: Boolean;
|
|
FOnNodeCheckedChange: TJvTreeViewNodeCheckedChange;
|
|
|
|
procedure InternalCustomDrawItem(Sender: TCustomTreeView;
|
|
Node: TTreeNode; State: TCustomDrawState; var DefaultDraw: Boolean);
|
|
function GetSelectedCount: Integer;
|
|
function GetSelectedItem(Index: Integer): TTreeNode;
|
|
{$IFDEF COMPILER5}
|
|
procedure SetMultiSelect(const Value: Boolean);
|
|
{$ENDIF COMPILER5}
|
|
procedure SetScrollDirection(const Value: Integer);
|
|
procedure WMLButtonDown(var Msg: TWMLButtonDown); message WM_LBUTTONDOWN;
|
|
procedure WMTimer(var Msg: TWMTimer); message WM_TIMER;
|
|
procedure WMHScroll(var Msg: TWMHScroll); message WM_HSCROLL;
|
|
procedure WMVScroll(var Msg: TWMVScroll); message WM_VSCROLL;
|
|
function GetItemHeight: Integer;
|
|
procedure SetItemHeight(Value: Integer);
|
|
function GetInsertMarkColor: TColor;
|
|
procedure SetInsertMarkColor(Value: TColor);
|
|
function GetLineColor: TColor;
|
|
procedure SetLineColor(Value: TColor);
|
|
function GetMaxScrollTime: Integer;
|
|
procedure SetMaxScrollTime(const Value: Integer);
|
|
function GetUseUnicode: Boolean;
|
|
procedure SetUseUnicode(const Value: Boolean);
|
|
procedure SetMenu(const Value: TMenu);
|
|
procedure DoMenuChange(Sender: TObject; Source: TMenuItem; Rebuild: Boolean);
|
|
procedure SetPageControl(const Value: TPageControl);
|
|
function GetItemIndex: Integer;
|
|
procedure SetItemIndex(const Value: Integer);
|
|
protected
|
|
procedure DoNodeCheckedChange(Node: TJvTreeNode);
|
|
procedure TreeNodeCheckedChange(Sender: TObject); virtual;
|
|
procedure SetCheckBoxes(const Value: Boolean); virtual;
|
|
|
|
procedure RebuildFromMenu; virtual;
|
|
function IsMenuItemClick(Node: TTreeNode): Boolean;
|
|
function DoComparePage(Page: TTabSheet; Node: TTreeNode): Boolean; virtual;
|
|
function CreateNode: TTreeNode; override;
|
|
procedure CreateParams(var Params: TCreateParams); override;
|
|
procedure CreateWnd; override;
|
|
procedure DestroyWnd; override;
|
|
procedure CNNotify(var Msg: TWMNotify); message CN_NOTIFY;
|
|
procedure WMPaint(var Msg: TMessage); message WM_PAINT;
|
|
procedure Change(Node: TTreeNode); override;
|
|
procedure Delete(Node: TTreeNode); override;
|
|
procedure DoEditCancelled; dynamic;
|
|
procedure DoEnter; override;
|
|
procedure DoExit; override;
|
|
procedure DoEndDrag(Target: TObject; X, Y: Integer); override;
|
|
procedure DoSelectionChange; dynamic;
|
|
procedure DragOver(Source: TObject; X, Y: Integer; State: TDragState;
|
|
var Accept: Boolean); override;
|
|
procedure Edit(const Item: TTVItem); override;
|
|
procedure InvalidateNode(Node: TTreeNode);
|
|
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
|
|
procedure KeyPress(var Key: Char); override;
|
|
procedure ResetPostOperationFlags;
|
|
property ScrollDirection: Integer read FScrollDirection write SetScrollDirection;
|
|
procedure Notification(AComponent: TComponent; Operation: TOperation);
|
|
override;
|
|
procedure DblClick; override;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
procedure ClearSelection; reintroduce;
|
|
function IsNodeSelected(Node: TTreeNode): Boolean;
|
|
procedure InvalidateNodeIcon(Node: TTreeNode);
|
|
procedure InvalidateSelectedItems;
|
|
procedure SelectItem(Node: TTreeNode; Unselect: Boolean = False);
|
|
property SelectedItems[Index: Integer]: TTreeNode read GetSelectedItem;
|
|
property SelectedCount: Integer read GetSelectedCount;
|
|
function GetBold(Node: TTreeNode): Boolean;
|
|
procedure SetBold(Node: TTreeNode; Value: Boolean);
|
|
function GetChecked(Node: TTreeNode): Boolean;
|
|
procedure SetChecked(Node: TTreeNode; Value: Boolean);
|
|
procedure SetNodePopup(Node: TTreeNode; Value: TPopupMenu);
|
|
function GetNodePopup(Node: TTreeNode): TPopupMenu;
|
|
procedure InsertMark(Node: TTreeNode; MarkAfter: Boolean); // TVM_SETINSERTMARK
|
|
procedure RemoveMark;
|
|
|
|
{ Move up the display order }
|
|
function MoveUp(AAbsoluteIndex: Integer; Focus: Boolean = True): Integer;
|
|
{ move down the display order }
|
|
function MoveDown(AAbsoluteIndex: Integer; Focus: Boolean = True): Integer;
|
|
|
|
property InsertMarkColor: TColor read GetInsertMarkColor write SetInsertMarkColor;
|
|
property Checked[Node: TTreeNode]: Boolean read GetChecked write SetChecked;
|
|
property MaxScrollTime: Integer read GetMaxScrollTime write SetMaxScrollTime;
|
|
// UseUnicode should only be changed on Win95 and Win98 that has IE5 or later installed
|
|
property UseUnicode: Boolean read GetUseUnicode write SetUseUnicode default False;
|
|
published
|
|
property LineColor: TColor read GetLineColor write SetLineColor default clDefault;
|
|
property ItemHeight: Integer read GetItemHeight write SetItemHeight default 16;
|
|
property Menu: TMenu read FMenu write SetMenu;
|
|
property MenuDblClick: Boolean read FMenuDblClick write FMenuDblClick default False;
|
|
property HintColor;
|
|
property ItemIndex: Integer read GetItemIndex write SetItemIndex stored False;
|
|
property Checkboxes: Boolean read FCheckBoxes write SetCheckBoxes default False;
|
|
property PageControl: TPageControl read FPageControl write SetPageControl;
|
|
property AutoDragScroll: Boolean read FAutoDragScroll write FAutoDragScroll default False;
|
|
{$IFDEF COMPILER5}
|
|
property MultiSelect: Boolean read FMultiSelect write SetMultiSelect default False;
|
|
{$ENDIF COMPILER5}
|
|
property OnVerticalScroll: TNotifyEvent read FOnVScroll write FOnVScroll;
|
|
property OnHorizontalScroll: TNotifyEvent read FOnHScroll write FOnHScroll;
|
|
property OnPageChanged: TPageChangedEvent read FOnPage write FOnPage;
|
|
property OnComparePage: TJvTreeViewComparePageEvent read FOnComparePage write FOnComparePage;
|
|
property OnMouseEnter;
|
|
property OnMouseLeave;
|
|
property OnParentColorChange;
|
|
property OnCustomDrawItem: TTVCustomDrawItemEvent read FOnCustomDrawItem write FOnCustomDrawItem;
|
|
property OnEditCancelled: TNotifyEvent read FOnEditCancelled write FOnEditCancelled;
|
|
property OnSelectionChange: TNotifyEvent read FOnSelectionChange write FOnSelectionChange;
|
|
|
|
property OnNodeCheckedChange: TJvTreeViewNodeCheckedChange read FOnNodeCheckedChange write FOnNodeCheckedChange;
|
|
end;
|
|
|
|
{$ENDIF VCL}
|
|
|
|
{$IFDEF VisualCLX}
|
|
|
|
{ A fake component which either maps the properties to TTreeView or ignores them. }
|
|
TJvTreeView = class(TJvExTreeView)
|
|
private
|
|
FOnSelectionChange: TNotifyEvent;
|
|
FLineColor: TColor;
|
|
FLastSelection: TTreeNode;
|
|
FHideSelection: Boolean;
|
|
FShowRoot: Boolean;
|
|
procedure SetLineColor(Value: TColor);
|
|
procedure SetHideSelection(Value: Boolean);
|
|
procedure SetShowRoot(Value: Boolean);
|
|
protected
|
|
procedure Change(Node: TTreeNode); override;
|
|
procedure DoSelectionChange; dynamic;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
published
|
|
property HideSelection: Boolean read FHideSelection write SetHideSelection default True;
|
|
property ShowRoot: Boolean read FShowRoot write SetShowRoot default True;
|
|
property LineColor: TColor read FLineColor write SetLineColor default clDefault;
|
|
|
|
property OnSelectionChange: TNotifyEvent read FOnSelectionChange write FOnSelectionChange;
|
|
end;
|
|
|
|
{$ENDIF VisualCLX}
|
|
|
|
{$IFDEF UNITVERSIONING}
|
|
const
|
|
UnitVersioning: TUnitVersionInfo = (
|
|
RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/tags/JVCL3_32/run/JvComCtrls.pas $';
|
|
Revision: '$Revision: 11177 $';
|
|
Date: '$Date: 2007-02-05 13:43:36 +0100 (lun., 05 févr. 2007) $';
|
|
LogPath: 'JVCL\run'
|
|
);
|
|
{$ENDIF UNITVERSIONING}
|
|
|
|
implementation
|
|
|
|
uses
|
|
SysUtils,
|
|
JclStrings,
|
|
JvThemes,
|
|
JvConsts, JvJCLUtils;
|
|
|
|
{$IFDEF VCL}
|
|
|
|
const
|
|
TVIS_CHECKED = $2000;
|
|
|
|
//=== { TJvIPAddressRange } ==================================================
|
|
|
|
constructor TJvIPAddressRange.Create(Control: TWinControl);
|
|
var
|
|
I: Integer;
|
|
begin
|
|
inherited Create;
|
|
FControl := Control;
|
|
for I := Low(FRange) to High(FRange) do
|
|
begin
|
|
FRange[I].Min := 0;
|
|
FRange[I].Max := 255;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvIPAddressRange.AssignTo(Dest: TPersistent);
|
|
begin
|
|
if Dest is TJvIPAddressRange then
|
|
with TJvIPAddressRange(Dest) do
|
|
begin
|
|
FRange := Self.FRange;
|
|
Change(-1);
|
|
end
|
|
else
|
|
inherited AssignTo(Dest);
|
|
end;
|
|
|
|
procedure TJvIPAddressRange.Change(Index: Integer);
|
|
var
|
|
I: Integer;
|
|
|
|
procedure ChangeRange(FieldIndex: Integer);
|
|
begin
|
|
with FRange[FieldIndex] do
|
|
FControl.Perform(IPM_SETRANGE, FieldIndex, MAKEIPRANGE(Min, Max));
|
|
end;
|
|
|
|
begin
|
|
if not FControl.HandleAllocated then
|
|
Exit;
|
|
if Index = -1 then
|
|
for I := Low(FRange) to High(FRange) do
|
|
ChangeRange(I)
|
|
else
|
|
ChangeRange(Index);
|
|
end;
|
|
|
|
function TJvIPAddressRange.GetMaxRange(Index: Integer): Byte;
|
|
begin
|
|
Result := FRange[Index].Max;
|
|
end;
|
|
|
|
function TJvIPAddressRange.GetMinRange(Index: Integer): Byte;
|
|
begin
|
|
Result := FRange[Index].Min;
|
|
end;
|
|
|
|
procedure TJvIPAddressRange.SetMaxRange(const Index: Integer; const Value: Byte);
|
|
begin
|
|
FRange[Index].Max := Value;
|
|
Change(Index);
|
|
end;
|
|
|
|
procedure TJvIPAddressRange.SetMinRange(const Index: Integer; const Value: Byte);
|
|
begin
|
|
FRange[Index].Min := Value;
|
|
Change(Index);
|
|
end;
|
|
|
|
//=== { TJvIPEditControlHelper } =============================================
|
|
|
|
constructor TJvIPEditControlHelper.Create(AIPAddress: TJvIPAddress);
|
|
begin
|
|
inherited Create{$IFDEF CLR}(nil){$ENDIF};
|
|
FHandle := 0;
|
|
FIPAddress := AIPAddress;
|
|
FInstance := MakeObjectInstance(WndProc);
|
|
end;
|
|
|
|
destructor TJvIPEditControlHelper.Destroy;
|
|
begin
|
|
Handle := 0;
|
|
if Assigned(FInstance) then
|
|
FreeObjectInstance(FInstance);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TJvIPEditControlHelper.SetFocus;
|
|
begin
|
|
if FHandle <> 0 then
|
|
begin
|
|
Windows.SetFocus(FHandle);
|
|
SendMessage(FHandle, EM_SETSEL, 0, MaxInt);
|
|
end;
|
|
end;
|
|
|
|
function TJvIPEditControlHelper.Focused: Boolean;
|
|
begin
|
|
if FHandle <> 0 then
|
|
Result := THandle(Windows.GetFocus) = FHandle
|
|
else
|
|
Result := False;
|
|
end;
|
|
|
|
procedure TJvIPEditControlHelper.DefaultHandler(var Msg);
|
|
begin
|
|
with TMessage(Msg) do
|
|
Result := CallWindowProc(FOrgWndProc, FHandle, Msg, WParam, LParam);
|
|
end;
|
|
|
|
procedure TJvIPEditControlHelper.SetHandle(const Value: THandle);
|
|
begin
|
|
if Value <> FHandle then
|
|
begin
|
|
if FHandle <> 0 then
|
|
SetWindowLong(FHandle, GWL_WNDPROC, Integer(FOrgWndProc));
|
|
|
|
FHandle := Value;
|
|
|
|
if FHandle <> 0 then
|
|
begin
|
|
{$IFDEF CLR}
|
|
FOrgWndProc := TFarProc(GetWindowLong(FHandle, GWL_WNDPROC));
|
|
SetWindowLong(FHandle, GWL_WNDPROC, FInstance);
|
|
{$ELSE}
|
|
FOrgWndProc := Pointer(GetWindowLong(FHandle, GWL_WNDPROC));
|
|
SetWindowLong(FHandle, GWL_WNDPROC, Integer(FInstance));
|
|
{$ENDIF CLR}
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvIPEditControlHelper.WndProc(var Msg: TMessage);
|
|
begin
|
|
case Msg.Msg of
|
|
WM_ENABLE:
|
|
if csDesigning in FIPAddress.ComponentState then
|
|
Exit
|
|
else
|
|
begin
|
|
{$IFDEF JVCLThemesEnabled}
|
|
if not FIPAddress.Enabled and ThemeServices.ThemesEnabled then
|
|
begin
|
|
EnableWindow(Handle, True);
|
|
Exit;
|
|
end;
|
|
{$ENDIF JVCLThemesEnabled}
|
|
end;
|
|
WM_DESTROY:
|
|
Handle := 0;
|
|
WM_KEYFIRST..WM_KEYLAST:
|
|
begin
|
|
FIPAddress.Dispatch(Msg);
|
|
if Msg.WParam = VK_TAB then
|
|
Exit;
|
|
end;
|
|
// mouse messages are sent through TJvIPAddress.WMParentNotify
|
|
end;
|
|
Dispatch(Msg);
|
|
end;
|
|
|
|
//=== { TJvIPAddress } =======================================================
|
|
|
|
constructor TJvIPAddress.Create(AOwner: TComponent);
|
|
var
|
|
I: Integer;
|
|
begin
|
|
CheckCommonControl(ICC_INTERNET_CLASSES);
|
|
inherited Create(AOwner);
|
|
ControlStyle := ControlStyle + [csFixedHeight, csReflector];
|
|
|
|
FRange := TJvIPAddressRange.Create(Self);
|
|
FAddressValues := TJvIPAddressValues.Create;
|
|
FAddressValues.OnChange := DoAddressChange;
|
|
FAddressValues.OnChanging := DoAddressChanging;
|
|
FTabThroughFields := True;
|
|
|
|
Color := clWindow;
|
|
ParentColor := False;
|
|
TabStop := True;
|
|
Width := 150;
|
|
AdjustHeight;
|
|
|
|
for I := 0 to High(FEditControls) do
|
|
FEditControls[I] := TJvIPEditControlHelper.Create(Self);
|
|
end;
|
|
|
|
destructor TJvIPAddress.Destroy;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
FreeAndNil(FRange);
|
|
FreeAndNil(FAddressValues);
|
|
inherited Destroy;
|
|
// (ahuser) I don't know why but TWinControl.DestroyWindowHandle raises an AV
|
|
// when FEditControls are released before inherited Destroy.
|
|
for I := 0 to High(FEditControls) do
|
|
FEditControls[I].Free;
|
|
end;
|
|
|
|
procedure TJvIPAddress.CreateParams(var Params: TCreateParams);
|
|
begin
|
|
InitCommonControl(ICC_INTERNET_CLASSES);
|
|
inherited CreateParams(Params);
|
|
CreateSubClass(Params, WC_IPADDRESS);
|
|
with Params do
|
|
begin
|
|
Style := Style or WS_CHILD;
|
|
WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
|
|
end;
|
|
end;
|
|
|
|
procedure TJvIPAddress.CreateWnd;
|
|
var
|
|
EditHandle: THandle;
|
|
Msg: TWMParentNotify;
|
|
begin
|
|
ClearEditControls;
|
|
FChanging := True;
|
|
try
|
|
inherited CreateWnd;
|
|
FRange.Change(-1);
|
|
if FSaveBlank then
|
|
ClearAddress
|
|
else
|
|
begin
|
|
Perform(IPM_SETADDRESS, 0, FAddress);
|
|
FAddressValues.Address := FAddress;
|
|
end;
|
|
if (FEditControlCount = 0) and (csDesigning in ComponentState) then
|
|
begin
|
|
// WM_PARENTNOTIFY messages are captured by the IDE starting when
|
|
// CreateWnd is called the second time. So we must find the edit controls
|
|
// ourself and simulate a WM_PARENTNOTIFY by a direct function call.
|
|
EditHandle := 0;
|
|
repeat
|
|
EditHandle := FindWindowEx(Handle, EditHandle, 'EDIT', nil);
|
|
if EditHandle <> 0 then
|
|
begin
|
|
Msg.Msg := WM_PARENTNOTIFY;
|
|
Msg.Event := WM_CREATE;
|
|
Msg.ChildID := GetDlgCtrlID(EditHandle);
|
|
Msg.ChildWnd := EditHandle;
|
|
WMParentNotify(Msg); // IDE captures WM_PARENTNOTIFY
|
|
end;
|
|
until EditHandle = 0;
|
|
end;
|
|
finally
|
|
FChanging := False;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvIPAddress.DestroyLocalFont;
|
|
begin
|
|
if FLocalFont <> 0 then
|
|
begin
|
|
OSCheck(DeleteObject(FLocalFont));
|
|
FLocalFont := 0;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvIPAddress.DestroyWnd;
|
|
begin
|
|
FSaveBlank := IsBlank;
|
|
inherited DestroyWnd;
|
|
end;
|
|
|
|
// Type used to get access to FindNextControl outside Forms.pas
|
|
// This allows to fix Mantis 2812
|
|
type
|
|
TWinControlAccess = class(TWinControl)
|
|
public
|
|
function FindNextControl(CurControl: TWinControl;
|
|
GoForward, CheckTabStop, CheckParent: Boolean): TWinControl;
|
|
end;
|
|
|
|
function TWinControlAccess.FindNextControl(CurControl: TWinControl;
|
|
GoForward, CheckTabStop, CheckParent: Boolean): TWinControl;
|
|
begin
|
|
Result := inherited FindNextControl(CurControl, GoForward, CheckTabStop, CheckParent);
|
|
end;
|
|
|
|
procedure TJvIPAddress.SelectTabControl(Previous: Boolean);
|
|
var
|
|
Control: TWinControl;
|
|
ParentForm: TCustomForm;
|
|
begin
|
|
ParentForm := GetParentForm(Self);
|
|
if Assigned(ParentForm) then
|
|
begin
|
|
// Must use GetParentForm to fix Mantis 2812, where it wasn't possible
|
|
// to tab outside the control
|
|
{$IFDEF CLR}
|
|
Control := TWinControl(ParentForm.GetType.GetMethod('FindNextControl').Invoke(ParentForm, [Self, not Previous, True, False]));
|
|
{$ELSE}
|
|
Control := TWinControlAccess(ParentForm).FindNextControl(Self, not Previous, True, False); //True);
|
|
{$ENDIF CLR}
|
|
if Control <> nil then
|
|
Control.SetFocus;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvIPAddress.WMKeyDown(var Msg: TWMKeyDown);
|
|
var
|
|
I, FocusIndex: Integer;
|
|
begin
|
|
if Msg.CharCode = VK_TAB then
|
|
begin
|
|
FocusIndex := -1;
|
|
for I := 0 to FEditControlCount - 1 do
|
|
begin
|
|
if FEditControls[I].Focused then
|
|
begin
|
|
FocusIndex := I;
|
|
Break;
|
|
end;
|
|
end;
|
|
|
|
if GetKeyState(VK_SHIFT) < 0 then
|
|
Dec(FocusIndex)
|
|
else
|
|
Inc(FocusIndex);
|
|
|
|
if FocusIndex >= 0 then
|
|
begin
|
|
if FocusIndex < FEditControlCount then
|
|
FEditControls[FocusIndex].SetFocus
|
|
else
|
|
SelectTabControl(False);
|
|
end
|
|
else
|
|
if FocusIndex = -1 then
|
|
SelectTabControl(True);
|
|
end
|
|
else
|
|
inherited;
|
|
end;
|
|
|
|
procedure TJvIPAddress.WMKeyUp(var Msg: TWMKeyUp);
|
|
begin
|
|
if Msg.CharCode = VK_TAB then
|
|
Msg.Result := 0
|
|
else
|
|
inherited;
|
|
end;
|
|
|
|
function TJvIPAddress.DoEraseBackground(Canvas: TCanvas; Param: Integer): Boolean;
|
|
begin
|
|
Canvas.Brush.Color := Color;
|
|
Canvas.FillRect(ClientRect);
|
|
Result := True;
|
|
end;
|
|
|
|
procedure TJvIPAddress.Paint;
|
|
var
|
|
I: Integer;
|
|
R1, R2: TRect;
|
|
X, Y: Integer;
|
|
Pt: TPoint;
|
|
begin
|
|
{ We paint the '.' ourself so we can also paint the control's background in
|
|
DoEraseBackground what would be impossible without self-painting because
|
|
the IP-Control always paints a clWindow background in WM_PAINT. }
|
|
for I := 0 to (FEditControlCount - 1) - 1 do
|
|
begin
|
|
GetWindowRect(FEditControls[I].Handle, R1);
|
|
GetWindowRect(FEditControls[I + 1].Handle, R2);
|
|
X := R1.Right + (R2.Left - R1.Right) div 2;
|
|
Y := R1.Top;
|
|
Pt := ScreenToClient(Point(X, Y));
|
|
Canvas.Font.Color := Font.Color;
|
|
Canvas.Brush.Color := Color;
|
|
Canvas.TextOut(Pt.X, Pt.Y, '.');
|
|
end;
|
|
end;
|
|
|
|
procedure TJvIPAddress.AdjustHeight;
|
|
var
|
|
DC: HDC;
|
|
SaveFont: HFONT;
|
|
// I: Integer;
|
|
// R: TRect;
|
|
Metrics: TTextMetric;
|
|
begin
|
|
DC := GetDC(HWND_DESKTOP);
|
|
SaveFont := SelectObject(DC, Font.Handle);
|
|
GetTextMetrics(DC, Metrics);
|
|
SelectObject(DC, SaveFont);
|
|
ReleaseDC(HWND_DESKTOP, DC);
|
|
Height := Metrics.tmHeight + (GetSystemMetrics(SM_CYBORDER) * 8);
|
|
{ for I := 0 to FEditControlCount - 1 do
|
|
begin
|
|
GetWindowRect(FEditControls[I].Handle, R);
|
|
R.TopLeft := ScreenToClient(R.TopLeft);
|
|
R.BottomRight := ScreenToClient(R.BottomRight);
|
|
OffsetRect(R, -R.Left, -R.Top);
|
|
R.Bottom := ClientHeight;
|
|
SetWindowPos(FEditControls[I].Handle, 0, 0, 0, R.Right, R.Bottom,
|
|
SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE);
|
|
end;}
|
|
end;
|
|
|
|
procedure TJvIPAddress.AdjustSize;
|
|
begin
|
|
inherited AdjustSize;
|
|
RecreateWnd;
|
|
end;
|
|
|
|
procedure TJvIPAddress.ClearAddress;
|
|
begin
|
|
if HandleAllocated then
|
|
Perform(IPM_CLEARADDRESS, 0, 0);
|
|
FAddressValues.Address := 0;
|
|
end;
|
|
|
|
procedure TJvIPAddress.ClearEditControls;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
for I := 0 to High(FEditControls) do
|
|
if FEditControls[I] <> nil then
|
|
FEditControls[I].Handle := 0;
|
|
FEditControlCount := 0;
|
|
end;
|
|
|
|
procedure TJvIPAddress.ColorChanged;
|
|
begin
|
|
inherited ColorChanged;
|
|
Invalidate;
|
|
end;
|
|
|
|
procedure TJvIPAddress.FontChanged;
|
|
begin
|
|
inherited FontChanged;
|
|
AdjustHeight;
|
|
Invalidate;
|
|
end;
|
|
|
|
procedure TJvIPAddress.EnabledChanged;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
inherited EnabledChanged;
|
|
for I := 0 to High(FEditControls) do
|
|
if (FEditControls[I] <> nil) and (FEditControls[I].Handle <> 0) then
|
|
EnableWindow(FEditControls[I].Handle, Enabled and not (csDesigning in ComponentState));
|
|
end;
|
|
|
|
procedure TJvIPAddress.CNCommand(var Msg: TWMCommand);
|
|
{$IFDEF CLR}
|
|
var
|
|
AddressStruct: record
|
|
Address: Longint;
|
|
end;
|
|
{$ENDIF CLR}
|
|
begin
|
|
with Msg do
|
|
case NotifyCode of
|
|
EN_CHANGE:
|
|
begin
|
|
{$IFDEF CLR}
|
|
Perform(IPM_GETADDRESS, 0, AddressStruct);
|
|
FAddress := AddressStruct.Address;
|
|
{$ELSE}
|
|
Perform(IPM_GETADDRESS, 0, Integer(@FAddress));
|
|
{$ENDIF CLR}
|
|
if not FChanging then
|
|
DoChange;
|
|
end;
|
|
EN_KILLFOCUS:
|
|
begin
|
|
FChanging := True;
|
|
try
|
|
if not IsBlank then
|
|
Perform(IPM_SETADDRESS, 0, FAddress);
|
|
finally
|
|
FChanging := False;
|
|
end;
|
|
end;
|
|
EN_SETFOCUS:
|
|
begin
|
|
FFocusFromField := True;
|
|
try
|
|
// Mantis 2599: Send a WM_SETFOCUS to self so that the
|
|
// OnEnter event (and the other control's OnExit) works.
|
|
// We simply take the precaution to indicate it comes
|
|
// from a field. See WMSetFocus for details
|
|
Perform(WM_SETFOCUS, 0, 0);
|
|
finally
|
|
FFocusFromField := False;
|
|
end;
|
|
end;
|
|
end;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TJvIPAddress.WMSetFocus(var Msg: TWMSetFocus);
|
|
begin
|
|
// if we receive the focus from a field, then it's because
|
|
// of a mouse click. Thus we do nothing or it would prevent
|
|
// the focus from being directly set to the field. Note that
|
|
// doing this does not prevent OnFocus from running, which
|
|
// is what we want.
|
|
if not FFocusFromField then
|
|
inherited;
|
|
end;
|
|
|
|
procedure TJvIPAddress.CNNotify(var Msg: TWMNotify);
|
|
{$IFDEF CLR}
|
|
var
|
|
IPAddr: TNMIPAddress;
|
|
{$ENDIF CLR}
|
|
begin
|
|
{$IFDEF CLR}
|
|
if Msg.NMHdr.code = IPN_FIELDCHANGED then
|
|
begin
|
|
IPAddr := TNMIPAddress(Marshal.PtrToStructure(IntPtr(Msg.OriginalMessage.LParam), TypeOf(TNMIPAddress)));
|
|
with IPAddr do
|
|
if hdr.code = IPN_FIELDCHANGED then
|
|
begin
|
|
DoFieldChange(iField, iValue);
|
|
Marshal.StructureToPtr(TObject(IPAddr), IntPtr(Msg.OriginalMessage.LParam), False);
|
|
end;
|
|
end;
|
|
{$ELSE}
|
|
with Msg, NMHdr^ do
|
|
if code = IPN_FIELDCHANGED then
|
|
with PNMIPAddress(NMHdr)^ do
|
|
DoFieldChange(iField, iValue);
|
|
{$ENDIF CLR}
|
|
inherited;
|
|
end;
|
|
|
|
procedure TJvIPAddress.DoAddressChange(Sender: TObject);
|
|
begin
|
|
Address := FAddressValues.Address;
|
|
end;
|
|
|
|
procedure TJvIPAddress.DoAddressChanging(Sender: TObject; Index: Integer; Value: Byte; var AllowChange: Boolean);
|
|
begin
|
|
AllowChange := (Index > -1) and (Index < 4) and
|
|
(Value >= FRange.FRange[Index].Min) and (Value <= FRange.FRange[Index].Max);
|
|
end;
|
|
|
|
procedure TJvIPAddress.DoChange;
|
|
begin
|
|
if Assigned(FOnChange) then
|
|
FOnChange(Self);
|
|
end;
|
|
|
|
procedure TJvIPAddress.DoFieldChange(FieldIndex: Integer; var FieldValue: Integer);
|
|
begin
|
|
if Assigned(FOnFieldChange) then
|
|
FOnFieldChange(Self, FieldIndex, FRange.FRange[FieldIndex], FieldValue);
|
|
end;
|
|
|
|
function TJvIPAddress.IsBlank: Boolean;
|
|
begin
|
|
Result := False;
|
|
if HandleAllocated then
|
|
Result := SendMessage(Handle, IPM_ISBLANK, 0, 0) <> 0;
|
|
end;
|
|
|
|
procedure TJvIPAddress.SetAddress(const Value: LongWord);
|
|
begin
|
|
if FAddress <> Value then
|
|
begin
|
|
FAddress := Value;
|
|
if HandleAllocated then
|
|
Perform(IPM_SETADDRESS, 0, FAddress);
|
|
FAddressValues.Address := Value;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvIPAddress.SetAddressValues(const Value: TJvIPAddressValues);
|
|
begin
|
|
// (p3) do nothing
|
|
end;
|
|
|
|
procedure TJvIPAddress.UpdateValuesFromString(S: string);
|
|
begin
|
|
with AddressValues do
|
|
begin
|
|
Value1 := StrToIntDef(StrToken(S, '.'), 0);
|
|
Value2 := StrToIntDef(StrToken(S, '.'), 0);
|
|
Value3 := StrToIntDef(StrToken(S, '.'), 0);
|
|
Value4 := StrToIntDef(S, 0);
|
|
end;
|
|
end;
|
|
|
|
{ Added 03/05/2004 by Kai Gossens }
|
|
|
|
procedure TJvIPAddress.WMCtlColorEdit(var Msg: TWMCtlColorEdit);
|
|
var
|
|
DC: HDC;
|
|
begin
|
|
inherited;
|
|
DC := GetDC(Handle);
|
|
try
|
|
Brush.Color := ColorToRGB(Color);
|
|
Brush.Style := bsSolid;
|
|
SetTextColor(DC, ColorToRGB(Font.Color));
|
|
SetBkColor(DC, ColorToRGB(Brush.Color));
|
|
SetTextColor(Msg.ChildDC, ColorToRGB(Font.Color));
|
|
SetBkColor(Msg.ChildDC, ColorToRGB(Brush.Color));
|
|
SetBkMode(Msg.ChildDC, TRANSPARENT);
|
|
finally
|
|
ReleaseDC(Handle, DC);
|
|
end;
|
|
Msg.Result := Brush.Handle;
|
|
end;
|
|
|
|
procedure TJvIPAddress.WMDestroy(var Msg: TWMNCDestroy);
|
|
begin
|
|
DestroyLocalFont;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TJvIPAddress.GetDlgCode(var Code: TDlgCodes);
|
|
begin
|
|
Include(Code, dcWantArrows);
|
|
if FTabThroughFields then
|
|
Include(Code, dcWantTab);
|
|
Exclude(Code, dcNative); // prevent inherited call
|
|
end;
|
|
|
|
procedure TJvIPAddress.WMSetText(var Msg: TWMSetText);
|
|
begin
|
|
// Update the internal values from the message's text
|
|
UpdateValuesFromString(Msg.Text);
|
|
|
|
// really long values for the text crashes the program (try: 127.0.0.8787787878787878), so we limit it here before it is set
|
|
with AddressValues do
|
|
{$IFDEF CLR}
|
|
Msg.Text := Format('%d.%d.%d.%d', [Value1, Value2, Value3, Value4]);
|
|
{$ELSE}
|
|
Msg.Text := PChar(Format('%d.%d.%d.%d', [Value1, Value2, Value3, Value4]));
|
|
{$ENDIF CLR}
|
|
|
|
inherited;
|
|
end;
|
|
|
|
procedure TJvIPAddress.WMGetText(var Msg: TWMGetText);
|
|
begin
|
|
inherited;
|
|
|
|
// Here, we are sure to have the text inside the Text member.
|
|
// It has been retrieved by the intricate message handling of the windows
|
|
// API, we simply use it to update the values of the AddressValues property
|
|
// If we did not do this, then those values would not get updated as reported
|
|
// in Mantis 2986.
|
|
if Assigned(AddressValues) then // prevent designtime AV in BDS 2006
|
|
UpdateValuesFromString(Msg.Text);
|
|
end;
|
|
|
|
procedure TJvIPAddress.WMParentNotify(var Msg: TWMParentNotify);
|
|
begin
|
|
with Msg do
|
|
case Event of
|
|
WM_CREATE:
|
|
if (FEditControlCount <= Length(FEditControls)) and
|
|
(FEditControls[FEditControlCount] <> nil) then
|
|
begin
|
|
FEditControls[FEditControlCount].Handle := ChildWnd;
|
|
EnableWindow(ChildWnd, Enabled and not (csDesigning in ComponentState));
|
|
Inc(FEditControlCount);
|
|
end;
|
|
WM_DESTROY:
|
|
ClearEditControls;
|
|
// (p3) this code prevents the user from dblclicking on any edit field
|
|
// to select it (the first edit is always selected). I don't know if removing
|
|
// it has any side-effects but I haven't noticed anything
|
|
// WM_LBUTTONDOWN, WM_MBUTTONDOWN, WM_RBUTTONDOWN:
|
|
// Perform(Event, Value, Integer(SmallPoint(XPos, YPos)));
|
|
end;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TJvIPAddress.WMSetFont(var Msg: TWMSetFont);
|
|
var
|
|
LF: TLogFont;
|
|
begin
|
|
{$IFNDEF CLR}
|
|
FillChar(LF, SizeOf(TLogFont), #0);
|
|
{$ENDIF CLR}
|
|
try
|
|
{$IFDEF CLR}
|
|
OSCheck(GetObject(Font.Handle, SizeOf(LF), LF) > 0);
|
|
{$ELSE}
|
|
OSCheck(GetObject(Font.Handle, SizeOf(LF), @LF) > 0);
|
|
{$ENDIF CLR}
|
|
DestroyLocalFont;
|
|
FLocalFont := CreateFontIndirect(LF);
|
|
Msg.Font := FLocalFont;
|
|
inherited;
|
|
except
|
|
Application.HandleException(Self);
|
|
end;
|
|
end;
|
|
|
|
{$ENDIF VCL}
|
|
|
|
//=== { TJvTabControlPainter } ===============================================
|
|
|
|
destructor TJvTabControlPainter.Destroy;
|
|
begin
|
|
if FClients <> nil then
|
|
while FClients.Count > 0 do
|
|
UnRegisterChange(TCustomTabControl(FClients.Last));
|
|
FreeAndNil(FClients);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TJvTabControlPainter.Change;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
if FClients <> nil then
|
|
for I := 0 to FClients.Count - 1 do
|
|
TCustomTabControl(FClients[I]).Invalidate;
|
|
end;
|
|
|
|
procedure TJvTabControlPainter.Notification(AComponent: TComponent;
|
|
Operation: TOperation);
|
|
begin
|
|
inherited Notification(AComponent, Operation);
|
|
if (Operation = opRemove) and (AComponent is TCustomTabControl) and (FClients <> nil) then
|
|
FClients.Remove(AComponent);
|
|
end;
|
|
|
|
procedure TJvTabControlPainter.RegisterChange(AControl: TCustomTabControl);
|
|
begin
|
|
if FClients = nil then
|
|
FClients := TList.Create;
|
|
if AControl <> nil then
|
|
begin
|
|
FClients.Add(AControl);
|
|
AControl.FreeNotification(Self);
|
|
AControl.Invalidate;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTabControlPainter.UnRegisterChange(AControl: TCustomTabControl);
|
|
begin
|
|
if FClients <> nil then
|
|
begin
|
|
FClients.Remove(AControl);
|
|
if (AControl <> nil) and not (csDestroying in AControl.ComponentState) then
|
|
AControl.Invalidate;
|
|
end;
|
|
end;
|
|
|
|
//=== { TJvTabDefaultPainter } ===============================================
|
|
|
|
constructor TJvTabDefaultPainter.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
FActiveFont := TFont.Create;
|
|
if Owner is TForm then
|
|
FActiveFont.Assign(TForm(Owner).Font)
|
|
else
|
|
{$IFDEF VCL}
|
|
FActiveFont.Assign(Screen.IconFont);
|
|
{$ENDIF VCL}
|
|
{$IFDEF VisualCLX}
|
|
FActiveFont.Assign(Screen.HintFont);
|
|
{$ENDIF VisualCLX}
|
|
FActiveFont.Color := clHighlight;
|
|
FActiveFont.OnChange := DoFontChange;
|
|
FActiveColorFrom := clWhite;
|
|
FActiveColorTo := clBtnFace;
|
|
FActiveGradientDirection := fdTopToBottom;
|
|
|
|
FDisabledFont := TFont.Create;
|
|
if Owner is TForm then
|
|
FDisabledFont.Assign(TForm(Owner).Font)
|
|
else
|
|
{$IFDEF VCL}
|
|
FDisabledFont.Assign(Screen.IconFont);
|
|
{$ENDIF VCL}
|
|
{$IFDEF VisualCLX}
|
|
FDisabledFont.Assign(Screen.HintFont);
|
|
{$ENDIF VisualCLX}
|
|
FDisabledFont.Color := clGrayText;
|
|
FDisabledFont.OnChange := DoFontChange;
|
|
FDisabledColorFrom := clBtnFace;
|
|
FDisabledColorTo := clBtnFace;
|
|
FDisabledGradientDirection := fdTopToBottom;
|
|
|
|
FInactiveFont := TFont.Create;
|
|
if Owner is TForm then
|
|
FInactiveFont.Assign(TForm(Owner).Font)
|
|
else
|
|
{$IFDEF VCL}
|
|
FInactiveFont.Assign(Screen.IconFont);
|
|
{$ENDIF VCL}
|
|
{$IFDEF VisualCLX}
|
|
FInactiveFont.Assign(Screen.HintFont);
|
|
{$ENDIF VisualCLX}
|
|
FInactiveFont.OnChange := DoFontChange;
|
|
FInactiveColorFrom := JvDefaultInactiveColorFrom;
|
|
FInactiveColorTo := JvDefaultInactiveColorTo;
|
|
FInactiveGradientDirection := fdTopToBottom;
|
|
FGlyphLayout := blGlyphLeft;
|
|
end;
|
|
|
|
destructor TJvTabDefaultPainter.Destroy;
|
|
begin
|
|
FActiveFont.Free;
|
|
FDisabledFont.Free;
|
|
FInactiveFont.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TJvTabDefaultPainter.DoFontChange(Sender: TObject);
|
|
begin
|
|
Change;
|
|
end;
|
|
|
|
procedure TJvTabDefaultPainter.DrawTab(AControl: TCustomTabControl;
|
|
Canvas: TCanvas; Images: TCustomImageList; ImageIndex: Integer;
|
|
const Caption: string; const Rect: TRect; Active, Enabled: Boolean);
|
|
var
|
|
TextRect, ImageRect: TRect;
|
|
SaveState: Integer;
|
|
procedure DrawDivider(X, Y, X1, Y1: Integer);
|
|
begin
|
|
Canvas.Pen.Color := clBtnShadow;
|
|
Canvas.MoveTo(X, Y);
|
|
Canvas.LineTo(X1, Y1);
|
|
Canvas.Pen.Color := clHighlightText;
|
|
Canvas.MoveTo(X + 1, Y + 1);
|
|
Canvas.LineTo(X1 + 1, Y1 + 1);
|
|
end;
|
|
begin
|
|
TextRect := Rect;
|
|
ImageRect := Rect;
|
|
if not Enabled then
|
|
begin
|
|
GradientFillRect(Canvas, TextRect, DisabledColorFrom, DisabledColorTo, DisabledGradientDirection, 255);
|
|
Canvas.Font := DisabledFont;
|
|
end
|
|
else
|
|
if Active then
|
|
begin
|
|
GradientFillRect(Canvas, TextRect, ActiveColorFrom, ActiveColorTo, ActiveGradientDirection, 255);
|
|
Canvas.Font := ActiveFont;
|
|
end
|
|
else
|
|
begin
|
|
GradientFillRect(Canvas, TextRect, InactiveColorFrom, InactiveColorTo, InactiveGradientDirection, 255);
|
|
Canvas.Font := InactiveFont;
|
|
end;
|
|
if Assigned(Images) and (ImageIndex >= 0) and (ImageIndex < Images.Count) then
|
|
begin // GlyphLayout is only used if we have images
|
|
case GlyphLayout of
|
|
blGlyphLeft:
|
|
begin
|
|
Inc(ImageRect.Left, 4);
|
|
ImageRect.Right := ImageRect.Left + Images.Width + 4;
|
|
TextRect.Left := ImageRect.Right;
|
|
end;
|
|
blGlyphRight:
|
|
begin
|
|
Dec(ImageRect.Right, 4);
|
|
ImageRect.Left := ImageRect.Right - Images.Width - 4;
|
|
TextRect.Right := ImageRect.Left;
|
|
end;
|
|
blGlyphTop:
|
|
begin
|
|
Dec(ImageRect.Bottom, RectHeight(Rect) div 2);
|
|
TextRect.Top := ImageRect.Bottom;
|
|
if Divider and (Caption <> '') then
|
|
DrawDivider(Rect.Left + 4 + Ord(Active), Rect.Top + RectHeight(Rect) div 2, Rect.Right - 4 - Ord(Active), Rect.Top + RectHeight(Rect) div 2);
|
|
end;
|
|
blGlyphBottom:
|
|
begin
|
|
Inc(ImageRect.Top, RectHeight(Rect) div 2);
|
|
TextRect.Bottom := ImageRect.Top;
|
|
if Divider and (Caption <> '') then
|
|
DrawDivider(Rect.Left + 4 + Ord(Active), Rect.Top + RectHeight(Rect) div 2, Rect.Right - 4 - Ord(Active), Rect.Top + RectHeight(Rect) div 2);
|
|
end;
|
|
end;
|
|
InflateRect(ImageRect, -(RectWidth(ImageRect) - Images.Width) div 2, -(RectHeight(ImageRect) - Images.Height) div 2);
|
|
SaveState := SaveDC(Canvas.Handle);
|
|
try
|
|
Images.Draw(Canvas, ImageRect.Left, ImageRect.Top, ImageIndex,
|
|
{$IFDEF VisualCLX}
|
|
itImage,
|
|
{$ENDIF VisualCLX}
|
|
Enabled);
|
|
finally
|
|
RestoreDC(Canvas.Handle, SaveState);
|
|
end;
|
|
end;
|
|
if Caption <> '' then
|
|
begin
|
|
// InflateRect(TextRect, -2, -2);
|
|
SetBkMode(Canvas.Handle, TRANSPARENT);
|
|
DrawText(Canvas, Caption, Length(Caption), TextRect, DT_SINGLELINE or DT_CENTER or DT_VCENTER);
|
|
end;
|
|
if Active and ShowFocus then
|
|
begin
|
|
TextRect := Rect;
|
|
InflateRect(TextRect, -3, -3);
|
|
Canvas.DrawFocusRect(TextRect);
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTabDefaultPainter.SetActiveColorFrom(const Value: TColor);
|
|
begin
|
|
if FActiveColorFrom <> Value then
|
|
begin
|
|
FActiveColorFrom := Value;
|
|
Change;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTabDefaultPainter.SetActiveFont(const Value: TFont);
|
|
begin
|
|
FActiveFont.Assign(Value);
|
|
end;
|
|
|
|
procedure TJvTabDefaultPainter.SetActiveColorTo(const Value: TColor);
|
|
begin
|
|
if FActiveColorTo <> Value then
|
|
begin
|
|
FActiveColorTo := Value;
|
|
Change;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTabDefaultPainter.SetActiveGradientDirection(
|
|
const Value: TFillDirection);
|
|
begin
|
|
if FActiveGradientDirection <> Value then
|
|
begin
|
|
FActiveGradientDirection := Value;
|
|
Change;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTabDefaultPainter.SetDisabledColorFrom(const Value: TColor);
|
|
begin
|
|
if FDisabledColorFrom <> Value then
|
|
begin
|
|
FDisabledColorFrom := Value;
|
|
Change;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTabDefaultPainter.SetDisabledColorTo(const Value: TColor);
|
|
begin
|
|
if FDisabledColorTo <> Value then
|
|
begin
|
|
FDisabledColorTo := Value;
|
|
Change;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTabDefaultPainter.SetDisabledFont(const Value: TFont);
|
|
begin
|
|
FDisabledFont.Assign(Value);
|
|
end;
|
|
|
|
procedure TJvTabDefaultPainter.SetDisabledGradientDirection(
|
|
const Value: TFillDirection);
|
|
begin
|
|
if FDisabledGradientDirection <> Value then
|
|
begin
|
|
FDisabledGradientDirection := Value;
|
|
Change;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTabDefaultPainter.SetInactiveColorFrom(const Value: TColor);
|
|
begin
|
|
if FInactiveColorFrom <> Value then
|
|
begin
|
|
FInactiveColorFrom := Value;
|
|
Change;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTabDefaultPainter.SetInactiveColorTo(const Value: TColor);
|
|
begin
|
|
if FInactiveColorTo <> Value then
|
|
begin
|
|
FInactiveColorTo := Value;
|
|
Change;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTabDefaultPainter.SetInactiveFont(const Value: TFont);
|
|
begin
|
|
FInactiveFont.Assign(Value);
|
|
end;
|
|
|
|
procedure TJvTabDefaultPainter.SetInactiveGradientDirection(const Value: TFillDirection);
|
|
begin
|
|
if FInactiveGradientDirection <> Value then
|
|
begin
|
|
FInactiveGradientDirection := Value;
|
|
Change;
|
|
end;
|
|
end;
|
|
|
|
function TJvTabDefaultPainter.IsActiveFontStored: Boolean;
|
|
begin
|
|
Result := True;
|
|
end;
|
|
|
|
function TJvTabDefaultPainter.IsDisabledFontStored: Boolean;
|
|
begin
|
|
Result := True;
|
|
end;
|
|
|
|
function TJvTabDefaultPainter.IsInactiveFontStored: Boolean;
|
|
begin
|
|
Result := True;
|
|
end;
|
|
|
|
procedure TJvTabDefaultPainter.SetGlyphLayout(const Value: TButtonLayout);
|
|
begin
|
|
if FGlyphLayout <> Value then
|
|
begin
|
|
FGlyphLayout := Value;
|
|
Change;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTabDefaultPainter.SetDivider(const Value: Boolean);
|
|
begin
|
|
if FDivider <> Value then
|
|
begin
|
|
FDivider := Value;
|
|
Change;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTabDefaultPainter.SetShowFocus(const Value: Boolean);
|
|
begin
|
|
if FShowFocus <> Value then
|
|
begin
|
|
FShowFocus := Value;
|
|
Change;
|
|
end;
|
|
end;
|
|
|
|
//=== { TJvTabControl } ======================================================
|
|
|
|
constructor TJvTabControl.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
{$IFDEF VisualCLX}
|
|
InputKeys := [ikTabs];
|
|
{$ENDIF VisualCLX}
|
|
end;
|
|
|
|
{$IFDEF VCL}
|
|
|
|
procedure TJvTabControl.CMDialogKey(var Msg: TWMKey);
|
|
begin
|
|
if (Msg.CharCode = VK_TAB) and (GetKeyState(VK_CONTROL) < 0) and
|
|
IsChild(Handle, Windows.GetFocus) then
|
|
begin
|
|
if GetKeyState(VK_SHIFT) < 0 then
|
|
begin
|
|
if TabIndex = 0 then
|
|
TabIndex := Tabs.Count - 1
|
|
else
|
|
TabIndex := TabIndex - 1;
|
|
end
|
|
else
|
|
TabIndex := (TabIndex + 1) mod Tabs.Count;
|
|
Msg.Result := 1;
|
|
end
|
|
else
|
|
inherited;
|
|
end;
|
|
|
|
procedure TJvTabControl.WMRButtonDown(var Msg: TWMRButtonDown);
|
|
var
|
|
I: Integer;
|
|
R: TRect;
|
|
P: TPoint;
|
|
begin
|
|
if RightClickSelect then
|
|
begin
|
|
with Msg do
|
|
P := SmallPointToPoint(SmallPoint(XPos,YPos));
|
|
for I := 0 to Tabs.Count -1 do
|
|
begin
|
|
R := TabRect(I);
|
|
if PtInRect(R, P) then
|
|
begin
|
|
if (TabIndex <> I) and CanChange then
|
|
begin
|
|
TabIndex := I;
|
|
Change;
|
|
end;
|
|
Break;
|
|
end;
|
|
end;
|
|
end;
|
|
inherited;
|
|
end;
|
|
|
|
{$ENDIF VCL}
|
|
|
|
{$IFDEF VisualCLX}
|
|
|
|
procedure TJvTabControl.KeyDown(var Key: Word; Shift: TShiftState);
|
|
begin
|
|
if (Key = VK_TAB) and (Shift * KeyboardShiftStates >= [ssCtrl]) then
|
|
begin
|
|
if (Shift * KeyboardShiftStates >= [ssShift]) then
|
|
begin
|
|
if TabIndex = 0 then
|
|
TabIndex := Tabs.Count - 1
|
|
else
|
|
TabIndex := TabIndex - 1;
|
|
end
|
|
else
|
|
TabIndex := (TabIndex + 1) mod Tabs.Count;
|
|
Key := 0;
|
|
end
|
|
else
|
|
inherited KeyDown(Key, Shift);
|
|
end;
|
|
|
|
procedure TJvTabControl.MouseDown(Button: TMouseButton; Shift: TShiftState;
|
|
X, Y: Integer);
|
|
var
|
|
I: Integer;
|
|
R: TRect;
|
|
P: TPoint;
|
|
begin
|
|
if RightClickSelect and (Button = mbRight) then
|
|
begin
|
|
P := Point(X,Y);
|
|
for I := 0 to Tabs.Count -1 do
|
|
begin
|
|
R := TabRect(I);
|
|
if PtInRect(R, P) then
|
|
begin
|
|
if (TabIndex <> I) and CanChange then
|
|
begin
|
|
TabIndex := I;
|
|
Change;
|
|
end;
|
|
Break;
|
|
end;
|
|
end;
|
|
end;
|
|
inherited MouseDown(Button, Shift, X, Y);
|
|
end;
|
|
|
|
function TJvTabControl.DrawTab(TabIndex: Integer; const Rect: TRect; Active: Boolean): Boolean;
|
|
begin
|
|
Result := True;
|
|
if Assigned(TabPainter) then
|
|
TabPainter.DrawTab(Self, Canvas, Images, GetImageIndex(TabIndex), Tabs[TabIndex].Caption, Rect, TabIndex = Self.TabIndex, Enabled)
|
|
else
|
|
Result := inherited DrawTab(TabIndex, Rect, Active);
|
|
end;
|
|
|
|
{$ENDIF VisualCLX}
|
|
|
|
{$IFDEF VCL}
|
|
procedure TJvTabControl.DrawTab(TabIndex: Integer; const Rect: TRect; Active: Boolean);
|
|
begin
|
|
if Assigned(TabPainter) then
|
|
TabPainter.DrawTab(Self, Canvas, Images, GetImageIndex(TabIndex), Tabs[TabIndex], Rect, TabIndex = Self.TabIndex, Enabled)
|
|
else
|
|
inherited DrawTab(TabIndex, Rect, Active);
|
|
end;
|
|
{$ENDIF VCL}
|
|
|
|
procedure TJvTabControl.Notification(AComponent: TComponent;
|
|
Operation: TOperation);
|
|
begin
|
|
inherited Notification(AComponent, Operation);
|
|
if (Operation = opRemove) and (AComponent = TabPainter) then
|
|
TabPainter := nil;
|
|
|
|
end;
|
|
|
|
procedure TJvTabControl.SetTabPainter(const Value: TJvTabControlPainter);
|
|
begin
|
|
if FTabPainter <> Value then
|
|
begin
|
|
if FTabPainter <> nil then
|
|
FTabPainter.UnRegisterChange(Self);
|
|
FTabPainter := Value;
|
|
if FTabPainter <> nil then
|
|
begin
|
|
FTabPainter.FreeNotification(Self);
|
|
FTabPainter.RegisterChange(Self);
|
|
end;
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
//=== { TJvPageControl } =====================================================
|
|
|
|
constructor TJvPageControl.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
FClientBorderWidth := JvDefPageControlBorder;
|
|
FHintSource := hsDefault;
|
|
end;
|
|
|
|
function TJvPageControl.FormKeyPreview: Boolean;
|
|
var
|
|
F: TCustomForm;
|
|
begin
|
|
F := GetParentForm(Self);
|
|
if F <> nil then
|
|
Result := F.KeyPreview
|
|
else
|
|
Result := False;
|
|
end;
|
|
|
|
function TJvPageControl.WantKey(Key: Integer; Shift: TShiftState;
|
|
const KeyText: WideString): Boolean;
|
|
var
|
|
ThisTab, Tab: TTabSheet;
|
|
Forwrd: Boolean;
|
|
begin
|
|
Result := False;
|
|
if HandleGlobalTab and not FormKeyPreview and
|
|
(Key = VK_TAB) and (Shift * KeyboardShiftStates >= [ssCtrl]) then
|
|
begin
|
|
ThisTab := ActivePage;
|
|
Forwrd := (Shift * KeyboardShiftStates >= [ssShift]);
|
|
Tab := ThisTab;
|
|
repeat
|
|
Tab := FindNextPage(Tab, Forwrd, True);
|
|
until (Tab = nil) or Tab.Enabled or (Tab = ThisTab);
|
|
if Tab <> ThisTab then
|
|
begin
|
|
if CanChange then
|
|
begin
|
|
ActivePage := Tab;
|
|
Result := True;
|
|
Change;
|
|
end;
|
|
Exit;
|
|
end;
|
|
end;
|
|
Result := inherited WantKey(Key, Shift, KeyText);
|
|
end;
|
|
|
|
{$IFDEF VCL}
|
|
procedure TJvPageControl.DrawTab(TabIndex: Integer; const Rect: TRect;
|
|
Active: Boolean);
|
|
{$ENDIF VCL}
|
|
{$IFDEF VisualCLX}
|
|
function TJvPageControl.DrawTab(TabIndex: Integer; const Rect: TRect;
|
|
Active: Boolean): Boolean;
|
|
{$ENDIF VisualCLX}
|
|
var
|
|
I, RealIndex: Integer;
|
|
begin
|
|
{$IFDEF VisualCLX}
|
|
Result := False;
|
|
{$ENDIF VisualCLX}
|
|
if TabPainter <> nil then
|
|
begin
|
|
RealIndex := 0;
|
|
I := 0;
|
|
while I <= TabIndex + RealIndex do
|
|
begin
|
|
if not Pages[I].TabVisible then
|
|
Inc(RealIndex);
|
|
Inc(I);
|
|
end;
|
|
RealIndex := RealIndex + TabIndex;
|
|
if RealIndex < PageCount then
|
|
TabPainter.DrawTab(Self, Canvas, Images, Pages[RealIndex].ImageIndex, Pages[RealIndex].Caption, Rect, Active, Pages[RealIndex].Enabled);
|
|
end
|
|
else
|
|
{$IFDEF VisualCLX} Result := {$ENDIF} inherited DrawTab(TabIndex, Rect, Active);
|
|
end;
|
|
|
|
procedure TJvPageControl.Loaded;
|
|
begin
|
|
inherited Loaded;
|
|
HideAllTabs := FHideAllTabs;
|
|
end;
|
|
|
|
procedure TJvPageControl.SetClientBorderWidth(const Value: TBorderWidth);
|
|
begin
|
|
if FClientBorderWidth <> Value then
|
|
begin
|
|
FClientBorderWidth := Value;
|
|
RecreateWnd;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvPageControl.SetHideAllTabs(const Value: Boolean);
|
|
var
|
|
I: Integer;
|
|
SaveActivePage: TTabSheet;
|
|
begin
|
|
FHideAllTabs := Value;
|
|
if (csDesigning in ComponentState) then
|
|
Exit;
|
|
if HandleAllocated then
|
|
begin
|
|
SaveActivePage := ActivePage;
|
|
for I := 0 to PageCount - 1 do
|
|
Pages[I].TabVisible := Pages[I].TabVisible and not FHideAllTabs;
|
|
ActivePage := SaveActivePage;
|
|
if FHideAllTabs and (SaveActivePage <> nil) then
|
|
SaveActivePage.TabStop := False;
|
|
end;
|
|
end;
|
|
|
|
{$IFDEF VCL}
|
|
procedure TJvPageControl.TCMAdjustRect(var Msg: TMessage);
|
|
var
|
|
Offset: Integer;
|
|
{$IFDEF CLR}
|
|
M: TTCMAdjustRect;
|
|
R: TRect;
|
|
{$ENDIF CLR}
|
|
begin
|
|
inherited;
|
|
if (Msg.WParam = 0) and (FClientBorderWidth <> JvDefPageControlBorder) then
|
|
begin
|
|
Offset := JvDefPageControlBorder - FClientBorderWidth;
|
|
{$IFDEF CLR}
|
|
M := TTCMAdjustRect.Create(Msg);
|
|
R := M.Prc;
|
|
InflateRect(R, Offset, Offset);
|
|
M.Prc := R;
|
|
{$ELSE}
|
|
InflateRect(PRect(Msg.LParam)^, Offset, Offset);
|
|
{$ENDIF CLR}
|
|
end;
|
|
end;
|
|
{$ENDIF VCL}
|
|
|
|
procedure TJvPageControl.UpdateTabImages;
|
|
begin
|
|
inherited UpdateTabImages;
|
|
end;
|
|
|
|
{$IFDEF VCL}
|
|
procedure TJvPageControl.WMLButtonDown(var Msg: TWMLButtonDown);
|
|
var
|
|
hi: TTCHitTestInfo;
|
|
I, TabIndex, RealIndex: Integer;
|
|
begin
|
|
if csDesigning in ComponentState then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
hi.pt.X := Msg.XPos;
|
|
hi.pt.Y := Msg.YPos;
|
|
hi.flags := 0;
|
|
{$IFDEF CLR}
|
|
TabIndex := Perform(TCM_HITTEST, 0, hi);
|
|
{$ELSE}
|
|
TabIndex := Perform(TCM_HITTEST, 0, Longint(@hi));
|
|
{$ENDIF CLR}
|
|
I := 0;
|
|
RealIndex := 0;
|
|
while I <= TabIndex + RealIndex do
|
|
begin
|
|
if not Pages[I].TabVisible then
|
|
Inc(RealIndex);
|
|
Inc(I);
|
|
end;
|
|
RealIndex := RealIndex + TabIndex;
|
|
if (RealIndex < PageCount) and (RealIndex >= 0) and ((hi.flags and TCHT_ONITEM) <> 0) then
|
|
if not Pages[RealIndex].Enabled then
|
|
begin
|
|
Msg.Result := 0;
|
|
Exit;
|
|
end;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TJvPageControl.WMRButtonDown(var Msg: TWMRButtonDown);
|
|
var
|
|
I: Integer;
|
|
R: TRect;
|
|
P: TPoint;
|
|
begin
|
|
if RightClickSelect then
|
|
begin
|
|
with Msg do
|
|
P := SmallPointToPoint(SmallPoint(XPos, YPos));
|
|
for I := 0 to PageCount -1 do
|
|
begin
|
|
R := TabRect(I);
|
|
if PtInRect(R, P) then
|
|
begin
|
|
if (ActivePageIndex <> I) and CanChange then
|
|
begin
|
|
ActivePageIndex := I;
|
|
Change;
|
|
end;
|
|
Break;
|
|
end;
|
|
end;
|
|
end;
|
|
inherited;
|
|
end;
|
|
|
|
{$ENDIF VCL}
|
|
|
|
function TJvPageControl.HintShow(var HintInfo: THintInfo): Boolean;
|
|
var
|
|
TabNo: Integer;
|
|
Tab: TTabSheet;
|
|
begin
|
|
Result := inherited HintShow(HintInfo);
|
|
|
|
if (FHintSource = hsDefault) or Result or (Self <> HintInfo.HintControl) then
|
|
Exit;
|
|
|
|
(*
|
|
hsDefault, // use default hint behaviour (i.e as regular control)
|
|
hsForceMain, // use the main controls hint even if subitems have hints
|
|
hsForceChildren, // always use subitems hints even if empty and main control has hint
|
|
hsPreferMain, // use main control hint unless empty then use subitems hints
|
|
hsPreferChildren // use subitems hints unless empty then use main control hint
|
|
);
|
|
*)
|
|
|
|
with HintInfo.CursorPos do
|
|
TabNo := IndexOfTabAt(X, Y); // X&Y are expected in Client coordinates
|
|
|
|
if (TabNo >= 0) and (TabNo < PageCount) then
|
|
Tab := Pages[TabNo]
|
|
else
|
|
Tab := nil;
|
|
if (FHintSource = hsForceMain) or ((FHintSource = hsPreferMain) and (GetShortHint(Hint) <> '')) then
|
|
HintInfo.HintStr := GetShortHint(Self.Hint)
|
|
else
|
|
if (Tab <> nil) and
|
|
((FHintSource = hsForceChildren) or ((FHintSource = hsPreferChildren) and (GetShortHint(Tab.Hint) <> '')) or
|
|
((FHintSource = hsPreferMain) and (GetShortHint(Hint) = ''))) then
|
|
begin
|
|
HintInfo.HintStr := GetShortHint(Tab.Hint);
|
|
HintInfo.CursorRect := TabRect(TabNo);
|
|
end;
|
|
end;
|
|
|
|
type
|
|
TTabSheetAccessProtected = class(TTabSheet);
|
|
|
|
function TJvPageControl.CanChange: Boolean;
|
|
begin
|
|
Result := inherited CanChange;
|
|
if Result and (ActivePage <> nil) and ReduceMemoryUse then
|
|
{$IFDEF CLR}
|
|
ActivePage.GetType.InvokeMember('DestroyHandle', BindingFlags.NonPublic or BindingFlags.InvokeMethod, nil, ActivePage, []);
|
|
{$ELSE}
|
|
TTabSheetAccessProtected(ActivePage).DestroyHandle;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TJvPageControl.SetReduceMemoryUse(const Value: Boolean);
|
|
begin
|
|
FReduceMemoryUse := Value;
|
|
end;
|
|
|
|
procedure TJvPageControl.SetTabPainter(const Value: TJvTabControlPainter);
|
|
begin
|
|
if FTabPainter <> Value then
|
|
begin
|
|
if FTabPainter <> nil then
|
|
FTabPainter.UnRegisterChange(Self);
|
|
FTabPainter := Value;
|
|
if FTabPainter <> nil then
|
|
begin
|
|
FTabPainter.FreeNotification(Self);
|
|
FTabPainter.RegisterChange(Self);
|
|
end;
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvPageControl.Notification(AComponent: TComponent;
|
|
Operation: TOperation);
|
|
begin
|
|
inherited Notification(AComponent, Operation);
|
|
if (Operation = opRemove) and (AComponent = TabPainter) then
|
|
TabPainter := nil;
|
|
end;
|
|
|
|
{$IFDEF VisualCLX}
|
|
procedure TJvPageControl.MouseDown(Button: TMouseButton;
|
|
Shift: TShiftState; X, Y: Integer);
|
|
var
|
|
I: Integer;
|
|
R: TRect;
|
|
P: TPoint;
|
|
begin
|
|
if RightClickSelect and (Button = mbRight) then
|
|
begin
|
|
P := Point(X,Y);
|
|
for I := 0 to PageCount -1 do
|
|
begin
|
|
R := TabRect(I);
|
|
if PtInRect(R, P) then
|
|
begin
|
|
if (ActivePageIndex <> I) and CanChange then
|
|
begin
|
|
ActivePageIndex := I;
|
|
Change;
|
|
end;
|
|
Break;
|
|
end;
|
|
end;
|
|
end;
|
|
inherited MouseDown(Button, Shift, X, Y);
|
|
end;
|
|
{$ENDIF VisualCLX}
|
|
|
|
//=== { TJvTrackBar } ========================================================
|
|
|
|
constructor TJvTrackBar.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
// ControlStyle := ControlStyle + [csAcceptsControls];
|
|
{$IFDEF VCL}
|
|
FToolTipSide := tsLeft;
|
|
{$ENDIF VCL}
|
|
FShowRange := True;
|
|
end;
|
|
|
|
{$IFDEF VCL}
|
|
|
|
procedure TJvTrackBar.CNHScroll(var Msg: TWMHScroll);
|
|
begin
|
|
if Msg.ScrollCode <> SB_ENDSCROLL then
|
|
inherited;
|
|
end;
|
|
|
|
procedure TJvTrackBar.CNVScroll(var Msg: TWMVScroll);
|
|
begin
|
|
if Msg.ScrollCode <> SB_ENDSCROLL then
|
|
inherited;
|
|
end;
|
|
|
|
procedure TJvTrackBar.CreateParams(var Params: TCreateParams);
|
|
begin
|
|
inherited CreateParams(Params);
|
|
with Params do
|
|
begin
|
|
if FToolTips and (GetComCtlVersion >= ComCtlVersionIE3) then
|
|
Style := Style or TBS_TOOLTIPS;
|
|
// (p3) this stolen from Rudy Velthuis's ExTrackBar
|
|
if not ShowRange then
|
|
Style := Style and not TBS_ENABLESELRANGE;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTrackBar.CreateWnd;
|
|
begin
|
|
inherited CreateWnd;
|
|
InternalSetToolTipSide;
|
|
end;
|
|
|
|
procedure TJvTrackBar.InternalSetToolTipSide;
|
|
const
|
|
ToolTipSides: array [TJvTrackToolTipSide] of DWORD =
|
|
(TBTS_LEFT, TBTS_TOP, TBTS_RIGHT, TBTS_BOTTOM);
|
|
begin
|
|
if HandleAllocated and (GetComCtlVersion >= ComCtlVersionIE3) then
|
|
SendMessage(Handle, TBM_SETTIPSIDE, ToolTipSides[FToolTipSide], 0);
|
|
end;
|
|
|
|
{$ENDIF VCL}
|
|
|
|
procedure TJvTrackBar.MouseUp(Button: TMouseButton; Shift: TShiftState;
|
|
X, Y: Integer);
|
|
begin
|
|
inherited MouseUp(Button, Shift, X, Y);
|
|
if Assigned(FOnChanged) then
|
|
FOnChanged(Self);
|
|
end;
|
|
|
|
procedure TJvTrackBar.SetShowRange(const Value: Boolean);
|
|
begin
|
|
if FShowRange <> Value then
|
|
begin
|
|
FShowRange := Value;
|
|
RecreateWnd;
|
|
end;
|
|
end;
|
|
|
|
{$IFDEF VCL}
|
|
procedure TJvTrackBar.SetToolTips(const Value: Boolean);
|
|
begin
|
|
if FToolTips <> Value then
|
|
begin
|
|
FToolTips := Value;
|
|
RecreateWnd;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTrackBar.SetToolTipSide(const Value: TJvTrackToolTipSide);
|
|
begin
|
|
if FToolTipSide <> Value then
|
|
begin
|
|
FToolTipSide := Value;
|
|
InternalSetToolTipSide;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTrackBar.WMNotify(var Msg: TWMNotify);
|
|
var
|
|
ToolTipTextLocal: string;
|
|
{$IFDEF CLR}
|
|
DispInfo: TNMTTDispInfo;
|
|
{$ENDIF CLR}
|
|
begin
|
|
if (Msg.NMHdr.code = TTN_NEEDTEXTW) and Assigned(FOnToolTip) then
|
|
begin
|
|
{$IFDEF CLR}
|
|
DispInfo := TNMTTDispInfo(Marshal.PtrToStructure(IntPtr(Msg.OriginalMessage.LParam), TypeOf(TNMTTDispInfo)));
|
|
with DispInfo do
|
|
begin
|
|
hinst := 0;
|
|
ToolTipTextLocal := IntToStr(Position);
|
|
FOnToolTip(Self, ToolTipTextLocal);
|
|
FToolTipText := ToolTipTextLocal;
|
|
lpszText := FToolTipText;
|
|
szText := #0;
|
|
Msg.Result := 1;
|
|
|
|
Marshal.StructureToPtr(TObject(DispInfo), IntPtr(Msg.OriginalMessage.LParam), False);
|
|
end;
|
|
{$ELSE}
|
|
with PNMTTDispInfoW(Msg.NMHdr)^ do
|
|
begin
|
|
hinst := 0;
|
|
ToolTipTextLocal := IntToStr(Position);
|
|
FOnToolTip(Self, ToolTipTextLocal);
|
|
FToolTipText := ToolTipTextLocal;
|
|
lpszText := PWideChar(FToolTipText);
|
|
FillChar(szText, SizeOf(szText), #0);
|
|
Msg.Result := 1;
|
|
end;
|
|
{$ENDIF CLR}
|
|
end
|
|
else
|
|
inherited;
|
|
end;
|
|
{$ENDIF VCL}
|
|
|
|
{$IFDEF VCL}
|
|
//=== { TJvTreeNode } ========================================================
|
|
|
|
class function TJvTreeNode.CreateEnh(AOwner: TTreeNodes): TJvTreeNode;
|
|
begin
|
|
Result := Create(AOwner);
|
|
|
|
// (obones): There is no need to create a popup for every single node, it even
|
|
// triggers Mantis 2582
|
|
// Result.FPopupMenu := TPopupMenu.Create(AOwner.Owner);
|
|
end;
|
|
|
|
constructor TJvTreeNode.Create(AOwner: TTreeNodes);
|
|
begin
|
|
inherited Create(AOwner);
|
|
|
|
FFont := nil;
|
|
FBrush := nil;
|
|
end;
|
|
|
|
destructor TJvTreeNode.Destroy;
|
|
begin
|
|
FFont.Free;
|
|
FBrush.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TJvTreeNode.DoCheckedChange;
|
|
begin
|
|
if Assigned(OnCheckedChange) then
|
|
OnCheckedChange(Self);
|
|
end;
|
|
|
|
procedure TJvTreeNode.Assign(Source: TPersistent);
|
|
begin
|
|
inherited Assign(Source);
|
|
if Source is TJvTreeNode then
|
|
begin
|
|
Checked := TJvTreeNode(Source).Checked;
|
|
Bold := TJvTreeNode(Source).Bold;
|
|
PopupMenu := TJvTreeNode(Source).PopupMenu;
|
|
Brush := TJvTreeNode(Source).Brush;
|
|
Font := TJvTreeNode(Source).Font;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTreeNode.SetPopupMenu(const Value: TPopupMenu);
|
|
begin
|
|
FPopupMenu := Value;
|
|
end;
|
|
|
|
procedure TJvTreeNode.SetFont(const Value: TFont);
|
|
begin
|
|
Font.Assign(Value);
|
|
end;
|
|
|
|
function TJvTreeNode.GetFont: TFont;
|
|
begin
|
|
if not Assigned(FFont) then
|
|
begin
|
|
FFont := TFont.Create;
|
|
if Assigned(Owner) and (TreeView is TJvExTreeView) then
|
|
FFont.Assign(TJvExTreeView(TreeView).Font);
|
|
end;
|
|
|
|
Result := FFont;
|
|
end;
|
|
|
|
function TJvTreeNode.GetBrush: TBrush;
|
|
begin
|
|
if not Assigned(FBrush) then
|
|
begin
|
|
FBrush := TBrush.Create;
|
|
if Assigned(Owner) and (TreeView is TJvExTreeView) then
|
|
FBrush.Assign(TJvExTreeView(TreeView).Brush);
|
|
end;
|
|
|
|
Result := FBrush;
|
|
end;
|
|
|
|
procedure TJvTreeNode.SetBrush(const Value: TBrush);
|
|
begin
|
|
Brush.Assign(Value);
|
|
end;
|
|
|
|
function TJvTreeNode.GetBold: Boolean;
|
|
var
|
|
Item: TTVItem;
|
|
begin
|
|
with Item do
|
|
begin
|
|
mask := TVIF_STATE;
|
|
hItem := ItemId;
|
|
if TreeView_GetItem(Handle, Item) then
|
|
Result := ((Item.State and TVIS_BOLD) = TVIS_BOLD)
|
|
else
|
|
Result := False;
|
|
end;
|
|
end;
|
|
|
|
function TJvTreeNode.GetChecked: Boolean;
|
|
var
|
|
Item: TTVItem;
|
|
begin
|
|
with Item do
|
|
begin
|
|
mask := TVIF_STATE;
|
|
hItem := ItemId;
|
|
if TreeView_GetItem(Handle, Item) then
|
|
Result := ((Item.State and TVIS_CHECKED) = TVIS_CHECKED)
|
|
else
|
|
Result := False;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTreeNode.SetBold(const Value: Boolean);
|
|
var
|
|
Item: TTVItem;
|
|
begin
|
|
if Value <> FBold then
|
|
begin
|
|
FBold := Value;
|
|
{$IFNDEF CLR}
|
|
FillChar(Item, SizeOf(Item), 0);
|
|
{$ENDIF !CLR}
|
|
with Item do
|
|
begin
|
|
mask := TVIF_STATE;
|
|
hItem := ItemId;
|
|
StateMask := TVIS_BOLD;
|
|
if Value then
|
|
Item.State := TVIS_BOLD
|
|
else
|
|
Item.State := 0;
|
|
TreeView_SetItem(Handle, Item);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTreeNode.SetChecked(Value: Boolean);
|
|
var
|
|
Item: TTVItem;
|
|
begin
|
|
if Value <> FChecked then
|
|
begin
|
|
FChecked := Value;
|
|
{$IFNDEF CLR}
|
|
FillChar(Item, SizeOf(Item), 0);
|
|
{$ENDIF !CLR}
|
|
with Item do
|
|
begin
|
|
hItem := ItemId;
|
|
mask := TVIF_STATE;
|
|
StateMask := TVIS_STATEIMAGEMASK;
|
|
if Value then
|
|
Item.State := TVIS_CHECKED
|
|
else
|
|
Item.State := TVIS_CHECKED shr 1;
|
|
TreeView_SetItem(Handle, Item);
|
|
end;
|
|
DoCheckedChange;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTreeNode.MoveTo(Destination: TTreeNode;
|
|
Mode: TNodeAttachMode);
|
|
var
|
|
SaveItem, Item: TTVItem;
|
|
begin
|
|
// Mantis 3028: We need to save the state of he item as the
|
|
// inherited MoveTo calls Assign on a newly created TVItem.
|
|
// Hence, the state is reset and lost, putting Bold and Checked
|
|
// to False. We could save those two properties, but it's better
|
|
// to save the state, because we may have other properties inside
|
|
// it in the future.
|
|
{$IFNDEF CLR}
|
|
FillChar(SaveItem, SizeOf(SaveItem), 0);
|
|
{$ENDIF !CLR}
|
|
SaveItem.hItem := ItemId;
|
|
SaveItem.mask := TVIF_STATE;
|
|
TreeView_GetItem(Handle, SaveItem);
|
|
|
|
inherited MoveTo(Destination, Mode);
|
|
|
|
{$IFNDEF CLR}
|
|
FillChar(Item, SizeOf(Item), 0);
|
|
{$ENDIF !CLR}
|
|
Item.hItem := ItemId;
|
|
Item.mask := TVIF_STATE;
|
|
Item.stateMask := TVIS_STATEIMAGEMASK;
|
|
Item.state := SaveItem.state;
|
|
TreeView_SetItem(Handle, Item);
|
|
end;
|
|
|
|
procedure TJvTreeNode.Reinitialize;
|
|
begin
|
|
if FChecked <> GetChecked then
|
|
begin
|
|
FChecked := not FChecked;
|
|
SetChecked(not FChecked);
|
|
end;
|
|
end;
|
|
|
|
//=== { TJvTreeView } ========================================================
|
|
|
|
const
|
|
AutoScrollMargin = 20;
|
|
AutoScrollTimerID = 100;
|
|
|
|
constructor TJvTreeView.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
FCheckBoxes := False;
|
|
// ControlStyle := ControlStyle + [csAcceptsControls];
|
|
FSelectedList := TObjectList.Create(False);
|
|
// Since IsCustomDrawn method is not virtual we have to assign ancestor's
|
|
// OnCustomDrawItem event to enable custom drawing
|
|
if not (csDesigning in ComponentState) then
|
|
inherited OnCustomDrawItem := InternalCustomDrawItem;
|
|
end;
|
|
|
|
destructor TJvTreeView.Destroy;
|
|
begin
|
|
FreeAndNil(FSelectedList);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TJvTreeView.Change(Node: TTreeNode);
|
|
begin
|
|
if FClearBeforeSelect then
|
|
begin
|
|
FClearBeforeSelect := False;
|
|
ClearSelection;
|
|
end;
|
|
if FSelectThisNode then
|
|
begin
|
|
FSelectThisNode := False;
|
|
SelectItem(Node);
|
|
end;
|
|
inherited Change(Node);
|
|
if not MenuDblClick and IsMenuItemClick(Node) then
|
|
TMenuItem(Node.Data).OnClick(TMenuItem(Node.Data));
|
|
end;
|
|
|
|
procedure TJvTreeView.ClearSelection;
|
|
var
|
|
NeedInvalidate: array of TTreeNode;
|
|
I: Integer;
|
|
begin
|
|
FClearBeforeSelect := False;
|
|
if not Assigned(FSelectedList) or (FSelectedList.Count = 0) then
|
|
Exit;
|
|
DoSelectionChange;
|
|
SetLength(NeedInvalidate, FSelectedList.Count);
|
|
for I := 0 to FSelectedList.Count - 1 do
|
|
NeedInvalidate[I] := SelectedItems[I];
|
|
FSelectedList.Clear;
|
|
for I := 0 to Length(NeedInvalidate) - 1 do
|
|
InvalidateNode(NeedInvalidate[I]);
|
|
end;
|
|
|
|
function TJvTreeView.CreateNode: TTreeNode;
|
|
begin
|
|
Result := TJvTreeNode.CreateEnh(Items);
|
|
(Result as TJvTreeNode).OnCheckedChange := TreeNodeCheckedChange;
|
|
end;
|
|
|
|
procedure TJvTreeView.CreateParams(var Params: TCreateParams);
|
|
begin
|
|
inherited CreateParams(Params);
|
|
|
|
// Mantis 3351: Recreating the window for adding the TVS_CHECKBOXES
|
|
// parameter seems to trigger a bug in ComCtrl where it will show a
|
|
// scroll bar that has nothing to do here. Setting the GWL_STYLE window
|
|
// long shows the checkboxes and does not trigger this bug.
|
|
{ if FCheckBoxes then
|
|
Params.Style := Params.Style or TVS_CHECKBOXES;}
|
|
end;
|
|
|
|
procedure TJvTreeView.CreateWnd;
|
|
begin
|
|
FReinitializeTreeNode := True;
|
|
inherited CreateWnd;
|
|
end;
|
|
|
|
procedure TJvTreeView.DestroyWnd;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
// update the FChecked field with the current data
|
|
for I := 0 to Items.Count - 1 do
|
|
TJvTreeNode(Items[I]).FChecked := TJvTreeNode(Items[I]).Checked;
|
|
inherited DestroyWnd;
|
|
end;
|
|
|
|
procedure TJvTreeView.Delete(Node: TTreeNode);
|
|
begin
|
|
if MultiSelect then
|
|
FSelectedList.Remove(Node);
|
|
inherited Delete(Node);
|
|
end;
|
|
|
|
procedure TJvTreeView.DoEditCancelled;
|
|
begin
|
|
if Assigned(FOnEditCancelled) then
|
|
FOnEditCancelled(Self);
|
|
end;
|
|
|
|
procedure TJvTreeView.DoEndDrag(Target: TObject; X, Y: Integer);
|
|
begin
|
|
ScrollDirection := 0;
|
|
inherited DoEndDrag(Target, X, Y);
|
|
end;
|
|
|
|
procedure TJvTreeView.DoEnter;
|
|
begin
|
|
InvalidateSelectedItems;
|
|
inherited DoEnter;
|
|
end;
|
|
|
|
procedure TJvTreeView.DoExit;
|
|
begin
|
|
InvalidateSelectedItems;
|
|
inherited DoExit;
|
|
end;
|
|
|
|
procedure TJvTreeView.DoSelectionChange;
|
|
begin
|
|
if Assigned(FOnSelectionChange) then
|
|
FOnSelectionChange(Self);
|
|
end;
|
|
|
|
procedure TJvTreeView.DragOver(Source: TObject; X, Y: Integer;
|
|
State: TDragState; var Accept: Boolean);
|
|
begin
|
|
inherited DragOver(Source, X, Y, State, Accept);
|
|
if not FAutoDragScroll then
|
|
Exit;
|
|
if Y < AutoScrollMargin then
|
|
ScrollDirection := -1
|
|
else
|
|
if Y > ClientHeight - AutoScrollMargin then
|
|
ScrollDirection := 1
|
|
else
|
|
ScrollDirection := 0;
|
|
end;
|
|
|
|
procedure TJvTreeView.Edit(const Item: TTVItem);
|
|
begin
|
|
inherited Edit(Item);
|
|
if Item.pszText = nil then
|
|
DoEditCancelled;
|
|
end;
|
|
|
|
function TJvTreeView.GetBold(Node: TTreeNode): Boolean;
|
|
begin
|
|
Result := TJvTreeNode(Node).Bold;
|
|
end;
|
|
|
|
function TJvTreeView.GetChecked(Node: TTreeNode): Boolean;
|
|
begin
|
|
Result := TJvTreeNode(Node).Checked;
|
|
end;
|
|
|
|
function TJvTreeView.GetNodePopup(Node: TTreeNode): TPopupMenu;
|
|
begin
|
|
Result := TJvTreeNode(Node).PopupMenu;
|
|
end;
|
|
|
|
function TJvTreeView.GetSelectedCount: Integer;
|
|
begin
|
|
if MultiSelect then
|
|
Result := FSelectedList.Count
|
|
else
|
|
Result := -1;
|
|
end;
|
|
|
|
function TJvTreeView.GetSelectedItem(Index: Integer): TTreeNode;
|
|
begin
|
|
Result := TTreeNode(FSelectedList[Index]);
|
|
end;
|
|
|
|
function TJvTreeView.GetItemIndex: Integer;
|
|
begin
|
|
Result := -1;
|
|
if Assigned(Selected) and (Items.Count>0) then
|
|
begin
|
|
Result := 0;
|
|
while (Result<Items.Count) and (Items[Result] <> Selected) do
|
|
Inc(Result);
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTreeView.InternalCustomDrawItem(Sender: TCustomTreeView;
|
|
Node: TTreeNode; State: TCustomDrawState; var DefaultDraw: Boolean);
|
|
begin
|
|
if (State = []) or (State = [cdsDefault]) or (State = [cdsSelected]) then
|
|
begin
|
|
Canvas.Font := TJvTreeNode(Node).Font;
|
|
Canvas.Brush := TJvTreeNode(Node).Brush;
|
|
end;
|
|
|
|
if MultiSelect then
|
|
begin
|
|
with Canvas.Font do
|
|
begin // fix HotTrack bug in custom drawing
|
|
OnChange(nil);
|
|
if cdsHot in State then
|
|
begin
|
|
Style := Style + [fsUnderLine];
|
|
if cdsSelected in State then
|
|
Color := clHighlightText
|
|
else
|
|
Color := clHighlight;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
// Mantis 3250: This needs to be done wether we are multiselecting or not
|
|
// but it forces the rest of the code to ensure that the list of selected
|
|
// nodes is consistent with the desired display (see CNNotify).
|
|
if IsNodeSelected(Node) then
|
|
begin
|
|
if Focused then
|
|
begin
|
|
Canvas.Font.Color := clHighlightText;
|
|
Canvas.Brush.Color := clHighlight;
|
|
end
|
|
else
|
|
if not HideSelection then
|
|
begin
|
|
Canvas.Font.Color := Font.Color;
|
|
Canvas.Brush.Color := clInactiveBorder;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
Canvas.Font.Color := Font.Color;
|
|
Canvas.Brush.Color := Color;
|
|
end;
|
|
|
|
if Assigned(FOnCustomDrawItem) then
|
|
FOnCustomDrawItem(Self, Node, State, DefaultDraw);
|
|
end;
|
|
|
|
procedure TJvTreeView.InvalidateNode(Node: TTreeNode);
|
|
var
|
|
R: TRect;
|
|
begin
|
|
if Assigned(Node) and Node.IsVisible then
|
|
begin
|
|
R := Node.DisplayRect(True);
|
|
InvalidateRect(Handle, {$IFNDEF CLR}@{$ENDIF} R, False);
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTreeView.InvalidateNodeIcon(Node: TTreeNode);
|
|
var
|
|
R: TRect;
|
|
begin
|
|
if Assigned(Node) and Assigned(Images) and Node.IsVisible then
|
|
begin
|
|
R := Node.DisplayRect(True);
|
|
R.Right := R.Left;
|
|
R.Left := R.Left - Images.Width * 3;
|
|
InvalidateRect(Handle, {$IFNDEF CLR}@{$ENDIF} R, True);
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTreeView.InvalidateSelectedItems;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
if HandleAllocated then
|
|
for I := 0 to SelectedCount - 1 do
|
|
InvalidateNode(SelectedItems[I]);
|
|
end;
|
|
|
|
function TJvTreeView.IsNodeSelected(Node: TTreeNode): Boolean;
|
|
begin
|
|
Result := FSelectedList.IndexOf(Node) <> -1;
|
|
end;
|
|
|
|
procedure TJvTreeView.KeyDown(var Key: Word; Shift: TShiftState);
|
|
begin
|
|
if MultiSelect then
|
|
begin
|
|
ResetPostOperationFlags;
|
|
if not (ssAlt in Shift) and not IsEditing then
|
|
begin
|
|
if Key = VK_SPACE then
|
|
SelectItem(Selected, IsNodeSelected(Selected))
|
|
else
|
|
begin
|
|
FSelectThisNode := True;
|
|
if Shift * [ssShift, ssCtrl] = [] then
|
|
FClearBeforeSelect := True;
|
|
end;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
FClearBeforeSelect := True;
|
|
FSelectThisNode := True;
|
|
end;
|
|
inherited KeyDown(Key, Shift);
|
|
if ((Key = VK_SPACE) or (Key = VK_RETURN)) and MenuDblClick and IsMenuItemClick(Selected) then
|
|
TMenuItem(Selected.Data).OnClick(TMenuItem(Selected.Data));
|
|
end;
|
|
|
|
procedure TJvTreeView.KeyPress(var Key: Char);
|
|
begin
|
|
if MultiSelect and (Key = ' ') and not IsEditing then
|
|
Key := #0
|
|
else
|
|
inherited KeyPress(Key);
|
|
end;
|
|
|
|
procedure TJvTreeView.ResetPostOperationFlags;
|
|
begin
|
|
FClearBeforeSelect := False;
|
|
FSelectThisNode := not MultiSelect;
|
|
end;
|
|
|
|
procedure TJvTreeView.SetItemIndex(const Value: Integer);
|
|
begin
|
|
if Value = -1 then
|
|
Selected := nil
|
|
else
|
|
Selected := Items[Value];
|
|
end;
|
|
|
|
procedure TJvTreeView.SelectItem(Node: TTreeNode; Unselect: Boolean);
|
|
begin
|
|
if Unselect then
|
|
FSelectedList.Remove(Node)
|
|
else
|
|
if not IsNodeSelected(Node) then
|
|
FSelectedList.Add(Node);
|
|
if HandleAllocated then
|
|
InvalidateNode(Node);
|
|
DoSelectionChange;
|
|
end;
|
|
|
|
procedure TJvTreeView.SetBold(Node: TTreeNode; Value: Boolean);
|
|
begin
|
|
TJvTreeNode(Node).Bold := Value;
|
|
end;
|
|
|
|
procedure TJvTreeView.DoNodeCheckedChange(Node: TJvTreeNode);
|
|
begin
|
|
if Assigned(OnNodeCheckedChange) then
|
|
OnNodeCheckedChange(Self, Node);
|
|
end;
|
|
|
|
procedure TJvTreeView.TreeNodeCheckedChange(Sender: TObject);
|
|
begin
|
|
DoNodeCheckedChange(Sender as TJvTreeNode);
|
|
end;
|
|
|
|
procedure TJvTreeView.SetCheckBoxes(const Value: Boolean);
|
|
{$IFDEF VisualCLX}
|
|
const
|
|
cNewType: array [Boolean] of TListViewItemType = (itDefault, itCheckBox);
|
|
{$ENDIF VisualCLX}
|
|
{$IFDEF VCL}
|
|
var
|
|
CurStyle: Integer;
|
|
{$ENDIF VCL}
|
|
begin
|
|
if FCheckBoxes <> Value then
|
|
begin
|
|
FCheckBoxes := Value;
|
|
{$IFDEF VCL}
|
|
// Mantis 3351: Recreating the window for adding the TVS_CHECKBOXES
|
|
// parameter seems to trigger a bug in ComCtrl where it will show a
|
|
// scroll bar that has nothing to do here. Setting the GWL_STYLE window
|
|
// long shows the checkboxes and does not trigger this bug.
|
|
//RecreateWnd;
|
|
|
|
HandleNeeded;
|
|
CurStyle := GetWindowLong(Handle, GWL_STYLE);
|
|
if FCheckBoxes then
|
|
SetWindowLong(Handle, GWL_STYLE, CurStyle or TVS_CHECKBOXES)
|
|
else
|
|
SetWindowLong(Handle, GWL_STYLE, CurStyle and not TVS_CHECKBOXES)
|
|
{$ENDIF VCL}
|
|
{$IFDEF VisualCLX}
|
|
Items.ChangeItemTypes(cNewType[FCheckBoxes]);
|
|
Selected := nil;
|
|
{$ENDIF VisualCLX}
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTreeView.SetChecked(Node: TTreeNode; Value: Boolean);
|
|
begin
|
|
TJvTreeNode(Node).Checked := Value;
|
|
end;
|
|
|
|
{$IFDEF COMPILER5}
|
|
procedure TJvTreeView.SetMultiSelect(const Value: Boolean);
|
|
begin
|
|
if FMultiSelect <> Value then
|
|
begin
|
|
FMultiSelect := Value;
|
|
ResetPostOperationFlags;
|
|
ClearSelection;
|
|
end;
|
|
end;
|
|
{$ENDIF COMPILER5}
|
|
|
|
procedure TJvTreeView.SetNodePopup(Node: TTreeNode; Value: TPopupMenu);
|
|
begin
|
|
TJvTreeNode(Node).PopupMenu := Value;
|
|
end;
|
|
|
|
procedure TJvTreeView.SetScrollDirection(const Value: Integer);
|
|
begin
|
|
if FScrollDirection <> Value then
|
|
begin
|
|
if Value = 0 then
|
|
KillTimer(Handle, AutoScrollTimerID)
|
|
else
|
|
if (Value <> 0) and (FScrollDirection = 0) then
|
|
SetTimer(Handle, AutoScrollTimerID, 200, nil);
|
|
FScrollDirection := Value;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTreeView.WMHScroll(var Msg: TWMHScroll);
|
|
begin
|
|
inherited;
|
|
if Assigned(FOnHScroll) then
|
|
FOnHScroll(Self);
|
|
end;
|
|
|
|
procedure TJvTreeView.WMLButtonDown(var Msg: TWMLButtonDown);
|
|
var
|
|
Node: TTreeNode;
|
|
FirstNodeIndex, I: Integer;
|
|
begin
|
|
ResetPostOperationFlags;
|
|
with Msg do
|
|
if (htOnItem in GetHitTestInfoAt(XPos, YPos)) then
|
|
begin
|
|
if MultiSelect then
|
|
begin
|
|
Node := GetNodeAt(XPos, YPos);
|
|
if Assigned(Node) and (ssCtrl in KeysToShiftState(Keys)) then
|
|
begin
|
|
SelectItem(Node, IsNodeSelected(Node));
|
|
end
|
|
else
|
|
if Assigned(Node) and (ssShift in KeysToShiftState(Keys)) then
|
|
begin
|
|
FirstNodeIndex := 0;
|
|
|
|
{$IFDEF COMPILER6_UP}
|
|
if SelectionCount > 0 then
|
|
FirstNodeIndex := Selections[0].Index;
|
|
{ELSE}
|
|
if Assigned(Selected) then
|
|
FirstNodeIndex := Selected.Index;
|
|
{$ENDIF COMPILER6_UP}
|
|
|
|
ClearSelection;
|
|
if FirstNodeIndex < Node.Index then
|
|
begin
|
|
for I := FirstNodeIndex to Node.Index do
|
|
SelectItem(Items[I]);
|
|
end
|
|
else
|
|
begin
|
|
for I := FirstNodeIndex downto Node.Index do
|
|
SelectItem(Items[I]);
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
ClearSelection;
|
|
SelectItem(Node);
|
|
end;
|
|
end;
|
|
end;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TJvTreeView.WMPaint(var Msg: TMessage);
|
|
var
|
|
I: Integer;
|
|
begin
|
|
inherited;
|
|
{ The tree node's checked property is reset at the first WM_PAINT.
|
|
So we must set it here again, but only the first time. }
|
|
if FReinitializeTreeNode then
|
|
begin
|
|
FReinitializeTreeNode := False;
|
|
for I := 0 to Items.Count - 1 do
|
|
TJvTreeNode(Items[I]).Reinitialize;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTreeView.CNNotify(var Msg: TWMNotify);
|
|
var
|
|
Node: TTreeNode;
|
|
Point: TPoint;
|
|
I, J: Integer;
|
|
begin
|
|
// Need to indicate ClearBeforeSelect if the item is about to change
|
|
// or we would get rendering glitches because of an inconsistent
|
|
// selection list. (Mantis 3250)
|
|
case Msg.NMHdr.code of
|
|
TVN_SELCHANGEDA, TVN_SELCHANGEDW:
|
|
if not Multiselect then
|
|
FClearBeforeSelect := True;
|
|
end;
|
|
|
|
inherited;
|
|
if Windows.GetCursorPos(Point) then // prevent AV after "computer locked" dialog
|
|
begin
|
|
Point := ScreenToClient(Point);
|
|
with Msg, Point do
|
|
case NMHdr.code of
|
|
NM_CLICK, NM_RCLICK:
|
|
begin
|
|
Node := GetNodeAt(X, Y);
|
|
if Assigned(Node) then
|
|
Selected := Node
|
|
else
|
|
begin
|
|
if FCheckBoxes then
|
|
begin
|
|
Node := GetNodeAt(X + 16, Y);
|
|
if Assigned(Node) then
|
|
Selected := Node
|
|
end;
|
|
end;
|
|
if (Selected <> nil) and (NMHdr.code = NM_RCLICK) then
|
|
if Assigned(TJvTreeNode(Selected).PopupMenu) then // Popup menu may not be assigned
|
|
TJvTreeNode(Selected).PopupMenu.Popup(Mouse.CursorPos.X, Mouse.CursorPos.Y);
|
|
end;
|
|
TVN_SELCHANGEDA, TVN_SELCHANGEDW:
|
|
if Assigned(FPageControl) then
|
|
if Selected <> nil then
|
|
begin
|
|
//Search for the correct page
|
|
J := -1;
|
|
for I := 0 to FPageControl.PageCount - 1 do
|
|
if DoComparePage(FPageControl.Pages[I], Selected) then
|
|
J := I;
|
|
if J <> -1 then
|
|
begin
|
|
FPageControl.ActivePage := FPageControl.Pages[J];
|
|
if Assigned(FOnPage) then
|
|
FOnPage(Self, Selected, FPageControl.Pages[J]);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TJvTreeView.DoComparePage(Page: TTabSheet; Node: TTreeNode): Boolean;
|
|
begin
|
|
if Assigned(FOnComparePage) then
|
|
FOnComparePage(Self, Page, Node, Result)
|
|
else
|
|
Result := AnsiSameText(Page.Caption, Node.Text);
|
|
end;
|
|
|
|
procedure TJvTreeView.WMTimer(var Msg: TWMTimer);
|
|
var
|
|
DragImages: TDragImageList;
|
|
begin
|
|
if Msg.TimerID = AutoScrollTimerID then
|
|
begin
|
|
DragImages := GetDragImages;
|
|
if Assigned(DragImages) then
|
|
DragImages.HideDragImage;
|
|
case FScrollDirection of
|
|
-1:
|
|
SendMessage(Handle, WM_VSCROLL, SB_LINEUP, 0);
|
|
1:
|
|
SendMessage(Handle, WM_VSCROLL, SB_LINEDOWN, 0);
|
|
end;
|
|
if Assigned(DragImages) then
|
|
DragImages.ShowDragImage;
|
|
Msg.Result := 1;
|
|
end
|
|
else
|
|
inherited;
|
|
end;
|
|
|
|
procedure TJvTreeView.WMVScroll(var Msg: TWMVScroll);
|
|
begin
|
|
inherited;
|
|
if Assigned(FOnVScroll) then
|
|
FOnVScroll(Self);
|
|
end;
|
|
|
|
function TJvTreeView.GetItemHeight: Integer;
|
|
begin
|
|
if HandleAllocated then
|
|
Result := SendMessage(Handle, TVM_GETITEMHEIGHT, 0, 0)
|
|
else
|
|
Result := 16;
|
|
end;
|
|
|
|
procedure TJvTreeView.SetItemHeight(Value: Integer);
|
|
begin
|
|
if Value <= 0 then
|
|
Value := 16;
|
|
if HandleAllocated then
|
|
SendMessage(Handle, TVM_SETITEMHEIGHT, Value, 0);
|
|
end;
|
|
|
|
function TJvTreeView.GetInsertMarkColor: TColor;
|
|
begin
|
|
if HandleAllocated then
|
|
Result := SendMessage(Handle, TVM_GETINSERTMARKCOLOR, 0, 0)
|
|
else
|
|
Result := clDefault;
|
|
end;
|
|
|
|
procedure TJvTreeView.SetInsertMarkColor(Value: TColor);
|
|
begin
|
|
if HandleAllocated then
|
|
begin
|
|
if Value = clDefault then
|
|
Value := Font.Color;
|
|
SendMessage(Handle, TVM_SETINSERTMARKCOLOR, 0, ColorToRGB(Value));
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTreeView.InsertMark(Node: TTreeNode; MarkAfter: Boolean);
|
|
begin
|
|
if HandleAllocated then
|
|
if Node = nil then
|
|
RemoveMark
|
|
else
|
|
SendMessage(Handle, TVM_SETINSERTMARK, Integer(MarkAfter), Integer(Node.ItemId));
|
|
end;
|
|
|
|
procedure TJvTreeView.RemoveMark;
|
|
begin
|
|
if HandleAllocated then
|
|
SendMessage(Handle, TVM_SETINSERTMARK, 0, 0);
|
|
end;
|
|
|
|
function TJvTreeView.GetLineColor: TColor;
|
|
begin
|
|
if HandleAllocated then
|
|
Result := SendMessage(Handle, TVM_GETLINECOLOR, 0, 0)
|
|
else
|
|
Result := clDefault;
|
|
end;
|
|
|
|
function TJvTreeView.MoveUp(AAbsoluteIndex: Integer; Focus: Boolean): Integer;
|
|
var
|
|
lNode, lNode2: TTreeNode;
|
|
begin
|
|
Result := AAbsoluteIndex;
|
|
if (AAbsoluteIndex > 0) and (AAbsoluteIndex < Items.Count) then
|
|
begin
|
|
lNode := Items[AAbsoluteIndex];
|
|
|
|
//if not lnode.IsFirstNode then // Delphi 7+
|
|
if not (not lnode.Deleting and (lnode.Parent = nil) and (lnode.GetPrevSibling = nil)) then
|
|
begin
|
|
lNode2 := lNode.getPrevSibling;
|
|
if lNode2 <> nil then
|
|
lNode.MoveTo(lNode2, naInsert);
|
|
end;
|
|
if Focus then
|
|
begin
|
|
lNode.Selected := True;
|
|
lNode.Focused := True;
|
|
end;
|
|
Result := lNode.AbsoluteIndex;
|
|
end;
|
|
end;
|
|
|
|
function TJvTreeView.MoveDown(AAbsoluteIndex: Integer; Focus: Boolean): Integer;
|
|
var
|
|
lNode, lNode2: TTreeNode;
|
|
begin
|
|
Result := AAbsoluteIndex;
|
|
if (AAbsoluteIndex >= 0) and (AAbsoluteIndex < Items.Count - 1) then
|
|
begin
|
|
lNode := Items[AAbsoluteIndex];
|
|
|
|
if not (not lNode.Deleting and (lNode.Parent = nil) and (lNode.getNextSibling = nil)) then
|
|
begin
|
|
lNode2 := lNode.getNextSibling;
|
|
if lNode2 <> nil then
|
|
lNode2.MoveTo(lNode, naInsert);
|
|
end;
|
|
if Focus then
|
|
begin
|
|
lNode.Selected := True;
|
|
lNode.Focused := True;
|
|
end;
|
|
Result := lNode.AbsoluteIndex;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTreeView.SetLineColor(Value: TColor);
|
|
begin
|
|
if HandleAllocated then
|
|
begin
|
|
if Value = clDefault then
|
|
Value := Font.Color;
|
|
SendMessage(Handle, TVM_SETLINECOLOR, 0, ColorToRGB(Value));
|
|
end;
|
|
end;
|
|
|
|
function TJvTreeView.GetMaxScrollTime: Integer;
|
|
begin
|
|
if HandleAllocated then
|
|
Result := SendMessage(Handle, TVM_GETSCROLLTIME, 0, 0)
|
|
else
|
|
Result := -1;
|
|
end;
|
|
|
|
procedure TJvTreeView.SetMaxScrollTime(const Value: Integer);
|
|
begin
|
|
if HandleAllocated then
|
|
SendMessage(Handle, TVM_SETSCROLLTIME, Value, 0);
|
|
end;
|
|
|
|
function TJvTreeView.GetUseUnicode: Boolean;
|
|
begin
|
|
if HandleAllocated then
|
|
Result := Boolean(SendMessage(Handle, TVM_GETUNICODEFORMAT, 0, 0))
|
|
else
|
|
Result := False;
|
|
end;
|
|
|
|
procedure TJvTreeView.SetUseUnicode(const Value: Boolean);
|
|
begin
|
|
// only try to change value if not running on NT platform
|
|
// (see MSDN: CCM_SETUNICODEFORMAT explanation for details)
|
|
if HandleAllocated and (Win32Platform <> VER_PLATFORM_WIN32_NT) then
|
|
SendMessage(Handle, TVM_SETUNICODEFORMAT, Integer(Value), 0);
|
|
end;
|
|
|
|
type
|
|
TMenuAccessProtected = class(TMenu);
|
|
|
|
procedure TJvTreeView.SetMenu(const Value: TMenu);
|
|
begin
|
|
if FMenu <> Value then
|
|
begin
|
|
if (FMenu <> nil) and not (csDesigning in ComponentState) then
|
|
{$IFDEF CLR}
|
|
SetProtectedObjectEvent(FMenu, 'OnChange', @FOldMenuChange);
|
|
{$ELSE}
|
|
TMenuAccessProtected(FMenu).OnChange := FOldMenuChange;
|
|
{$ENDIF CLR}
|
|
FMenu := Value;
|
|
if FMenu <> nil then
|
|
begin
|
|
FMenu.FreeNotification(Self);
|
|
if not (csDesigning in ComponentState) then
|
|
begin
|
|
{$IFDEF CLR}
|
|
FOldMenuChange := TMenuChangeEvent(GetProtectedObjectEvent(FMenu, 'OnChange'));
|
|
SetProtectedObjectEvent(FMenu, 'OnChange', @DoMenuChange);
|
|
{$ELSE}
|
|
FOldMenuChange := TMenuAccessProtected(FMenu).OnChange;
|
|
TMenuAccessProtected(FMenu).OnChange := DoMenuChange;
|
|
{$ENDIF CLR}
|
|
end;
|
|
end;
|
|
RebuildFromMenu;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTreeView.DoMenuChange(Sender: TObject; Source: TMenuItem;
|
|
Rebuild: Boolean);
|
|
begin
|
|
if Assigned(FOldMenuChange) then
|
|
FOldMenuChange(Sender, Source, Rebuild);
|
|
RebuildFromMenu;
|
|
end;
|
|
|
|
procedure TJvTreeView.RebuildFromMenu;
|
|
var
|
|
I: Integer;
|
|
|
|
procedure MakeSubMenu(AParent: TTreeNode; AMenuItem: TMenuItem);
|
|
var
|
|
I: Integer;
|
|
ANode: TTreeNode;
|
|
begin
|
|
if (AMenuItem.Caption <> '-') and (AMenuItem.Caption <> '') then
|
|
begin
|
|
ANode := Items.AddChildObject(AParent, StripHotKey(AMenuItem.Caption), TObject(AMenuItem));
|
|
ANode.ImageIndex := AMenuItem.ImageIndex;
|
|
ANode.SelectedIndex := AMenuItem.ImageIndex;
|
|
for I := 0 to AMenuItem.Count - 1 do
|
|
MakeSubMenu(ANode, AMenuItem.Items[I]);
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
Items.BeginUpdate;
|
|
try
|
|
Items.Clear;
|
|
if Menu <> nil then
|
|
begin
|
|
for I := 0 to Menu.Items.Count - 1 do
|
|
MakeSubMenu(nil, Menu.Items[I]);
|
|
end;
|
|
finally
|
|
Items.EndUpdate;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTreeView.Notification(AComponent: TComponent;
|
|
Operation: TOperation);
|
|
begin
|
|
inherited Notification(AComponent, Operation);
|
|
if Operation = opRemove then
|
|
begin
|
|
if AComponent = FMenu then
|
|
Menu := nil
|
|
else
|
|
if AComponent = FPageControl then
|
|
PageControl := nil;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTreeView.DblClick;
|
|
begin
|
|
inherited DblClick;
|
|
if MenuDblClick and IsMenuItemClick(Selected) then
|
|
TMenuItem(Selected.Data).OnClick(TMenuItem(Selected.Data));
|
|
end;
|
|
|
|
function TJvTreeView.IsMenuItemClick(Node: TTreeNode): Boolean;
|
|
begin
|
|
Result := Assigned(Menu) and Assigned(Node) and Assigned(Node.Data) and
|
|
(TObject(Node.Data) is TMenuItem) and Assigned(TMenuItem(Node.Data).OnClick);
|
|
end;
|
|
|
|
procedure TJvTreeView.SetPageControl(const Value: TPageControl);
|
|
begin
|
|
if FPageControl <> Value then
|
|
begin
|
|
FPageControl := Value;
|
|
if FPageControl <> nil then
|
|
FPageControl.FreeNotification(Self);
|
|
end;
|
|
end;
|
|
|
|
//=== { TJvIPAddressValues } =================================================
|
|
|
|
procedure TJvIPAddressValues.Change;
|
|
begin
|
|
if Assigned(FOnChange) then
|
|
FOnChange(Self);
|
|
end;
|
|
|
|
function TJvIPAddressValues.Changing(Index: Integer; Value: Byte): Boolean;
|
|
begin
|
|
Result := True;
|
|
if Assigned(FOnChanging) then
|
|
FOnChanging(Self, Index, Value, Result);
|
|
end;
|
|
|
|
function TJvIPAddressValues.GetValue: Cardinal;
|
|
begin
|
|
Result := MAKEIPADDRESS(FValues[0], FValues[1], FValues[2], FValues[3]);
|
|
end;
|
|
|
|
function TJvIPAddressValues.GetValues(Index: Integer): Byte;
|
|
begin
|
|
Result := FValues[Index];
|
|
end;
|
|
|
|
procedure TJvIPAddressValues.SetValue(const AValue: Cardinal);
|
|
var
|
|
FChange: Boolean;
|
|
begin
|
|
FChange := False;
|
|
if GetValue <> AValue then
|
|
begin
|
|
if Changing(0, FIRST_IPADDRESS(AValue)) then
|
|
begin
|
|
FValues[0] := FIRST_IPADDRESS(AValue);
|
|
FChange := True;
|
|
end;
|
|
if Changing(1, SECOND_IPADDRESS(AValue)) then
|
|
begin
|
|
FValues[1] := SECOND_IPADDRESS(AValue);
|
|
FChange := True;
|
|
end;
|
|
if Changing(2, THIRD_IPADDRESS(AValue)) then
|
|
begin
|
|
FValues[2] := THIRD_IPADDRESS(AValue);
|
|
FChange := True;
|
|
end;
|
|
if Changing(3, FOURTH_IPADDRESS(AValue)) then
|
|
begin
|
|
FValues[3] := FOURTH_IPADDRESS(AValue);
|
|
FChange := True;
|
|
end;
|
|
if FChange then
|
|
Change;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvIPAddressValues.SetValues(Index: Integer; Value: Byte);
|
|
begin
|
|
if (Index >= Low(FValues)) and (Index <= High(FValues)) and (FValues[Index] <> Value) then
|
|
begin
|
|
FValues[Index] := Value;
|
|
Change;
|
|
end;
|
|
end;
|
|
{$ENDIF VCL}
|
|
|
|
{$IFDEF VisualCLX}
|
|
|
|
//=== { TJvTreeView } ========================================================
|
|
|
|
constructor TJvTreeView.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
FLineColor := clDefault;
|
|
FLastSelection := nil;
|
|
end;
|
|
|
|
destructor TJvTreeView.Destroy;
|
|
begin
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TJvTreeView.SetLineColor(Value: TColor);
|
|
begin
|
|
if Value <> FLineColor then
|
|
begin
|
|
FLineColor := Value;
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTreeView.SetHideSelection(Value: Boolean);
|
|
begin
|
|
if Value <> FHideSelection then
|
|
begin
|
|
FHideSelection := Value;
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTreeView.SetShowRoot(Value: Boolean);
|
|
begin
|
|
if Value <> FShowRoot then
|
|
begin
|
|
FShowRoot := Value;
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTreeView.Change(Node: TTreeNode);
|
|
begin
|
|
if Selected <> FLastSelection then
|
|
begin
|
|
FLastSelection := Selected;
|
|
DoSelectionChange;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvTreeView.DoSelectionChange;
|
|
begin
|
|
if Assigned(FOnSelectionChange) then
|
|
FOnSelectionChange(Self);
|
|
end;
|
|
|
|
{$ENDIF VisualCLX}
|
|
|
|
{$IFDEF UNITVERSIONING}
|
|
initialization
|
|
RegisterUnitVersion(HInstance, UnitVersioning);
|
|
|
|
finalization
|
|
UnregisterUnitVersion(HInstance);
|
|
{$ENDIF UNITVERSIONING}
|
|
|
|
end.
|
|
|