babaev-an/lasarus_compotents
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Стартовый пул

Browse Source
This commit is contained in:
Александр Бабаев
2024-04-02 08:46:59 +03:00
parent fd57fffd3a
commit 3bb34d000b
5591 changed files with 3291734 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

632
VirtualTreeview/CHANGES.txt Normal file
View File

@@ -0,0 +1,632 @@
V5.4.1: (26 May 2014)
* Added packages for C++ Builder XE6
* If toAutoChangeScale is set in AutoOptions, the Virtual TreeView control now
increases the DefaultNodeHeight if the font size is too large to fit.
* If toAutoChangeScale is set in AutoOptions, the columns widths are now adjusted too.
* Improved implementation for toRestoreSelection option
* Fixed possible AV in PaintNodeButton()
* Now ensuring that both GetHorzScrollBarSliderRect() and
GetVertScrollBarSliderRect() return a valid value for every code path (Thx to
Dmitri Dmitrienko). This could cause strange out of resources exceptions with VCL
styles enabled.
* Fixed issue #434: Application compiled with Delphi 7 stops responding when you call AddChild
* A few minor changes
V5.4.0: (22 Apr 2014)
* Added support for XE6.
* Added new option toRestoreSelection to TVTSelectionOptions: Set to true if upon refill the previously
elected nodes should be selected again. The nodes will be identified by its caption only.
* Added new option toAlwaysSelectNode to TVTSelectionOption enum. If this flag is set, the treeview tries to
lways have a node selected. This behavior is closer to the Windows TreeView and useful in Windows Explorer
tyle applications. It is also useful for accessible applications which can indicate having the focus by
isplaying a selection.
* Added function TBaseVirtualTree.IsEmpty which returns True if the control has no nodes.
* Fixed a wrongly drawn selection after the user scrolled horizontally.
* Fixed issue #423: Change property TVirtualTreeColumn.Tag to NativeInt.
* Implemented #415: Added feature for design time column header dragging and resizing. (Thx to fr0st.brutal)
* Fixed issue #180: Memory leak in grid demo of Advanced project
* Implemented #422: Added TBaseVirtualTree.GetFirstChildNoInit()
* Fixed issue #420: Add coEditable to TVTColumnOption) by applying the supplied path. Thx to Stefan Glienke.
* Fixed issue #419: Some issues with changing to edit mode with clicking
* Fixed issue #430: TVTDragManager memory leak with visual inheritance. Thx to Andreas Hausladen for the patch.
* Fixed issue #431: Visual bug when using TStringEditLink with large node heights
* TVclStyleScrollBarsHook.WMMouseMove(): Now preventing possible range check error exception.
* Now handling WM_MOVE and WM_POSCHNAGED correctly in TVclStyleScrollBarsHook (Thx to Dmitri Dmitrienko)
* Preventing possible stack overflow in TVirtualTreeHintWindow.ActivateHint (Thx to Dmitri Dmitrienko)
* Added packages for C++ Builder XE5.
* Some minor changes, improvements and fixes have been incorporated
V5.3.0: (04 Jan 2014)
* Fix for issue #159 (Cursor missing in edit with non-standard DPI): Ensuring a minimum size of the edit control
* Fixed issue #403: Declare TVTGetNodeProc as reference to procedure (for D2009+)
* Fixed issue #402: TVTEdit.CNCommand discard all notification except EN_UPDATE due to missing inherited
* Corrected fix for issue #376 (Incorrect selection paint when toGridExtensions is included in the MiscOptions)
* Fixed issue #401: OnNodeClick event doesn't trigger in some case, coFixed set for a column
* Modified #316 (concerning r498). The fix for #316 will only be applied in case toMultiSelect is set.
If toMultiSelect is not set we can start a drag anywhere in the row.
* ContentToHTML() and ContentToRTF() now return a string of type RawByteString.
Because the generated strings are pre-encoded in UTF-8, the previous type AnsiString caused
problems in Delphi 2009+ e.g. when this string was written using the VCL TStreamWriter class.
The helper class TBufferedAnsiString therefore uses RywByteString now as type too.
* Fixed issue #399: EditDelay not working
* Fixed issue #400: AltGr+A does not behave as expected for foreign keyboard layouts in VTEdit
* Fixed issue #388: VirtualStringTree with toFixedIndent causes range check error
* Edit box when editing a node in a tree with toFixedIndent now has the correct indent
* Fixed issue #392: Now ensuring that MeasureItemHeight() is only called from the main thread.
* Fixed #383: Clear vsHasChildren for a node without children even if the children count didn't change.
* Fixed #377: Wrong font (size, etc) in TargetCanvas in MeasureItem for first node
* Fixed issue #398 (hoAutoResize causes DFM designer to be modified after loading) by calling TControl.Updating()/Updated() in AdjustAutoSize()
* Preventing possible AV in TBaseVirtualTree.FontChanged()
* Fixed 32Bit Integer overflows in Win64 build in TBufferedAnsiString.
V5.2.2: (30 Oct 2013)
- Added support for Delphi / RAD Studio XE5
- Fixed issue #371: property OnGesture is now published.
- Fixed issue #365: No longer changing timer resolution globally
- Fixed issue #347: No expand-pluses seen under Windopws classic theme for a vcl styled application
- Fixed issue #373: Scrollbar does not size properly for more than 2000 nodes with variable node height:
The OnMeasureItem event is triggered only in case the toVariableNode flags in included in MiscOptions
- Fixed issue #376: Incorrect selection paint when toGridExtensions is included in the MiscOptions
- Improved displaying of EmptyListMessage text, especially when scrolling horizontally.
- Fixed issue #61: EditCursor missing with manifest + toThemeAware + vsMultiline
- Fixed issue #352: Minor improvement in calculation of right margin of hint window.
V5.2.1: (06 Sep 2013)
- Fixed #352 and #354 by modifying the implementation of #237 so that a focused node is ensured only if the
control is being entered using the TAB key. This is consistent with the behavior of the Windows Explorer.
- Fixed issue #360 (In the calculation of the horizontal scroll bar static text should be considered) by
calling DoGetNodeExtraWidth() in TBaseVirtualTree.GetMaxRightExtend()
- Used fix proposed in issue #361 to fix issue #357 (AV in advanced demo - PropertiesDemo form in XE3+)
- Removed call to TCustomStyleEngine.UnRegisterStyleHook() to fix issue #359/#355
- Fixed issue #358: Horizontal Scrollbar issue when expand ing and scrollbars get visible
- Fixed issue #355/#345: exception regarding style services
V5.2: (09 Aug 2013)
- OnMouseEnter and OnMouseLeave events have been added (#238)
- Improved dpi scaling for VirtualTreeView and Header
- toAutoChangeScale and toAutoSort are now among the defualt values for TCustomVirtualTreeOptions.AutoOptions
- Fixed issue #237: Auto focus the first node on enter if there is no focused node
- Fixed issue #344: Cannot select row by Ctrl+Click on empty column
- Fixed issue #206: Column painting issue with coWrapCaption in Options
- Fixed issue #128: OleUninitialize in FinalizeGlobalStructures can hang when using Virtual Treeview in a DLL
- Added new public property LastDragEffect which supplies the last executed drag effect.
- Added virtual method GetNodeImageSize() which can be overridden if one needs different sized images.
- Added new public property LastDragEffect which supplies the last executed drag effect.
- Fixed issue #206: Column painting issue with coWrapCaption in Options
- Fixed issue #336 by ignoring PARENTDOUBLEBUFFEREDCHANGED message.
- Fixed issue #342 by adding a new implementation of the VCL's DoubleBuffered property.
The inherited DoubleBuffered property of TWinControl must not be set to True!
- A few minor improvements have been added.
V5.1.3: (17 Apr 2013)
- Fixed #340: GetHitTestInfoAt on right border of fixed column.
- Fixed #337: Cannot "grab" item for dragging, odd behaviour of multi selecting with the selection
rectangle when toFullRowSelect is True but toSimpleDrawSelection is False. (thx to Stefan Glienke)
- Fixed #341: Error when unloading DLL due to missing UnRegisterStyleHook
- Improved fix for #323: The fix applied in V5.1.2 was a breaking change for some projects, especially
if not all the initialization was done in the OnInitNode event (reported as #338). vsInitialUserData
has been renamed to vsOnFreeNodeCallRequired and is now set when GetNodeData is called. This fixes
the possible memory leak reported in #323 and has better backward compatibility.
- Fixed #316: These fixes are to make the treeview behave more like the windows explorer regarding
selecting and dragging. Thanks to Stefan Glienke.
- Fixed #333: Possible Integer overflow in 64Bit builds.
- Compatibility with / packages for Delphi Xe$ / RAD Studio XE4 have been added.
V5.1.2 (04 Apr 2013):
- Added function TVirtualTreeColumns.GetFirstColumn that returns the first column in display order.
- Fixed issue #322: CaptionAlignment is not being restored by Header.LoadFromStream().
- TBaseVirtualTree.GetNodeData() now calls InitNode() if the node had not beend initialized.
This fixes issue #323 (Memory leak when the Node has children )
- Fixed issue #326: Application hangs when aborting OLE Copy/Paste Operation
- Added new option poResizeToFitItem to TVTHeaderPopupOption: Adds an item which, if clicked,
resizes all columns to fit by calling TVTHeader.AutoFitColumns()
- Property RangeX is now public in the class TVirtualStringTree (#327)
- TVirtualTreeColumns.HandleClick(): No longer triggering auto sort if just the checkbox in the header was clicked
- TBaseVirtualTree.SetCheckType new resets PVirtualNode.CheckState only if the check state does not fit the new check type
- Fixed issue #321: Delphi2009: undeclared identifier: 'fState' in VirtualTrees.pas:DrawDisabledImage()
- Fixed issue #315: hoHeaderClickAutoSort was only working if toAutoSort is also set
V5.1.1 (07 Feb 2013):
- Fixed issue #313: Translucent selection rectangle completely broken when PaintBackground is used
- Fixed issue #314: Only if toAutoSort is True non-expanded nodes will be excluded from sorting.
This restores the behavior of V5.0.X.
- Fixed issue #306: Drag image was broken except for CF_HDROP
- Fixed issue #305: Broken hint drawing with classic windows theme and toUseExplorerTheme
- Fixed issue #298: Bad canvas parameters in OnBeforeCellPaint method
- If NodeDataSize has its default value -1, now sizeof(Pointer) is used at runtime as actual value.
This makes it easier to store a simple Pointer with each node indepedent of the target platform (32/64Bit).
- Fixed issue #300: Made the hint text more centered in the hint window
- If TVirtualTreeColumn.CheckBox is set to True in Designer, then hoShowImages is now added to Header.Options
- Fixed issue #302: AV when painting sorted header column containing checkbox
- Now soring subnodes when they get expanded and the toAutoSort flag is set
- Added fix for ugly drawn disabled images (thx to S. Glienke). See also:
http://stackoverflow.com/questions/6003018/make-disabled-menu-and-toolbar-images-look-better
http://qc.embarcadero.com/wc/qcmain.aspx?d=86879
- Fixed issue #299: Draw themed focus rectangle with toUseExplorerTheme
- Fixed issue #198: Wrong check images
- Removed file VTConfig.inc. The former $ifdef ReverseFullExpandHotKey is now a flag in the
TVTMiscOption enumeration. The $ifdef TntSupport can be defined at the beginning of the unit VirtualTrees.
- Added new optional parameter "Recursive" to TBaseVirtualTree.Sort()
V5.1.0 (05 Nov 2012):
- Fixed issue #291: Empty hint strings are shown when using custom hint window classes
- Added support for VCl styles of RAD Studio XE2 and higher. (Thanks to Dietmar R<>sler, issue #288)
- Fixed issue #285: access violation when mouse down over checkbox sometimes
- Fixed issue #293: OnAdvancedHeaderDraw is called with wrong PaintInfo.PaintRectangle
- Improved creation of IDragSourceHelper and added support for IDragSourceHelper2
- Fixed problem with drawing selection rectangle after canceled rename
- Improved creation of IDragSourceHelper and added support for IDragSourceHelper2
- Fixed issue regarding activating explorer theme
- Fixed issue #222: FDottedBrush is never released in the tree is never shown
- Fixed issue #52: Misalignement of CheckBox and TreeLine/Buttons
- Fixed issue #43: VT stop repaint after Windows visual style change
- Fixed issue #66: column auto-resize makes not aware of StaticText
- Fixed issue #53: Misalignment Images Columns > 0
- Fixed issue #176: Multiline Aligment Problem
- Fixed issue #283: VTV no longer allows to drop above or below when using Full row selection
- Fixed issue #173: Two suggestions about class member visibilities
- Fixed issue #192: Fixed column painting bug when OffsetX > 0
- Fixed Delphi 2007 Designer package
V5.0.1 (06 Sep 2012):
- Added Support for RAD Studio XE3
- Fixed definition of event OnAfterHeaderExport, it used the same member variable as OnBeforeHeaderExport.
- Fixed problem with Delphi 2007 package
- Delphi 2009 and 2010 packages are also implicit build packages now, like those for XE and XE2 (issue #279)
- Fixed #251: Added supoort for C++ Builder XE2
- Fixed #274: Wrong stop condition in TBaseVirtualTree.GetLastVisible
- Fixed runtime package of Delphi 7
- Fixed issue #273: Incremental search for international symbols not working in Delphi 2009-XE2
- A few minor bug fixes have been incorporated
July 03, 2012
- Release of V5.0.0 final
June 11-30, 2012
- Release of V5.0.0 RC2
- Removed dependecy on file Compilers.inc
- Removed dependency on file MSAAIntf.pas
- Removed folder Common
- Fixed issue #252: Incorrect width of edit control rectangle when grid extensions are set
- Fixed issue #259: Hit position wrong when Indent is not default
- Fixed issue #253: Compatibility issues with XE2's VCL style checkboxes
- Fixed issue #265: Lib suffix not set for all configurations in Delphi XE2 package
- Bug fix: Functions GetLastVisible and GetLastVisibleNoInit return correct results even if some anchestor of the last visible node is not effectively visible
- Improvement: Added functions GetNextSiblingNoInit and GetPreviousSiblingNoInit
- "Res" folder of Advanced sample was not included in ZIP archive
- Added folder "Contributions" to release
June 01-10, 2012
- Release of V5.0.0 RC1
- Updated help file for V5.0
April 2012
- Added support for theming of hint window (thanks to Arno Garrels and Uwe Schuster)
- TBaseVirtualTree.CheckParentCheckState: Fixed duplicate recursion to parent nodes
March 2012
- Fixed painting of Windows7/Vista style Explorer selection in case tsUseExplorerTheme is in TreeOptions
- Ctrl + A now selects all items
January 2012
- Bug fix: Fixed a potential access violation in TBaseVirtualTree.FullCollapse in case of toChildrenAbove
December 2011
- Fixed compiler warning in RAD Studio XE2 regarding deprecated ThemeServices
September 2011
- The property EmptyListMessage may now contain linebreaks in Delphi 2009 and higher, the text in now printed in dark gray.
- Support for flat scroll bars has been removed.
- Global variables InWin2k and IsWinXP, enum member hsXPStyle, function DrawXPButton() and support for Windows 2000 has been removed.
- Global variable IsWinNT and support for Windows 9x has been removed.
- Improvement: Added support for Delphi XE2 and 64Bit compiler.
- Support for Delphi 5/6 and C++ Builder 5/6 has been dropped.
- Bug fix: Fixed a potential integer overflow in TBaseVirtualTree.ToggleNode in case of toChildrenAbove and NodeInView
- Bug fix: Fixed a potential Assertion in TBaseVirtualTree.ToggleNode by checking GetFirstVisible before calling GetDisplayRect
- Bug fix: TCustomVirtualTreeOptions.SetPaintOptions correctly changes the VisibleCount when toShowFilteredNodes is toggled
- Improvement: Added new functions TBaseVirtualTree.DetermineDropMode
- Improvement: Added usage of TBaseVirtualTree.DetermineDropMode in TBaseVirtualTree.DragOver
- Improvement: Made EffectiveOffsetX accessible via read-only protected property for easier subclassing
- Improvement: Moved TBaseVirtualTree.DetermineLineImageAndSelectLevel from private to protected for easier subclassing
- Improvement: Sorted TBaseVirtualTree.SetEmptyListMessage
August 2011
- Improvement: Minor code improvements
April 2011
- Bug fix: Reverted change of November 2010 (Creating the WorkerThread will no longer change System.IsMultiThread)
it caused sporadic AVs during app start which disappeared after revering the change. This code can lead to a wrong value
of System.IsMultiThread which causes the memory manager to assume a single threaded application.
- Bug fix: When advancing to the next item while in edit mode, we are now also calling CanEdit().
February 2011
- Bug fix: In case the LastStructureChangeNode is deleted before the StructureChange event is fired,
the reference to the LastStructureChangeNode is cleared to avoid providing an invalid node
January 2011
- Improvement: RTF export now uses landscape paper format and smaller margins, so that more of the contents
fits on the page
- Improvement: New Option hoHeaderClickAutoSort for TVTHeader.Options: Clicks on the header will make the
clicked column the SortColumn or toggle sort direction if it already was the sort column
- Improvement: Pressing the tab key in edit mode advances to the next node in edit node, just like the
Windows 7 Explorer does it.
- Bug fix: No longer auto-scrolling horizontally when the focused node changes if toFullRowSelect is turned on.
- Bug fix: Fixed a clipping issue when drawing unbuffered
December 2010
- Improvement: TBaseVirtualTree.HandleMouseUp now checks CanEdit just in case toEditOnClick
- Bug fix: TotalNodeHeights are now correctly adjusted when toggling toShowHiddenNodes
- Bug fix: Fixed BCB compiler error due to re-defining IDropTargetHelper
- Improvement: New TVTInternalPaintOption poUnbuffered to directly paint onto a given canvas (especially useful
when printing and/or scaling via world transformations)
- Improvement: Refactored header painting to be more flexible (e.g. for printing)
- Improvement: Made additional fields accessible via protected read-only properties for easier subclassing
November 2010
- Improvement: All calls to SetWindowOrgEx now respect the canvas' transformation
- Improvement: TBaseVirtualTree.GetNodeHeight will no longer measure the node height, if the node is about
to be deleted
- Improvement: Made TBaseVirtualTree.FRangeX and FRangeY accessible via read-only protected property
- Improvement: Unified clipping handling
- Improvement: Added new color setting "SelectionTextColor"
- Improvement: Creating the WorkerThread will no longer change System.IsMultiThread
- Bug fix: Fixed a potential integer overflow in TBaseVirtualTree.ToggleNode
- Bug fix: TBaseVirtualTree.ToggleNode now measures the child node heights before summing them
- Improvement: Made some private field of TVTHeader and TVirtualTreeColumns protected to make writing
derived classes easier
- Improvement: Enclosed call to DoDragDrop in TBaseVirtualTree.CMDrag in a try..finally block
- Improvement: The default inplace editor now resizes itself even when the tree is in grid mode
- Bug fix: TBaseVirtualTree.PrepareBitmaps now checks the existance of the main column correctly
- Bug fix: TBaseVirtualTree.UpdateEditBounds now checks wether the focused node is assigned
- Improvement: TBaseVirtualTree.FHintData is now available to derived classes via the protected property HintData
October 2010
- Bug fix: Now taking horizontal scroll position into account when drawing text of EmptyListMessage property
- Bug fix: Prevented potential "index out of bounds" exception in TVirtualTreeHintWindow.CalcHintRect
- Bug fix - Issue #187: Showing a dialog in OnChange or OnRemoveSelection event handlers can cause the VT to
enter mode for drawing selection rectangle.
- Improvement: Made inherited event OnCanResize published for TVirtualStringTree for Delphi 2010 and later
- Improvement: TBaseVirtualTree.ToggleNode now tries to keep the visual position of the toggled node,
even when toChildrenAbove is set
September 2010
- Improvement: Added additional check regarding the tree reference to TVirtualTreeHintWindow.AnimationCallback
- Improvement: Made TBaseVirtualTree.AdjustImageBorder protected and virtual
- Improvement: TVirtualTreeColumns now observes if the focused column is removed
- Improvement: Made compatible with Delphi XE (Thanks to Roman Kassebaum)
August 2010
- Improvement: TCustomVirtualStringTree.DoTextMeasuring now returns TSize
- Improvement: Renamed TVTMeasureTextWidthEvent to TVTMeasureTextEvent and introduced new
event TCustomVirtualStringTree.OnMeasureTextHeight
- Improvement: Made TBaseVirtualTree.GetMaxColumnWidth virtual
- Bug fix: TBaseVirtualTree.OnRemoveFromSelection is now triggered by TBaseVirtualTree.RemoveFromSelection
as intended
July 2010
- Bug fix: Toggling toShowFilteredNodes will now update the node counts in the tree even if its handle has not
been allocated so far
- Bug fix: TBaseVirtualTree.FindNodeInSelection should now work correctly with nodes above the 2gb boundary
- Bug fix: Nodes that are about to be deleted are now removed from TBaseVirtualTree.FDragSelection
- Bug fix: Changed TBaseVirtualTree.WMKeyDown to correctly handle special keys in Unicode based Delphi versions
- Bug fix: Changed declaration of TBaseVirtualTree.EmptyListMessage to UnicodeString
- Improvement: Added new property TBaseVirtualTree.EmptyListMessage. If this property is not empty, the assigned
text will be displayed if there are no nodes to display, similar to the Windows XP file search.
- Improvement: Added tstChecked to TVSTTextSourceType enumeration and support for the new flag to
GetRenderStartValues(). So you can export only checked nodes.
June 2010
- Bug fix: range select with no nodes will no longer result in an access violation
- Bug fix: TBaseVirtualTree.SetVisible now correctly decrements the visible node count
- Bug fix: TStringEditLink.BeginEdit now calls AutoAdjustSize to ensure a consistent size of the edit field
- Improvement: TVTHeader.AutoFitColumns is now declared virtual
- Bug fix: header captions were badly positioned text if Extra Large fonts have been activated in the Windows
display options
May 2010
- Improvement: TBaseVirtualTree.PaintTree is now declared virtual
- Bug fix: corrected calculations regarding tree height and visible count when using filtered nodes
April 2010
- Bug fix: Changed TBaseVirtualTree.SetChildCount and TBaseVirtualTree.InitNode to correctly handle filtered nodes
- Bug fix: Ctrl+Click on a node often cause a delayed update of the displayed selection due to a missing (or
misplaced) call to Invalidate() in HandleClickSelection().
- Bug fix: Shift+PgUp and Shift+PgDown now behave like a usual List(View) and select the node of the previous/
next page. The behaviourly that was formerly assigned to these shortcuts is now triggeres when using
Shift+Alt+PgUp / Shift+Alt+PgDown
March 2010
- Bug fix: TBaseVirtualTree.CMMouseLeave now checks if the header is assigned before working with it
- Bug fix: TCustomVirtualTreeOptions.SetPaintOptions will now invalidate the node cache if toChildrenAbove is
changed
- Bug fix: TBaseVirtualTree.HandleMouseUp will no longer cause an AV if HitInfo.HitNode is not assigned and
tsToggleFocusedSelection is set
- Improvement: new properties TBaseVirtualTree.OnAddToSelection and TBaseVirtualTree.OnRemoveFromSelection
- Bug fix: fixed a whole bunch of painting issues regarding drag & drop
- Bug fix: fixed TBaseVirtualTree.DragFinished to generate a button up event in case of using OLE drag & drop
- Bug fix: TBaseVirtualTree.DeleteChildren no longer fails if the given node is nil
January 2010
- Bug fix: Removed defaults from TVirtualTreeColumn.BiDiMode and TVirtualTreeColumn.Color
- Bug fix: Clearing the columns while editing no longer raises an exception
- Improvement: refactored handling of long running operations
- Bug fix: TBaseVirtualTree.OnGetHelpContext now delivers the currently focused column instead of always 0
- Improvement: the sort operation can now be canceled
- Improvement: all BeginOperation/EndOperation pairs are now enclosed in try..finally blocks
- Bug fix: the combination of toUseExplorerTheme and toFullRowSelect now also works correct when no columns are
defined
December 2009
- Bug fix: TVTHeader.HandleMessage now correctly handles double click autosizing when the index differs from
its position
November 2009
- Bug fix: TBaseVirtualTree.AdjustTotalHeight didn't change the height of invisible nodes which caused some trouble
when making those nodes visible again
- Improvement: a column is no longer painted 'down' if its check box was clicked
- Bug fix: one can no longer toggle the check state of a column with the right mouse button
- Bug fix: one can no longer toggle the check state of a node with the right mouse button
- Bug fix: TCustomVirtualTreeOptions.SetPaintOptions no longer accidentally removed the the explorer theme
- Bug fix: Fixed a potential Integer overflow in TBaseVirtualTree.CalculateVerticalAlignments
October 2009
- Bug fix: enabling checkbox support for a column is now possible without assigning a dummy imagelist
- Bug fix: checkboxes in the header are now correctly aligned
- Improvement: changed TBaseVirtualTree.PaintCheckImage to be usable by TVirtualTreeColumns.PaintHeader to be
able to paint themed header checkboxes
- Bug fix: TBaseVirtualTree.GetCheckImage now correctly handles cases when Node is nil and ImgCheckType is either
ctTriStateCheckBox or ctNone
- Bug fix: TBaseVirtualTree.HasImage now implicitly initializes the given node if needed to avoid requesting the
imageindex for nodes that are not initialized
- Bug fix: fixed possible AV when setting toExplorerTheme with no columns defined
- Improvement: new events TBaseVirtualTree.OnSaveTree and TBaseVirtualTree.OnLoadTree
September 2009
- Bug fix: TBaseVirtualTree.OnColumnClick will no longer be triggered twice
- Improvement: new TVirtualNodeInitState ivsReInit to indicate that a node is about to be re-initialized
- Bug fix: TCustomVirtualStringTree.DoTextMeasuring now makes use of the parameter Width of the
OnMeasureTextWidth event
- Bug fix: TBaseVirtualTree.DetermineLineImageAndSelectLevel will no longer access LineImage[-1]
- Bug fix: clearing the columns now correctly reset TBaseVirtualTree.FFocusedColumn
- Improvement: explorer style painting is now more close to the real explorer
- Bug fix: TCustomVirtualStringTree.TContentToHTML.WriteStyle will no longer produce invalid CSS
- Bug fix: the parameter DragEffect of TBaseVirtualTree.DragAndDrop is now var as it should be
August 2009
- Bug fix: TBaseVirtualTree.MoveTo now initializes the target node using the target tree
- Bug fix: TBaseVirtualTree.FVisibleCount is now calculated correctly when using filtered nodes
- Improvement: introduced new initial node state ivsFiltered
July 2009
- Improvement: modified TVTHeader.HandleHeaderMouseMove to make resizing the autosize column with the
mouse possible
- Improvement: modified TBaseVirtualTree.DoCreateEditor so that applications can now return NIL in OnCreateEditor
to use the standard editor of the tree
- Bug fix: pressing CTRL + PgUp/PgDown no longer leads to an index-out-of-bounds exception if no columns are used
- Bug fix: avoided race condition between TBaseVirtualTree.DeleteNode and the worker thread
- Bug fix: TBaseVirtualTree.ToggleNode could produce an overflow if range checking was enabled
- Bug fix: TWorkerThread will no longer reference the tree after it has been destroyed (Mantis issue #384)
- Improvement: removed support for Delphi versions older than Delphi 7
- Improvement: removed local memory manager
June 2009
- Bug fix: TBaseVirtualTree.InternalConnectNode checked the expanded state of the wrong node if Mode was
amAddChildFirst or amAddChildLast
- Improvement: 'hidden nodes' are now called 'filtered nodes'
- Improvement: converted line endings back to CR/LF
- Improvement: new events TBaseVirtualTree.OnCanSplitterResizeNode and TBaseVirtualTree.OnCanSplitterResizeHeader
- Improvement: made TVirtualTreeColumns.DoCanSplitterResize virtual
- Improvement: made some methods of TVirtualTreeHintWindow protected to make subclassing easier
- Bug fix: fixed some issues concerning the vista theme handling
- Improvement: unified source code indentation
May 2009
- Improvement: new TVTMiscOption toEditOnClick, toEditOnDblClick to control if editing can be started with a single
click or a double click
- Bug fix: the internal pointers of TBufferedAnsiString are now PAnsiChar to work correctly with Delphi 2009
April 2009
- Bug fix: TBaseVirtualTree.GetVisibleParent no longer returns the given node in case it is fully visible
- Improvement: fixed a potential issue in TVirtualTreeColumns.TotalWidth in case it is called before
FPositionToIndex is initialized
- Bug fix: TBaseVirtualTree.CollectSelectedNodesLTR and TBaseVirtualTree.CollectSelectedNodesRTL handle straight
vertical selection rectangles no longer as empty
- Bug fix: TCheckImageKind.ckSystemDefault now works as intended
- Improvement: made the following methods of TBaseVirtualTree virtual: PrepareCell, AddChild, BeginUpdate,
EndUpdate and SortTree
- Improvement: made TBaseVirtualTree.PrepareCell protected
- Improvement: moved some members of TVTEdit and TStringEditLink from private to protected
- Improvement: re-designed header click handling
- Improvement: new TVTPaintOption toShowHiddenNodes to globally ignore the hidden state of nodes
- Improvement: individual nodes can now be hidden without affecting their children
- Improvement: re-designed Explorer theme drawing
- Bug fix: corrected allocation problems in TBufferedAnsiString and TWideBufferedString
March 2009
- Bug fix: fixed an issue in TVirtualTreeColumns.HandleClick that could lead to a case where no header click event
is triggered
- Bug fix: fixed an issue in TBaseVirtualTree.HandleHotTrack that could lead to an endless loop under certain
conditions
- Improvement: removed unused variables in TVirtualTreeColumn.ComputeHeaderLayout
- Bug fix: corrected TBaseVirtualTree.GetVisibleParent
- Improvement: extended hot node tracking to track the hot column too
- Improvement: new THitPosition hiOnItemButtonExact used to draw hot buttons when using Windows Vista's Explorer
theme
- Improvement: new TVTPaintOption toHideTreeLinesIfThemed to consider toShowTreeLines only if running unthemed
- Improvement: new TVTPaintOption toUseExplorerTheme to draw the tree like Windows Vista's Explorer treeview
February 2009
- Bug fix: reverted the implementation of DrawTextW back to the one prior to 4.8.1 as the line end detection
lead to a compiler warning under Delphi 2009
- Bug fix: corrected implementation of GetStringDrawRect to match its declaration (UnicodeString vs WideString)
- Bug fix: the node focus will no longer change if a TVTMiscOption.toGridExtensions is set and one clicks right of
(or left of, if right-to-left reading) the last column
- Bug fix: fixed an issue with TVTHeader.Assign that could lead to an access violation if the header is created at
runtime
- Bug fix: one can no longer change a node's height with the right mouse button even if toNodeHeightResize and
toRightClickSelect are set
- Improvement: TVTAutoOption.toDisableAutoScrollOnFocus now works for nodes too
- Improvement: new property TBaseVirtualTree.SelectionLocked to disable changing the selection
- Improvement: made the dual-scroll effect in TBaseVirtualTree.ToggleNode much smoother
- Bug fix: removed off-by-1 errors in TBaseVirtualTree.ToggleNode
- Bug fix: added a check for FUpdateCount to TBaseVirtualTree.SetUpdateState as otherwise every call to
TBaseVirtualTree.DoBeforeCellPaint to get the cell content margin within an Begin/EndUpdate-block would
re-enable painting
- Bug fix: TVTHeader.HandleMessage could provide a wrong column index to OnBeforeColumnWidthTracking in some cases
- Improvement: new properties TBaseVirtualTree.OnBeforeAutoFitColumn, TBaseVirtualTree.OnAfterAutoFitColumn
- Improvement: new procedures TBaseVirtualTree.CancelOperation, TBaseVirtualTree.BeginOperation,
TBaseVirtualTree.EndOperation and new property TBaseVirtualTree.OperationCanceled to enable the
application to stop (possibly) long-running operations
- Improvement: integrated changes from Andreas Hausladen
- Improvement: integrated changes from Dmitry Zegebart where applicable
- Bug fix: removed off-by-1 error in TBaseVirtualTree.GetDisplayRect
- Bug fix: changed the size of the buffer used in TBaseVirtualTree.PaintTree to paint the area below the last node
as the bitmap was not completely erased using previous size under certain conditions
- Bug fix: fixed TBaseVirtualTree.GetPreviousLevel
January 2009
- Bug fix: removed off-by-1 error in TBaseVirtualTree.GetBottomNode
- Improvement: improved speed of TBaseVirtualTree.GetMaxColumnWidth when using UseSmartColumnWidth
- Version is now 4.8.0
December 2008
- Bug fix: modified TBaseVirtualTree.UpdateHorizontalScrollbar and TBaseVirtualTree.UpdateVerticalScrollbar to
recalculate the tree's dimensions even if an update is in progress
- Improvement: renamed TVTHeaderState hsTracking and hsTrackPending to hsColumnWidthTracking and
hsColumnWidthTrackPending
- Improvement: modified TBaseVirtualTree.GetFirstVisible and TBaseVirtualTree.GetFirstVisibleNoInit to optionally
take a node to specify where to start
- Improvement: modified TVTAfterGetMaxColumnWidthEvent to make the result of TBaseVirtualTree.GetMaxColumnWidth
changable
- Bug fix: corrected TBaseVirtualTree.GetMaxColumnWidth to consider toFixedIndent and no longer take nodes into
account that are just above or below the visible area
- Improvement: new property TVirtualTreeColumns.DefaultWidth
- Improvement: new property TVTHeader.FixedAreaConstraints (new class TVTFixedAreaConstraints) to limit the
fixed area (header, fixed columns) to a percentage of the client area
November 2008
- Improvement: new cursor added: crVertSplit used for height tracking
- Improvement: changed type of TVTHeader.Height from Cardinal to Integer to make boundary checks easier
- Improvement: new properties TVTHeader.MinHeight and TVTHeader.MaxHeight
- Improvement: new VirtualTreeStates tsNodeHeightTracking and tsNodeHeightTrackPending
- Improvement: new HeaderStates hsHeightTracking and hsHeightTrackPending
- Improvement: new TVTMiscOption toNodeHeightResize to allow changing node heights via mouse
- Improvement: new TVTHeaderOption hoHeightResize to allow changing header height via mouse
- Improvement: new properties TBaseVirtualTree.OnHeaderHeightTracking, TBaseVirtualTree.OnHeaderDblClickResize,
TBaseVirtualTree.OnColumnWidthTracking, TBaseVirtualTree.OnColumnWidthDblClickResize,
TBaseVirtualTree.OnNodeHeightTracking, TBaseVirtualTree.OnNodeHeightDblClickResize
- Improvement: new function TVTHeader.ResizeColumns to resize multiple columns at once
- Improvement: TVTHeader.DetermineSplitterIndex is no longer influenced by non-resizable columns
- Bug fix: TBaseVirtualTree.ToggleNode now uses DoStateChange to modify FStates
- Bug fix: TBaseVirtualTree.DoBeforeCellPaint now saves the update rect if CellPaintMode is cpmGetContentMargin
and restores it afterwards
- Improvement: modified TBaseVirtualTree.CmMouseWheel to handle mice with wheel delta < 120 correctly
- Improvement: modified TVTHeader.LoadFromStream and WriteToStream to save ParentFont
- Improvement: TVTHeader.Font is now only stored by Delphi if ParentFont is False (Mantis issue #217)
- Bug fix: corrected TVTHeader.Create to set TVTHeader.FOptions correctly to the default value (Mantis issue #333)
- Improvement: new TVTAnimationOption toAdvancedAnimatedToggle to scroll the node to be toggled animatedly instead
of just scroll its child nodes animatedly
- Improvement: added VirtualTreeState tsToggling to eliminate artefacts caused by TBaseVirtualTree.DoSetOffsetXY
while toggling
- Bug fix: corrected button handling when toFixedIndent is set
- Improvement: redesigned TBaseVirtualTree.ToggleNode to harmonize the visual toggle behaviour independent of
toChildrenAbove
- Improvement: made TBaseVirtualTree.CanEdit public
- Improvement: added parameter ConsiderChildrenAbove to TGetNextNodeProc
- Improvement: modified all variants of TBaseVirtualTree.GetFirst and TBaseVirtualTree.GetLast to optionally
consider toChildrenAbove
October 2008
- Bug fix: removed 'FVisibleCount := 0' from TBaseVirtualTree.Clear as this would lead to incorrect VisibleCount in
read-only mode
- Bug fix: fixed a condition in TBaseVirtualTree.ToggleCallback that could lead to artefacts
- Improvement: changed the implementation of TBaseVirtualTree.GetNext/GetPrevious so that no penalties occur if
toChildrenAbove is not set
- Improvement: TBaseVirtualTree.ToggleNode will no longer leave nodes with state vsToggeling if an exception
occurs
- Improvement: improved behaviour of TBaseVirtualTree.ToggleNode in case toChildrenAbove is set
- Bug fix: corrected TBaseVirtualTree.ScrollIntoView to behave as expected when no fixed columns exist
- Bug fix: extended TBaseVirtualTree.InitializeLineImageAndSelectLevel to eliminate artifacts while scrolling with
toChildrenAbove set
- Bug fix: corrected CompareNodePositions to consider toChildrenAbove
- Bug fix: corrected ToggleNode to scroll correctly if toChildrenAbove and toAnimatedToggle are set
- Improvement: new TVTPaintOption toFixedIndent to draw the tree with a fixed ident (instead of node level
dependent indents)
- Improvement: new TVTPaintOption toChildrenAbove to draw children nodes above their parent
August 2008
- Improvement: redesigned and overloaded TBaseVirtualTree.ScrollIntoView in order to use vertical scrolling
separately
- Improvement: optimized TBaseVirtualTree.ScrollIntoView for horizontal scrolling
- Improvement: in TBaseVirtualTree.WMKeyDown column navigation for VK_PRIOR and VK_NEXT is now handled in same way
as row navigation
- Improvement: new TVTHeaderOption hoDisableAnimatedResize to disable animated resize for all columns
- Improvement: new TVTColumnOption coDisableAnimatedResize to disable animated resize for a specific column
- Improvement: in TBaseVirtualTree.UpdateHorizontalScrollBar and TBaseVirtualTree.UpdateVerticalScrollBar scrollbar
updates now avoided for tsUpdating in FStates
July 2008
- Improvement: in TBaseVirtualTree.WMHScroll the horizontal page scrolling now considers fixed columns
- Improvement: in TBaseVirtualTree.ScrollIntoView the case of FFocusedColumn being invalid is considered
- Improvement: in TBaseVirtualTree.HandleMouseDown DoFocusNode is not called if node focus did not change
- Improvement: in TBaseVirtualTree.SetFocusedColumn the focused node will only be invalidate if it was actually
scrolled into view
- Improvement: new TVTColumnOption coAllowFocus to affect column focus behaviour
- Improvement: new function TVTHeader.AllowFocus to check wether a column can be focused
- Improvement: in TBaseVirtualTree.SetFocusedColumn the old colunm and the new column are both invalidated
- Improvement: merged latest changes from Jim into current code base.
June 2008
- Improvement: new property TVirtualTreeColumns.Count
- Bug fix: in TVirtualTreeColumns.AnimatedResize the column is validated (to avoid "List index out of bounds")
- Improvement: the content retangle of the cell can be modified via the OnBeforeCellPaint event, the cell paint
mode indicates wether OnBeforeCellPaint is called for painting the cell or just for getting the
cell content margin
- Improvement: new functions added: TBaseVirtualTree.DoGetCellContentMargins,
TCustomVirtualDrawTree.DoGetCellContentMargin
- Improvement: new property: TCustomVirtualDrawTree.OnGetCellContentMargin
- Improvement: in TBaseVirtualTree.GetMaxColumnWidth the cell content margin is considered
- Improvement: in TBaseVirtualTree.CMHintShow the cell content margin is considered for singleline tooltips
- Improvement: new function added: TVTHeader.DoGetPopupMenu (to query the application via TreeView.FOnGetPopupMenu
for a column specific header popup menu)
- Improvement: new property added: TBaseVirtualTree.OnCanSplitterResizeColumn,
new function added: TVirtualTreeColumns.GetScrollWidth
- Improvement: horizontal page scrolling now uses the average column width (of all visible, non-fixed columns) as
scroll amount
- Improvement: procedure TBaseVirtualTree.CMMouseWheel redesigned
- Bug fix: TVTHeader.DetermineSplitterIndex works correctly even when using fixed columns
- Bug fix: on right-to-left BiDiMode TVirtualTreeColumns.PaintHeader respects (left) scroll bar correctly
- Bug fix: for multiline tooltips also the column width is checked to determine the tooltip is needed or
unnecessary
- Improvement: the result value of GetUseSmartColumnWidth is initialized correctly
- Improvement: added hoFullRepaintOnResize to TVTHeaderOption to enable full header repainting (instead of
repainting all subsequent columns only) on resizing a column
- Bug fix: horizontal page scrolling via mouse wheel now works correctly, i.e. in TBaseVirtualTree.CMMouseWheel
ScrollCount includes GetVisibleFixedWidth and FIndent
- Improvement: new TVTColumnOption coSmartResize to avoid contradicting the virtual paradigm
- Improvement: horizontal scrolling via mouse wheel can be forced by holding the shift key
- Improvement: new parameter for function TBaseVirtualTree.GetMaxColumnWidth added: UseSmartColumnWidth (to
avoid contradicting the virtual paradigm, i.e. leave nodes out of consideration which are not in
view)
- Improvement: new parameters for TVTHeader.AutoFitColumns added: SmartAutoFitType, RangeStartCol and
RangeEndCol
- Improvement: new parameters for events FOnAfterAutoFitColumns, FOnBeforeAutoFitColumns, FOnAfterGetMaxColumnWidth
and FOnBeforeGetMaxColumnWidth added
- Version is now 4.6.0
May 2008
- Improvement: new properties: FOnAfterAutoFitColumns, FOnBeforeAutoFitColumns, FOnAfterGetMaxColumnWidth and
FOnBeforeGetMaxColumnWidth
- Bug fix: FDropTargetNode is considered in TBaseVirtualTree.DoFreeNode
August 2007
- for accessibility, added an OnGetImageText event that can be used to give accessible text to images used in nodes.
- Implemented an ImageText property used by the VTAccessibility unit to retrieve text for a given node and its column.
- Switched loading of accessibility libraries to dynamic from static to avoid problems in Win95
June 2007
- Bug fix: Fixed a problem with potentially large amount of nodes (larger than 2 billion) in
TBaseVirtualTree.SetChildCount.
- Bug fix: remove hint if any in case the tree loses the focus.
- Improvement: TVirtualTreeColumns.HandleClick is now virtual, introduced TVTHeader.DoSetSortColumn.
- Bug fix: compiler error due to old variable reference when enabling flat scrollbars.
May 2007
- Improvement: new functions: GetPreviousSelected, GetPreviousChecked, GetCheckedCount,
GetPreviousCutCopy, GetCutCopyCount, GetFirstLeaf, GetNextLeaf,
GetPreviousLeaf, GetFirstLevel, GetNextLevel, GetPreviousLevel
- Improvement: new properties: CheckedCount, CutCopyCount
- Improvement: DoFocusChanging for finding a valid column (TBaseVirtualTree.WMKeyDown)
March 2007
- Improvement: adjusted accessibility implementation to compile with pre-BDS IDEs.
- If a column is not visible, MultiColumnAccessibility now will not include it.
January 2007
- Improvement: added code donation from Marco Zehe (with help from Sebastian Modersohn) which implements the
MS accessibility interface for Virtual Treeview.
December 2006
- Improvement: bidi mode implementation finished (toAutoBidiColumnOrdering introduced)
- Change: right-to-left flag removed from shorten string methods/events (not necessary)
- Version is now 4.5.0
November 2006
- Bug fix: Total height is wrong on reading from stream
September 2006
- Bug fix: Mantis issue #326
July 2006
- Change: value for crHeaderSplit cursor conflicts with other resource IDs, so I changed it.
- Published OnStartDrag in VirtualDrawTree.
April 2006
- Bug fix: check for MMX availabiltiy is missing in some places before calling MMX code
- Bug fix: flag for VCL dragging was removed too late causing all kind of problems with mouse up code in VCL drag mode.
- Bug fix: If the past mode in ProcessOLEData is amInsertAfter then nodes where inserted in the wrong order.
March 2006
- Bug fix: total count and total height is wrong after loading from stream
- Bug fix: variable node height computation
- Bug fix: FLastChangedNode was not reset in DoFreeNode
February 2006
- Improvement: GetFirstChecked now also has a default value for its state parameter.
- Improvement: avoid potential reentrancy problems in paint code by checking for the paint state there.
January 2006
- Bug fix: disabled images are now drawn like enabled ones (with respect to position, indices etc.).
- Improvement: New property BottomSpace, allows to specify an additional area below the last node in the tree.
- Bug fix: VT.EndUpdate did not invalidate the cache so the cache was never used again after that.
- Improvement: tree states for double clicks (left, middle, right).
December 2005
- Bug fix: check for column index for auto setting main column if the current one is deleted.
For full document history see help file.

674
VirtualTreeview/VTAccessibility.pas Normal file
View File

@@ -0,0 +1,674 @@
unit VTAccessibility;
// This unit implements iAccessible interfaces for the VirtualTree visual components
// and the currently focused node.
//
// Written by Marco Zehe. (c) 2007
interface
uses Windows, Classes, ActiveX, oleacc, VirtualTrees, VTAccessibilityFactory, Controls;
type
TVirtualTreeAccessibility = class(TInterfacedObject, IDispatch, IAccessible)
private
FVirtualTree: TVirtualStringTree;
public
{ IAccessibility }
function Get_accParent(out ppdispParent: IDispatch): HResult; stdcall;
function Get_accChildCount(out pcountChildren: Integer): HResult; stdcall;
function Get_accChild(varChild: OleVariant; out ppdispChild: IDispatch): HResult; stdcall;
function Get_accName(varChild: OleVariant; out pszName: WideString): HResult; stdcall;
function Get_accValue(varChild: OleVariant; out pszValue: WideString): HResult; stdcall;
function Get_accDescription(varChild: OleVariant; out pszDescription: WideString): HResult; stdcall;
function Get_accRole(varChild: OleVariant; out pvarRole: OleVariant): HResult; stdcall;
function Get_accState(varChild: OleVariant; out pvarState: OleVariant): HResult; stdcall;
function Get_accHelp(varChild: OleVariant; out pszHelp: WideString): HResult; stdcall;
function Get_accHelpTopic(out pszHelpFile: WideString; varChild: OleVariant;
out pidTopic: Integer): HResult; stdcall;
function Get_accKeyboardShortcut(varChild: OleVariant; out pszKeyboardShortcut: WideString): HResult; stdcall;
function Get_accFocus(out pvarChild: OleVariant): HResult; stdcall;
function Get_accSelection(out pvarChildren: OleVariant): HResult; stdcall;
function Get_accDefaultAction(varChild: OleVariant; out pszDefaultAction: WideString): HResult; stdcall;
function accSelect(flagsSelect: Integer; varChild: OleVariant): HResult; stdcall;
function accLocation(out pxLeft: Integer; out pyTop: Integer; out pcxWidth: Integer;
out pcyHeight: Integer; varChild: OleVariant): HResult; stdcall;
function accNavigate(navDir: Integer; varStart: OleVariant; out pvarEndUpAt: OleVariant): HResult; stdcall;
function accHitTest(xLeft: Integer; yTop: Integer; out pvarChild: OleVariant): HResult; stdcall;
function accDoDefaultAction(varChild: OleVariant): HResult; stdcall;
function Set_accName(varChild: OleVariant; const pszName: WideString): HResult; stdcall;
function Set_accValue(varChild: OleVariant; const pszValue: WideString): HResult; stdcall;
{IDispatch}
function GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount: Integer; LocaleID: Integer; DispIDs: Pointer): HRESULT; stdcall;
function GetTypeInfo(Index: Integer; LocaleID: Integer;
out TypeInfo): HRESULT; stdcall;
function GetTypeInfoCount(out Count: Integer): HRESULT; stdcall;
function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params; VarResult: Pointer; ExcepInfo: Pointer;
ArgErr: Pointer): HRESULT; stdcall;
constructor Create(VirtualTree: TVirtualStringTree);
end;
TVirtualTreeItemAccessibility = class(TVirtualTreeAccessibility, IAccessible)
public
{ IAccessibility }
function Get_accParent(out ppdispParent: IDispatch): HResult; stdcall;
function Get_accChildCount(out pcountChildren: Integer): HResult; stdcall;
function Get_accChild(varChild: OleVariant; out ppdispChild: IDispatch): HResult; stdcall;
function Get_accName(varChild: OleVariant; out pszName: WideString): HResult; stdcall;
function Get_accValue(varChild: OleVariant; out pszValue: WideString): HResult; stdcall;
function Get_accDescription(varChild: OleVariant; out pszDescription: WideString): HResult; stdcall;
function Get_accRole(varChild: OleVariant; out pvarRole: OleVariant): HResult; stdcall;
function Get_accState(varChild: OleVariant; out pvarState: OleVariant): HResult; stdcall;
function accLocation(out pxLeft: Integer;
out pyTop: Integer; out pcxWidth: Integer;
out pcyHeight: Integer; varChild: OleVariant): HResult; stdcall;
constructor Create(VirtualTree: TVirtualStringTree);
end;
TVTMultiColumnItemAccessibility = class(TVirtualTreeItemAccessibility, IAccessible)
private
function GetItemDescription(varChild: OleVariant; out pszDescription: WideString; IncludeMainColumn: boolean): HResult; stdcall;
public
{ IAccessibility }
function Get_accName(varChild: OleVariant; out pszName: WideString): HResult; stdcall;
function Get_accDescription(varChild: OleVariant; out pszDescription: WideString): HResult; stdcall;
end;
TVTDefaultAccessibleProvider = class(TInterfacedObject, IVTAccessibleProvider)
function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible;
end;
TVTDefaultAccessibleItemProvider = class(TInterfacedObject, IVTAccessibleProvider)
function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible;
end;
TVTMultiColumnAccessibleItemProvider = class(TInterfacedObject, IVTAccessibleProvider)
function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible;
end;
implementation
uses Variants, SysUtils, Types, Forms;
{ TVirtualTreeAccessibility }
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.accDoDefaultAction(varChild: OleVariant): HResult;
// a default action is not supported.
begin
Result := DISP_E_MEMBERNOTFOUND;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.accHitTest(xLeft: Integer; yTop: Integer; out pvarChild: OleVariant): HResult;
// returns the iAccessible object at the given point, if applicable.
var
Pt: TPoint;
HitInfo: THitInfo;
begin
Result := S_FALSE;
if FVirtualTree <> nil then
begin
// VariantInit(pvarChild);
// TVarData(pvarChild).VType := VT_I4;
Pt := fVirtualTree.ScreenToClient(Point(xLeft, yTop));
if fVirtualTree.FocusedNode <> nil then
begin
fVirtualTree.GetHitTestInfoAt(xLeft, yTop, false, HitInfo);
if FVirtualTree.FocusedNode = HitInfo.HitNode then
begin
pvarChild := FVirtualTree.AccessibleItem;
Result := S_OK;
exit;
end;
end;
if PtInRect(FVirtualTree.BoundsRect, Pt) then
begin
pvarChild := CHILDID_SELF;
Result := S_OK;
end;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.accLocation(out pxLeft: Integer;
out pyTop: Integer; out pcxWidth: Integer;
out pcyHeight: Integer; varChild: OleVariant): HResult;
// returns the location of the VirtualStringTree object.
var
P: TPoint;
begin
Result := S_FALSE;
if varChild = CHILDID_SELF then
begin
if FVirtualTree <> nil then
begin
P := FVirtualTree.ClientToScreen(FVirtualTree.ClientRect.TopLeft);
pxLeft := P.X;
pyTop := P.Y;
pcxWidth := FVirtualTree.Width;
pcyHeight := FVirtualTree.Height;
Result := S_OK;
end;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.accNavigate(navDir: Integer; varStart: OleVariant;
out pvarEndUpAt: OleVariant): HResult;
// This is not supported.
begin
Result := DISP_E_MEMBERNOTFOUND;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Get_accSelection(out pvarChildren: OleVariant): HResult;
// returns the selected child ID, if any.
begin
Result := s_false;
if FVirtualTree <> nil then
if fVirtualTree.FocusedNode <> nil then
begin
pvarChildren := 1;
result := s_OK;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
constructor TVirtualTreeAccessibility.Create(VirtualTree: TVirtualStringTree);
// assigns the parent and current fields, and lets the control's iAccessible object know its address.
begin
fVirtualTree := VirtualTree;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.GetIDsOfNames(const IID: TGUID;
Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HRESULT;
// Not supported.
begin
Result := E_NOTIMPL;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.GetTypeInfo(Index, LocaleID: Integer;
out TypeInfo): HRESULT;
// not supported.
begin
Result := E_NOTIMPL;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.GetTypeInfoCount(
out Count: Integer): HRESULT;
// not supported.
begin
Result := E_NOTIMPL;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Get_accChild(varChild: OleVariant; out ppdispChild: IDispatch): HResult;
// returns the iAccessible child, whicfh represents the focused item.
begin
if varChild = CHILDID_SELF then
begin
ppdispChild := FVirtualTree.AccessibleItem;
Result := S_OK;
end
else
Result := E_INVALIDARG
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Get_accChildCount(out pcountChildren: Integer): HResult;
// Returns the number 1 for the one child: The focused item.
begin
pcountChildren := 1;
Result := S_OK;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Get_accDefaultAction(varChild: OleVariant; out pszDefaultAction: WideString): HResult;
// Not supported.
begin
Result := DISP_E_MEMBERNOTFOUND;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Get_accDescription(varChild: OleVariant; out pszDescription: WideString): HResult;
// returns the hint of the control, if assigned.
begin
pszDescription := '';
Result := S_FALSE;
if varChild = CHILDID_SELF then
begin
if FVirtualTree <> nil then
pszDescription := GetLongHint(fVirtualTree.Hint);
end;
if Length(pszDescription) > 0 then
Result := S_OK;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Get_accFocus(out pvarChild: OleVariant): HResult;
// returns the child ID of 1, if assigned.
begin
Result := s_false;
if fVirtualTree <> nil then
begin
if FVirtualTree.FocusedNode <> nil then
begin
pvarChild := fVirtualTree.AccessibleItem;
result := s_OK;
end
else begin
pvarChild := childid_self;
result := S_OK;
end;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Get_accHelp(varChild: OleVariant; out pszHelp: WideString): HResult;
// Not supported.
begin
Result := DISP_E_MEMBERNOTFOUND;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Get_accHelpTopic(out pszHelpFile: WideString; varChild: OleVariant;
out pidTopic: Integer): HResult;
// Returns the HelpContext ID, if present.
begin
pszHelpFile := '';
pidTopic := 0;
Result := S_OK;
if varChild = CHILDID_SELF then
if FVirtualTree <> nil then
begin
pszHelpFile := Application.HelpFile;
pidTopic := FVirtualTree.HelpContext;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Get_accKeyboardShortcut(varChild: OleVariant; out pszKeyboardShortcut: WideString): HResult;
// Not supported.
begin
pszKeyboardShortcut := '';
Result := S_FALSE;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Get_accName(varChild: OleVariant; out pszName: WideString): HResult;
// if set, returns the new published AccessibleName property.
// otherwise, returns the default text.
begin
pszName := '';
Result := S_FALSE;
if varChild = CHILDID_SELF then
begin
if FVirtualTree <> nil then
begin
if FVirtualTree.AccessibleName <> '' then
pszName := FVirtualTree.AccessibleName
else
PSZName := FVirtualTree.DefaultText;
result := S_OK;
end;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Get_accParent(out ppdispParent: IDispatch): HResult;
// Returns false, the tree itself does not have a parent.
begin
ppdispParent := nil;
Result := S_FALSE;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Get_accRole(varChild: OleVariant; out pvarRole: OleVariant): HResult;
// tells MSAA that it is a TreeView.
begin
Result := S_OK;
// VariantInit(pvarRole);
// TVarData(pvarRole).VType := VT_I4;
if varChild = CHILDID_SELF then
begin
if FVirtualTree <> nil then
pvarRole := ROLE_SYSTEM_OUTLINE
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.accSelect(flagsSelect: Integer; varChild: OleVariant): HResult;
// since we're not supporting more than one item, this is not supported currently.
begin
Result := DISP_E_MEMBERNOTFOUND;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Get_accState(varChild: OleVariant; out pvarState: OleVariant): HResult;
// returns the state of the control.
const
IsEnabled: array[Boolean] of Integer = (STATE_SYSTEM_UNAVAILABLE, 0);
HasPopup: array[Boolean] of Integer = (0, STATE_SYSTEM_HASPOPUP);
IsVisible: array[Boolean] of Integer = (STATE_SYSTEM_INVISIBLE, 0);
begin
Result := S_OK;
// VariantInit(pvarState);
// TVarData(pvarState).VType := VT_I4;
if varChild = CHILDID_SELF then
begin
if FVirtualTree <> nil then
begin
pvarState := STATE_SYSTEM_FOCUSED or STATE_SYSTEM_FOCUSABLE or STATE_SYSTEM_HOTTRACKED;
pvarState := pvarState or IsVisible[FVirtualTree.Visible];
pvarState := pvarState or IsEnabled[FVirtualTree.Enabled];
end
else
Result := E_INVALIDARG;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Get_accValue(varChild: OleVariant; out pszValue: WideString): HResult;
// the TreeView control itself does not have a value, returning false here.
begin
pszValue := '';
Result := S_FALSE;//DISP_E_MEMBERNOTFOUND;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Invoke(DispID: Integer; const IID: TGUID;
LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
ArgErr: Pointer): HRESULT;
// not supported.
begin
Result := E_NOTIMPL;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Set_accName(varChild: OleVariant; const pszName: WideString): HResult; stdcall;
// not supported.
begin
Result := DISP_E_MEMBERNOTFOUND
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeAccessibility.Set_accValue(varChild: OleVariant; const pszValue: WideString): HResult;
// not supported.
begin
Result := DISP_E_MEMBERNOTFOUND
end;
{ TVirtualTreeItemAccessibility }
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeItemAccessibility.accLocation(out pxLeft, pyTop, pcxWidth,
pcyHeight: Integer; varChild: OleVariant): HResult;
// returns the location of the current accessible item.
var
P: TPoint;
DisplayRect: TRect;
begin
Result := S_FALSE;
if varChild = CHILDID_SELF then
begin
if FVirtualTree.FocusedNode <> nil then
begin
DisplayRect := FVirtualTree.GetDisplayRect(FVirtualTree.FocusedNode, -1, TRUE, FALSE);
P := FVirtualTree.ClientToScreen(DisplayRect.TopLeft);
pxLeft := P.X;
pyTop := P.Y;
pcxWidth := DisplayRect.Right - DisplayRect.Left;
pcyHeight := DisplayRect.Bottom - DisplayRect.Top;
Result := S_OK;
end;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
constructor TVirtualTreeItemAccessibility.Create(VirtualTree: TVirtualStringTree);
// sets up the parent/child relationship.
begin
fVirtualTree := VirtualTree;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeItemAccessibility.Get_accChild(varChild: OleVariant; out ppdispChild: IDispatch): HResult;
// the item does not have children. Returning false.
begin
ppdispChild := nil;
Result := S_FALSE;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeItemAccessibility.Get_accChildCount(out pcountChildren: Integer): HResult;
// the item itself does not have children, returning 0.
begin
pcountChildren := 0;
Result := S_OK;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeItemAccessibility.Get_accDescription(varChild: OleVariant; out pszDescription: WideString): HResult;
// not supported for an item.
begin
Result := DISP_E_MEMBERNOTFOUND;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeItemAccessibility.Get_accName(varChild: OleVariant; out pszName: WideString): HResult;
// the name is the node's caption.
begin
pszName := '';
Result := S_FALSE;
if varChild = childid_self then
begin
if FVirtualTree <> nil then
if FVirtualTree.FocusedNode <> nil then
begin
pszName := FVirtualTree.Text[FVirtualTree.FocusedNode, FVirtualTree.Header.MainColumn];
result := S_OK;
end
else begin
PSZName := FVirtualTree.DefaultText;
result := S_OK;
end;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeItemAccessibility.Get_accParent(out ppdispParent: IDispatch): HResult;
// tells MSAA that the VritualStringTree is its parent.
begin
result := S_FALSE;
if FVirtualTree <> nil then
begin
ppdispParent := FVirtualTree.Accessible;
Result := S_OK;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeItemAccessibility.Get_accRole(varChild: OleVariant; out pvarRole: OleVariant): HResult;
// tells MSAA that it is a TreeView item as opposed to the TreeView itself.
begin
Result := S_OK;
// VariantInit(pvarRole);
// TVarData(pvarRole).VType := VT_I4;
if varChild = childid_self then
begin
if FVirtualTree <> nil then
pvarRole := ROLE_SYSTEM_OUTLINEITEM
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeItemAccessibility.Get_accState(varChild: OleVariant; out pvarState: OleVariant): HResult;
// Tells MSAA the state the item is in.
const
IsEnabled: array[Boolean] of Integer = (STATE_SYSTEM_UNAVAILABLE, 0);
HasPopup: array[Boolean] of Integer = (0, STATE_SYSTEM_HASPOPUP);
IsVisible: array[Boolean] of Integer = (STATE_SYSTEM_INVISIBLE, 0);
IsChecked: array[Boolean] of Integer = (0, STATE_SYSTEM_CHECKED);
IsExpanded: array[Boolean] of Integer = (0, STATE_SYSTEM_EXPANDED);
IsCollapsed: array[Boolean] of Integer = (0, STATE_SYSTEM_COLLAPSED);
begin
Result := S_OK;
// VariantInit(pvarState);
// TVarData(pvarState).VType := VT_I4;
if varChild = childid_self then
begin
if FVirtualTree <> nil then
begin
pvarState := STATE_SYSTEM_FOCUSED or STATE_SYSTEM_FOCUSABLE or STATE_SYSTEM_HOTTRACKED;
pvarState := pvarState or IsVisible[FVirtualTree.Visible];
pvarState := pvarState or IsEnabled[FVirtualTree.Enabled];
if fVirtualTree.FocusedNode <> nil then
begin
pvarState := pvarState or IsChecked[csCheckedNormal = FVirtualTree.FocusedNode.CheckState];
pvarState := pvarState or IsExpanded[VSExpanded in FVirtualTree.FocusedNode.States];
if not (vsExpanded in FVirtualTree.FocusedNode.States) then
pvarState:= PvarState or IsCollapsed[vsHasChildren in FVirtualTree.FocusedNode.States];
end;
end
else
Result := E_INVALIDARG;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVirtualTreeItemAccessibility.Get_accValue(varChild: OleVariant; out pszValue: WideString): HResult;
// for a TreeView item, the value is the nesting level number, 0-based.
begin
pszValue := '';
Result := S_FALSE;//DISP_E_MEMBERNOTFOUND;
if varChild = childid_self then
if FVirtualTree <> nil then
if FVirtualTree.FocusedNode <> nil then
begin
PSZValue := IntToStr(FVirtualTree.GetNodeLevel(FVirtualTree.FocusedNode));
result := S_OK;
end;
end;
{ TVTMultiColumnItemAccessibility }
function TVTMultiColumnItemAccessibility.GetItemDescription(
varChild: OleVariant; out pszDescription: WideString;
IncludeMainColumn: boolean): HResult;
var
I: Integer;
sTemp: WideString;
begin
pszDescription := '';
Result := S_FALSE;
if varChild = childid_self then
begin
if FVirtualTree <> nil then
if FVirtualTree.FocusedNode <> nil then
begin
if IncludeMainColumn then
pszDescription := FVirtualTree.Text[FVirtualTree.FocusedNode, FVirtualTree.Header.MainColumn]
+'; ';
for I := 0 to FVirtualTree.Header.Columns.Count - 1 do
if FVirtualTree.Header.MainColumn <> I then
begin
sTemp := FVirtualTree.Text[FVirtualTree.FocusedNode, I];
if sTemp <> '' then
pszDescription := pszDescription
+FVirtualTree.Header.Columns[I].Text
+': '
+sTemp
+'; ';
end;
if pszDescription <> '' then
if pszDescription[Length(pszDescription)-1] = ';' then
Delete(pszDescription, length(pszDescription)-1, 2);
result := S_OK;
end
else begin
PSZDescription := FVirtualTree.DefaultText;
result := S_OK;
end;
end;
end;
function TVTMultiColumnItemAccessibility.Get_accDescription(
varChild: OleVariant; out pszDescription: WideString): HResult;
begin
result := GetItemDescription(varChild, pszDescription, false)
end;
function TVTMultiColumnItemAccessibility.Get_accName(varChild: OleVariant;
out pszName: WideString): HResult;
begin
result := GetItemDescription(varChild, pszName, true)
end;
{ TVTDefaultAccessibleProvider }
function TVTDefaultAccessibleProvider.CreateIAccessible(
ATree: TBaseVirtualTree): IAccessible;
begin
result := TVirtualTreeAccessibility.Create(TVirtualStringTree(ATree));
end;
{ TVTDefaultAccessibleItemProvider }
function TVTDefaultAccessibleItemProvider.CreateIAccessible(
ATree: TBaseVirtualTree): IAccessible;
begin
result := TVirtualTreeItemAccessibility.Create(TVirtualStringTree(ATree));
end;
{ TVTMultiColumnAccessibleItemProvider }
function TVTMultiColumnAccessibleItemProvider.CreateIAccessible(
ATree: TBaseVirtualTree): IAccessible;
begin
result := nil;
if TVirtualStringTree(ATree).Header.UseColumns then
result := TVTMultiColumnItemAccessibility.Create(TVirtualStringTree(ATree));
end;
var
IDefaultAccessibleProvider: TVTDefaultAccessibleProvider;
IDefaultAccessibleItemProvider: TVTDefaultAccessibleItemProvider;
IMultiColumnAccessibleProvider: TVTMultiColumnAccessibleItemProvider;
initialization
if VTAccessibleFactory = nil then
VTAccessibleFactory := TVTAccessibilityFactory.Create;
if IDefaultAccessibleProvider = nil then
begin
IDefaultAccessibleProvider := TVTDefaultAccessibleProvider.Create;
VTAccessibleFactory.RegisterAccessibleProvider(IDefaultAccessibleProvider);
end;
if IDefaultAccessibleItemProvider = nil then
begin
IDefaultAccessibleItemProvider := TVTDefaultAccessibleItemProvider.Create;
VTAccessibleFactory.RegisterAccessibleProvider(IDefaultAccessibleItemProvider);
end;
if IMultiColumnAccessibleProvider = nil then
begin
IMultiColumnAccessibleProvider := TVTMultiColumnAccessibleItemProvider.Create;
VTAccessibleFactory.RegisterAccessibleProvider(IMultiColumnAccessibleProvider);
end;
finalization
if VTAccessibleFactory <> nil then
begin
VTAccessibleFactory.UnRegisterAccessibleProvider(IMultiColumnAccessibleProvider);
IMultiColumnAccessibleProvider := nil;
VTAccessibleFactory.UnRegisterAccessibleProvider(IDefaultAccessibleItemProvider);
IDefaultAccessibleItemProvider := nil;
VTAccessibleFactory.UnRegisterAccessibleProvider(IDefaultAccessibleProvider);
IDefaultAccessibleProvider := nil;
end;
end.

123
VirtualTreeview/VTAccessibilityFactory.pas Normal file
View File

@@ -0,0 +1,123 @@
unit VTAccessibilityFactory;
// class to create IAccessibles for the tree passed into it.
// If not already assigned, creates IAccessibles for the tree itself
// and the focused item
// the tree accessible is returned when the tree receives an WM_GETOBJECT message
// the AccessibleItem is returned when the Accessible is being asked for the first child
// To create your own IAccessibles, use the VTStandardAccessible unit as a reference,
// and assign your Accessibles to the variables in tthe unit's initialization.
// You only need to add the unit to your project, and voil<69>, you have an accessible string tree!
//
// Written by Marco Zehe. (c) 2007
interface
uses
Classes, oleacc, VirtualTrees;
type
IVTAccessibleProvider = interface
function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible;
end;
TVTAccessibilityFactory = class(TObject)
private
FAccessibleProviders: TInterfaceList;
public
constructor Create;
destructor Destroy; override;
function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible;
procedure RegisterAccessibleProvider(AProvider: IVTAccessibleProvider);
procedure UnRegisterAccessibleProvider(AProvider: IVTAccessibleProvider);
end;
var
VTAccessibleFactory: TVTAccessibilityFactory;
implementation
{ TVTAccessibilityFactory }
constructor TVTAccessibilityFactory.Create;
begin
inherited;
FAccessibleProviders := TInterfaceList.Create;
FAccessibleProviders.Clear;
end;
function TVTAccessibilityFactory.CreateIAccessible(
ATree: TBaseVirtualTree): IAccessible;
var
I: Integer;
TmpIAccessible: IAccessible;
// returns an IAccessible.
// 1. If the Accessible property of the passed-in tree is nil,
// the first registered element will be returned.
// Usually, this is the IAccessible that provides information about the tree itself.
// If it is not nil, we'll check whether the AccessibleItem is nil.
// If it is, we'll look in the registered IAccessibles for the appropriate one.
// Each IAccessibleProvider will check the tree for properties to determine whether it is responsible.
// We'll work top to bottom, from the most complicated to the most simple.
// The index for these should all be greater than 0, e g the IAccessible for the tree itself should always be registered first, then any IAccessible items.
begin
result := nil;
if ATree <> nil then
begin
if ATree.Accessible = nil then
begin
if FAccessibleProviders.Count > 0 then
begin
result := IVTAccessibleProvider(FAccessibleProviders.Items[0]).CreateIAccessible(ATree);
exit;
end;
end;
if ATree.AccessibleItem = nil then
begin
if FAccessibleProviders.Count > 0 then
begin
for I := FAccessibleProviders.Count - 1 downto 1 do
begin
TmpIAccessible := IVTAccessibleProvider(FAccessibleProviders.Items[I]).CreateIAccessible(ATree);
if TmpIAccessible <> nil then
begin
result := TmpIAccessible;
break;
end;
end;
if TmpIAccessible = nil then
begin
result := IVTAccessibleProvider(FAccessibleProviders.Items[0]).CreateIAccessible(ATree);
end;
end;
end
else begin
result := ATree.AccessibleItem;
end;
end;
end;
destructor TVTAccessibilityFactory.Destroy;
begin
FAccessibleProviders.Free;
FAccessibleProviders := nil;
inherited;
end;
procedure TVTAccessibilityFactory.RegisterAccessibleProvider(
AProvider: IVTAccessibleProvider);
// Ads a provider if it is not already registered
begin
if FAccessibleProviders.IndexOf(AProvider) < 0 then
FAccessibleProviders.Add(AProvider)
end;
procedure TVTAccessibilityFactory.UnRegisterAccessibleProvider(
AProvider: IVTAccessibleProvider);
// Unregisters/removes an IAccessible provider if it is present
begin
if FAccessibleProviders.IndexOf(AProvider) >= 0 then
FAccessibleProviders.Remove(AProvider);
end;
end.

51
VirtualTreeview/VTConfig.inc Normal file
View File

@@ -0,0 +1,51 @@
// Configuration file for VirtualTrees.pas (see www.soft-gems.net).
//
// The content of this file is public domain. You may do with it whatever you like, provided the header stays fully intact
// in all version and derivative work.
//
// The original code is VTConfig.inc, released October 5, 2004.
//
// The initial developer of the original code is Mike Lischke (public@soft-gems.net, www.soft-gems.net).
//----------------------------------------------------------------------------------------------------------------------
{.$define UseFlatScrollbars}
{.$define ReverseFullExpandHotKey} // Used to define Ctrl+'+' instead of Ctrl+Shift+'+' for full expand (and similar for collapsing).
// Enable this switch for Windows XP theme support. If you compile with Delphi 6 or lower you must download and install
// the Soft Gems Theme Manager package.
{.$define ThemeSupport}
// Virtual Treeview can use a tiny but very effective local memory manager for node allocation.
// The local memory manager was implemented by David Clark from Caelo Software Inc.
// See below for more info about it.
{.$define UseLocalMemoryManager}
//Lazarus port options
{$define EnableOLE}
{.$define EnableNativeTVM}
{.$define EnablePrint}
{.$define EnableNCFunctions}
{$define EnableAdvancedGraphics}
{$define EnableAlphaBlend}
{.$define EnableAccessible}
{$define ThemeSupport}
{$if defined(LCLWin32) or defined(LCLWinCE)}
{$define LCLWin}
{$endif}
{.$define DEBUG_VTV}
{$define USE_DELPHICOMPAT}
//since
{$if not defined(USE_DELPHICOMPAT) and not defined(LCLWin)}
{$define INCOMPLETE_WINAPI}
{$endif}
//under linux the performance is poor with threading enabled
{$ifdef Windows}
{$define EnableThreadSupport}
{$endif}
{$if defined(CPU64) or defined(LCLCarbon)}
{$define PACKARRAYPASCAL}
{$endif}
{$define CompilerVersion := 19}

32
VirtualTreeview/VTGraphics.pas Normal file
View File

@@ -0,0 +1,32 @@
unit VTGraphics;
{$mode delphi}
interface
uses
DelphiCompat, Types, LCLIntf, LCLType;
type
// Describes the mode how to blend pixels.
TBlendMode = (
bmConstantAlpha, // apply given constant alpha
bmPerPixelAlpha, // use alpha value of the source pixel
bmMasterAlpha, // use alpha value of source pixel and multiply it with the constant alpha value
bmConstantAlphaAndColor // blend the destination color with the given constant color und the constant alpha value
);
procedure AlphaBlend(Source, Destination: HDC; const R: TRect; const Target: TPoint; Mode: TBlendMode; ConstantAlpha, Bias: Integer);
function CalculateScanline(Bits: Pointer; Width, Height, Row: Integer): Pointer;
function GetBitmapBitsFromBitmap(Bitmap: HBITMAP): Pointer;
implementation
{$i vtgraphicsi.inc}
end.

250
VirtualTreeview/VTHeaderPopup.pas Normal file
View File

@@ -0,0 +1,250 @@
unit VTHeaderPopup;
//----------------------------------------------------------------------------------------------------------------------
//
// Version 4.7.0
//
// 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/
//
// Alternatively, you may redistribute this library, use and/or modify it under the terms of the
// GNU Lesser General Public License as published by the Free Software Foundation;
// either version 2.1 of the License, or (at your option) any later version.
// You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/.
//
// Software distributed under the License is distributed on an "AS IS"
// basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
// License for the specific language governing rights and limitations
// under the License.
//
// The Original Code is VTHeaderPopup.pas.
//
// The Initial Developer of the Original Code is Ralf Junker <delphi@zeitungsjunge.de>. All Rights Reserved.
//
// September 2004:
// - Bug fix: TVTHeaderPopupMenu.OnMenuItemClick used the wrong Tag member for the event.
//
// Modified 12 Dec 2003 by Ralf Junker <delphi@zeitungsjunge.de>.
// - Added missing default storage specifier for Options property.
// - To avoid mixing up image lists of different trees sharing the same header
// popup, set the popup's image list to nil if hoShowImages is not in the
// tree's header options.
// - Added an additional check for the PopupComponent property before casting
// it hardly to a Virtual Treeview in OnMenuItemClick. See entry 31 Mar 2003.
//
// Modified 14 Sep 2003 by Mike Lischke <public@delphi-gems.com>.
// - Renamed event type name to be consistent with other event types (e.g. used in VT).
// - Added event for hiding/showing columns.
// - DoXXX method are now virtual.
// - Conditional code rearrangement to get back Ctrl+Shift+Up/Down navigation.
//
// Modified 31 Mar 2003 by Mike Lischke <public@soft-gems.net>.
// - Added a check for the PopupComponent property before casting it hardly to
// a Virtual Treeview. People might (accidentally) misuse the header popup.
//
// Modified 20 Oct 2002 by Borut Maricic <borut.maricic@pobox.com>.
// - Added the possibility to use Troy Wolbrink's Unicode aware popup menu.
// Define the compiler symbol TNT to enable it. You can get Troy's Unicode
// controls collection from http://home.ccci.org/wolbrink/tnt/delphi_unicode_controls.htm.
//
// Modified 24 Feb 2002 by Ralf Junker <delphi@zeitungsjunge.de>.
// - Fixed a bug where the OnAddHeaderPopupItem would interfere with
// poAllowHideAll options.
// - All column indexes now consistently use TColumnIndex (instead of Integer).
//
// Modified 23 Feb 2002 by Ralf Junker <delphi@zeitungsjunge.de>.
// - Added option to show menu items in the same order as the columns or in
// original order.
// - Added option to prevent the user to hide all columns.
//
// Modified 17 Feb 2002 by Jim Kueneman <jimdk@mindspring.com>.
// - Added the event to filter the items as they are added to the menu.
// 2014
// - Adapted and improved for LCL by Luiz Américo Pereira Câmara
//----------------------------------------------------------------------------------------------------------------------
{$mode delphi}
interface
uses
Menus, VirtualTrees;
type
TVTHeaderPopupOption = (
poOriginalOrder, // Show menu items in original column order as they were added to the tree.
poAllowHideAll, // Allows to hide all columns, including the last one.
poResizeToFitItem // Adds an item which, if clicks, resizes all columns to fit by callung TVTHeader.AutoFitColumns
);
TVTHeaderPopupOptions = set of TVTHeaderPopupOption;
TAddPopupItemType = (
apNormal,
apDisabled,
apHidden
);
TAddHeaderPopupItemEvent = procedure(const Sender: TBaseVirtualTree; const Column: TColumnIndex;
var Cmd: TAddPopupItemType) of object;
TColumnChangeEvent = procedure(const Sender: TBaseVirtualTree; const Column: TColumnIndex; Visible: Boolean) of object;
TVTMenuItem = TMenuItem;
TVTHeaderPopupMenu = class(TPopupMenu)
strict private
FOptions: TVTHeaderPopupOptions;
FOnAddHeaderPopupItem: TAddHeaderPopupItemEvent;
FOnColumnChange: TColumnChangeEvent;
strict protected
procedure DoAddHeaderPopupItem(const Column: TColumnIndex; out Cmd: TAddPopupItemType); virtual;
procedure DoColumnChange(Column: TColumnIndex; Visible: Boolean); virtual;
procedure OnMenuItemClick(Sender: TObject);
public
procedure Popup(x, y: Integer); override;
published
property Options: TVTHeaderPopupOptions read FOptions write FOptions default [];
property OnAddHeaderPopupItem: TAddHeaderPopupItemEvent read FOnAddHeaderPopupItem write FOnAddHeaderPopupItem;
property OnColumnChange: TColumnChangeEvent read FOnColumnChange write FOnColumnChange;
end;
//----------------------------------------------------------------------------------------------------------------------
implementation
uses
Classes;
const
cResizeToFitMenuItemName = 'VT_ResizeToFitMenuItem';
type
TVirtualTreeCast = class(TBaseVirtualTree); // Necessary to make the header accessible.
//----------------- TVTHeaderPopupMenu ---------------------------------------------------------------------------------
procedure TVTHeaderPopupMenu.DoAddHeaderPopupItem(const Column: TColumnIndex; out Cmd: TAddPopupItemType);
begin
Cmd := apNormal;
if Assigned(FOnAddHeaderPopupItem) then
FOnAddHeaderPopupItem(TVirtualTreeCast(PopupComponent), Column, Cmd);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTHeaderPopupMenu.DoColumnChange(Column: TColumnIndex; Visible: Boolean);
begin
if Assigned(FOnColumnChange) then
FOnColumnChange(TVirtualTreeCast(PopupComponent), Column, Visible);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTHeaderPopupMenu.OnMenuItemClick(Sender: TObject);
begin
if Assigned(PopupComponent) and (PopupComponent is TBaseVirtualTree) then begin
if TVTMenuItem(Sender).Name = cResizeToFitMenuItemName then begin
TVirtualTreeCast(PopupComponent).Header.AutoFitColumns();
end
else begin
with TVTMenuItem(Sender),
TVirtualTreeCast(PopupComponent).Header.Columns.Items[Tag] do
begin
if Checked then
Options := Options - [coVisible]
else
Options := Options + [coVisible];
DoColumnChange(TVTMenuItem(Sender).Tag, not Checked);
end;
end;//else
end;
end;
//----------------------------------------------------------------------------------------------------------------------
resourcestring
sResizeToFit = '&Resize All Columns To Fit';
procedure TVTHeaderPopupMenu.Popup(x, y: Integer);
var
ColPos: TColumnPosition;
ColIdx: TColumnIndex;
NewMenuItem: TVTMenuItem;
Cmd: TAddPopupItemType;
VisibleCounter: Cardinal;
VisibleItem: TVTMenuItem;
begin
if Assigned(PopupComponent) and (PopupComponent is TBaseVirtualTree) then
begin
// Delete existing menu items.
while Items.Count > 0 do
Items[0].Free;
if poResizeToFitItem in Self.Options then begin
NewMenuItem := NewItem(sResizeToFit, 0, False, True, OnMenuItemClick, 0, cResizeToFitMenuItemName);
Items.Add(NewMenuItem);
Items.Add(NewLine());
end;//poResizeToFitItem
// Add column menu items.
with TVirtualTreeCast(PopupComponent).Header do
begin
if hoShowImages in Options then
Self.Images := Images
else
// Remove a possible reference to image list of another tree previously assigned.
Self.Images := nil;
VisibleItem := nil;
VisibleCounter := 0;
for ColPos := 0 to Columns.Count - 1 do
begin
if poOriginalOrder in FOptions then
ColIdx := ColPos
else
ColIdx := Columns.ColumnFromPosition(ColPos);
with Columns[ColIdx] do
begin
if coVisible in Options then
Inc(VisibleCounter);
DoAddHeaderPopupItem(ColIdx, Cmd);
if Cmd <> apHidden then
begin
NewMenuItem := TVTMenuItem.Create(Self);
NewMenuItem.Tag := ColIdx;
NewMenuItem.Caption := Text;
NewMenuItem.Hint := Hint;
NewMenuItem.ImageIndex := ImageIndex;
NewMenuItem.Checked := coVisible in Options;
NewMenuItem.OnClick := OnMenuItemClick;
if Cmd = apDisabled then
NewMenuItem.Enabled := False
else
if coVisible in Options then
VisibleItem := NewMenuItem;
Items.Add(NewMenuItem);
end;
end;
end;
// Conditionally disable menu item of last enabled column.
if (VisibleCounter = 1) and (VisibleItem <> nil) and not (poAllowHideAll in FOptions) then
VisibleItem.Enabled := False;
end;
end;
inherited;
end;
//----------------------------------------------------------------------------------------------------------------------
end.

57
VirtualTreeview/VTIDEEditors.pas Normal file
View File

@@ -0,0 +1,57 @@
unit VTIDEEditors;
{$mode objfpc}{$H+}
interface
uses
ComponentEditors, PropEdits, VirtualTrees;
type
// The usual trick to make a protected property accessible in the ShowCollectionEditor call below.
TVirtualTreeCast = class(TBaseVirtualTree);
{ TVirtualTreeEditor }
TVirtualTreeEditor = class(TComponentEditor)
public
procedure Edit; override;
function GetVerbCount: Integer; override;
function GetVerb(Index: Integer): string; override;
procedure ExecuteVerb(Index: Integer); override;
end;
implementation
{ TVirtualTreeEditor }
procedure TVirtualTreeEditor.Edit;
var
Tree: TVirtualTreeCast;
begin
Tree := TVirtualTreeCast(GetComponent);
TCollectionPropertyEditor.ShowCollectionEditor(Tree.Header.Columns, Tree, 'Columns');
end;
function TVirtualTreeEditor.GetVerbCount: Integer;
begin
Result := 1;
end;
function TVirtualTreeEditor.GetVerb(Index: Integer): string;
begin
case Index of
0: Result := 'Edit Columns...';
end;
end;
procedure TVirtualTreeEditor.ExecuteVerb(Index: Integer);
begin
case Index of
0: Edit;
end;
end;
end.

36047
VirtualTreeview/VirtualTrees.pas Normal file
View File

File diff suppressed because it is too large Load Diff

2
VirtualTreeview/include/intf/carbon/olemethods.inc Normal file
View File

@@ -0,0 +1,2 @@
{$i ../dummyolemethods.inc}

23
VirtualTreeview/include/intf/carbon/vtgraphicsi.inc Normal file
View File

@@ -0,0 +1,23 @@
//todo: properly implement
procedure AlphaBlend(Source, Destination: HDC; const R: TRect; const Target: TPoint; Mode: TBlendMode; ConstantAlpha, Bias: Integer);
begin
case Mode of
bmConstantAlpha,
bmPerPixelAlpha,
bmMasterAlpha,
bmConstantAlphaAndColor:
begin
BitBlt(Destination, Target.X, Target.Y, R.Right - R.Left, R.Bottom - R.Top, Source, R.Left, R.Right, SRCCOPY);
end;
end;
end;
function CalculateScanline(Bits: Pointer; Width, Height, Row: Integer): Pointer;
begin
Result := nil;
end;
function GetBitmapBitsFromBitmap(Bitmap: HBITMAP): Pointer;
begin
Result := nil;
end;

2
VirtualTreeview/include/intf/carbon/vtvdragmanager.inc Normal file
View File

@@ -0,0 +1,2 @@
{$i ../dummydragmanager.inc}

2
VirtualTreeview/include/intf/cocoa/olemethods.inc Normal file
View File

@@ -0,0 +1,2 @@
{$i ../dummyolemethods.inc}

23
VirtualTreeview/include/intf/cocoa/vtgraphicsi.inc Normal file
View File

@@ -0,0 +1,23 @@
//todo: properly implement
procedure AlphaBlend(Source, Destination: HDC; const R: TRect; const Target: TPoint; Mode: TBlendMode; ConstantAlpha, Bias: Integer);
begin
case Mode of
bmConstantAlpha,
bmPerPixelAlpha,
bmMasterAlpha,
bmConstantAlphaAndColor:
begin
BitBlt(Destination, Target.X, Target.Y, R.Right - R.Left, R.Bottom - R.Top, Source, R.Left, R.Right, SRCCOPY);
end;
end;
end;
function CalculateScanline(Bits: Pointer; Width, Height, Row: Integer): Pointer;
begin
Result := nil;
end;
function GetBitmapBitsFromBitmap(Bitmap: HBITMAP): Pointer;
begin
Result := nil;
end;

2
VirtualTreeview/include/intf/cocoa/vtvdragmanager.inc Normal file
View File

@@ -0,0 +1,2 @@
{$i ../dummydragmanager.inc}

790
VirtualTreeview/include/intf/dummydragmanager.inc Normal file
View File

@@ -0,0 +1,790 @@
//----------------------------------------------------------------------------------------------------------------------
// OLE drag and drop support classes
// This is quite heavy stuff (compared with the VCL implementation) but is much better suited to fit the needs
// of DD'ing various kinds of virtual data and works also between applications.
//----------------- TEnumFormatEtc -------------------------------------------------------------------------------------
constructor TEnumFormatEtc.Create(Tree: TBaseVirtualTree; AFormatEtcArray: TFormatEtcArray);
var
I: Integer;
begin
inherited Create;
{
FTree := Tree;
// Make a local copy of the format data.
SetLength(FFormatEtcArray, Length(AFormatEtcArray));
for I := 0 to High(AFormatEtcArray) do
FFormatEtcArray[I] := AFormatEtcArray[I];
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TEnumFormatEtc.Clone(out Enum: IEnumFormatEtc): HResult;
{
var
AClone: TEnumFormatEtc;
}
begin
{
Result := S_OK;
try
AClone := TEnumFormatEtc.Create(nil, FFormatEtcArray);
AClone.FCurrentIndex := FCurrentIndex;
Enum := AClone as IEnumFormatEtc;
except
Result := E_FAIL;
end;
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TEnumFormatEtc.Next(celt: LongWord; out elt: FormatEtc;pceltFetched:pULong=nil): HResult;
{
var
CopyCount: LongWord;
}
begin
{
Result := S_FALSE;
CopyCount := Length(FFormatEtcArray) - FCurrentIndex;
if celt < CopyCount then
CopyCount := celt;
if CopyCount > 0 then
begin
Move(FFormatEtcArray[FCurrentIndex], elt, CopyCount * SizeOf(TFormatEtc));
Inc(FCurrentIndex, CopyCount);
Result := S_OK;
end;
//todo_lcl_check Delphi treats pceltFetched an PInteger. Implemented like in fpc.activex. What heappens with
// a C Program call with a NULL in pCeltFetcjed??
//Answer: Yes. Is necessary a check here
if @pceltFetched <> nil then
pceltFetched := CopyCount;
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TEnumFormatEtc.Reset: HResult;
begin
{
FCurrentIndex := 0;
Result := S_OK;
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TEnumFormatEtc.Skip(celt: LongWord): HResult;
begin
{
if FCurrentIndex + celt < High(FFormatEtcArray) then
begin
Inc(FCurrentIndex, celt);
Result := S_Ok;
end
else
Result := S_FALSE;
}
end;
//----------------- TVTDataObject --------------------------------------------------------------------------------------
constructor TVTDataObject.Create(AOwner: TBaseVirtualTree; ForClipboard: Boolean);
begin
inherited Create;
{
FOwner := AOwner;
FForClipboard := ForClipboard;
FOwner.GetNativeClipboardFormats(FFormatEtcArray);
}
end;
//----------------------------------------------------------------------------------------------------------------------
destructor TVTDataObject.Destroy;
var
I: Integer;
StgMedium: PStgMedium;
begin
{
// Cancel a pending clipboard operation if this data object was created for the clipboard and
// is freed because something else is placed there.
if FForClipboard and not (tsClipboardFlushing in FOwner.FStates) then
FOwner.CancelCutOrCopy;
// Release any internal clipboard formats
for I := 0 to High(FormatEtcArray) do
begin
StgMedium := FindInternalStgMedium(FormatEtcArray[I].cfFormat);
if Assigned(StgMedium) then
ReleaseStgMedium(StgMedium);
end;
FormatEtcArray := nil;
inherited;
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.CanonicalIUnknown(TestUnknown: IUnknown): IUnknown;
// Uses COM object identity: An explicit call to the IUnknown::QueryInterface method, requesting the IUnknown
// interface, will always return the same pointer.
begin
{
if Assigned(TestUnknown) then
begin
if TestUnknown.QueryInterface(IUnknown, Result) = 0 then
Result._Release // Don't actually need it just need the pointer value
else
Result := TestUnknown
end
else
Result := TestUnknown
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.EqualFormatEtc(FormatEtc1, FormatEtc2: TFormatEtc): Boolean;
begin
{
Result := (FormatEtc1.cfFormat = FormatEtc2.cfFormat) and (FormatEtc1.ptd = FormatEtc2.ptd) and
(FormatEtc1.dwAspect = FormatEtc2.dwAspect) and (FormatEtc1.lindex = FormatEtc2.lindex) and
(FormatEtc1.tymed and FormatEtc2.tymed <> 0);
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.FindFormatEtc(TestFormatEtc: TFormatEtc; const FormatEtcArray: TFormatEtcArray): integer;
var
I: integer;
begin
{
Result := -1;
for I := 0 to High(FormatEtcArray) do
begin
if EqualFormatEtc(TestFormatEtc, FormatEtcArray[I]) then
begin
Result := I;
Break;
end
end;
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.FindInternalStgMedium(Format: TClipFormat): PStgMedium;
{
var
I: integer;
}
begin
{
Result := nil;
for I := 0 to High(InternalStgMediumArray) do
begin
if Format = InternalStgMediumArray[I].Format then
begin
Result := @InternalStgMediumArray[I].Medium;
Break;
end
end;
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.HGlobalClone(HGlobal: THandle): THandle;
// Returns a global memory block that is a copy of the passed memory block.
{
var
Size: Cardinal;
Data,
NewData: PChar;
}
begin
{
Size := GlobalSize(HGlobal);
Result := GlobalAlloc(GPTR, Size);
Data := GlobalLock(hGlobal);
try
NewData := GlobalLock(Result);
try
Move(Data^, NewData^, Size);
finally
GlobalUnLock(Result);
end
finally
GlobalUnLock(hGlobal);
end;
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.RenderInternalOLEData(const FormatEtcIn: TFormatEtc; var Medium: TStgMedium;
var OLEResult: HResult): Boolean;
// Tries to render one of the formats which have been stored via the SetData method.
// Since this data is already there it is just copied or its reference count is increased (depending on storage medium).
{
var
InternalMedium: PStgMedium;
}
begin
{
Result := True;
InternalMedium := FindInternalStgMedium(FormatEtcIn.cfFormat);
if Assigned(InternalMedium) then
OLEResult := StgMediumIncRef(InternalMedium^, Medium, False, Self as IDataObject)
else
Result := False;
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.StgMediumIncRef(const InStgMedium: TStgMedium; var OutStgMedium: TStgMedium;
CopyInMedium: Boolean; DataObject: IDataObject): HRESULT;
// InStgMedium is the data that is requested, OutStgMedium is the data that we are to return either a copy of or
// increase the IDataObject's reference and send ourselves back as the data (unkForRelease). The InStgMedium is usually
// the result of a call to find a particular FormatEtc that has been stored locally through a call to SetData.
// If CopyInMedium is not true we already have a local copy of the data when the SetData function was called (during
// that call the CopyInMedium must be true). Then as the caller asks for the data through GetData we do not have to make
// copy of the data for the caller only to have them destroy it then need us to copy it again if necessary.
// This way we increase the reference count to ourselves and pass the STGMEDIUM structure initially stored in SetData.
// This way when the caller frees the structure it sees the unkForRelease is not nil and calls Release on the object
// instead of destroying the actual data.
var
Len: Integer;
begin
{
Result := S_OK;
// Simply copy all fields to start with.
OutStgMedium := InStgMedium;
// The data handled here always results from a call of SetData we got. This ensures only one storage format
// is indicated and hence the case statement below is safe (IDataObject.GetData can optionally use several
// storage formats).
case InStgMedium.tymed of
TYMED_HGLOBAL:
begin
if CopyInMedium then
begin
// Generate a unique copy of the data passed
OutStgMedium.hGlobal := HGlobalClone(InStgMedium.hGlobal);
if OutStgMedium.hGlobal = 0 then
Result := E_OUTOFMEMORY
end
else
// Don't generate a copy just use ourselves and the copy previously saved.
OutStgMedium.PunkForRelease := Pointer(DataObject); // Does not increase RefCount.
end;
TYMED_FILE:
begin
//todo_lcl_check
Len := Length(WideString(InStgMedium.lpszFileName)) + 1; // Don't forget the terminating null character.
OutStgMedium.lpszFileName := CoTaskMemAlloc(2 * Len);
Move(InStgMedium.lpszFileName^, OutStgMedium.lpszFileName^, 2 * Len);
end;
TYMED_ISTREAM:
IUnknown(OutStgMedium.Pstm)._AddRef;
TYMED_ISTORAGE:
IUnknown(OutStgMedium.Pstg)._AddRef;
TYMED_GDI:
if not CopyInMedium then
// Don't generate a copy just use ourselves and the previously saved data.
OutStgMedium.PunkForRelease := Pointer(DataObject) // Does not increase RefCount.
else
Result := DV_E_TYMED; // Don't know how to copy GDI objects right now.
TYMED_MFPICT:
if not CopyInMedium then
// Don't generate a copy just use ourselves and the previously saved data.
OutStgMedium.PunkForRelease := Pointer(DataObject) // Does not increase RefCount.
else
Result := DV_E_TYMED; // Don't know how to copy MetaFile objects right now.
TYMED_ENHMF:
if not CopyInMedium then
// Don't generate a copy just use ourselves and the previously saved data.
OutStgMedium.PunkForRelease := Pointer(DataObject) // Does not increase RefCount.
else
Result := DV_E_TYMED; // Don't know how to copy enhanced metafiles objects right now.
else
Result := DV_E_TYMED;
end;
if (Result = S_OK) and Assigned(OutStgMedium.PunkForRelease) then
IUnknown(OutStgMedium.PunkForRelease)._AddRef;
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.DAdvise(const FormatEtc: TFormatEtc; advf: DWord; const advSink: IAdviseSink;
out dwConnection: DWord): HResult;
// Advise sink management is greatly simplified by the IDataAdviseHolder interface.
// We use this interface and forward all concerning calls to it.
begin
{
Result := S_OK;
if FAdviseHolder = nil then
Result := CreateDataAdviseHolder(FAdviseHolder);
if Result = S_OK then
Result := FAdviseHolder.Advise(Self as IDataObject, FormatEtc, advf, advSink, dwConnection);
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.DUnadvise(dwConnection: DWord): HResult;
begin
{
if FAdviseHolder = nil then
Result := E_NOTIMPL
else
Result := FAdviseHolder.Unadvise(dwConnection);
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.EnumDAdvise(Out enumAdvise : IEnumStatData):HResult;
begin
{
if FAdviseHolder = nil then
Result := OLE_E_ADVISENOTSUPPORTED
else
Result := FAdviseHolder.EnumAdvise(enumAdvise);
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.EnumFormatEtc(Direction: DWord; out EnumFormatEtc: IEnumFormatEtc): HResult;
{
var
NewList: TEnumFormatEtc;
}
begin
{
Result := E_FAIL;
if Direction = DATADIR_GET then
begin
NewList := TEnumFormatEtc.Create(FOwner, FormatEtcArray);
EnumFormatEtc := NewList as IEnumFormatEtc;
Result := S_OK;
end
else
EnumFormatEtc := nil;
if EnumFormatEtc = nil then
Result := OLE_S_USEREG;
}
end;
//----------------------------------------------------------------------------------------------------------------------
Function TVTDataObject.GetCanonicalFormatEtc(const pformatetcIn : FORMATETC;Out pformatetcOut : FORMATETC):HResult;
begin
//Result := DATA_S_SAMEFORMATETC;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.GetData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium): HResult;
// Data is requested by clipboard or drop target. This method dispatchs the call
// depending on the data being requested.
{
var
I: Integer;
Data: PVTReference;
}
begin
{
// The tree reference format is always supported and returned from here.
if FormatEtcIn.cfFormat = CF_VTREFERENCE then
begin
// Note: this format is not used while flushing the clipboard to avoid a dangling reference
// when the owner tree is destroyed before the clipboard data is replaced with something else.
if tsClipboardFlushing in FOwner.FStates then
Result := E_FAIL
else
begin
Medium.hGlobal := GlobalAlloc(GHND or GMEM_SHARE, SizeOf(TVTReference));
Data := GlobalLock(Medium.hGlobal);
Data.Process := GetCurrentProcessID;
Data.Tree := FOwner;
GlobalUnlock(Medium.hGlobal);
Medium.tymed := TYMED_HGLOBAL;
Medium.PunkForRelease := nil;
Result := S_OK;
end;
end
else
begin
try
// See if we accept this type and if not get the correct return value.
Result := QueryGetData(FormatEtcIn);
if Result = S_OK then
begin
for I := 0 to High(FormatEtcArray) do
begin
if EqualFormatEtc(FormatEtcIn, FormatEtcArray[I]) then
begin
if not RenderInternalOLEData(FormatEtcIn, Medium, Result) then
Result := FOwner.RenderOLEData(FormatEtcIn, Medium, FForClipboard);
Break;
end;
end
end
except
FillChar(Medium, SizeOf(Medium), #0);
Result := E_FAIL;
end;
end;
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.GetDataHere(const FormatEtc: TFormatEtc; out Medium: TStgMedium): HResult;
begin
//Result := E_NOTIMPL;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.QueryGetData(const FormatEtc: TFormatEtc): HResult;
{
var
I: Integer;
}
begin
{
Result := DV_E_CLIPFORMAT;
for I := 0 to High(FFormatEtcArray) do
begin
if FormatEtc.cfFormat = FFormatEtcArray[I].cfFormat then
begin
if (FormatEtc.tymed and FFormatEtcArray[I].tymed) <> 0 then
begin
if FormatEtc.dwAspect = FFormatEtcArray[I].dwAspect then
begin
if FormatEtc.lindex = FFormatEtcArray[I].lindex then
begin
Result := S_OK;
Break;
end
else
Result := DV_E_LINDEX;
end
else
Result := DV_E_DVASPECT;
end
else
Result := DV_E_TYMED;
end;
end
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.SetData(const FormatEtc: TFormatEtc; {$ifdef VER2_0}var{$else}const{$endif} Medium: TStgMedium; DoRelease: BOOL): HResult;
// Allows dynamic adding to the IDataObject during its existance. Most noteably it is used to implement
// IDropSourceHelper and allows to set a special format for optimized moves during a shell transfer.
{
var
Index: Integer;
LocalStgMedium: PStgMedium;
}
begin
{
// See if we already have a format of that type available.
Index := FindFormatEtc(FormatEtc, FormatEtcArray);
if Index > - 1 then
begin
// Just use the TFormatEct in the array after releasing the data.
LocalStgMedium := FindInternalStgMedium(FormatEtcArray[Index].cfFormat);
if Assigned(LocalStgMedium) then
begin
ReleaseStgMedium(LocalStgMedium);
FillChar(LocalStgMedium^, SizeOf(LocalStgMedium^), #0);
end;
end
else
begin
// It is a new format so create a new TFormatCollectionItem, copy the
// FormatEtc parameter into the new object and and put it in the list.
SetLength(FFormatEtcArray, Length(FormatEtcArray) + 1);
FormatEtcArray[High(FormatEtcArray)] := FormatEtc;
// Create a new InternalStgMedium and initialize it and associate it with the format.
SetLength(FInternalStgMediumArray, Length(InternalStgMediumArray) + 1);
InternalStgMediumArray[High(InternalStgMediumArray)].Format := FormatEtc.cfFormat;
LocalStgMedium := @InternalStgMediumArray[High(InternalStgMediumArray)].Medium;
FillChar(LocalStgMedium^, SizeOf(LocalStgMedium^), #0);
end;
if DoRelease then
begin
// We are simply being given the data and we take control of it.
LocalStgMedium^ := Medium;
Result := S_OK
end
else
begin
// We need to reference count or copy the data and keep our own references to it.
Result := StgMediumIncRef(Medium, LocalStgMedium^, True, Self as IDataObject);
// Can get a circular reference if the client calls GetData then calls SetData with the same StgMedium.
// Because the unkForRelease for the IDataObject can be marshalled it is necessary to get pointers that
// can be correctly compared. See the IDragSourceHelper article by Raymond Chen at MSDN.
if Assigned(LocalStgMedium.PunkForRelease) then
begin
if CanonicalIUnknown(Self) = CanonicalIUnknown(IUnknown(LocalStgMedium.PunkForRelease)) then
IUnknown(LocalStgMedium.PunkForRelease) := nil; // release the interface
end;
end;
// Tell all registered advice sinks about the data change.
if Assigned(FAdviseHolder) then
FAdviseHolder.SendOnDataChange(Self as IDataObject, 0, 0);
}
end;
//----------------- TVTDragManager -------------------------------------------------------------------------------------
constructor TVTDragManager.Create(AOwner: TBaseVirtualTree);
begin
inherited Create;
FOwner := AOwner;
{
// Create an instance of the drop target helper interface. This will fail but not harm on systems which do
// not support this interface (everything below Windows 2000);
CoCreateInstance(CLSID_DragDropHelper, nil, CLSCTX_INPROC_SERVER, IID_IDropTargetHelper, FDropTargetHelper);
}
end;
//----------------------------------------------------------------------------------------------------------------------
destructor TVTDragManager.Destroy;
begin
// Set the owner's reference to us to nil otherwise it will access an invalid pointer
// after our desctruction is complete.
Pointer(FOwner.FDragManager) := nil;
inherited;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.GetDataObject: IDataObject;
begin
// When the owner tree starts a drag operation then it gets a data object here to pass it to the OLE subsystem.
// In this case there is no local reference to a data object and one is created (but not stored).
// If there is a local reference then the owner tree is currently the drop target and the stored interface is
// that of the drag initiator.
{
if Assigned(FDataObject) then
Result := FDataObject
else
begin
Result := FOwner.DoCreateDataObject;
if Result = nil then
Result := TVTDataObject.Create(FOwner, False) as IDataObject;
end;
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.GetDragSource: TBaseVirtualTree;
begin
//Result := FDragSource;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.GetDropTargetHelperSupported: Boolean;
begin
//Result := Assigned(FDropTargetHelper);
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.GetIsDropTarget: Boolean;
begin
//Result := FIsDropTarget;
Result := True;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.DragEnter(const DataObject: IDataObject; KeyState: LongWord; Pt: TPoint;
var Effect: LongWord): HResult;
begin
{
FDataObject := DataObject;
FIsDropTarget := True;
SystemParametersInfo(SPI_GETDRAGFULLWINDOWS, 0, @FFullDragging, 0);
// If full dragging of window contents is disabled in the system then our tree windows will be locked
// and cannot be updated during a drag operation. With the following call painting is again enabled.
if not FFullDragging then
LockWindowUpdate(0);
if Assigned(FDropTargetHelper) and FFullDragging then
FDropTargetHelper.DragEnter(FOwner.Handle, DataObject, Pt, Effect);
FDragSource := FOwner.GetTreeFromDataObject(DataObject);
Result := FOwner.DragEnter(KeyState, Pt, Effect);
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.DragLeave: HResult;
begin
{
if Assigned(FDropTargetHelper) and FFullDragging then
FDropTargetHelper.DragLeave;
FOwner.DragLeave;
FIsDropTarget := False;
FDragSource := nil;
FDataObject := nil;
Result := NOERROR;
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.DragOver(KeyState: LongWord; Pt: TPoint; var Effect: LongWord): HResult;
begin
{
if Assigned(FDropTargetHelper) and FFullDragging then
FDropTargetHelper.DragOver(Pt, Effect);
Result := FOwner.DragOver(FDragSource, KeyState, dsDragMove, Pt, Effect);
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.Drop(const DataObject: IDataObject; KeyState: LongWord; Pt: TPoint;
var Effect: LongWord): HResult;
begin
{
if Assigned(FDropTargetHelper) and FFullDragging then
FDropTargetHelper.Drop(DataObject, Pt, Effect);
Result := FOwner.DragDrop(DataObject, KeyState, Pt, Effect);
FIsDropTarget := False;
FDataObject := nil;
}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTDragManager.ForceDragLeave;
// Some drop targets, e.g. Internet Explorer leave a drag image on screen instead removing it when they receive
// a drop action. This method calls the drop target helper's DragLeave method to ensure it removes the drag image from
// screen. Unfortunately, sometimes not even this does help (e.g. when dragging text from VT to a text field in IE).
begin
{
if Assigned(FDropTargetHelper) and FFullDragging then
FDropTargetHelper.DragLeave;
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.GiveFeedback(Effect: LongWord): HResult;
begin
//Result := DRAGDROP_S_USEDEFAULTCURSORS;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.QueryContinueDrag(EscapePressed: BOOL; KeyState: LongWord): HResult;
var
RButton,
LButton: Boolean;
begin
{
LButton := (KeyState and MK_LBUTTON) <> 0;
RButton := (KeyState and MK_RBUTTON) <> 0;
// Drag'n drop canceled by pressing both mouse buttons or Esc?
if (LButton and RButton) or EscapePressed then
Result := DRAGDROP_S_CANCEL
else
// Drag'n drop finished?
if not (LButton or RButton) then
Result := DRAGDROP_S_DROP
else
Result := S_OK;
}
end;

404
VirtualTreeview/include/intf/dummyolemethods.inc Normal file
View File

@@ -0,0 +1,404 @@
function TBaseVirtualTree.GetTreeFromDataObject(const DataObject: IDataObject): TBaseVirtualTree;
// Returns the owner/sender of the given data object by means of a special clipboard format
// or nil if the sender is in another process or no virtual tree at all.
var
Medium: TStgMedium;
Data: PVTReference;
begin
Result := nil;
{
if Assigned(DataObject) then
begin
StandardOLEFormat.cfFormat := CF_VTREFERENCE;
if DataObject.GetData(StandardOLEFormat, Medium) = S_OK then
begin
Data := GlobalLock(Medium.hGlobal);
if Assigned(Data) then
begin
if Data.Process = GetCurrentProcessID then
Result := Data.Tree;
GlobalUnlock(Medium.hGlobal);
end;
ReleaseStgMedium(@Medium);
end;
end;
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TBaseVirtualTree.RenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium;
ForClipboard: Boolean): HResult;
// Returns a memory expression of all currently selected nodes in the Medium structure.
// Note: The memory requirement of this method might be very high. This depends however on the requested storage format.
// For HGlobal (a global memory block) we need to render first all nodes to local memory and copy this then to
// the global memory in Medium. This is necessary because we have first to determine how much
// memory is needed before we can allocate it. Hence for a short moment we need twice the space as used by the
// nodes alone (plus the amount the nodes need in the tree anyway)!
// With IStream this does not happen. We directly stream out the nodes and pass the constructed stream along.
//--------------- local function --------------------------------------------
{
procedure WriteNodes(Stream: TStream);
var
Selection: TNodeArray;
I: Integer;
begin
if ForClipboard then
Selection := GetSortedCutCopySet(True)
else
Selection := GetSortedSelection(True);
for I := 0 to High(Selection) do
WriteNode(Stream, Selection[I]);
end;
//--------------- end local function ----------------------------------------
var
Data: PCardinal;
ResPointer: Pointer;
ResSize: Integer;
OLEStream: IStream;
VCLStream: TStream;
}
begin
{
FillChar(Medium, SizeOf(Medium), 0);
// We can render the native clipboard format in two different storage media.
if (FormatEtcIn.cfFormat = CF_VIRTUALTREE) and (FormatEtcIn.tymed and (TYMED_HGLOBAL or TYMED_ISTREAM) <> 0) then
begin
VCLStream := nil;
try
Medium.PunkForRelease := nil;
// Return data in one of the supported storage formats, prefer IStream.
if FormatEtcIn.tymed and TYMED_ISTREAM <> 0 then
begin
// Create an IStream on a memory handle (here it is 0 which indicates to implicitely allocated a handle).
// Do not use TStreamAdapter as it is not compatible with OLE (when flushing the clipboard OLE wants the HGlobal
// back which is not supported by TStreamAdapater).
CreateStreamOnHGlobal(0, True, OLEStream);
VCLStream := TOLEStream.Create(OLEStream);
WriteNodes(VCLStream);
// Rewind stream.
VCLStream.Position := 0;
Medium.tymed := TYMED_ISTREAM;
IUnknown(Medium.Pstm) := OLEStream;
Result := S_OK;
end
else
begin
VCLStream := TMemoryStream.Create;
WriteNodes(VCLStream);
ResPointer := TMemoryStream(VCLStream).Memory;
ResSize := VCLStream.Position;
// Allocate memory to hold the string.
if ResSize > 0 then
begin
Medium.hGlobal := GlobalAlloc(GHND or GMEM_SHARE, ResSize + SizeOf(Cardinal));
Data := GlobalLock(Medium.hGlobal);
// Store the size of the data too, for easy retrival.
Data^ := ResSize;
Inc(Data);
Move(ResPointer^, Data^, ResSize);
GlobalUnlock(Medium.hGlobal);
Medium.tymed := TYMED_HGLOBAL;
Result := S_OK;
end
else
Result := E_FAIL;
end;
finally
// We can free the VCL stream here since it was either a pure memory stream or only a wrapper around
// the OLEStream which exists independently.
VCLStream.Free;
end;
end
else // Ask application descendants to render self defined formats.
Result := DoRenderOLEData(FormatEtcIn, Medium, ForClipboard);
}
end;
//----------------------------------------------------------------------------------------------------------------------
type
// needed to handle OLE global memory objects
TOLEMemoryStream = class(TCustomMemoryStream)
public
function Write(const Buffer; Count: Integer): Longint; override;
end;
//----------------------------------------------------------------------------------------------------------------------
function TOLEMemoryStream.Write(const Buffer; Count: Integer): Integer;
begin
//raise EStreamError.CreateRes(PResStringRec(@SCantWriteResourceStreamError));
raise EStreamError.Create(SCantWriteResourceStreamError);
end;
//----------------------------------------------------------------------------------------------------------------------
function TBaseVirtualTree.ProcessOLEData(Source: TBaseVirtualTree; DataObject: IDataObject; TargetNode: PVirtualNode;
Mode: TVTNodeAttachMode; Optimized: Boolean): Boolean;
// Recreates the (sub) tree structure serialized into memory and provided by DataObject. The new nodes are attached to
// the passed node or FRoot if TargetNode is nil according to Mode. Optimized can be set to True if the entire operation
// happens within the same process (i.e. sender and receiver of the OLE operation are located in the same process).
// Optimize = True makes only sense if the operation to carry out is a move hence it is also the indication of the
// operation to be done here. Source is the source of the OLE data and only of use (and usually assigned) when
// an OLE operation takes place in the same application.
// Returns True on success, i.e. the CF_VIRTUALTREE format is supported by the data object and the structure could be
// recreated, otherwise False.
var
Medium: TStgMedium;
Stream: TStream;
Data: Pointer;
Node: PVirtualNode;
Nodes: TNodeArray;
I: Integer;
Res: HRESULT;
ChangeReason: TChangeReason;
begin
{
Nodes := nil;
// Check the data format available by the data object.
with StandardOLEFormat do
begin
// Read best format.
cfFormat := CF_VIRTUALTREE;
end;
Result := DataObject.QueryGetData(StandardOLEFormat) = S_OK;
if Result and not (toReadOnly in FOptions.FMiscOptions) then
begin
BeginUpdate;
Result := False;
try
if TargetNode = nil then
TargetNode := FRoot;
if TargetNode = FRoot then
begin
case Mode of
amInsertBefore:
Mode := amAddChildFirst;
amInsertAfter:
Mode := amAddChildLast;
end;
end;
// Optimized means source is known and in the same process so we can access its pointers, which avoids duplicating
// the data while doing a serialization. Can only be used with cut'n paste and drag'n drop with move effect.
if Optimized then
begin
if tsOLEDragging in Source.FStates then
Nodes := Source.FDragSelection
else
Nodes := Source.GetSortedCutCopySet(True);
if Mode in [amInsertBefore,amAddChildLast] then
begin
for I := 0 to High(Nodes) do
if not HasAsParent(TargetNode, Nodes[I]) then
Source.MoveTo(Nodes[I], TargetNode, Mode, False);
end
else
begin
for I := High(Nodes) downto 0 do
if not HasAsParent(TargetNode, Nodes[I]) then
Source.MoveTo(Nodes[I], TargetNode, Mode, False);
end;
Result := True;
end
else
begin
if Source = Self then
ChangeReason := crNodeCopied
else
ChangeReason := crNodeAdded;
Res := DataObject.GetData(StandardOLEFormat, Medium);
if Res = S_OK then
begin
case Medium.tymed of
TYMED_ISTREAM, // IStream interface
TYMED_HGLOBAL: // global memory block
begin
Stream := nil;
if Medium.tymed = TYMED_ISTREAM then
Stream := TOLEStream.Create(IUnknown(Medium.Pstm) as IStream)
else
begin
Data := GlobalLock(Medium.hGlobal);
if Assigned(Data) then
begin
// Get the total size of data to retrieve.
I := PCardinal(Data)^;
Inc(PCardinal(Data));
Stream := TOLEMemoryStream.Create;
TOLEMemoryStream(Stream).SetPointer(Data, I);
end;
end;
if Assigned(Stream) then
try
while Stream.Position < Stream.Size do
begin
Node := MakeNewNode;
InternalConnectNode(Node, TargetNode, Self, Mode);
InternalAddFromStream(Stream, VTTreeStreamVersion, Node);
// This seems a bit strange because of the callback for granting to add the node
// which actually comes after the node has been added. The reason is that the node must
// contain valid data otherwise I don't see how the application can make a funded decision.
if not DoNodeCopying(Node, TargetNode) then
DeleteNode(Node)
else
DoNodeCopied(Node);
StructureChange(Node, ChangeReason);
// In order to maintain the same node order when restoring nodes in the case of amInsertAfter
// we have to move the reference node continously. Othwise we would end up with reversed node order.
if Mode = amInsertAfter then
TargetNode := Node;
end;
Result := True;
finally
Stream.Free;
if Medium.tymed = TYMED_HGLOBAL then
GlobalUnlock(Medium.hGlobal);
end;
end;
end;
ReleaseStgMedium(@Medium);
end;
end;
finally
EndUpdate;
end;
end;
}
end;
//----------------------------------------------------------------------------------------------------------------------
function TCustomVirtualStringTree.ContentToClipboard(Format: Word; Source: TVSTTextSourceType): HGLOBAL;
// This method constructs a shareable memory object filled with string data in the required format. Supported are:
// CF_TEXT - plain ANSI text (Unicode text is converted using the user's current locale)
// CF_UNICODETEXT - plain Unicode text
// CF_CSV - comma separated plain ANSI text
// CF_VRTF + CF_RTFNOOBS - rich text (plain ANSI)
// CF_HTML - HTML text encoded using UTF-8
//
// Result is the handle to a globally allocated memory block which can directly be used for clipboard and drag'n drop
// transfers. The caller is responsible for freeing the memory. If for some reason the content could not be rendered
// the Result is 0.
//--------------- local function --------------------------------------------
{
procedure MakeFragment(var HTML: string);
// Helper routine to build a properly-formatted HTML fragment.
const
Version = 'Version:1.0'#13#10;
StartHTML = 'StartHTML:';
EndHTML = 'EndHTML:';
StartFragment = 'StartFragment:';
EndFragment = 'EndFragment:';
DocType = '<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">';
HTMLIntro = '<html><head><META http-equiv=Content-Type content="text/html; charset=utf-8">' +
'</head><body><!--StartFragment-->';
HTMLExtro = '<!--EndFragment--></body></html>';
NumberLengthAndCR = 10;
// Let the compiler determine the description length.
DescriptionLength = Length(Version) + Length(StartHTML) + Length(EndHTML) + Length(StartFragment) +
Length(EndFragment) + 4 * NumberLengthAndCR;
var
Description: string;
StartHTMLIndex,
EndHTMLIndex,
StartFragmentIndex,
EndFragmentIndex: Integer;
begin
// The HTML clipboard format is defined by using byte positions in the entire block where HTML text and
// fragments start and end. These positions are written in a description. Unfortunately the positions depend on the
// length of the description but the description may change with varying positions.
// To solve this dilemma the offsets are converted into fixed length strings which makes it possible to know
// the description length in advance.
StartHTMLIndex := DescriptionLength; // position 0 after the description
StartFragmentIndex := StartHTMLIndex + Length(DocType) + Length(HTMLIntro);
EndFragmentIndex := StartFragmentIndex + Length(HTML);
EndHTMLIndex := EndFragmentIndex + Length(HTMLExtro);
Description := Version +
SysUtils.Format('%s%.8d', [StartHTML, StartHTMLIndex]) + #13#10 +
SysUtils.Format('%s%.8d', [EndHTML, EndHTMLIndex]) + #13#10 +
SysUtils.Format('%s%.8d', [StartFragment, StartFragmentIndex]) + #13#10 +
SysUtils.Format('%s%.8d', [EndFragment, EndFragmentIndex]) + #13#10;
HTML := Description + DocType + HTMLIntro + HTML + HTMLExtro;
end;
}
//--------------- end local function ----------------------------------------
var
Data: Pointer;
DataSize: Cardinal;
S: string;
WS: WideString;
P: Pointer;
begin
Result := 0;
{
case Format of
CF_TEXT:
begin
S := ContentToText(Source, #9) + #0;
Data := PChar(S);
DataSize := Length(S);
end;
CF_UNICODETEXT:
begin
WS := ContentToUnicode(Source, #9) + #0;
Data := PWideChar(WS);
DataSize := 2 * Length(WS);
end;
else
if Format = CF_CSV then
S := ContentToText(Source, ListSeparator) + #0
else
if (Format = CF_VRTF) or (Format = CF_VRTFNOOBJS) then
S := ContentToRTF(Source) + #0
else
if Format = CF_HTML then
begin
S := ContentToHTML(Source);
// Build a valid HTML clipboard fragment.
MakeFragment(S);
S := S + #0;
end;
Data := PChar(S);
DataSize := Length(S);
end;
if DataSize > 0 then
begin
Result := GlobalAlloc(GHND or GMEM_SHARE, DataSize);
P := GlobalLock(Result);
Move(Data^, P^, DataSize);
GlobalUnlock(Result);
end;
}
end;

2
VirtualTreeview/include/intf/gtk/olemethods.inc Normal file
View File

@@ -0,0 +1,2 @@
{$i ../dummyolemethods.inc}

67
VirtualTreeview/include/intf/gtk/vtgraphicsi.inc Normal file
View File

@@ -0,0 +1,67 @@
uses
gtkdef, gtkint, CairoXlib, gdk, Cairo, glib;
//procedure gdk_drawable_get_size(drawable: PGdkDrawable; width, height: Pgint); cdecl; external gdkdll;
procedure AlphaBlend(Source, Destination: HDC; const R: TRect; const Target: TPoint; Mode: TBlendMode; ConstantAlpha, Bias: Integer);
function CreateSurface(GtkDC: TGtkDeviceContext): Pcairo_surface_t;
var
Width, Height: gint;
Visual: PGdkVisual;
begin
Result := nil;
if (GtkDC <> nil) and (GtkDC.Drawable <> nil) then
begin
gdk_window_get_size(GtkDC.Drawable, @Width, @Height);
Visual := gdk_visual_get_system;
Result := cairo_xlib_surface_create(
GDK_WINDOW_XDISPLAY(PGdkWindowPrivate(GtkDC.Drawable)),
GDK_WINDOW_XWINDOW(PGdkWindowPrivate(GtkDC.Drawable)),
GDK_VISUAL_XVISUAL(PGdkVisualPrivate(Visual)),
Width, Height);
end;
end;
var
SrcDC: TGtkDeviceContext absolute Source;
DestDC: TGtkDeviceContext absolute Destination;
SrcSurface, DestSurface: Pcairo_surface_t;
SrcContext, DestContext: Pcairo_t;
begin
case Mode of
bmConstantAlpha:;
bmPerPixelAlpha:;
bmMasterAlpha:;
bmConstantAlphaAndColor:
begin
DestSurface := CreateSurface(DestDC);
if DestSurface <> nil then
begin
DestContext := cairo_create(DestSurface);
cairo_set_source_rgba(DestContext,
(Bias and $000000FF) / 255,
((Bias shr 8) and $000000FF) / 255,
((Bias shr 16) and $000000FF) / 255,
ConstantAlpha / 255
);
cairo_rectangle(DestContext, R.Left + Target.x, R.Top + Target.y,
R.Right - R.Left, R.Bottom - R.Top);
cairo_fill(DestContext);
cairo_destroy(DestContext);
cairo_surface_destroy(DestSurface);
end;
end;
end;
end;
function CalculateScanline(Bits: Pointer; Width, Height, Row: Integer): Pointer;
begin
Result := nil;
end;
function GetBitmapBitsFromBitmap(Bitmap: HBITMAP): Pointer;
begin
Result := nil;
end;

2
VirtualTreeview/include/intf/gtk/vtvdragmanager.inc Normal file
View File

@@ -0,0 +1,2 @@
{$i ../dummydragmanager.inc}

2
VirtualTreeview/include/intf/gtk2/olemethods.inc Normal file
View File

@@ -0,0 +1,2 @@
{$i ../dummyolemethods.inc}

59
VirtualTreeview/include/intf/gtk2/vtgraphicsi.inc Normal file
View File

@@ -0,0 +1,59 @@
uses
gtk2def, gdk2, GTK2Proc, Cairo, LCLVersion;
{$MACRO ON}
{$if lcl_fullversion > 1000000}
{$define TGtk2DeviceContext:=TGtkDeviceContext}
{$endif}
function gdk_cairo_create(drawable: PGdkDrawable): Pcairo_t cdecl external gdklib;
procedure AlphaBlend(Source, Destination: HDC; const R: TRect; const Target: TPoint; Mode: TBlendMode; ConstantAlpha, Bias: Integer);
function GetContext(GtkDC: TGtk2DeviceContext): Pcairo_t;
begin
Result := nil;
if (GtkDC <> nil) and (GtkDC.Drawable <> nil) then
Result := gdk_cairo_create(GtkDC.Drawable);
end;
var
SrcDC: TGtk2DeviceContext absolute Source;
DestDC: TGtk2DeviceContext absolute Destination;
SrcContext, DestContext: Pcairo_t;
begin
case Mode of
bmConstantAlpha:;
bmPerPixelAlpha:;
bmMasterAlpha:;
bmConstantAlphaAndColor:
begin
DestContext := GetContext(DestDC);
if DestContext <> nil then
begin
cairo_set_source_rgba(DestContext,
(Bias and $000000FF) / 255,
((Bias shr 8) and $000000FF) / 255,
((Bias shr 16) and $000000FF) / 255,
ConstantAlpha / 255
);
cairo_rectangle(DestContext, R.Left + Target.x, R.Top + Target.y,
R.Right - R.Left, R.Bottom - R.Top);
cairo_fill(DestContext);
cairo_destroy(DestContext);
end;
end;
end;
end;
function CalculateScanline(Bits: Pointer; Width, Height, Row: Integer): Pointer;
begin
Result := nil;
end;
function GetBitmapBitsFromBitmap(Bitmap: HBITMAP): Pointer;
begin
Result := nil;
end;

2
VirtualTreeview/include/intf/gtk2/vtvdragmanager.inc Normal file
View File

@@ -0,0 +1,2 @@
{$i ../dummydragmanager.inc}

2
VirtualTreeview/include/intf/qt/olemethods.inc Normal file
View File

@@ -0,0 +1,2 @@
{$i ../dummyolemethods.inc}

858
VirtualTreeview/include/intf/qt/vtgraphicsi.inc Normal file
View File

@@ -0,0 +1,858 @@
uses
qt4, qtobjects;
{$ASMMODE INTEL}
procedure AlphaBlendLineConstant(Source, Destination: Pointer; Count: Integer; ConstantAlpha, Bias: Integer);
// Blends a line of Count pixels from Source to Destination using a constant alpha value.
// The layout of a pixel must be BGRA where A is ignored (but is calculated as the other components).
// ConstantAlpha must be in the range 0..255 where 0 means totally transparent (destination pixel only)
// and 255 totally opaque (source pixel only).
// Bias is an additional value which gets added to every component and must be in the range -128..127
asm
{$ifdef CPU64}
//windows
// RCX contains Source
// RDX contains Destination
// R8D contains Count
// R9D contains ConstantAlpha
// Bias is on the stack
//non windows
// RDI contains Source
// RSI contains Destination
// EDX contains Count
// ECX contains ConstantAlpha
// R8D contains Bias
//.NOFRAME
// Load XMM3 with the constant alpha value (replicate it for every component).
// Expand it to word size.
{$ifdef windows}
MOVD XMM3, R9D // ConstantAlpha
{$else}
MOVD XMM3, ECX // ConstantAlpha
{$endif}
PUNPCKLWD XMM3, XMM3
PUNPCKLDQ XMM3, XMM3
// Load XMM5 with the bias value.
{$ifdef windows}
MOVD XMM5, [Bias]
{$else}
MOVD XMM5, R8D //Bias
{$endif}
PUNPCKLWD XMM5, XMM5
PUNPCKLDQ XMM5, XMM5
// Load XMM4 with 128 to allow for saturated biasing.
MOV R10D, 128
MOVD XMM4, R10D
PUNPCKLWD XMM4, XMM4
PUNPCKLDQ XMM4, XMM4
@1: // The pixel loop calculates an entire pixel in one run.
// Note: The pixel byte values are expanded into the higher bytes of a word due
// to the way unpacking works. We compensate for this with an extra shift.
{$ifdef windows}
MOVD XMM1, DWORD PTR [RCX] // data is unaligned
MOVD XMM2, DWORD PTR [RDX] // data is unaligned
{$else}
MOVD XMM1, DWORD PTR [RDI] // data is unaligned
MOVD XMM2, DWORD PTR [RSI] // data is unaligned
{$endif}
PXOR XMM0, XMM0 // clear source pixel register for unpacking
PUNPCKLBW XMM0, XMM1{[RCX]} // unpack source pixel byte values into words
PSRLW XMM0, 8 // move higher bytes to lower bytes
PXOR XMM1, XMM1 // clear target pixel register for unpacking
PUNPCKLBW XMM1, XMM2{[RDX]} // unpack target pixel byte values into words
MOVQ XMM2, XMM1 // make a copy of the shifted values, we need them again
PSRLW XMM1, 8 // move higher bytes to lower bytes
// calculation is: target = (alpha * (source - target) + 256 * target) / 256
PSUBW XMM0, XMM1 // source - target
PMULLW XMM0, XMM3 // alpha * (source - target)
PADDW XMM0, XMM2 // add target (in shifted form)
PSRLW XMM0, 8 // divide by 256
// Bias is accounted for by conversion of range 0..255 to -128..127,
// doing a saturated add and convert back to 0..255.
PSUBW XMM0, XMM4
PADDSW XMM0, XMM5
PADDW XMM0, XMM4
PACKUSWB XMM0, XMM0 // convert words to bytes with saturation
{$ifdef windows}
MOVD DWORD PTR [RDX], XMM0 // store the result
{$else}
MOVD DWORD PTR [RSI], XMM0 // store the result
{$endif}
@3:
{$ifdef windows}
ADD RCX, 4
ADD RDX, 4
DEC R8D
{$else}
ADD RDI, 4
ADD RSI, 4
DEC EDX
{$endif}
JNZ @1
{$else}
// EAX contains Source
// EDX contains Destination
// ECX contains Count
// ConstantAlpha and Bias are on the stack
PUSH ESI // save used registers
PUSH EDI
MOV ESI, EAX // ESI becomes the actual source pointer
MOV EDI, EDX // EDI becomes the actual target pointer
// Load MM6 with the constant alpha value (replicate it for every component).
// Expand it to word size.
MOV EAX, [ConstantAlpha]
DB $0F, $6E, $F0 /// MOVD MM6, EAX
DB $0F, $61, $F6 /// PUNPCKLWD MM6, MM6
DB $0F, $62, $F6 /// PUNPCKLDQ MM6, MM6
// Load MM5 with the bias value.
MOV EAX, [Bias]
DB $0F, $6E, $E8 /// MOVD MM5, EAX
DB $0F, $61, $ED /// PUNPCKLWD MM5, MM5
DB $0F, $62, $ED /// PUNPCKLDQ MM5, MM5
// Load MM4 with 128 to allow for saturated biasing.
MOV EAX, 128
DB $0F, $6E, $E0 /// MOVD MM4, EAX
DB $0F, $61, $E4 /// PUNPCKLWD MM4, MM4
DB $0F, $62, $E4 /// PUNPCKLDQ MM4, MM4
@1: // The pixel loop calculates an entire pixel in one run.
// Note: The pixel byte values are expanded into the higher bytes of a word due
// to the way unpacking works. We compensate for this with an extra shift.
DB $0F, $EF, $C0 /// PXOR MM0, MM0, clear source pixel register for unpacking
DB $0F, $60, $06 /// PUNPCKLBW MM0, [ESI], unpack source pixel byte values into words
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, move higher bytes to lower bytes
DB $0F, $EF, $C9 /// PXOR MM1, MM1, clear target pixel register for unpacking
DB $0F, $60, $0F /// PUNPCKLBW MM1, [EDI], unpack target pixel byte values into words
DB $0F, $6F, $D1 /// MOVQ MM2, MM1, make a copy of the shifted values, we need them again
DB $0F, $71, $D1, $08 /// PSRLW MM1, 8, move higher bytes to lower bytes
// calculation is: target = (alpha * (source - target) + 256 * target) / 256
DB $0F, $F9, $C1 /// PSUBW MM0, MM1, source - target
DB $0F, $D5, $C6 /// PMULLW MM0, MM6, alpha * (source - target)
DB $0F, $FD, $C2 /// PADDW MM0, MM2, add target (in shifted form)
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, divide by 256
// Bias is accounted for by conversion of range 0..255 to -128..127,
// doing a saturated add and convert back to 0..255.
DB $0F, $F9, $C4 /// PSUBW MM0, MM4
DB $0F, $ED, $C5 /// PADDSW MM0, MM5
DB $0F, $FD, $C4 /// PADDW MM0, MM4
DB $0F, $67, $C0 /// PACKUSWB MM0, MM0, convert words to bytes with saturation
DB $0F, $7E, $07 /// MOVD [EDI], MM0, store the result
@3:
ADD ESI, 4
ADD EDI, 4
DEC ECX
JNZ @1
POP EDI
POP ESI
{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure AlphaBlendLinePerPixel(Source, Destination: Pointer; Count, Bias: Integer);
// Blends a line of Count pixels from Source to Destination using the alpha value of the source pixels.
// The layout of a pixel must be BGRA.
// Bias is an additional value which gets added to every component and must be in the range -128..127
asm
{$ifdef CPU64}
//windows
// RCX contains Source
// RDX contains Destination
// R8D contains Count
// R9D contains Bias
//non windows
// RDI contains Source
// RSI contains Destination
// EDX contains Count
// ECX contains Bias
//.NOFRAME
// Load XMM5 with the bias value.
{$ifdef windows}
MOVD XMM5, R9D // Bias
{$else}
MOVD XMM5, ECX // Bias
{$endif}
PUNPCKLWD XMM5, XMM5
PUNPCKLDQ XMM5, XMM5
// Load XMM4 with 128 to allow for saturated biasing.
MOV R10D, 128
MOVD XMM4, R10D
PUNPCKLWD XMM4, XMM4
PUNPCKLDQ XMM4, XMM4
@1: // The pixel loop calculates an entire pixel in one run.
// Note: The pixel byte values are expanded into the higher bytes of a word due
// to the way unpacking works. We compensate for this with an extra shift.
{$ifdef windows}
MOVD XMM1, DWORD PTR [RCX] // data is unaligned
MOVD XMM2, DWORD PTR [RDX] // data is unaligned
{$else}
MOVD XMM1, DWORD PTR [RDI] // data is unaligned
MOVD XMM2, DWORD PTR [RSI] // data is unaligned
{$endif}
PXOR XMM0, XMM0 // clear source pixel register for unpacking
PUNPCKLBW XMM0, XMM1{[RCX]} // unpack source pixel byte values into words
PSRLW XMM0, 8 // move higher bytes to lower bytes
PXOR XMM1, XMM1 // clear target pixel register for unpacking
PUNPCKLBW XMM1, XMM2{[RDX]} // unpack target pixel byte values into words
MOVQ XMM2, XMM1 // make a copy of the shifted values, we need them again
PSRLW XMM1, 8 // move higher bytes to lower bytes
// Load XMM3 with the source alpha value (replicate it for every component).
// Expand it to word size.
MOVQ XMM3, XMM0
PUNPCKHWD XMM3, XMM3
PUNPCKHDQ XMM3, XMM3
// calculation is: target = (alpha * (source - target) + 256 * target) / 256
PSUBW XMM0, XMM1 // source - target
PMULLW XMM0, XMM3 // alpha * (source - target)
PADDW XMM0, XMM2 // add target (in shifted form)
PSRLW XMM0, 8 // divide by 256
// Bias is accounted for by conversion of range 0..255 to -128..127,
// doing a saturated add and convert back to 0..255.
PSUBW XMM0, XMM4
PADDSW XMM0, XMM5
PADDW XMM0, XMM4
PACKUSWB XMM0, XMM0 // convert words to bytes with saturation
{$ifdef windows}
MOVD DWORD PTR [RDX], XMM0 // store the result
{$else}
MOVD DWORD PTR [RSI], XMM0 // store the result
{$endif}
@3:
{$ifdef windows}
ADD RCX, 4
ADD RDX, 4
DEC R8D
{$else}
ADD RDI, 4
ADD RSI, 4
DEC EDX
{$endif}
JNZ @1
{$else}
// EAX contains Source
// EDX contains Destination
// ECX contains Count
// Bias is on the stack
PUSH ESI // save used registers
PUSH EDI
MOV ESI, EAX // ESI becomes the actual source pointer
MOV EDI, EDX // EDI becomes the actual target pointer
// Load MM5 with the bias value.
MOV EAX, [Bias]
DB $0F, $6E, $E8 /// MOVD MM5, EAX
DB $0F, $61, $ED /// PUNPCKLWD MM5, MM5
DB $0F, $62, $ED /// PUNPCKLDQ MM5, MM5
// Load MM4 with 128 to allow for saturated biasing.
MOV EAX, 128
DB $0F, $6E, $E0 /// MOVD MM4, EAX
DB $0F, $61, $E4 /// PUNPCKLWD MM4, MM4
DB $0F, $62, $E4 /// PUNPCKLDQ MM4, MM4
@1: // The pixel loop calculates an entire pixel in one run.
// Note: The pixel byte values are expanded into the higher bytes of a word due
// to the way unpacking works. We compensate for this with an extra shift.
DB $0F, $EF, $C0 /// PXOR MM0, MM0, clear source pixel register for unpacking
DB $0F, $60, $06 /// PUNPCKLBW MM0, [ESI], unpack source pixel byte values into words
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, move higher bytes to lower bytes
DB $0F, $EF, $C9 /// PXOR MM1, MM1, clear target pixel register for unpacking
DB $0F, $60, $0F /// PUNPCKLBW MM1, [EDI], unpack target pixel byte values into words
DB $0F, $6F, $D1 /// MOVQ MM2, MM1, make a copy of the shifted values, we need them again
DB $0F, $71, $D1, $08 /// PSRLW MM1, 8, move higher bytes to lower bytes
// Load MM6 with the source alpha value (replicate it for every component).
// Expand it to word size.
DB $0F, $6F, $F0 /// MOVQ MM6, MM0
DB $0F, $69, $F6 /// PUNPCKHWD MM6, MM6
DB $0F, $6A, $F6 /// PUNPCKHDQ MM6, MM6
// calculation is: target = (alpha * (source - target) + 256 * target) / 256
DB $0F, $F9, $C1 /// PSUBW MM0, MM1, source - target
DB $0F, $D5, $C6 /// PMULLW MM0, MM6, alpha * (source - target)
DB $0F, $FD, $C2 /// PADDW MM0, MM2, add target (in shifted form)
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, divide by 256
// Bias is accounted for by conversion of range 0..255 to -128..127,
// doing a saturated add and convert back to 0..255.
DB $0F, $F9, $C4 /// PSUBW MM0, MM4
DB $0F, $ED, $C5 /// PADDSW MM0, MM5
DB $0F, $FD, $C4 /// PADDW MM0, MM4
DB $0F, $67, $C0 /// PACKUSWB MM0, MM0, convert words to bytes with saturation
DB $0F, $7E, $07 /// MOVD [EDI], MM0, store the result
@3:
ADD ESI, 4
ADD EDI, 4
DEC ECX
JNZ @1
POP EDI
POP ESI
{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure AlphaBlendLineMaster(Source, Destination: Pointer; Count: Integer; ConstantAlpha, Bias: Integer);
// Blends a line of Count pixels from Source to Destination using the source pixel and a constant alpha value.
// The layout of a pixel must be BGRA.
// ConstantAlpha must be in the range 0..255.
// Bias is an additional value which gets added to every component and must be in the range -128..127
asm
{$ifdef CPU64}
//windows
// RCX contains Source
// RDX contains Destination
// R8D contains Count
// R9D contains ConstantAlpha
// Bias is on the stack
//non windows
// RDI contains Source
// RSI contains Destination
// EDX contains Count
// ECX contains ConstantAlpha
// R8D contains Bias
//.SAVENV XMM6 //todo see how implement in fpc
// Load XMM3 with the constant alpha value (replicate it for every component).
// Expand it to word size.
{$ifdef windows}
MOVD XMM3, R9D // ConstantAlpha
{$else}
MOVD XMM3, ECX // ConstantAlpha
{$endif}
PUNPCKLWD XMM3, XMM3
PUNPCKLDQ XMM3, XMM3
// Load XMM5 with the bias value.
{$ifdef windows}
MOV R10D, [Bias]
MOVD XMM5, R10D
{$else}
MOVD XMM5, R8D
{$endif}
PUNPCKLWD XMM5, XMM5
PUNPCKLDQ XMM5, XMM5
// Load XMM4 with 128 to allow for saturated biasing.
MOV R10D, 128
MOVD XMM4, R10D
PUNPCKLWD XMM4, XMM4
PUNPCKLDQ XMM4, XMM4
@1: // The pixel loop calculates an entire pixel in one run.
// Note: The pixel byte values are expanded into the higher bytes of a word due
// to the way unpacking works. We compensate for this with an extra shift.
{$ifdef windows}
MOVD XMM1, DWORD PTR [RCX] // data is unaligned
MOVD XMM2, DWORD PTR [RDX] // data is unaligned
{$else}
MOVD XMM1, DWORD PTR [RDI] // data is unaligned
MOVD XMM2, DWORD PTR [RSI] // data is unaligned
{$endif}
PXOR XMM0, XMM0 // clear source pixel register for unpacking
PUNPCKLBW XMM0, XMM1{[RCX]} // unpack source pixel byte values into words
PSRLW XMM0, 8 // move higher bytes to lower bytes
PXOR XMM1, XMM1 // clear target pixel register for unpacking
PUNPCKLBW XMM1, XMM2{[RCX]} // unpack target pixel byte values into words
MOVQ XMM2, XMM1 // make a copy of the shifted values, we need them again
PSRLW XMM1, 8 // move higher bytes to lower bytes
// Load XMM6 with the source alpha value (replicate it for every component).
// Expand it to word size.
MOVQ XMM6, XMM0
PUNPCKHWD XMM6, XMM6
PUNPCKHDQ XMM6, XMM6
PMULLW XMM6, XMM3 // source alpha * master alpha
PSRLW XMM6, 8 // divide by 256
// calculation is: target = (alpha * master alpha * (source - target) + 256 * target) / 256
PSUBW XMM0, XMM1 // source - target
PMULLW XMM0, XMM6 // alpha * (source - target)
PADDW XMM0, XMM2 // add target (in shifted form)
PSRLW XMM0, 8 // divide by 256
// Bias is accounted for by conversion of range 0..255 to -128..127,
// doing a saturated add and convert back to 0..255.
PSUBW XMM0, XMM4
PADDSW XMM0, XMM5
PADDW XMM0, XMM4
PACKUSWB XMM0, XMM0 // convert words to bytes with saturation
{$ifdef windows}
MOVD DWORD PTR [RDX], XMM0 // store the result
{$else}
MOVD DWORD PTR [RSI], XMM0 // store the result
{$endif}
@3:
{$ifdef windows}
ADD RCX, 4
ADD RDX, 4
DEC R8D
{$else}
ADD RDI, 4
ADD RSI, 4
DEC EDX
{$endif}
JNZ @1
{$else}
// EAX contains Source
// EDX contains Destination
// ECX contains Count
// ConstantAlpha and Bias are on the stack
PUSH ESI // save used registers
PUSH EDI
MOV ESI, EAX // ESI becomes the actual source pointer
MOV EDI, EDX // EDI becomes the actual target pointer
// Load MM6 with the constant alpha value (replicate it for every component).
// Expand it to word size.
MOV EAX, [ConstantAlpha]
DB $0F, $6E, $F0 /// MOVD MM6, EAX
DB $0F, $61, $F6 /// PUNPCKLWD MM6, MM6
DB $0F, $62, $F6 /// PUNPCKLDQ MM6, MM6
// Load MM5 with the bias value.
MOV EAX, [Bias]
DB $0F, $6E, $E8 /// MOVD MM5, EAX
DB $0F, $61, $ED /// PUNPCKLWD MM5, MM5
DB $0F, $62, $ED /// PUNPCKLDQ MM5, MM5
// Load MM4 with 128 to allow for saturated biasing.
MOV EAX, 128
DB $0F, $6E, $E0 /// MOVD MM4, EAX
DB $0F, $61, $E4 /// PUNPCKLWD MM4, MM4
DB $0F, $62, $E4 /// PUNPCKLDQ MM4, MM4
@1: // The pixel loop calculates an entire pixel in one run.
// Note: The pixel byte values are expanded into the higher bytes of a word due
// to the way unpacking works. We compensate for this with an extra shift.
DB $0F, $EF, $C0 /// PXOR MM0, MM0, clear source pixel register for unpacking
DB $0F, $60, $06 /// PUNPCKLBW MM0, [ESI], unpack source pixel byte values into words
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, move higher bytes to lower bytes
DB $0F, $EF, $C9 /// PXOR MM1, MM1, clear target pixel register for unpacking
DB $0F, $60, $0F /// PUNPCKLBW MM1, [EDI], unpack target pixel byte values into words
DB $0F, $6F, $D1 /// MOVQ MM2, MM1, make a copy of the shifted values, we need them again
DB $0F, $71, $D1, $08 /// PSRLW MM1, 8, move higher bytes to lower bytes
// Load MM7 with the source alpha value (replicate it for every component).
// Expand it to word size.
DB $0F, $6F, $F8 /// MOVQ MM7, MM0
DB $0F, $69, $FF /// PUNPCKHWD MM7, MM7
DB $0F, $6A, $FF /// PUNPCKHDQ MM7, MM7
DB $0F, $D5, $FE /// PMULLW MM7, MM6, source alpha * master alpha
DB $0F, $71, $D7, $08 /// PSRLW MM7, 8, divide by 256
// calculation is: target = (alpha * master alpha * (source - target) + 256 * target) / 256
DB $0F, $F9, $C1 /// PSUBW MM0, MM1, source - target
DB $0F, $D5, $C7 /// PMULLW MM0, MM7, alpha * (source - target)
DB $0F, $FD, $C2 /// PADDW MM0, MM2, add target (in shifted form)
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, divide by 256
// Bias is accounted for by conversion of range 0..255 to -128..127,
// doing a saturated add and convert back to 0..255.
DB $0F, $F9, $C4 /// PSUBW MM0, MM4
DB $0F, $ED, $C5 /// PADDSW MM0, MM5
DB $0F, $FD, $C4 /// PADDW MM0, MM4
DB $0F, $67, $C0 /// PACKUSWB MM0, MM0, convert words to bytes with saturation
DB $0F, $7E, $07 /// MOVD [EDI], MM0, store the result
@3:
ADD ESI, 4
ADD EDI, 4
DEC ECX
JNZ @1
POP EDI
POP ESI
{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure AlphaBlendLineMasterAndColor(Destination: Pointer; Count: Integer; ConstantAlpha, Color: Integer);
// Blends a line of Count pixels in Destination against the given color using a constant alpha value.
// The layout of a pixel must be BGRA and Color must be rrggbb00 (as stored by a COLORREF).
// ConstantAlpha must be in the range 0..255.
asm
{$ifdef CPU64}
//windows
// RCX contains Destination
// EDX contains Count
// R8D contains ConstantAlpha
// R9D contains Color
//non windows
// RDI contains Destination
// ESI contains Count
// EDX contains ConstantAlpha
// ECX contains Color
//.NOFRAME
// The used formula is: target = (alpha * color + (256 - alpha) * target) / 256.
// alpha * color (factor 1) and 256 - alpha (factor 2) are constant values which can be calculated in advance.
// The remaining calculation is therefore: target = (F1 + F2 * target) / 256
// Load XMM3 with the constant alpha value (replicate it for every component).
// Expand it to word size. (Every calculation here works on word sized operands.)
{$ifdef windows}
MOVD XMM3, R8D // ConstantAlpha
{$else}
MOVD XMM3, EDX // ConstantAlpha
{$endif}
PUNPCKLWD XMM3, XMM3
PUNPCKLDQ XMM3, XMM3
// Calculate factor 2.
MOV R10D, $100
MOVD XMM2, R10D
PUNPCKLWD XMM2, XMM2
PUNPCKLDQ XMM2, XMM2
PSUBW XMM2, XMM3 // XMM2 contains now: 255 - alpha = F2
// Now calculate factor 1. Alpha is still in XMM3, but the r and b components of Color must be swapped.
{$ifdef windows}
BSWAP R9D // Color
ROR R9D, 8
MOVD XMM1, R9D // Load the color and convert to word sized values.
{$else}
BSWAP ECX // Color
ROR ECX, 8
MOVD XMM1, ECX // Load the color and convert to word sized values.
{$endif}
PXOR XMM4, XMM4
PUNPCKLBW XMM1, XMM4
PMULLW XMM1, XMM3 // XMM1 contains now: color * alpha = F1
@1: // The pixel loop calculates an entire pixel in one run.
{$ifdef windows}
MOVD XMM0, DWORD PTR [RCX]
{$else}
MOVD XMM0, DWORD PTR [RDI]
{$endif}
PUNPCKLBW XMM0, XMM4
PMULLW XMM0, XMM2 // calculate F1 + F2 * target
PADDW XMM0, XMM1
PSRLW XMM0, 8 // divide by 256
PACKUSWB XMM0, XMM0 // convert words to bytes with saturation
{$ifdef windows}
MOVD DWORD PTR [RCX], XMM0 // store the result
ADD RCX, 4
DEC EDX
{$else}
MOVD DWORD PTR [RDI], XMM0 // store the result
ADD RDI, 4
DEC ESI
{$endif}
JNZ @1
{$else}
// EAX contains Destination
// EDX contains Count
// ECX contains ConstantAlpha
// Color is passed on the stack
// The used formula is: target = (alpha * color + (256 - alpha) * target) / 256.
// alpha * color (factor 1) and 256 - alpha (factor 2) are constant values which can be calculated in advance.
// The remaining calculation is therefore: target = (F1 + F2 * target) / 256
// Load MM3 with the constant alpha value (replicate it for every component).
// Expand it to word size. (Every calculation here works on word sized operands.)
DB $0F, $6E, $D9 /// MOVD MM3, ECX
DB $0F, $61, $DB /// PUNPCKLWD MM3, MM3
DB $0F, $62, $DB /// PUNPCKLDQ MM3, MM3
// Calculate factor 2.
MOV ECX, $100
DB $0F, $6E, $D1 /// MOVD MM2, ECX
DB $0F, $61, $D2 /// PUNPCKLWD MM2, MM2
DB $0F, $62, $D2 /// PUNPCKLDQ MM2, MM2
DB $0F, $F9, $D3 /// PSUBW MM2, MM3 // MM2 contains now: 255 - alpha = F2
// Now calculate factor 1. Alpha is still in MM3, but the r and b components of Color must be swapped.
MOV ECX, [Color]
BSWAP ECX
ROR ECX, 8
DB $0F, $6E, $C9 /// MOVD MM1, ECX // Load the color and convert to word sized values.
DB $0F, $EF, $E4 /// PXOR MM4, MM4
DB $0F, $60, $CC /// PUNPCKLBW MM1, MM4
DB $0F, $D5, $CB /// PMULLW MM1, MM3 // MM1 contains now: color * alpha = F1
@1: // The pixel loop calculates an entire pixel in one run.
DB $0F, $6E, $00 /// MOVD MM0, [EAX]
DB $0F, $60, $C4 /// PUNPCKLBW MM0, MM4
DB $0F, $D5, $C2 /// PMULLW MM0, MM2 // calculate F1 + F2 * target
DB $0F, $FD, $C1 /// PADDW MM0, MM1
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8 // divide by 256
DB $0F, $67, $C0 /// PACKUSWB MM0, MM0 // convert words to bytes with saturation
DB $0F, $7E, $00 /// MOVD [EAX], MM0 // store the result
ADD EAX, 4
DEC EDX
JNZ @1
{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure EMMS;
// Reset MMX state to use the FPU for other tasks again.
{$ifdef CPU64}
inline;
begin
end;
{$else}
asm
DB $0F, $77 /// EMMS
end;
{$endif}
//----------------------------------------------------------------------------------------------------------------------
function GetBitmapBitsFromDeviceContext(DC: HDC; out Width, Height: Integer): Pointer;
// Helper function used to retrieve the bitmap selected into the given device context. If there is a bitmap then
// the function will return a pointer to its bits otherwise nil is returned.
// Additionally the dimensions of the bitmap are returned.
var
Bitmap: HBITMAP;
DIB: TDIBSection;
begin
Result := nil;
Width := 0;
Height := 0;
Bitmap := GetCurrentObject(DC, OBJ_BITMAP);
if Bitmap <> 0 then
begin
if GetObject(Bitmap, SizeOf(DIB), @DIB) = SizeOf(DIB) then
begin
Assert(DIB.dsBm.bmPlanes * DIB.dsBm.bmBitsPixel = 32, 'Alpha blending error: bitmap must use 32 bpp.');
Result := DIB.dsBm.bmBits;
Width := DIB.dsBmih.biWidth;
Height := DIB.dsBmih.biHeight;
end;
end;
Assert(Result <> nil, 'Alpha blending DC error: no bitmap available.');
end;
//----------------------------------------------------------------------------------------------------------------------
function GetBitmapBitsFromBitmap(Bitmap: HBITMAP): Pointer;
var
DIB: TDIBSection;
begin
Result := nil;
if Bitmap <> 0 then
begin
if GetObject(Bitmap, SizeOf(DIB), @DIB) = SizeOf(DIB) then
begin
Assert(DIB.dsBm.bmPlanes * DIB.dsBm.bmBitsPixel = 32, 'Alpha blending error: bitmap must use 32 bpp.');
Result := DIB.dsBm.bmBits;
end;
end;
end;
function CalculateScanline(Bits: Pointer; Width, Height, Row: Integer): Pointer;
// Helper function to calculate the start address for the given row.
begin
//todo: Height is always > 0 in LCL
{
if Height > 0 then // bottom-up DIB
Row := Height - Row - 1;
}
// Return DWORD aligned address of the requested scanline.
Result := Bits + Row * ((Width * 32 + 31) and not 31) div 8;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure AlphaBlend(Source, Destination: HDC; const R: TRect; const Target: TPoint; Mode: TBlendMode; ConstantAlpha, Bias: Integer);
// Optimized alpha blend procedure using MMX instructions to perform as quick as possible.
// For this procedure to work properly it is important that both source and target bitmap use the 32 bit color format.
// R describes the source rectangle to work on.
// Target is the place (upper left corner) in the target bitmap where to blend to. Note that source width + X offset
// must be less or equal to the target width. Similar for the height.
// If Mode is bmConstantAlpha then the blend operation uses the given ConstantAlpha value for all pixels.
// If Mode is bmPerPixelAlpha then each pixel is blended using its individual alpha value (the alpha value of the source).
// If Mode is bmMasterAlpha then each pixel is blended using its individual alpha value multiplied by ConstantAlpha.
// If Mode is bmConstantAlphaAndColor then each destination pixel is blended using ConstantAlpha but also a constant
// color which will be obtained from Bias. In this case no offset value is added, otherwise Bias is used as offset.
// Blending of a color into target only (bmConstantAlphaAndColor) ignores Source (the DC) and Target (the position).
// CAUTION: This procedure does not check whether MMX instructions are actually available! Call it only if MMX is really
// usable.
var
Y: Integer;
SourceRun,
TargetRun: PByte;
SourceBits,
DestBits: Pointer;
SourceWidth,
SourceHeight,
DestWidth,
DestHeight: Integer;
//BlendColor: TQColor;
begin
if not IsRectEmpty(R) then
begin
{$ifdef CPU64}
//avoid MasterAlpha due to incomplete AlphaBlendLineMaster. See comment in procedure
if Mode = bmMasterAlpha then
Mode := bmConstantAlpha;
{$endif}
// Note: it is tempting to optimize the special cases for constant alpha 0 and 255 by just ignoring soure
// (alpha = 0) or simply do a blit (alpha = 255). But this does not take the bias into account.
case Mode of
bmConstantAlpha:
begin
// Get a pointer to the bitmap bits for the source and target device contexts.
// Note: this supposes that both contexts do actually have bitmaps assigned!
SourceBits := GetBitmapBitsFromDeviceContext(Source, SourceWidth, SourceHeight);
DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth, DestHeight);
if Assigned(SourceBits) and Assigned(DestBits) then
begin
for Y := 0 to R.Bottom - R.Top - 1 do
begin
SourceRun := CalculateScanline(SourceBits, SourceWidth, SourceHeight, Y + R.Top);
Inc(SourceRun, 4 * R.Left);
TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y + Target.Y);
Inc(TargetRun, 4 * Target.X);
AlphaBlendLineConstant(SourceRun, TargetRun, R.Right - R.Left, ConstantAlpha, Bias);
end;
end;
EMMS;
end;
bmPerPixelAlpha:
begin
SourceBits := GetBitmapBitsFromDeviceContext(Source, SourceWidth, SourceHeight);
DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth, DestHeight);
if Assigned(SourceBits) and Assigned(DestBits) then
begin
for Y := 0 to R.Bottom - R.Top - 1 do
begin
SourceRun := CalculateScanline(SourceBits, SourceWidth, SourceHeight, Y + R.Top);
Inc(SourceRun, 4 * R.Left);
TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y + Target.Y);
Inc(TargetRun, 4 * Target.X);
AlphaBlendLinePerPixel(SourceRun, TargetRun, R.Right - R.Left, Bias);
end;
end;
EMMS;
end;
bmMasterAlpha:
begin
SourceBits := GetBitmapBitsFromDeviceContext(Source, SourceWidth, SourceHeight);
DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth, DestHeight);
if Assigned(SourceBits) and Assigned(DestBits) then
begin
for Y := 0 to R.Bottom - R.Top - 1 do
begin
SourceRun := CalculateScanline(SourceBits, SourceWidth, SourceHeight, Y + R.Top);
Inc(SourceRun, 4 * Target.X);
TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y + Target.Y);
AlphaBlendLineMaster(SourceRun, TargetRun, R.Right - R.Left, ConstantAlpha, Bias);
end;
end;
EMMS;
end;
bmConstantAlphaAndColor:
begin
//todo: see why is not working
{
QColor_fromRgb(@BlendColor,
Bias and $000000FF,
(Bias shr 8) and $000000FF,
(Bias shr 16) and $000000FF,
ConstantAlpha);
QPainter_fillRect(TQTDeviceContext(Destination).Widget,
R.Left + Target.x, R.Top + Target.y,
R.Right - R.Left, R.Bottom - R.Top, @BlendColor);
}
// Source is ignored since there is a constant color value.
DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth, DestHeight);
if Assigned(DestBits) then
begin
for Y := 0 to R.Bottom - R.Top - 1 do
begin
TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y + R.Top);
Inc(TargetRun, 4 * R.Left);
AlphaBlendLineMasterAndColor(TargetRun, R.Right - R.Left, ConstantAlpha, Bias);
end;
end;
EMMS;
end;
end;
end;
end;

2
VirtualTreeview/include/intf/qt/vtvdragmanager.inc Normal file
View File

@@ -0,0 +1,2 @@
{$i ../dummydragmanager.inc}

396
VirtualTreeview/include/intf/win32/olemethods.inc Normal file
View File

@@ -0,0 +1,396 @@
function TBaseVirtualTree.GetTreeFromDataObject(const DataObject: IDataObject): TBaseVirtualTree;
// Returns the owner/sender of the given data object by means of a special clipboard format
// or nil if the sender is in another process or no virtual tree at all.
var
Medium: TStgMedium;
Data: PVTReference;
begin
Result := nil;
if Assigned(DataObject) then
begin
StandardOLEFormat.cfFormat := CF_VTREFERENCE;
if DataObject.GetData(StandardOLEFormat, Medium) = S_OK then
begin
Data := GlobalLock(Medium.hGlobal);
if Assigned(Data) then
begin
if Data.Process = GetCurrentProcessID then
Result := Data.Tree;
GlobalUnlock(Medium.hGlobal);
end;
ReleaseStgMedium(@Medium);
end;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TBaseVirtualTree.RenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium;
ForClipboard: Boolean): HResult;
// Returns a memory expression of all currently selected nodes in the Medium structure.
// Note: The memory requirement of this method might be very high. This depends however on the requested storage format.
// For HGlobal (a global memory block) we need to render first all nodes to local memory and copy this then to
// the global memory in Medium. This is necessary because we have first to determine how much
// memory is needed before we can allocate it. Hence for a short moment we need twice the space as used by the
// nodes alone (plus the amount the nodes need in the tree anyway)!
// With IStream this does not happen. We directly stream out the nodes and pass the constructed stream along.
//--------------- local function --------------------------------------------
procedure WriteNodes(Stream: TStream);
var
Selection: TNodeArray;
I: Integer;
begin
if ForClipboard then
Selection := GetSortedCutCopySet(True)
else
Selection := GetSortedSelection(True);
for I := 0 to High(Selection) do
WriteNode(Stream, Selection[I]);
end;
//--------------- end local function ----------------------------------------
var
Data: PCardinal;
ResPointer: Pointer;
ResSize: Integer;
OLEStream: IStream;
VCLStream: TStream;
begin
FillChar(Medium, SizeOf(Medium), 0);
// We can render the native clipboard format in two different storage media.
if (FormatEtcIn.cfFormat = CF_VIRTUALTREE) and (FormatEtcIn.tymed and (TYMED_HGLOBAL or TYMED_ISTREAM) <> 0) then
begin
VCLStream := nil;
try
Medium.PunkForRelease := nil;
// Return data in one of the supported storage formats, prefer IStream.
if FormatEtcIn.tymed and TYMED_ISTREAM <> 0 then
begin
// Create an IStream on a memory handle (here it is 0 which indicates to implicitely allocated a handle).
// Do not use TStreamAdapter as it is not compatible with OLE (when flushing the clipboard OLE wants the HGlobal
// back which is not supported by TStreamAdapater).
CreateStreamOnHGlobal(0, True, OLEStream);
VCLStream := TOLEStream.Create(OLEStream);
WriteNodes(VCLStream);
// Rewind stream.
VCLStream.Position := 0;
Medium.tymed := TYMED_ISTREAM;
IUnknown(Medium.Pstm) := OLEStream;
Result := S_OK;
end
else
begin
VCLStream := TMemoryStream.Create;
WriteNodes(VCLStream);
ResPointer := TMemoryStream(VCLStream).Memory;
ResSize := VCLStream.Position;
// Allocate memory to hold the string.
if ResSize > 0 then
begin
Medium.hGlobal := GlobalAlloc(GHND or GMEM_SHARE, ResSize + SizeOf(Cardinal));
Data := GlobalLock(Medium.hGlobal);
// Store the size of the data too, for easy retrival.
Data^ := ResSize;
Inc(Data);
Move(ResPointer^, Data^, ResSize);
GlobalUnlock(Medium.hGlobal);
Medium.tymed := TYMED_HGLOBAL;
Result := S_OK;
end
else
Result := E_FAIL;
end;
finally
// We can free the VCL stream here since it was either a pure memory stream or only a wrapper around
// the OLEStream which exists independently.
VCLStream.Free;
end;
end
else // Ask application descendants to render self defined formats.
Result := DoRenderOLEData(FormatEtcIn, Medium, ForClipboard);
end;
//----------------------------------------------------------------------------------------------------------------------
type
// needed to handle OLE global memory objects
TOLEMemoryStream = class(TCustomMemoryStream)
public
function Write(const Buffer; Count: Integer): Longint; override;
end;
//----------------------------------------------------------------------------------------------------------------------
function TOLEMemoryStream.Write(const Buffer; Count: Integer): Integer;
begin
//raise EStreamError.CreateRes(PResStringRec(@SCantWriteResourceStreamError));
raise EStreamError.Create(SCantWriteResourceStreamError);
end;
//----------------------------------------------------------------------------------------------------------------------
function TBaseVirtualTree.ProcessOLEData(Source: TBaseVirtualTree; DataObject: IDataObject; TargetNode: PVirtualNode;
Mode: TVTNodeAttachMode; Optimized: Boolean): Boolean;
// Recreates the (sub) tree structure serialized into memory and provided by DataObject. The new nodes are attached to
// the passed node or FRoot if TargetNode is nil according to Mode. Optimized can be set to True if the entire operation
// happens within the same process (i.e. sender and receiver of the OLE operation are located in the same process).
// Optimize = True makes only sense if the operation to carry out is a move hence it is also the indication of the
// operation to be done here. Source is the source of the OLE data and only of use (and usually assigned) when
// an OLE operation takes place in the same application.
// Returns True on success, i.e. the CF_VIRTUALTREE format is supported by the data object and the structure could be
// recreated, otherwise False.
var
Medium: TStgMedium;
Stream: TStream;
Data: Pointer;
Node: PVirtualNode;
Nodes: TNodeArray;
I: Integer;
Res: HRESULT;
ChangeReason: TChangeReason;
begin
Nodes := nil;
// Check the data format available by the data object.
with StandardOLEFormat do
begin
// Read best format.
cfFormat := CF_VIRTUALTREE;
end;
Result := DataObject.QueryGetData(StandardOLEFormat) = S_OK;
if Result and not (toReadOnly in FOptions.FMiscOptions) then
begin
BeginUpdate;
Result := False;
try
if TargetNode = nil then
TargetNode := FRoot;
if TargetNode = FRoot then
begin
case Mode of
amInsertBefore:
Mode := amAddChildFirst;
amInsertAfter:
Mode := amAddChildLast;
end;
end;
// Optimized means source is known and in the same process so we can access its pointers, which avoids duplicating
// the data while doing a serialization. Can only be used with cut'n paste and drag'n drop with move effect.
if Optimized then
begin
if tsOLEDragging in Source.FStates then
Nodes := Source.FDragSelection
else
Nodes := Source.GetSortedCutCopySet(True);
if Mode in [amInsertBefore,amAddChildLast] then
begin
for I := 0 to High(Nodes) do
if not HasAsParent(TargetNode, Nodes[I]) then
Source.MoveTo(Nodes[I], TargetNode, Mode, False);
end
else
begin
for I := High(Nodes) downto 0 do
if not HasAsParent(TargetNode, Nodes[I]) then
Source.MoveTo(Nodes[I], TargetNode, Mode, False);
end;
Result := True;
end
else
begin
if Source = Self then
ChangeReason := crNodeCopied
else
ChangeReason := crNodeAdded;
Res := DataObject.GetData(StandardOLEFormat, Medium);
if Res = S_OK then
begin
case Medium.tymed of
TYMED_ISTREAM, // IStream interface
TYMED_HGLOBAL: // global memory block
begin
Stream := nil;
if Medium.tymed = TYMED_ISTREAM then
Stream := TOLEStream.Create(IUnknown(Medium.Pstm) as IStream)
else
begin
Data := GlobalLock(Medium.hGlobal);
if Assigned(Data) then
begin
// Get the total size of data to retrieve.
I := PCardinal(Data)^;
Inc(PCardinal(Data));
Stream := TOLEMemoryStream.Create;
TOLEMemoryStream(Stream).SetPointer(Data, I);
end;
end;
if Assigned(Stream) then
try
while Stream.Position < Stream.Size do
begin
Node := MakeNewNode;
InternalConnectNode(Node, TargetNode, Self, Mode);
InternalAddFromStream(Stream, VTTreeStreamVersion, Node);
// This seems a bit strange because of the callback for granting to add the node
// which actually comes after the node has been added. The reason is that the node must
// contain valid data otherwise I don't see how the application can make a funded decision.
if not DoNodeCopying(Node, TargetNode) then
DeleteNode(Node)
else
DoNodeCopied(Node);
StructureChange(Node, ChangeReason);
// In order to maintain the same node order when restoring nodes in the case of amInsertAfter
// we have to move the reference node continously. Othwise we would end up with reversed node order.
if Mode = amInsertAfter then
TargetNode := Node;
end;
Result := True;
finally
Stream.Free;
if Medium.tymed = TYMED_HGLOBAL then
GlobalUnlock(Medium.hGlobal);
end;
end;
end;
ReleaseStgMedium(@Medium);
end;
end;
finally
EndUpdate;
end;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TCustomVirtualStringTree.ContentToClipboard(Format: Word; Source: TVSTTextSourceType): HGLOBAL;
// This method constructs a shareable memory object filled with string data in the required format. Supported are:
// CF_TEXT - plain ANSI text (Unicode text is converted using the user's current locale)
// CF_UNICODETEXT - plain Unicode text
// CF_CSV - comma separated plain ANSI text
// CF_VRTF + CF_RTFNOOBS - rich text (plain ANSI)
// CF_HTML - HTML text encoded using UTF-8
//
// Result is the handle to a globally allocated memory block which can directly be used for clipboard and drag'n drop
// transfers. The caller is responsible for freeing the memory. If for some reason the content could not be rendered
// the Result is 0.
//--------------- local function --------------------------------------------
procedure MakeFragment(var HTML: string);
// Helper routine to build a properly-formatted HTML fragment.
const
Version = 'Version:1.0'#13#10;
StartHTML = 'StartHTML:';
EndHTML = 'EndHTML:';
StartFragment = 'StartFragment:';
EndFragment = 'EndFragment:';
DocType = '<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">';
HTMLIntro = '<html><head><META http-equiv=Content-Type content="text/html; charset=utf-8">' +
'</head><body><!--StartFragment-->';
HTMLExtro = '<!--EndFragment--></body></html>';
NumberLengthAndCR = 10;
// Let the compiler determine the description length.
DescriptionLength = Length(Version) + Length(StartHTML) + Length(EndHTML) + Length(StartFragment) +
Length(EndFragment) + 4 * NumberLengthAndCR;
var
Description: string;
StartHTMLIndex,
EndHTMLIndex,
StartFragmentIndex,
EndFragmentIndex: Integer;
begin
// The HTML clipboard format is defined by using byte positions in the entire block where HTML text and
// fragments start and end. These positions are written in a description. Unfortunately the positions depend on the
// length of the description but the description may change with varying positions.
// To solve this dilemma the offsets are converted into fixed length strings which makes it possible to know
// the description length in advance.
StartHTMLIndex := DescriptionLength; // position 0 after the description
StartFragmentIndex := StartHTMLIndex + Length(DocType) + Length(HTMLIntro);
EndFragmentIndex := StartFragmentIndex + Length(HTML);
EndHTMLIndex := EndFragmentIndex + Length(HTMLExtro);
Description := Version +
SysUtils.Format('%s%.8d', [StartHTML, StartHTMLIndex]) + #13#10 +
SysUtils.Format('%s%.8d', [EndHTML, EndHTMLIndex]) + #13#10 +
SysUtils.Format('%s%.8d', [StartFragment, StartFragmentIndex]) + #13#10 +
SysUtils.Format('%s%.8d', [EndFragment, EndFragmentIndex]) + #13#10;
HTML := Description + DocType + HTMLIntro + HTML + HTMLExtro;
end;
//--------------- end local function ----------------------------------------
var
Data: Pointer;
DataSize: Cardinal;
S: string;
WS: UnicodeString;
P: Pointer;
begin
Result := 0;
case Format of
CF_TEXT:
begin
S := ContentToAnsi(Source, #9) + #0;
Data := PChar(S);
DataSize := Length(S);
end;
CF_UNICODETEXT:
begin
WS := ContentToUTF16(Source, #9) + #0;
Data := PWideChar(WS);
DataSize := 2 * Length(WS);
end;
else
if Format = CF_CSV then
S := ContentToAnsi(Source, DefaultFormatSettings.ListSeparator) + #0
else
if (Format = CF_VRTF) or (Format = CF_VRTFNOOBJS) then
S := ContentToRTF(Source) + #0
else
if Format = CF_HTML then
begin
S := ContentToHTML(Source);
// Build a valid HTML clipboard fragment.
MakeFragment(S);
S := S + #0;
end;
Data := PChar(S);
DataSize := Length(S);
end;
if DataSize > 0 then
begin
Result := GlobalAlloc(GHND or GMEM_SHARE, DataSize);
P := GlobalLock(Result);
Move(Data^, P^, DataSize);
GlobalUnlock(Result);
end;
end;

725
VirtualTreeview/include/intf/win32/vtgraphicsi.inc Normal file
View File

@@ -0,0 +1,725 @@
{$ASMMODE INTEL}
procedure AlphaBlendLineConstant(Source, Destination: Pointer; Count: Integer; ConstantAlpha, Bias: Integer);
// Blends a line of Count pixels from Source to Destination using a constant alpha value.
// The layout of a pixel must be BGRA where A is ignored (but is calculated as the other components).
// ConstantAlpha must be in the range 0..255 where 0 means totally transparent (destination pixel only)
// and 255 totally opaque (source pixel only).
// Bias is an additional value which gets added to every component and must be in the range -128..127
asm
{$ifdef CPU64}
// RCX contains Source
// RDX contains Destination
// R8D contains Count
// R9D contains ConstantAlpha
// Bias is on the stack
//.NOFRAME
// Load XMM3 with the constant alpha value (replicate it for every component).
// Expand it to word size.
MOVD XMM3, R9D // ConstantAlpha
PUNPCKLWD XMM3, XMM3
PUNPCKLDQ XMM3, XMM3
// Load XMM5 with the bias value.
MOVD XMM5, [Bias]
PUNPCKLWD XMM5, XMM5
PUNPCKLDQ XMM5, XMM5
// Load XMM4 with 128 to allow for saturated biasing.
MOV R10D, 128
MOVD XMM4, R10D
PUNPCKLWD XMM4, XMM4
PUNPCKLDQ XMM4, XMM4
@1: // The pixel loop calculates an entire pixel in one run.
// Note: The pixel byte values are expanded into the higher bytes of a word due
// to the way unpacking works. We compensate for this with an extra shift.
MOVD XMM1, DWORD PTR [RCX] // data is unaligned
MOVD XMM2, DWORD PTR [RDX] // data is unaligned
PXOR XMM0, XMM0 // clear source pixel register for unpacking
PUNPCKLBW XMM0, XMM1{[RCX]} // unpack source pixel byte values into words
PSRLW XMM0, 8 // move higher bytes to lower bytes
PXOR XMM1, XMM1 // clear target pixel register for unpacking
PUNPCKLBW XMM1, XMM2{[RDX]} // unpack target pixel byte values into words
MOVQ XMM2, XMM1 // make a copy of the shifted values, we need them again
PSRLW XMM1, 8 // move higher bytes to lower bytes
// calculation is: target = (alpha * (source - target) + 256 * target) / 256
PSUBW XMM0, XMM1 // source - target
PMULLW XMM0, XMM3 // alpha * (source - target)
PADDW XMM0, XMM2 // add target (in shifted form)
PSRLW XMM0, 8 // divide by 256
// Bias is accounted for by conversion of range 0..255 to -128..127,
// doing a saturated add and convert back to 0..255.
PSUBW XMM0, XMM4
PADDSW XMM0, XMM5
PADDW XMM0, XMM4
PACKUSWB XMM0, XMM0 // convert words to bytes with saturation
MOVD DWORD PTR [RDX], XMM0 // store the result
@3:
ADD RCX, 4
ADD RDX, 4
DEC R8D
JNZ @1
{$else}
// EAX contains Source
// EDX contains Destination
// ECX contains Count
// ConstantAlpha and Bias are on the stack
PUSH ESI // save used registers
PUSH EDI
MOV ESI, EAX // ESI becomes the actual source pointer
MOV EDI, EDX // EDI becomes the actual target pointer
// Load MM6 with the constant alpha value (replicate it for every component).
// Expand it to word size.
MOV EAX, [ConstantAlpha]
DB $0F, $6E, $F0 /// MOVD MM6, EAX
DB $0F, $61, $F6 /// PUNPCKLWD MM6, MM6
DB $0F, $62, $F6 /// PUNPCKLDQ MM6, MM6
// Load MM5 with the bias value.
MOV EAX, [Bias]
DB $0F, $6E, $E8 /// MOVD MM5, EAX
DB $0F, $61, $ED /// PUNPCKLWD MM5, MM5
DB $0F, $62, $ED /// PUNPCKLDQ MM5, MM5
// Load MM4 with 128 to allow for saturated biasing.
MOV EAX, 128
DB $0F, $6E, $E0 /// MOVD MM4, EAX
DB $0F, $61, $E4 /// PUNPCKLWD MM4, MM4
DB $0F, $62, $E4 /// PUNPCKLDQ MM4, MM4
@1: // The pixel loop calculates an entire pixel in one run.
// Note: The pixel byte values are expanded into the higher bytes of a word due
// to the way unpacking works. We compensate for this with an extra shift.
DB $0F, $EF, $C0 /// PXOR MM0, MM0, clear source pixel register for unpacking
DB $0F, $60, $06 /// PUNPCKLBW MM0, [ESI], unpack source pixel byte values into words
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, move higher bytes to lower bytes
DB $0F, $EF, $C9 /// PXOR MM1, MM1, clear target pixel register for unpacking
DB $0F, $60, $0F /// PUNPCKLBW MM1, [EDI], unpack target pixel byte values into words
DB $0F, $6F, $D1 /// MOVQ MM2, MM1, make a copy of the shifted values, we need them again
DB $0F, $71, $D1, $08 /// PSRLW MM1, 8, move higher bytes to lower bytes
// calculation is: target = (alpha * (source - target) + 256 * target) / 256
DB $0F, $F9, $C1 /// PSUBW MM0, MM1, source - target
DB $0F, $D5, $C6 /// PMULLW MM0, MM6, alpha * (source - target)
DB $0F, $FD, $C2 /// PADDW MM0, MM2, add target (in shifted form)
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, divide by 256
// Bias is accounted for by conversion of range 0..255 to -128..127,
// doing a saturated add and convert back to 0..255.
DB $0F, $F9, $C4 /// PSUBW MM0, MM4
DB $0F, $ED, $C5 /// PADDSW MM0, MM5
DB $0F, $FD, $C4 /// PADDW MM0, MM4
DB $0F, $67, $C0 /// PACKUSWB MM0, MM0, convert words to bytes with saturation
DB $0F, $7E, $07 /// MOVD [EDI], MM0, store the result
@3:
ADD ESI, 4
ADD EDI, 4
DEC ECX
JNZ @1
POP EDI
POP ESI
{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure AlphaBlendLinePerPixel(Source, Destination: Pointer; Count, Bias: Integer);
// Blends a line of Count pixels from Source to Destination using the alpha value of the source pixels.
// The layout of a pixel must be BGRA.
// Bias is an additional value which gets added to every component and must be in the range -128..127
asm
{$ifdef CPU64}
// RCX contains Source
// RDX contains Destination
// R8D contains Count
// R9D contains Bias
//.NOFRAME
// Load XMM5 with the bias value.
MOVD XMM5, R9D // Bias
PUNPCKLWD XMM5, XMM5
PUNPCKLDQ XMM5, XMM5
// Load XMM4 with 128 to allow for saturated biasing.
MOV R10D, 128
MOVD XMM4, R10D
PUNPCKLWD XMM4, XMM4
PUNPCKLDQ XMM4, XMM4
@1: // The pixel loop calculates an entire pixel in one run.
// Note: The pixel byte values are expanded into the higher bytes of a word due
// to the way unpacking works. We compensate for this with an extra shift.
MOVD XMM1, DWORD PTR [RCX] // data is unaligned
MOVD XMM2, DWORD PTR [RDX] // data is unaligned
PXOR XMM0, XMM0 // clear source pixel register for unpacking
PUNPCKLBW XMM0, XMM1{[RCX]} // unpack source pixel byte values into words
PSRLW XMM0, 8 // move higher bytes to lower bytes
PXOR XMM1, XMM1 // clear target pixel register for unpacking
PUNPCKLBW XMM1, XMM2{[RDX]} // unpack target pixel byte values into words
MOVQ XMM2, XMM1 // make a copy of the shifted values, we need them again
PSRLW XMM1, 8 // move higher bytes to lower bytes
// Load XMM3 with the source alpha value (replicate it for every component).
// Expand it to word size.
MOVQ XMM3, XMM0
PUNPCKHWD XMM3, XMM3
PUNPCKHDQ XMM3, XMM3
// calculation is: target = (alpha * (source - target) + 256 * target) / 256
PSUBW XMM0, XMM1 // source - target
PMULLW XMM0, XMM3 // alpha * (source - target)
PADDW XMM0, XMM2 // add target (in shifted form)
PSRLW XMM0, 8 // divide by 256
// Bias is accounted for by conversion of range 0..255 to -128..127,
// doing a saturated add and convert back to 0..255.
PSUBW XMM0, XMM4
PADDSW XMM0, XMM5
PADDW XMM0, XMM4
PACKUSWB XMM0, XMM0 // convert words to bytes with saturation
MOVD DWORD PTR [RDX], XMM0 // store the result
@3:
ADD RCX, 4
ADD RDX, 4
DEC R8D
JNZ @1
{$else}
// EAX contains Source
// EDX contains Destination
// ECX contains Count
// Bias is on the stack
PUSH ESI // save used registers
PUSH EDI
MOV ESI, EAX // ESI becomes the actual source pointer
MOV EDI, EDX // EDI becomes the actual target pointer
// Load MM5 with the bias value.
MOV EAX, [Bias]
DB $0F, $6E, $E8 /// MOVD MM5, EAX
DB $0F, $61, $ED /// PUNPCKLWD MM5, MM5
DB $0F, $62, $ED /// PUNPCKLDQ MM5, MM5
// Load MM4 with 128 to allow for saturated biasing.
MOV EAX, 128
DB $0F, $6E, $E0 /// MOVD MM4, EAX
DB $0F, $61, $E4 /// PUNPCKLWD MM4, MM4
DB $0F, $62, $E4 /// PUNPCKLDQ MM4, MM4
@1: // The pixel loop calculates an entire pixel in one run.
// Note: The pixel byte values are expanded into the higher bytes of a word due
// to the way unpacking works. We compensate for this with an extra shift.
DB $0F, $EF, $C0 /// PXOR MM0, MM0, clear source pixel register for unpacking
DB $0F, $60, $06 /// PUNPCKLBW MM0, [ESI], unpack source pixel byte values into words
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, move higher bytes to lower bytes
DB $0F, $EF, $C9 /// PXOR MM1, MM1, clear target pixel register for unpacking
DB $0F, $60, $0F /// PUNPCKLBW MM1, [EDI], unpack target pixel byte values into words
DB $0F, $6F, $D1 /// MOVQ MM2, MM1, make a copy of the shifted values, we need them again
DB $0F, $71, $D1, $08 /// PSRLW MM1, 8, move higher bytes to lower bytes
// Load MM6 with the source alpha value (replicate it for every component).
// Expand it to word size.
DB $0F, $6F, $F0 /// MOVQ MM6, MM0
DB $0F, $69, $F6 /// PUNPCKHWD MM6, MM6
DB $0F, $6A, $F6 /// PUNPCKHDQ MM6, MM6
// calculation is: target = (alpha * (source - target) + 256 * target) / 256
DB $0F, $F9, $C1 /// PSUBW MM0, MM1, source - target
DB $0F, $D5, $C6 /// PMULLW MM0, MM6, alpha * (source - target)
DB $0F, $FD, $C2 /// PADDW MM0, MM2, add target (in shifted form)
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, divide by 256
// Bias is accounted for by conversion of range 0..255 to -128..127,
// doing a saturated add and convert back to 0..255.
DB $0F, $F9, $C4 /// PSUBW MM0, MM4
DB $0F, $ED, $C5 /// PADDSW MM0, MM5
DB $0F, $FD, $C4 /// PADDW MM0, MM4
DB $0F, $67, $C0 /// PACKUSWB MM0, MM0, convert words to bytes with saturation
DB $0F, $7E, $07 /// MOVD [EDI], MM0, store the result
@3:
ADD ESI, 4
ADD EDI, 4
DEC ECX
JNZ @1
POP EDI
POP ESI
{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure AlphaBlendLineMaster(Source, Destination: Pointer; Count: Integer; ConstantAlpha, Bias: Integer);
// Blends a line of Count pixels from Source to Destination using the source pixel and a constant alpha value.
// The layout of a pixel must be BGRA.
// ConstantAlpha must be in the range 0..255.
// Bias is an additional value which gets added to every component and must be in the range -128..127
asm
{$ifdef CPU64}
// RCX contains Source
// RDX contains Destination
// R8D contains Count
// R9D contains ConstantAlpha
// Bias is on the stack
//.SAVENV XMM6 //todo see how implement in fpc AlphaBlendLineMaster
// Load XMM3 with the constant alpha value (replicate it for every component).
// Expand it to word size.
MOVD XMM3, R9D // ConstantAlpha
PUNPCKLWD XMM3, XMM3
PUNPCKLDQ XMM3, XMM3
// Load XMM5 with the bias value.
MOV R10D, [Bias]
MOVD XMM5, R10D
PUNPCKLWD XMM5, XMM5
PUNPCKLDQ XMM5, XMM5
// Load XMM4 with 128 to allow for saturated biasing.
MOV R10D, 128
MOVD XMM4, R10D
PUNPCKLWD XMM4, XMM4
PUNPCKLDQ XMM4, XMM4
@1: // The pixel loop calculates an entire pixel in one run.
// Note: The pixel byte values are expanded into the higher bytes of a word due
// to the way unpacking works. We compensate for this with an extra shift.
MOVD XMM1, DWORD PTR [RCX] // data is unaligned
MOVD XMM2, DWORD PTR [RDX] // data is unaligned
PXOR XMM0, XMM0 // clear source pixel register for unpacking
PUNPCKLBW XMM0, XMM1{[RCX]} // unpack source pixel byte values into words
PSRLW XMM0, 8 // move higher bytes to lower bytes
PXOR XMM1, XMM1 // clear target pixel register for unpacking
PUNPCKLBW XMM1, XMM2{[RCX]} // unpack target pixel byte values into words
MOVQ XMM2, XMM1 // make a copy of the shifted values, we need them again
PSRLW XMM1, 8 // move higher bytes to lower bytes
// Load XMM6 with the source alpha value (replicate it for every component).
// Expand it to word size.
MOVQ XMM6, XMM0
PUNPCKHWD XMM6, XMM6
PUNPCKHDQ XMM6, XMM6
PMULLW XMM6, XMM3 // source alpha * master alpha
PSRLW XMM6, 8 // divide by 256
// calculation is: target = (alpha * master alpha * (source - target) + 256 * target) / 256
PSUBW XMM0, XMM1 // source - target
PMULLW XMM0, XMM6 // alpha * (source - target)
PADDW XMM0, XMM2 // add target (in shifted form)
PSRLW XMM0, 8 // divide by 256
// Bias is accounted for by conversion of range 0..255 to -128..127,
// doing a saturated add and convert back to 0..255.
PSUBW XMM0, XMM4
PADDSW XMM0, XMM5
PADDW XMM0, XMM4
PACKUSWB XMM0, XMM0 // convert words to bytes with saturation
MOVD DWORD PTR [RDX], XMM0 // store the result
@3:
ADD RCX, 4
ADD RDX, 4
DEC R8D
JNZ @1
{$else}
// EAX contains Source
// EDX contains Destination
// ECX contains Count
// ConstantAlpha and Bias are on the stack
PUSH ESI // save used registers
PUSH EDI
MOV ESI, EAX // ESI becomes the actual source pointer
MOV EDI, EDX // EDI becomes the actual target pointer
// Load MM6 with the constant alpha value (replicate it for every component).
// Expand it to word size.
MOV EAX, [ConstantAlpha]
DB $0F, $6E, $F0 /// MOVD MM6, EAX
DB $0F, $61, $F6 /// PUNPCKLWD MM6, MM6
DB $0F, $62, $F6 /// PUNPCKLDQ MM6, MM6
// Load MM5 with the bias value.
MOV EAX, [Bias]
DB $0F, $6E, $E8 /// MOVD MM5, EAX
DB $0F, $61, $ED /// PUNPCKLWD MM5, MM5
DB $0F, $62, $ED /// PUNPCKLDQ MM5, MM5
// Load MM4 with 128 to allow for saturated biasing.
MOV EAX, 128
DB $0F, $6E, $E0 /// MOVD MM4, EAX
DB $0F, $61, $E4 /// PUNPCKLWD MM4, MM4
DB $0F, $62, $E4 /// PUNPCKLDQ MM4, MM4
@1: // The pixel loop calculates an entire pixel in one run.
// Note: The pixel byte values are expanded into the higher bytes of a word due
// to the way unpacking works. We compensate for this with an extra shift.
DB $0F, $EF, $C0 /// PXOR MM0, MM0, clear source pixel register for unpacking
DB $0F, $60, $06 /// PUNPCKLBW MM0, [ESI], unpack source pixel byte values into words
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, move higher bytes to lower bytes
DB $0F, $EF, $C9 /// PXOR MM1, MM1, clear target pixel register for unpacking
DB $0F, $60, $0F /// PUNPCKLBW MM1, [EDI], unpack target pixel byte values into words
DB $0F, $6F, $D1 /// MOVQ MM2, MM1, make a copy of the shifted values, we need them again
DB $0F, $71, $D1, $08 /// PSRLW MM1, 8, move higher bytes to lower bytes
// Load MM7 with the source alpha value (replicate it for every component).
// Expand it to word size.
DB $0F, $6F, $F8 /// MOVQ MM7, MM0
DB $0F, $69, $FF /// PUNPCKHWD MM7, MM7
DB $0F, $6A, $FF /// PUNPCKHDQ MM7, MM7
DB $0F, $D5, $FE /// PMULLW MM7, MM6, source alpha * master alpha
DB $0F, $71, $D7, $08 /// PSRLW MM7, 8, divide by 256
// calculation is: target = (alpha * master alpha * (source - target) + 256 * target) / 256
DB $0F, $F9, $C1 /// PSUBW MM0, MM1, source - target
DB $0F, $D5, $C7 /// PMULLW MM0, MM7, alpha * (source - target)
DB $0F, $FD, $C2 /// PADDW MM0, MM2, add target (in shifted form)
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, divide by 256
// Bias is accounted for by conversion of range 0..255 to -128..127,
// doing a saturated add and convert back to 0..255.
DB $0F, $F9, $C4 /// PSUBW MM0, MM4
DB $0F, $ED, $C5 /// PADDSW MM0, MM5
DB $0F, $FD, $C4 /// PADDW MM0, MM4
DB $0F, $67, $C0 /// PACKUSWB MM0, MM0, convert words to bytes with saturation
DB $0F, $7E, $07 /// MOVD [EDI], MM0, store the result
@3:
ADD ESI, 4
ADD EDI, 4
DEC ECX
JNZ @1
POP EDI
POP ESI
{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure AlphaBlendLineMasterAndColor(Destination: Pointer; Count: Integer; ConstantAlpha, Color: Integer);
// Blends a line of Count pixels in Destination against the given color using a constant alpha value.
// The layout of a pixel must be BGRA and Color must be rrggbb00 (as stored by a COLORREF).
// ConstantAlpha must be in the range 0..255.
asm
{$ifdef CPU64}
// RCX contains Destination
// EDX contains Count
// R8D contains ConstantAlpha
// R9D contains Color
//.NOFRAME
// The used formula is: target = (alpha * color + (256 - alpha) * target) / 256.
// alpha * color (factor 1) and 256 - alpha (factor 2) are constant values which can be calculated in advance.
// The remaining calculation is therefore: target = (F1 + F2 * target) / 256
// Load XMM3 with the constant alpha value (replicate it for every component).
// Expand it to word size. (Every calculation here works on word sized operands.)
MOVD XMM3, R8D // ConstantAlpha
PUNPCKLWD XMM3, XMM3
PUNPCKLDQ XMM3, XMM3
// Calculate factor 2.
MOV R10D, $100
MOVD XMM2, R10D
PUNPCKLWD XMM2, XMM2
PUNPCKLDQ XMM2, XMM2
PSUBW XMM2, XMM3 // XMM2 contains now: 255 - alpha = F2
// Now calculate factor 1. Alpha is still in XMM3, but the r and b components of Color must be swapped.
BSWAP R9D // Color
ROR R9D, 8
MOVD XMM1, R9D // Load the color and convert to word sized values.
PXOR XMM4, XMM4
PUNPCKLBW XMM1, XMM4
PMULLW XMM1, XMM3 // XMM1 contains now: color * alpha = F1
@1: // The pixel loop calculates an entire pixel in one run.
MOVD XMM0, DWORD PTR [RCX]
PUNPCKLBW XMM0, XMM4
PMULLW XMM0, XMM2 // calculate F1 + F2 * target
PADDW XMM0, XMM1
PSRLW XMM0, 8 // divide by 256
PACKUSWB XMM0, XMM0 // convert words to bytes with saturation
MOVD DWORD PTR [RCX], XMM0 // store the result
ADD RCX, 4
DEC EDX
JNZ @1
{$else}
// EAX contains Destination
// EDX contains Count
// ECX contains ConstantAlpha
// Color is passed on the stack
// The used formula is: target = (alpha * color + (256 - alpha) * target) / 256.
// alpha * color (factor 1) and 256 - alpha (factor 2) are constant values which can be calculated in advance.
// The remaining calculation is therefore: target = (F1 + F2 * target) / 256
// Load MM3 with the constant alpha value (replicate it for every component).
// Expand it to word size. (Every calculation here works on word sized operands.)
DB $0F, $6E, $D9 /// MOVD MM3, ECX
DB $0F, $61, $DB /// PUNPCKLWD MM3, MM3
DB $0F, $62, $DB /// PUNPCKLDQ MM3, MM3
// Calculate factor 2.
MOV ECX, $100
DB $0F, $6E, $D1 /// MOVD MM2, ECX
DB $0F, $61, $D2 /// PUNPCKLWD MM2, MM2
DB $0F, $62, $D2 /// PUNPCKLDQ MM2, MM2
DB $0F, $F9, $D3 /// PSUBW MM2, MM3 // MM2 contains now: 255 - alpha = F2
// Now calculate factor 1. Alpha is still in MM3, but the r and b components of Color must be swapped.
MOV ECX, [Color]
BSWAP ECX
ROR ECX, 8
DB $0F, $6E, $C9 /// MOVD MM1, ECX // Load the color and convert to word sized values.
DB $0F, $EF, $E4 /// PXOR MM4, MM4
DB $0F, $60, $CC /// PUNPCKLBW MM1, MM4
DB $0F, $D5, $CB /// PMULLW MM1, MM3 // MM1 contains now: color * alpha = F1
@1: // The pixel loop calculates an entire pixel in one run.
DB $0F, $6E, $00 /// MOVD MM0, [EAX]
DB $0F, $60, $C4 /// PUNPCKLBW MM0, MM4
DB $0F, $D5, $C2 /// PMULLW MM0, MM2 // calculate F1 + F2 * target
DB $0F, $FD, $C1 /// PADDW MM0, MM1
DB $0F, $71, $D0, $08 /// PSRLW MM0, 8 // divide by 256
DB $0F, $67, $C0 /// PACKUSWB MM0, MM0 // convert words to bytes with saturation
DB $0F, $7E, $00 /// MOVD [EAX], MM0 // store the result
ADD EAX, 4
DEC EDX
JNZ @1
{$endif}
end;
//----------------------------------------------------------------------------------------------------------------------
procedure EMMS;
// Reset MMX state to use the FPU for other tasks again.
{$ifdef CPU64}
inline;
begin
end;
{$else}
asm
DB $0F, $77 /// EMMS
end;
{$endif}
//----------------------------------------------------------------------------------------------------------------------
function GetBitmapBitsFromDeviceContext(DC: HDC; out Width, Height: Integer): Pointer;
// Helper function used to retrieve the bitmap selected into the given device context. If there is a bitmap then
// the function will return a pointer to its bits otherwise nil is returned.
// Additionally the dimensions of the bitmap are returned.
var
Bitmap: HBITMAP;
DIB: TDIBSection;
begin
Result := nil;
Width := 0;
Height := 0;
Bitmap := GetCurrentObject(DC, OBJ_BITMAP);
if Bitmap <> 0 then
begin
if GetObject(Bitmap, SizeOf(DIB), @DIB) = SizeOf(DIB) then
begin
Assert(DIB.dsBm.bmPlanes * DIB.dsBm.bmBitsPixel = 32, 'Alpha blending error: bitmap must use 32 bpp.');
Result := DIB.dsBm.bmBits;
Width := DIB.dsBmih.biWidth;
Height := DIB.dsBmih.biHeight;
end;
end;
Assert(Result <> nil, 'Alpha blending DC error: no bitmap available.');
end;
//----------------------------------------------------------------------------------------------------------------------
function GetBitmapBitsFromBitmap(Bitmap: HBITMAP): Pointer;
var
DIB: TDIBSection;
begin
Result := nil;
if Bitmap <> 0 then
begin
if GetObject(Bitmap, SizeOf(DIB), @DIB) = SizeOf(DIB) then
begin
Assert(DIB.dsBm.bmPlanes * DIB.dsBm.bmBitsPixel = 32, 'Alpha blending error: bitmap must use 32 bpp.');
Result := DIB.dsBm.bmBits;
end;
end;
end;
function CalculateScanline(Bits: Pointer; Width, Height, Row: Integer): Pointer;
// Helper function to calculate the start address for the given row.
begin
//todo: Height is always > 0 in LCL
{
if Height > 0 then // bottom-up DIB
Row := Height - Row - 1;
}
// Return DWORD aligned address of the requested scanline.
Result := Bits + Row * ((Width * 32 + 31) and not 31) div 8;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure AlphaBlend(Source, Destination: HDC; const R: TRect; const Target: TPoint; Mode: TBlendMode; ConstantAlpha, Bias: Integer);
// Optimized alpha blend procedure using MMX instructions to perform as quick as possible.
// For this procedure to work properly it is important that both source and target bitmap use the 32 bit color format.
// R describes the source rectangle to work on.
// Target is the place (upper left corner) in the target bitmap where to blend to. Note that source width + X offset
// must be less or equal to the target width. Similar for the height.
// If Mode is bmConstantAlpha then the blend operation uses the given ConstantAlpha value for all pixels.
// If Mode is bmPerPixelAlpha then each pixel is blended using its individual alpha value (the alpha value of the source).
// If Mode is bmMasterAlpha then each pixel is blended using its individual alpha value multiplied by ConstantAlpha.
// If Mode is bmConstantAlphaAndColor then each destination pixel is blended using ConstantAlpha but also a constant
// color which will be obtained from Bias. In this case no offset value is added, otherwise Bias is used as offset.
// Blending of a color into target only (bmConstantAlphaAndColor) ignores Source (the DC) and Target (the position).
// CAUTION: This procedure does not check whether MMX instructions are actually available! Call it only if MMX is really
// usable.
var
Y: Integer;
SourceRun,
TargetRun: PByte;
SourceBits,
DestBits: Pointer;
SourceWidth,
SourceHeight,
DestWidth,
DestHeight: Integer;
begin
if not IsRectEmpty(R) then
begin
{$ifdef CPU64}
//avoid MasterAlpha due to incomplete AlphaBlendLineMaster. See comment in procedure
if Mode = bmMasterAlpha then
Mode := bmConstantAlpha;
{$endif}
// Note: it is tempting to optimize the special cases for constant alpha 0 and 255 by just ignoring soure
// (alpha = 0) or simply do a blit (alpha = 255). But this does not take the bias into account.
case Mode of
bmConstantAlpha:
begin
// Get a pointer to the bitmap bits for the source and target device contexts.
// Note: this supposes that both contexts do actually have bitmaps assigned!
SourceBits := GetBitmapBitsFromDeviceContext(Source, SourceWidth, SourceHeight);
DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth, DestHeight);
if Assigned(SourceBits) and Assigned(DestBits) then
begin
for Y := 0 to R.Bottom - R.Top - 1 do
begin
SourceRun := CalculateScanline(SourceBits, SourceWidth, SourceHeight, Y + R.Top);
Inc(SourceRun, 4 * R.Left);
TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y + Target.Y);
Inc(TargetRun, 4 * Target.X);
AlphaBlendLineConstant(SourceRun, TargetRun, R.Right - R.Left, ConstantAlpha, Bias);
end;
end;
EMMS;
end;
bmPerPixelAlpha:
begin
SourceBits := GetBitmapBitsFromDeviceContext(Source, SourceWidth, SourceHeight);
DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth, DestHeight);
if Assigned(SourceBits) and Assigned(DestBits) then
begin
for Y := 0 to R.Bottom - R.Top - 1 do
begin
SourceRun := CalculateScanline(SourceBits, SourceWidth, SourceHeight, Y + R.Top);
Inc(SourceRun, 4 * R.Left);
TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y + Target.Y);
Inc(TargetRun, 4 * Target.X);
AlphaBlendLinePerPixel(SourceRun, TargetRun, R.Right - R.Left, Bias);
end;
end;
EMMS;
end;
bmMasterAlpha:
begin
SourceBits := GetBitmapBitsFromDeviceContext(Source, SourceWidth, SourceHeight);
DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth, DestHeight);
if Assigned(SourceBits) and Assigned(DestBits) then
begin
for Y := 0 to R.Bottom - R.Top - 1 do
begin
SourceRun := CalculateScanline(SourceBits, SourceWidth, SourceHeight, Y + R.Top);
Inc(SourceRun, 4 * Target.X);
TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y + Target.Y);
AlphaBlendLineMaster(SourceRun, TargetRun, R.Right - R.Left, ConstantAlpha, Bias);
end;
end;
EMMS;
end;
bmConstantAlphaAndColor:
begin
// Source is ignored since there is a constant color value.
DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth, DestHeight);
if Assigned(DestBits) then
begin
for Y := 0 to R.Bottom - R.Top - 1 do
begin
TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y + R.Top);
Inc(TargetRun, 4 * R.Left);
AlphaBlendLineMasterAndColor(TargetRun, R.Right - R.Left, ConstantAlpha, Bias);
end;
end;
EMMS;
end;
end;
end;
end;

726
VirtualTreeview/include/intf/win32/vtvdragmanager.inc Normal file
View File

@@ -0,0 +1,726 @@
//----------------------------------------------------------------------------------------------------------------------
// OLE drag and drop support classes
// This is quite heavy stuff (compared with the VCL implementation) but is much better suited to fit the needs
// of DD'ing various kinds of virtual data and works also between applications.
//----------------- TEnumFormatEtc -------------------------------------------------------------------------------------
constructor TEnumFormatEtc.Create(Tree: TBaseVirtualTree; AFormatEtcArray: TFormatEtcArray);
var
I: Integer;
begin
inherited Create;
FTree := Tree;
// Make a local copy of the format data.
SetLength(FFormatEtcArray, Length(AFormatEtcArray));
for I := 0 to High(AFormatEtcArray) do
FFormatEtcArray[I] := AFormatEtcArray[I];
end;
//----------------------------------------------------------------------------------------------------------------------
function TEnumFormatEtc.Clone(out Enum: IEnumFormatEtc): HResult;
var
AClone: TEnumFormatEtc;
begin
Result := S_OK;
try
AClone := TEnumFormatEtc.Create(nil, FFormatEtcArray);
AClone.FCurrentIndex := FCurrentIndex;
Enum := AClone as IEnumFormatEtc;
except
Result := E_FAIL;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TEnumFormatEtc.Next(celt: LongWord; out elt: FormatEtc; pceltFetched:pULong=nil): HResult;
var
CopyCount: LongWord;
begin
Result := S_FALSE;
CopyCount := Length(FFormatEtcArray) - FCurrentIndex;
if celt < CopyCount then
CopyCount := celt;
if CopyCount > 0 then
begin
Move(FFormatEtcArray[FCurrentIndex], elt, CopyCount * SizeOf(TFormatEtc));
Inc(FCurrentIndex, CopyCount);
Result := S_OK;
end;
if pceltFetched <> nil then
pceltFetched^ := CopyCount;
end;
//----------------------------------------------------------------------------------------------------------------------
function TEnumFormatEtc.Reset: HResult;
begin
FCurrentIndex := 0;
Result := S_OK;
end;
//----------------------------------------------------------------------------------------------------------------------
function TEnumFormatEtc.Skip(celt: LongWord): HResult;
begin
if FCurrentIndex + celt < High(FFormatEtcArray) then
begin
Inc(FCurrentIndex, celt);
Result := S_Ok;
end
else
Result := S_FALSE;
end;
//----------------- TVTDataObject --------------------------------------------------------------------------------------
constructor TVTDataObject.Create(AOwner: TBaseVirtualTree; ForClipboard: Boolean);
begin
inherited Create;
FOwner := AOwner;
FForClipboard := ForClipboard;
FOwner.GetNativeClipboardFormats(FFormatEtcArray);
end;
//----------------------------------------------------------------------------------------------------------------------
destructor TVTDataObject.Destroy;
var
I: Integer;
StgMedium: PStgMedium;
begin
// Cancel a pending clipboard operation if this data object was created for the clipboard and
// is freed because something else is placed there.
if FForClipboard and not (tsClipboardFlushing in FOwner.FStates) then
FOwner.CancelCutOrCopy;
// Release any internal clipboard formats
for I := 0 to High(FormatEtcArray) do
begin
StgMedium := FindInternalStgMedium(FormatEtcArray[I].cfFormat);
if Assigned(StgMedium) then
ReleaseStgMedium(StgMedium);
end;
FormatEtcArray := nil;
inherited;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.CanonicalIUnknown(TestUnknown: IUnknown): IUnknown;
// Uses COM object identity: An explicit call to the IUnknown::QueryInterface method, requesting the IUnknown
// interface, will always return the same pointer.
begin
if Assigned(TestUnknown) then
begin
if TestUnknown.QueryInterface(IUnknown, Result) = 0 then
Result._Release // Don't actually need it just need the pointer value
else
Result := TestUnknown
end
else
Result := TestUnknown
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.EqualFormatEtc(FormatEtc1, FormatEtc2: TFormatEtc): Boolean;
begin
Result := (FormatEtc1.cfFormat = FormatEtc2.cfFormat) and (FormatEtc1.ptd = FormatEtc2.ptd) and
(FormatEtc1.dwAspect = FormatEtc2.dwAspect) and (FormatEtc1.lindex = FormatEtc2.lindex) and
(FormatEtc1.tymed and FormatEtc2.tymed <> 0);
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.FindFormatEtc(TestFormatEtc: TFormatEtc; const FormatEtcArray: TFormatEtcArray): integer;
var
I: integer;
begin
Result := -1;
for I := 0 to High(FormatEtcArray) do
begin
if EqualFormatEtc(TestFormatEtc, FormatEtcArray[I]) then
begin
Result := I;
Break;
end
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.FindInternalStgMedium(Format: TClipFormat): PStgMedium;
var
I: integer;
begin
Result := nil;
for I := 0 to High(InternalStgMediumArray) do
begin
if Format = InternalStgMediumArray[I].Format then
begin
Result := @InternalStgMediumArray[I].Medium;
Break;
end
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.HGlobalClone(HGlobal: THandle): THandle;
// Returns a global memory block that is a copy of the passed memory block.
var
Size: Cardinal;
Data,
NewData: PByte;
begin
Size := GlobalSize(HGlobal);
Result := GlobalAlloc(GPTR, Size);
Data := GlobalLock(hGlobal);
try
NewData := GlobalLock(Result);
try
Move(Data^, NewData^, Size);
finally
GlobalUnLock(Result);
end
finally
GlobalUnLock(hGlobal);
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.RenderInternalOLEData(const FormatEtcIn: TFormatEtc; var Medium: TStgMedium;
var OLEResult: HResult): Boolean;
// Tries to render one of the formats which have been stored via the SetData method.
// Since this data is already there it is just copied or its reference count is increased (depending on storage medium).
var
InternalMedium: PStgMedium;
begin
Result := True;
InternalMedium := FindInternalStgMedium(FormatEtcIn.cfFormat);
if Assigned(InternalMedium) then
OLEResult := StgMediumIncRef(InternalMedium^, Medium, False, Self as IDataObject)
else
Result := False;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.StgMediumIncRef(const InStgMedium: TStgMedium; var OutStgMedium: TStgMedium;
CopyInMedium: Boolean; DataObject: IDataObject): HRESULT;
// InStgMedium is the data that is requested, OutStgMedium is the data that we are to return either a copy of or
// increase the IDataObject's reference and send ourselves back as the data (unkForRelease). The InStgMedium is usually
// the result of a call to find a particular FormatEtc that has been stored locally through a call to SetData.
// If CopyInMedium is not true we already have a local copy of the data when the SetData function was called (during
// that call the CopyInMedium must be true). Then as the caller asks for the data through GetData we do not have to make
// copy of the data for the caller only to have them destroy it then need us to copy it again if necessary.
// This way we increase the reference count to ourselves and pass the STGMEDIUM structure initially stored in SetData.
// This way when the caller frees the structure it sees the unkForRelease is not nil and calls Release on the object
// instead of destroying the actual data.
var
Len: Integer;
begin
Result := S_OK;
// Simply copy all fields to start with.
OutStgMedium := InStgMedium;
// The data handled here always results from a call of SetData we got. This ensures only one storage format
// is indicated and hence the case statement below is safe (IDataObject.GetData can optionally use several
// storage formats).
case InStgMedium.tymed of
TYMED_HGLOBAL:
begin
if CopyInMedium then
begin
// Generate a unique copy of the data passed
OutStgMedium.hGlobal := HGlobalClone(InStgMedium.hGlobal);
if OutStgMedium.hGlobal = 0 then
Result := E_OUTOFMEMORY
end
else
// Don't generate a copy just use ourselves and the copy previously saved.
OutStgMedium.PunkForRelease := Pointer(DataObject); // Does not increase RefCount.
end;
TYMED_FILE:
begin
//todo_lcl_check
Len := Length(WideString(InStgMedium.lpszFileName)) + 1; // Don't forget the terminating null character.
OutStgMedium.lpszFileName := CoTaskMemAlloc(2 * Len);
Move(InStgMedium.lpszFileName^, OutStgMedium.lpszFileName^, 2 * Len);
end;
TYMED_ISTREAM:
IUnknown(OutStgMedium.Pstm)._AddRef;
TYMED_ISTORAGE:
IUnknown(OutStgMedium.Pstg)._AddRef;
TYMED_GDI:
if not CopyInMedium then
// Don't generate a copy just use ourselves and the previously saved data.
OutStgMedium.PunkForRelease := Pointer(DataObject) // Does not increase RefCount.
else
Result := DV_E_TYMED; // Don't know how to copy GDI objects right now.
TYMED_MFPICT:
if not CopyInMedium then
// Don't generate a copy just use ourselves and the previously saved data.
OutStgMedium.PunkForRelease := Pointer(DataObject) // Does not increase RefCount.
else
Result := DV_E_TYMED; // Don't know how to copy MetaFile objects right now.
TYMED_ENHMF:
if not CopyInMedium then
// Don't generate a copy just use ourselves and the previously saved data.
OutStgMedium.PunkForRelease := Pointer(DataObject) // Does not increase RefCount.
else
Result := DV_E_TYMED; // Don't know how to copy enhanced metafiles objects right now.
else
Result := DV_E_TYMED;
end;
if (Result = S_OK) and Assigned(OutStgMedium.PunkForRelease) then
IUnknown(OutStgMedium.PunkForRelease)._AddRef;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.DAdvise(const FormatEtc: TFormatEtc; advf: DWord; const advSink: IAdviseSink;
out dwConnection: DWord): HResult;
// Advise sink management is greatly simplified by the IDataAdviseHolder interface.
// We use this interface and forward all concerning calls to it.
begin
Result := S_OK;
if FAdviseHolder = nil then
Result := CreateDataAdviseHolder(FAdviseHolder);
if Result = S_OK then
Result := FAdviseHolder.Advise(Self as IDataObject, FormatEtc, advf, advSink, dwConnection);
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.DUnadvise(dwConnection: DWord): HResult;
begin
if FAdviseHolder = nil then
Result := E_NOTIMPL
else
Result := FAdviseHolder.Unadvise(dwConnection);
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.EnumDAdvise(Out enumAdvise : IEnumStatData):HResult;
begin
if FAdviseHolder = nil then
Result := OLE_E_ADVISENOTSUPPORTED
else
Result := FAdviseHolder.EnumAdvise(enumAdvise);
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.EnumFormatEtc(Direction: DWord; out EnumFormatEtc: IEnumFormatEtc): HResult;
var
NewList: TEnumFormatEtc;
begin
Result := E_FAIL;
if Direction = DATADIR_GET then
begin
NewList := TEnumFormatEtc.Create(FOwner, FormatEtcArray);
EnumFormatEtc := NewList as IEnumFormatEtc;
Result := S_OK;
end
else
EnumFormatEtc := nil;
if EnumFormatEtc = nil then
Result := OLE_S_USEREG;
end;
//----------------------------------------------------------------------------------------------------------------------
Function TVTDataObject.GetCanonicalFormatEtc(const pformatetcIn : FORMATETC;Out pformatetcOut : FORMATETC):HResult;
begin
Result := DATA_S_SAMEFORMATETC;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.GetData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium): HResult;
// Data is requested by clipboard or drop target. This method dispatchs the call
// depending on the data being requested.
var
I: Integer;
Data: PVTReference;
begin
// The tree reference format is always supported and returned from here.
if FormatEtcIn.cfFormat = CF_VTREFERENCE then
begin
// Note: this format is not used while flushing the clipboard to avoid a dangling reference
// when the owner tree is destroyed before the clipboard data is replaced with something else.
if tsClipboardFlushing in FOwner.FStates then
Result := E_FAIL
else
begin
Medium.hGlobal := GlobalAlloc(GHND or GMEM_SHARE, SizeOf(TVTReference));
Data := GlobalLock(Medium.hGlobal);
Data.Process := GetCurrentProcessID;
Data.Tree := FOwner;
GlobalUnlock(Medium.hGlobal);
Medium.tymed := TYMED_HGLOBAL;
Medium.PunkForRelease := nil;
Result := S_OK;
end;
end
else
begin
try
// See if we accept this type and if not get the correct return value.
Result := QueryGetData(FormatEtcIn);
if Result = S_OK then
begin
for I := 0 to High(FormatEtcArray) do
begin
if EqualFormatEtc(FormatEtcIn, FormatEtcArray[I]) then
begin
if not RenderInternalOLEData(FormatEtcIn, Medium, Result) then
Result := FOwner.RenderOLEData(FormatEtcIn, Medium, FForClipboard);
Break;
end;
end
end
except
FillChar(Medium, SizeOf(Medium), #0);
Result := E_FAIL;
end;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.GetDataHere(const FormatEtc: TFormatEtc; out Medium: TStgMedium): HResult;
begin
Result := E_NOTIMPL;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.QueryGetData(const FormatEtc: TFormatEtc): HResult;
var
I: Integer;
begin
Result := DV_E_CLIPFORMAT;
for I := 0 to High(FFormatEtcArray) do
begin
if FormatEtc.cfFormat = FFormatEtcArray[I].cfFormat then
begin
if (FormatEtc.tymed and FFormatEtcArray[I].tymed) <> 0 then
begin
if FormatEtc.dwAspect = FFormatEtcArray[I].dwAspect then
begin
if FormatEtc.lindex = FFormatEtcArray[I].lindex then
begin
Result := S_OK;
Break;
end
else
Result := DV_E_LINDEX;
end
else
Result := DV_E_DVASPECT;
end
else
Result := DV_E_TYMED;
end;
end
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDataObject.SetData(const FormatEtc: TFormatEtc; const Medium: TStgMedium; DoRelease: BOOL): HResult;
// Allows dynamic adding to the IDataObject during its existance. Most noteably it is used to implement
// IDropSourceHelper and allows to set a special format for optimized moves during a shell transfer.
var
Index: Integer;
LocalStgMedium: PStgMedium;
begin
// See if we already have a format of that type available.
Index := FindFormatEtc(FormatEtc, FormatEtcArray);
if Index > - 1 then
begin
// Just use the TFormatEct in the array after releasing the data.
LocalStgMedium := FindInternalStgMedium(FormatEtcArray[Index].cfFormat);
if Assigned(LocalStgMedium) then
begin
ReleaseStgMedium(LocalStgMedium);
FillChar(LocalStgMedium^, SizeOf(LocalStgMedium^), #0);
end;
end
else
begin
// It is a new format so create a new TFormatCollectionItem, copy the
// FormatEtc parameter into the new object and and put it in the list.
SetLength(FFormatEtcArray, Length(FormatEtcArray) + 1);
FormatEtcArray[High(FormatEtcArray)] := FormatEtc;
// Create a new InternalStgMedium and initialize it and associate it with the format.
SetLength(FInternalStgMediumArray, Length(InternalStgMediumArray) + 1);
InternalStgMediumArray[High(InternalStgMediumArray)].Format := FormatEtc.cfFormat;
LocalStgMedium := @InternalStgMediumArray[High(InternalStgMediumArray)].Medium;
FillChar(LocalStgMedium^, SizeOf(LocalStgMedium^), #0);
end;
if DoRelease then
begin
// We are simply being given the data and we take control of it.
LocalStgMedium^ := Medium;
Result := S_OK
end
else
begin
// We need to reference count or copy the data and keep our own references to it.
Result := StgMediumIncRef(Medium, LocalStgMedium^, True, Self as IDataObject);
// Can get a circular reference if the client calls GetData then calls SetData with the same StgMedium.
// Because the unkForRelease for the IDataObject can be marshalled it is necessary to get pointers that
// can be correctly compared. See the IDragSourceHelper article by Raymond Chen at MSDN.
if Assigned(LocalStgMedium.PunkForRelease) then
begin
if CanonicalIUnknown(Self) = CanonicalIUnknown(IUnknown(LocalStgMedium.PunkForRelease)) then
IUnknown(LocalStgMedium.PunkForRelease) := nil; // release the interface
end;
end;
// Tell all registered advice sinks about the data change.
if Assigned(FAdviseHolder) then
FAdviseHolder.SendOnDataChange(Self as IDataObject, 0, 0);
end;
//----------------- TVTDragManager -------------------------------------------------------------------------------------
constructor TVTDragManager.Create(AOwner: TBaseVirtualTree);
begin
inherited Create;
FOwner := AOwner;
// Create an instance of the drop target helper interface. This will fail but not harm on systems which do
// not support this interface (everything below Windows 2000);
CoCreateInstance(CLSID_DragDropHelper, nil, CLSCTX_INPROC_SERVER, IID_IDropTargetHelper, FDropTargetHelper);
end;
//----------------------------------------------------------------------------------------------------------------------
destructor TVTDragManager.Destroy;
begin
// Set the owner's reference to us to nil otherwise it will access an invalid pointer
// after our desctruction is complete.
Pointer(FOwner.FDragManager) := nil;
inherited;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.GetDataObject: IDataObject;
begin
// When the owner tree starts a drag operation then it gets a data object here to pass it to the OLE subsystem.
// In this case there is no local reference to a data object and one is created (but not stored).
// If there is a local reference then the owner tree is currently the drop target and the stored interface is
// that of the drag initiator.
if Assigned(FDataObject) then
Result := FDataObject
else
begin
Result := FOwner.DoCreateDataObject;
if Result = nil then
Result := TVTDataObject.Create(FOwner, False) as IDataObject;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.GetDragSource: TBaseVirtualTree;
begin
Result := FDragSource;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.GetDropTargetHelperSupported: Boolean;
begin
Result := Assigned(FDropTargetHelper);
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.GetIsDropTarget: Boolean;
begin
Result := FIsDropTarget;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.DragEnter(const DataObject: IDataObject; KeyState: LongWord; Pt: TPoint;
var Effect: LongWord): HResult;
begin
FDataObject := DataObject;
FIsDropTarget := True;
SystemParametersInfo(SPI_GETDRAGFULLWINDOWS, 0, @FFullDragging, 0);
// If full dragging of window contents is disabled in the system then our tree windows will be locked
// and cannot be updated during a drag operation. With the following call painting is again enabled.
if not FFullDragging then
LockWindowUpdate(0);
if Assigned(FDropTargetHelper) and FFullDragging then
FDropTargetHelper.DragEnter(FOwner.Handle, DataObject, Pt, Effect);
FDragSource := FOwner.GetTreeFromDataObject(DataObject);
Result := FOwner.DragEnter(KeyState, Pt, Effect);
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.DragLeave: HResult;
begin
if Assigned(FDropTargetHelper) and FFullDragging then
FDropTargetHelper.DragLeave;
FOwner.DragLeave;
FIsDropTarget := False;
FDragSource := nil;
FDataObject := nil;
Result := NOERROR;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.DragOver(KeyState: LongWord; Pt: TPoint; var Effect: LongWord): HResult;
begin
if Assigned(FDropTargetHelper) and FFullDragging then
FDropTargetHelper.DragOver(Pt, Effect);
Result := FOwner.DragOver(FDragSource, KeyState, dsDragMove, Pt, Effect);
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTDragManager.Drop(const DataObject: IDataObject; KeyState: LongWord; Pt: TPoint;
var Effect: LongWord): HResult;
begin
if Assigned(FDropTargetHelper) and FFullDragging then
FDropTargetHelper.Drop(DataObject, Pt, Effect);
Result := FOwner.DragDrop(DataObject, KeyState, Pt, Effect);
FIsDropTarget := False;
FDataObject := nil;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTDragManager.ForceDragLeave;
// Some drop targets, e.g. Internet Explorer leave a drag image on screen instead removing it when they receive
// a drop action. This method calls the drop target helper's DragLeave method to ensure it removes the drag image from
// screen. Unfortunately, sometimes not even this does help (e.g. when dragging text from VT to a text field in IE).
begin
if Assigned(FDropTargetHelper) and FFullDragging then
FDropTargetHelper.DragLeave;
end;
//----------------------------------------------------------------------------------------------------------------------
{$IF FPC_FULLVERSION < 020601}
function TVTDragManager.GiveFeedback(Effect: Longint): HResult;
{$ELSE}
function TVTDragManager.GiveFeedback(Effect: LongWord): HResult;
{$ENDIF}
begin
Result := DRAGDROP_S_USEDEFAULTCURSORS;
end;
//----------------------------------------------------------------------------------------------------------------------
{$IF FPC_FULLVERSION < 020601}
function TVTDragManager.QueryContinueDrag(EscapePressed: BOOL; KeyState: Longint): HResult;
{$ELSE}
function TVTDragManager.QueryContinueDrag(EscapePressed: BOOL; KeyState: LongWord): HResult;
{$ENDIF}
var
RButton,
LButton: Boolean;
begin
LButton := (KeyState and MK_LBUTTON) <> 0;
RButton := (KeyState and MK_RBUTTON) <> 0;
// Drag'n drop canceled by pressing both mouse buttons or Esc?
if (LButton and RButton) or EscapePressed then
Result := DRAGDROP_S_CANCEL
else
// Drag'n drop finished?
if not (LButton or RButton) then
Result := DRAGDROP_S_DROP
else
Result := S_OK;
end;

161
VirtualTreeview/lclconstants.inc Normal file
View File

@@ -0,0 +1,161 @@
// Message constants that are not defined in LCL
WM_APP = $8000;
// ExtTextOut Options
ETO_RTLREADING = 128;
//DrawText options
DT_RTLREADING = 131072;
// Clipboard constants
CF_BITMAP = 2;
CF_DIB = 8;
CF_PALETTE = 9;
CF_ENHMETAFILE = 14;
CF_METAFILEPICT = 3;
CF_OEMTEXT = 7;
CF_TEXT = 1;
CF_UNICODETEXT = 13;
CF_DIF = 5;
CF_DSPBITMAP = 130;
CF_DSPENHMETAFILE = 142;
CF_DSPMETAFILEPICT = 131;
CF_DSPTEXT = 129;
CF_GDIOBJFIRST = 768;
CF_GDIOBJLAST = 1023;
CF_HDROP = 15;
CF_LOCALE = 16;
CF_OWNERDISPLAY = 128;
CF_PENDATA = 10;
CF_PRIVATEFIRST = 512;
CF_PRIVATELAST = 767;
CF_RIFF = 11;
CF_SYLK = 4;
CF_WAVE = 12;
CF_TIFF = 6;
CF_MAX = 17;
// Win32 colors
CLR_NONE = $ffffffff;
CLR_DEFAULT = $ff000000;
//DrawFrameControl constants
DFCS_HOT = $1000;
//Thread support
//This values is for win32, how about others??
INFINITE = $FFFFFFFF;
//OLE Support
E_OUTOFMEMORY = HRESULT($8007000E);
E_INVALIDARG = HRESULT($80070057);
E_NOINTERFACE = HRESULT($80004002);
E_POINTER = HRESULT($80004003);
E_HANDLE = HRESULT($80070006);
E_ABORT = HRESULT($80004004);
E_FAIL = HRESULT($80004005);
E_ACCESSDENIED = HRESULT($80070005);
DV_E_TYMED = HRESULT($80040069);
DV_E_CLIPFORMAT = HRESULT($8004006A);
DV_E_LINDEX = HRESULT($80040068);
DV_E_DVASPECT = HRESULT($8004006B);
OLE_E_ADVISENOTSUPPORTED = HRESULT($80040003);
OLE_S_USEREG = HRESULT($00040000);
DATA_S_SAMEFORMATETC = HRESULT($00040130);
DRAGDROP_S_DROP = HRESULT($00040100);
DRAGDROP_S_CANCEL = HRESULT($00040101);
DRAGDROP_S_USEDEFAULTCURSORS = HRESULT($00040102);
NOERROR = 0;
SPI_GETDRAGFULLWINDOWS = 38;
// windows management
SWP_HIDEWINDOW = 128;
SWP_SHOWWINDOW = 64;
//Imagelists
ILD_NORMAL = 0;
// Set WindowPos
SWP_FRAMECHANGED = 32;
SWP_NOOWNERZORDER = 512;
SWP_NOSENDCHANGING = 1024;
{ RedrawWindow }
RDW_ERASE = 4;
RDW_FRAME = 1024;
RDW_INTERNALPAINT = 2;
RDW_INVALIDATE = 1;
RDW_NOERASE = 32;
RDW_NOFRAME = 2048;
RDW_NOINTERNALPAINT = 16;
RDW_VALIDATE = 8;
RDW_ERASENOW = 512;
RDW_UPDATENOW = 256;
RDW_ALLCHILDREN = 128;
RDW_NOCHILDREN = 64;
//SetRedraw
WM_SETREDRAW = 11;
//Dummy
CM_PARENTFONTCHANGED = 1999;
//Wheel
WHEEL_DELTA = 120;
WHEEL_PAGESCROLL = High(DWord);
SPI_GETWHEELSCROLLLINES = 104;
//MultiByte
MB_USEGLYPHCHARS = 4;
LOCALE_IDEFAULTANSICODEPAGE = 4100;
//Image list
ILD_TRANSPARENT = $00000001;
ILD_MASK = $00000010;
ILD_IMAGE = $00000020;
ILD_ROP = $00000040;
ILD_BLEND25 = $00000002;
ILD_BLEND50 = $00000004;
ILD_OVERLAYMASK = $00000F00;
{ GetDCEx }
DCX_WINDOW = $1;
DCX_CACHE = $2;
DCX_PARENTCLIP = $20;
DCX_CLIPSIBLINGS = $10;
DCX_CLIPCHILDREN = $8;
DCX_NORESETATTRS = $4;
DCX_LOCKWINDOWUPDATE = $400;
DCX_EXCLUDERGN = $40;
DCX_INTERSECTRGN = $80;
DCX_VALIDATE = $200000;
SCantWriteResourceStreamError = 'CantWriteResourceStreamError';
//command
EN_UPDATE = 1024;
ES_AUTOHSCROLL = $80;
ES_AUTOVSCROLL = $40;
ES_CENTER = $1;
ES_LEFT = 0;
ES_LOWERCASE = $10;
ES_MULTILINE = $4;
ES_NOHIDESEL = $100;
EM_SETRECTNP = 180;
DT_END_ELLIPSIS = 32768;

88
VirtualTreeview/lclfunctions.inc Normal file
View File

@@ -0,0 +1,88 @@
//Used in DrawTextW
{
function GetTextAlign(DC: HDC): UINT;
begin
Logger.AddCheckPoint(lcDummyFunctions,'GetTextAlign');
Result:=TA_TOP or TA_LEFT;
end;
}
//Used in DrawTextW, ShortenString, TVirtualTreeColumn.ComputeHeaderLayout, TVirtualTreeColumns.DrawButtonText,
// TVTEdit.AutoAdjustSize, TCustomVirtualStringTree.PaintNormalText, TCustomVirtualStringTree.WMSetFont
// TCustomVirtualStringTree.DoTextMeasuring
{
function GetTextExtentPoint32W(DC: HDC; Str: PWideChar; Count: Integer; var Size: TSize): Boolean;
var
TempStr: String;
begin
Logger.AddCheckPoint(lcDummyFunctions,'GetTextExtentPoint32W');
TempStr:=WideCharToString(Str);
Result:=GetTextExtentPoint(DC, PChar(TempStr), Length(TempStr), Size);
end;
}
//Used in DrawTextW
{
function ExtTextOutW(DC: HDC; X, Y: Integer; Options: LongInt; Rect: PRect;
Str: PWideChar; Count: LongInt; Dx: PInteger): Boolean;
var
TempStr: String;
begin
Logger.AddCheckPoint(lcDummyFunctions,'ExtTextOutW');
TempStr:=WideCharToString(Str);
Result:= ExtTextOut(DC, X, Y, Options, Rect, PChar(TempStr), Length(TempStr), Dx);
end;
}
//Used in TVirtualTreeHintWindow.CalcHintRect, TVirtualTreeColumn.ComputeHeaderLayout
// TBaseVirtualTree.CollectSelectedNodesRTL, TBaseVirtualTree.DetermineHitPositionRTL
// TBaseVirtualTree.UpdateEditBounds, TBaseVirtualTree.GetDisplayRect, PaintTree,
// TStringEditLink.PrepareEdit, TCustomVirtualStringTree.ComputeNodeHeight etc
function MapWindowPoints(hWndFrom, hWndTo: HWND; var lpPoints; cPoints: UINT): Integer;
var
I:Integer;
XOffset, YOffset: SmallInt;
FromRect,ToRect: TRect;
begin
GetWindowRect(hWndFrom,FromRect);
GetWindowRect(hWndTo,ToRect);
XOffset:=(FromRect.Left - ToRect.Left);
YOffset:=(FromRect.Top - ToRect.Top);
for i:=0 to cPoints - 1 do
begin
{
Mode Delphi does not support treating a pointer as a array
if ObjFpc is used than this syntax is preferred
PPoint(@lpPoints)[i].x:= XOffset + PPoint(@lpPoints)[i].x;
PPoint(@lpPoints)[i].y:= YOffset + PPoint(@lpPoints)[i].y;
}
PPoint(@lpPoints+i)^.x:= XOffset + PPoint(@lpPoints+i)^.x;
PPoint(@lpPoints+i)^.y:= YOffset + PPoint(@lpPoints+i)^.y;
end;
Result:=MakeLong(XOffset,YOffset);
end;
{$ifndef UseExternalDragManager}
function RegisterDragDrop(hwnd:HWND; pDropTarget:IDropTarget):WINOLEAPI;stdcall;external 'ole32.dll' name 'RegisterDragDrop';
function RevokeDragDrop(hwnd:HWND):WINOLEAPI;stdcall;external 'ole32.dll' name 'RevokeDragDrop';
function DoDragDrop(pDataObj:IDataObject; pDropSource:IDropSource; dwOKEffects:DWORD; pdwEffect:LPDWORD):WINOLEAPI;stdcall;external 'ole32.dll' name 'DoDragDrop';
function OleInitialize(pvReserved:LPVOID):WINOLEAPI;stdcall;external 'ole32.dll' name 'OleInitialize';
procedure OleUninitialize;stdcall;external 'ole32.dll' name 'OleUninitialize';
procedure ReleaseStgMedium(_para1:LPSTGMEDIUM);stdcall;external 'ole32.dll' name 'ReleaseStgMedium';
function OleSetClipboard(pDataObj:IDataObject):WINOLEAPI;stdcall;external 'ole32.dll' name 'OleSetClipboard';
function OleGetClipboard(out ppDataObj:IDataObject):WINOLEAPI;stdcall;external 'ole32.dll' name 'OleGetClipboard';
function OleFlushClipboard:WINOLEAPI;stdcall;external 'ole32.dll' name 'OleFlushClipboard';
function OleIsCurrentClipboard(pDataObj:IDataObject):WINOLEAPI;stdcall;external 'ole32.dll' name 'OleIsCurrentClipboard';
function CreateStreamOnHGlobal(hGlobal:HGLOBAL; fDeleteOnRelease:BOOL;out stm:IStream):WINOLEAPI;stdcall;external 'ole32.dll' name 'CreateStreamOnHGlobal';
{$endif}

38
VirtualTreeview/registervirtualtreeview.pas Normal file
View File

@@ -0,0 +1,38 @@
unit registervirtualtreeview;
{$Mode ObjFpc}
{$H+}
interface
procedure Register;
implementation
uses
Classes, SysUtils, LResources, LazarusPackageIntf,
VirtualTrees, VTHeaderPopup, VTIDEEditors, ComponentEditors;
procedure RegisterUnitVirtualTrees;
begin
RegisterComponents('Virtual Controls', [TVirtualDrawTree, TVirtualStringTree]);
end;
procedure RegisterUnitVTHeaderPopup;
begin
RegisterComponents('Virtual Controls', [TVTHeaderPopupMenu]);
end;
procedure Register;
begin
RegisterComponentEditor([TVirtualDrawTree, TVirtualStringTree], TVirtualTreeEditor);
RegisterUnit('VirtualTrees', @RegisterUnitVirtualTrees);
RegisterUnit('VTHeaderPopup', @RegisterUnitVTHeaderPopup);
end;
initialization
{$i ideicons.lrs}
end.

3
VirtualTreeview/units/carbon/fakeactivex.pas Normal file
View File

@@ -0,0 +1,3 @@
unit FakeActiveX;
{$i ../dummyactivex.inc}

38
VirtualTreeview/units/carbon/fakemmsystem.pas Normal file
View File

@@ -0,0 +1,38 @@
unit fakemmsystem;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Types;
function timeBeginPeriod(x1: DWord): DWord;
function timeEndPeriod(x1: DWord): DWord;
function timeGetTime: DWORD;
implementation
function timeBeginPeriod(x1: DWord): DWord;
begin
end;
function timeEndPeriod(x1: DWord): DWord;
begin
end;
function timeGetTime: DWORD;
var
ATime: TSystemTime;
begin
//todo: properly implement
GetLocalTime(ATime);
Result := ATime.MilliSecond;
end;
end.

1623
VirtualTreeview/units/carbon/virtualdragmanager.pas Normal file
View File

File diff suppressed because it is too large Load Diff

58
VirtualTreeview/units/carbon/virtualpanningwindow.pas Normal file
View File

@@ -0,0 +1,58 @@
unit virtualpanningwindow;
{$mode objfpc}{$H+}
interface
uses
LCLType, Graphics, Classes, SysUtils;
type
{ TVirtualPanningWindow }
TVirtualPanningWindow = class
private
FHandle: THandle;
FOwnerHandle: THandle;
FImage: TBitmap;
procedure HandlePaintMessage;
public
procedure Start(OwnerHandle: THandle; const Position: TPoint);
procedure Stop;
procedure Show(ClipRegion: HRGN);
property Image: TBitmap read FImage;
property Handle: THandle read FHandle;
end;
implementation
{$ifdef DEBUG_VTV}
uses
vtlogger;
{$endif}
{ TVirtualPanningWindow }
procedure TVirtualPanningWindow.HandlePaintMessage;
begin
end;
procedure TVirtualPanningWindow.Start(OwnerHandle: THandle; const Position: TPoint);
begin
FImage := TBitmap.Create;
end;
procedure TVirtualPanningWindow.Stop;
begin
FImage.Free;
FImage := nil;
end;
procedure TVirtualPanningWindow.Show(ClipRegion: HRGN);
begin
{$ifdef DEBUG_VTV}Logger.SendBitmap([lcPanning],'Panning Image',FImage);{$endif}
end;
end.

3
VirtualTreeview/units/cocoa/fakeactivex.pas Normal file
View File

@@ -0,0 +1,3 @@
unit FakeActiveX;
{$i ../dummyactivex.inc}

38
VirtualTreeview/units/cocoa/fakemmsystem.pas Normal file
View File

@@ -0,0 +1,38 @@
unit fakemmsystem;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Types;
function timeBeginPeriod(x1: DWord): DWord;
function timeEndPeriod(x1: DWord): DWord;
function timeGetTime: DWORD;
implementation
function timeBeginPeriod(x1: DWord): DWord;
begin
end;
function timeEndPeriod(x1: DWord): DWord;
begin
end;
function timeGetTime: DWORD;
var
ATime: TSystemTime;
begin
//todo: properly implement
GetLocalTime(ATime);
Result := ATime.MilliSecond;
end;
end.

1623
VirtualTreeview/units/cocoa/virtualdragmanager.pas Normal file
View File

File diff suppressed because it is too large Load Diff

58
VirtualTreeview/units/cocoa/virtualpanningwindow.pas Normal file
View File

@@ -0,0 +1,58 @@
unit virtualpanningwindow;
{$mode objfpc}{$H+}
interface
uses
LCLType, Graphics, Classes, SysUtils;
type
{ TVirtualPanningWindow }
TVirtualPanningWindow = class
private
FHandle: THandle;
FOwnerHandle: THandle;
FImage: TBitmap;
procedure HandlePaintMessage;
public
procedure Start(OwnerHandle: THandle; const Position: TPoint);
procedure Stop;
procedure Show(ClipRegion: HRGN);
property Image: TBitmap read FImage;
property Handle: THandle read FHandle;
end;
implementation
{$ifdef DEBUG_VTV}
uses
vtlogger;
{$endif}
{ TVirtualPanningWindow }
procedure TVirtualPanningWindow.HandlePaintMessage;
begin
end;
procedure TVirtualPanningWindow.Start(OwnerHandle: THandle; const Position: TPoint);
begin
FImage := TBitmap.Create;
end;
procedure TVirtualPanningWindow.Stop;
begin
FImage.Free;
FImage := nil;
end;
procedure TVirtualPanningWindow.Show(ClipRegion: HRGN);
begin
{$ifdef DEBUG_VTV}Logger.SendBitmap([lcPanning],'Panning Image',FImage);{$endif}
end;
end.

420
VirtualTreeview/units/dummyactivex.inc Normal file
View File

@@ -0,0 +1,420 @@
{fake unit just to compile - not used under non windows}
{$mode delphi}
interface
uses
{$ifdef Windows} Windows, {$endif} Classes, SysUtils, Types;
const
TYMED_HGLOBAL = 1;
TYMED_ISTREAM = 4;
DVASPECT_CONTENT = 1;
CLSCTX_INPROC_SERVER = $0010;
DROPEFFECT_COPY = 1;
DROPEFFECT_LINK = 4;
DROPEFFECT_MOVE = 2;
DROPEFFECT_NONE = 0;
DROPEFFECT_SCROLL = dword($80000000);
DATADIR_GET = 1;
type
//types from win unit
Long = LongInt;
WinBool = LongBool;
Bool = WinBool;
ULONG = cardinal;
PULONG = ^ULONG;
LONGLONG = int64;
LPDWORD = ^DWORD;
LPVOID = pointer;
TCOLORREF = cardinal;
TIID = TGUID;
LARGE_INTEGER = record
case byte of
0: (LowPart : DWORD;
HighPart : LONG);
1: (QuadPart : LONGLONG);
end;
PLARGE_INTEGER = ^LARGE_INTEGER;
_LARGE_INTEGER = LARGE_INTEGER;
TLargeInteger = Int64;
PLargeInteger = ^TLargeInteger;
ULARGE_INTEGER = record
case byte of
0: (LowPart : DWORD;
HighPart : DWORD);
1: (QuadPart : LONGLONG);
end;
PULARGE_INTEGER = ^ULARGE_INTEGER;
_ULARGE_INTEGER = ULARGE_INTEGER;
HANDLE = System.THandle;
HWND = HANDLE;
//HRESULT = System.HResult;
HBITMAP = HANDLE;
HENHMETAFILE = HANDLE;
//activex types
IMoniker = Interface;
WINOLEAPI = HResult;
TLCID = DWORD;
OleChar = WChar;
LPOLESTR = ^OLECHAR;
HMetaFilePict = Pointer;
tagBIND_OPTS = Record
cvStruct, // sizeof(BIND_OPTS)
grfFlags,
grfMode,
dwTickCountDeadline : DWord;
End;
TBind_Opts = tagBIND_OPTS;
TCLIPFORMAT = Word;
tagDVTARGETDEVICE = Record
tdSize : DWord;
tdDriverNameOffset,
tdDeviceNameOffset,
tdPortNameOffset,
tdExtDevmodeOffset : Word;
Data : Record End;
End;
DVTARGETDEVICE = TagDVTARGETDEVICE;
PDVTARGETDEVICE = ^tagDVTARGETDEVICE;
tagFORMATETC = Record
CfFormat : Word {TCLIPFORMAT};
Ptd : PDVTARGETDEVICE;
dwAspect : DWORD;
lindex : Long;
tymed : DWORD;
End;
FORMATETC = TagFORMATETC;
TFORMATETC = FORMATETC;
LPFORMATETC = ^FORMATETC;
PFormatEtc = LPFORMATETC;
tagSTATDATA = Record
// field used by:
FORMATETC : Tformatetc; // EnumAdvise, EnumData (cache), EnumFormats
advf : DWord; // EnumAdvise, EnumData (cache)
padvSink : Pointer {IAdviseSink}; // EnumAdvise
dwConnection: DWord; // EnumAdvise
End;
STATDATA = TagStatData;
TagSTGMEDIUM = Record
Tymed : DWord;
Case Integer Of
0 : (HBITMAP : hBitmap; PUnkForRelease : Pointer {IUnknown});
1 : (HMETAFILEPICT : hMetaFilePict );
2 : (HENHMETAFILE : hEnhMetaFile );
3 : (HGLOBAL : hGlobal );
4 : (lpszFileName : LPOLESTR );
5 : (pstm : Pointer{IStream} );
6 : (pstg : Pointer{IStorage} );
End;
USTGMEDIUM = TagSTGMEDIUM;
STGMEDIUM = USTGMEDIUM;
TStgMedium = TagSTGMEDIUM;
PStgMedium = ^TStgMedium;
LPSTGMEDIUM = ^STGMEDIUM;
IEnumString = Interface (IUnknown)
['{00000101-0000-0000-C000-000000000046}']
Function Next(Celt:ULong;Out xcelt;Out Celtfetched:ULong):HResult; StdCall;
// Function RemoteNext(Celt:ULong; Out celt;Out Celtfetched:ULong):HResult; StdCall;
Function Skip (Celt:ULong):Hresult;StdCall;
Function Reset:HResult;StdCall;
Function Clone(Out penum:IEnumString):HResult;StdCall;
End;
IEnumMoniker = Interface (IUnknown)
['{00000102-0000-0000-C000-000000000046}']
Function Next(celt:ULong; out Elt;out celftfetched: ULong):HResult; StdCall;
// Function RemoteNext(Celt:ULong; Out rgelt;out celtfetched :ULong):Hresult; StdCall;
Function Skip(celt:Ulong):HResult; StdCall;
Function Reset:HResult; StdCall;
Function Close(out penum:IEnumMoniker):HResult;StdCall;
End;
IEnumSTATDATA = Interface (IUnknown)
['{00000105-0000-0000-C000-000000000046}']
Function Next (Celt:ULong;Out xcelt;pceltfetched : PUlong):HResult; StdCall;
// Function RemoteNext(Celt:ULong;Out Rgelt:statdata;Out pceltFetched:ULong):HResult; StdCall;
Function Skip(Celt:ULong):HResult;StdCall;
Function Reset:HResult;StdCall;
Function Clone(out penum:IEnumstatdata):HResult;StdCall;
End;
IEnumFORMATETC = Interface (IUnknown)
['{00000103-0000-0000-C000-000000000046}']
Function Next(Celt:ULong;Out Rgelt:FormatEtc;pceltFetched:pULong=nil):HResult; StdCall;
// Function RemoteNext(Celt:ULong;Out Rgelt:FormatEtc;Out pceltFetched:ULong):HResult; StdCall;
Function Skip(Celt:ULong):HResult;StdCall;
Function Reset:HResult;StdCall;
Function Clone(out penum:IEnumFORMATETC):HResult;StdCall;
End;
IPersist = Interface (IUnknown)
['{0000010c-0000-0000-C000-000000000046}']
Function GetClassId(clsid:TClsId):HResult; StdCall;
End;
IPersistStream = Interface(IPersist)
['{00000109-0000-0000-C000-000000000046}']
Function IsDirty:HResult; StdCall;
Function Load(Const stm: IStream):HResult; StdCall;
Function Save(Const stm: IStream;fClearDirty:Bool):HResult;StdCall;
Function GetSizeMax(Out cbSize:ULarge_Integer):HResult; StdCall;
End;
IRunningObjectTable = Interface (IUnknown)
['{00000010-0000-0000-C000-000000000046}']
Function Register (grfFlags :DWord;const unkobject:IUnknown;Const mkObjectName:IMoniker;Out dwregister:DWord):HResult;StdCall;
Function Revoke (dwRegister:DWord):HResult; StdCall;
Function IsRunning (Const mkObjectName: IMoniker):HResult;StdCall;
Function GetObject (Const mkObjectName: IMoniker; Out punkObject:IUnknown):HResult; StdCall;
Function NoteChangeTime(dwRegister :DWord;Const FileTime: TFileTime):HResult;StdCall;
Function GetTimeOfLastChange(Const mkObjectName:IMoniker;Out filetime:TFileTime):HResult; StdCall;
Function EnumRunning (Out enumMoniker: IEnumMoniker):HResult; StdCall;
End;
IBindCtx = Interface (IUnknown)
['{0000000e-0000-0000-C000-000000000046}']
Function RegisterObjectBound(Const punk:IUnknown):HResult; stdCall;
Function RevokeObjectBound (Const Punk:IUnknown):HResult; stdCall;
Function ReleaseBoundObjects :HResult; StdCall;
Function SetBindOptions(Const bindOpts:TBind_Opts):HResult; stdCall;
// Function RemoteSetBindOptions(Const bind_opts: TBind_Opts2):HResult;StdCall;
Function GetBindOptions(var BindOpts:TBind_Opts):HResult; stdCall;
// Function RemoteGetBindOptions(Var bind_opts: TBind_Opts2):HResult;StdCall;
Function GetRunningObjectTable(Out rot : IRunningObjectTable):Hresult; StdCall;
Function RegisterObjectParam(Const pszkey:LPOleStr;const punk:IUnknown):HResult;
Function GetObjectParam(Const pszkey:LPOleStr; out punk: IUnknown):HResult; StdCall;
Function EnumObjectParam (out enum:IEnumString):Hresult;StdCall;
Function RevokeObjectParam(pszKey:LPOleStr):HResult;StdCall;
End;
PIMoniker = ^IMoniker;
IMoniker = Interface (IPersistStream)
['{0000000f-0000-0000-C000-000000000046}']
Function BindToObject (const pbc:IBindCtx;const mktoleft:IMoniker; RiidResult:TIID;Out vresult):HResult;StdCall;
// Function RemoteBindToObject (const pbc:IBindCtx;const mktoleft:IMoniker;RiidResult:TIID;Out vresult):HResult;StdCall;
Function BindToStorage(Const Pbc:IBindCtx;Const mktoLeft:IMoniker; Riid:TIID;Out vobj):HResult; StdCall;
// Function RemoteBindToStorage(Const Pbc:IBindCtx;Const mktoLeft:IMoniker; Riid:TIID;Out vobj):HResult; StdCall;
Function Reduce (const pbc:IBindCtx; dwReduceHowFar:DWord; mktoLeft: PIMoniker; Out mkReduced:IMoniker):HResult; StdCall;
Function ComposeWith(Const MkRight:IMoniker;fOnlyIfNotGeneric:BOOL; OUT mkComposite:IMoniker):HResult; StdCall;
Function Enum(fForward:Bool;Out enumMoniker:IEnumMoniker):HResult;StdCall;
Function IsEqual(Const mkOtherMoniker:IMoniker):HResult;StdCall;
Function Hash (Out dwHash:Dword):HResult;StdCall;
Function IsRunning(Const bc:IBindCtx;Const MkToLeft:IMoniker;Const mknewlyRunning:IMoniker):HResult;StdCall;
Function GetTimeOfLastChange(Const bc:IBindCtx;Const mkToLeft:IMoniker; out ft : FileTime):HResult; StdCall;
Function Inverse(out mk : IMoniker):HResult; StdCall;
Function CommonPrefixWith (Const mkOther:IMoniker):HResult; StdCall;
Function RelativePathTo(Const mkother:IMoniker; Out mkRelPath : IMoniker):HResult;StdCall;
Function GetDisplayName(Const bc:IMoniker;const mktoleft:IMoniker;Out szDisplayName: pOleStr):HResult; StdCall;
Function ParseDisplayName(Const bc:IBindCtx;Const mkToLeft:IMoniker;szDisplayName:POleStr;out cheaten:ULong;out mkOut:IMoniker):HResult; StdCall;
Function IsSystemMonitor(Out dwMkSys:DWord):HResult;StdCall;
End;
IAdviseSink = Interface (IUnknown)
['{0000010f-0000-0000-C000-000000000046}']
{$ifdef midl500} ['{00000150-0000-0000-C000-000000000046}'] {$endif}
Procedure OnDataChange (Const pformatetc : Formatetc;const pstgmed : STGMEDIUM); StdCall;
Procedure OnViewChange (dwAspect : DWord; lindex : Long); StdCall;
Procedure OnRename (Const pmk : IMoniker); StdCall;
Procedure OnSave; StdCall;
Procedure OnClose; StdCall;
End;
//Fake interfaces
IDataObject = Interface (IUnknown)
['{0000010e-0000-0000-C000-000000000046}']
Function GetData(Const formatetcIn : FORMATETC;Out medium : STGMEDIUM):HRESULT; STDCALL;
Function GetDataHere(CONST pformatetc : FormatETC; Out medium : STGMEDIUM):HRESULT; STDCALL;
Function QueryGetData(const pformatetc : FORMATETC):HRESULT; STDCALL;
Function GetCanonicalFormatEtc(const pformatetcIn : FORMATETC;Out pformatetcOut : FORMATETC):HResult; STDCALl;
Function SetData (Const pformatetc : FORMATETC;const medium:STGMEDIUM;FRelease : BOOL):HRESULT; StdCall;
Function EnumFormatEtc(dwDirection : DWord; OUT enumformatetcpara : IENUMFORMATETC):HRESULT; StdCall;
Function DAdvise(const formatetc : FORMATETC;advf :DWORD; CONST AdvSink : IAdviseSink;OUT dwConnection:DWORD):HRESULT;StdCall;
Function DUnadvise(dwconnection :DWord) :HRESULT;StdCall;
Function EnumDAdvise(Out enumAdvise : IEnumStatData):HResult;StdCall;
End;
IDropTarget = interface(IUnknown)
['{00000122-0000-0000-C000-000000000046}']
function DragEnter(const dataObj: IDataObject; grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD): HResult;StdCall;
function DragOver(grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD): HResult;StdCall;
function DragLeave: HResult;StdCall;
function Drop(const dataObj: IDataObject; grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD):HResult;StdCall;
end;
IDropSource = interface(IUnknown)
['{00000121-0000-0000-C000-000000000046}']
function QueryContinueDrag(fEscapePressed: BOOL;
grfKeyState: DWORD):HResult;StdCall;
function GiveFeedback(dwEffect: DWORD): HResult;StdCall;
end;
IDataAdviseHolder = Interface (IUnknown)
['{00000110-0000-0000-C000-000000000046}']
Function Advise (CONST pdataObject : IDataObject;CONST fetc:FORMATETC;advf : DWORD;Const pAdvise:IAdviseSink;Out DwConnection:DWord):HResult; StdCall;
Function Unadvise (dwConnection:Dword):HResult; StdCall;
Function EnumAdvise(out penumAdvise : IEnumStatData):HResult;StdCall;
Function SendOnDataChange(const pDataObject :IDataObject;DwReserved,advf : DWord):HResult; StdCall;
End;
//Ole helper functions
function Succeeded(Status : HRESULT) : BOOLEAN;
function Failed(Status : HRESULT) : BOOLEAN;
//ActiveX functions that have wrong calling convention in fpc
function RegisterDragDrop(hwnd:HWND; pDropTarget:IDropTarget):WINOLEAPI;stdcall;
function RevokeDragDrop(hwnd:HWND):WINOLEAPI;stdcall;
function DoDragDrop(pDataObj:IDataObject; pDropSource:IDropSource; dwOKEffects:DWORD; pdwEffect:LPDWORD):WINOLEAPI;
function OleInitialize(pvReserved:LPVOID):WINOLEAPI;stdcall;
procedure OleUninitialize;stdcall;
procedure ReleaseStgMedium(_para1:LPSTGMEDIUM);stdcall;
function OleSetClipboard(pDataObj:IDataObject):WINOLEAPI;stdcall;
function OleGetClipboard(out ppDataObj:IDataObject):WINOLEAPI;stdcall;
function OleFlushClipboard:WINOLEAPI;stdcall;
function OleIsCurrentClipboard(pDataObj:IDataObject):WINOLEAPI;stdcall;
function CreateStreamOnHGlobal(hGlobal:HGLOBAL; fDeleteOnRelease:BOOL;out stm:IStream):WINOLEAPI;stdcall;
function CoCreateInstance(const _para1:TCLSID; _para2:IUnknown; _para3:DWORD;const _para4:TIID;out _para5):HRESULT;stdcall;
implementation
function Succeeded(Status : HRESULT) : BOOLEAN;
begin
Succeeded:=Status and HRESULT($80000000)=0;
end;
function Failed(Status : HRESULT) : BOOLEAN;
begin
Failed:=Status and HRESULT($80000000)<>0;
end;
function RegisterDragDrop(hwnd: HWND; pDropTarget: IDropTarget): WINOLEAPI;
begin
//Logger.SendError([lcOle],'Ole function called in Linux');
//Logger.SendCallStack([lcOle],'Stack');
end;
function RevokeDragDrop(hwnd: HWND): WINOLEAPI;
begin
//Logger.SendError([lcOle],'Ole function called in Linux');
//Logger.SendCallStack([lcOle],'Stack');
end;
function DoDragDrop(pDataObj: IDataObject; pDropSource: IDropSource;
dwOKEffects: DWORD; pdwEffect: LPDWORD): WINOLEAPI;
begin
//Logger.SendError([lcOle],'Ole function called in Linux');
//Logger.SendCallStack([lcOle],'Stack');
end;
function OleInitialize(pvReserved: LPVOID): WINOLEAPI;
begin
//Logger.SendError([lcOle],'Ole function called in Linux');
//Logger.SendCallStack([lcOle],'Stack');
end;
procedure OleUninitialize;
begin
//Logger.SendError([lcOle],'Ole function called in Linux');
//Logger.SendCallStack([lcOle],'Stack');
end;
procedure ReleaseStgMedium(_para1: LPSTGMEDIUM);
begin
//Logger.SendError([lcOle],'Ole function called in Linux');
//Logger.SendCallStack([lcOle],'Stack');
end;
function OleSetClipboard(pDataObj: IDataObject): WINOLEAPI;
begin
//Logger.SendError([lcOle],'Ole function called in Linux');
//Logger.SendCallStack([lcOle],'Stack');
end;
function OleGetClipboard(out ppDataObj: IDataObject): WINOLEAPI;
begin
//Logger.SendError([lcOle],'Ole function called in Linux');
//Logger.SendCallStack([lcOle],'Stack');
end;
function OleFlushClipboard: WINOLEAPI;
begin
// Logger.SendError([lcOle],'Ole function called in Linux');
//Logger.SendCallStack([lcOle],'Stack');
end;
function OleIsCurrentClipboard(pDataObj: IDataObject): WINOLEAPI;
begin
//Logger.SendError([lcOle],'Ole function called in Linux');
//Logger.SendCallStack([lcOle],'Stack');
end;
function CreateStreamOnHGlobal(hGlobal: HGLOBAL; fDeleteOnRelease: BOOL; out
stm: IStream): WINOLEAPI;
begin
//Logger.SendError([lcOle],'Ole function called in Linux');
//Logger.SendCallStack([lcOle],'Stack');
end;
function CoCreateInstance(const _para1: TCLSID; _para2: IUnknown;
_para3: DWORD; const _para4: TIID; out _para5): HRESULT;
begin
//Logger.SendError([lcOle],'Ole function called in Linux');
//Logger.SendCallStack([lcOle],'Stack');
end;
end.

3
VirtualTreeview/units/gtk/fakeactivex.pas Normal file
View File

@@ -0,0 +1,3 @@
unit FakeActiveX;
{$i ../dummyactivex.inc}

38
VirtualTreeview/units/gtk/fakemmsystem.pas Normal file
View File

@@ -0,0 +1,38 @@
unit fakemmsystem;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Types;
function timeBeginPeriod(x1: DWord): DWord;
function timeEndPeriod(x1: DWord): DWord;
function timeGetTime: DWORD;
implementation
function timeBeginPeriod(x1: DWord): DWord;
begin
end;
function timeEndPeriod(x1: DWord): DWord;
begin
end;
function timeGetTime: DWORD;
var
ATime: TSystemTime;
begin
//todo: properly implement
GetLocalTime(ATime);
Result := ATime.MilliSecond;
end;
end.

1623
VirtualTreeview/units/gtk/virtualdragmanager.pas Normal file
View File

File diff suppressed because it is too large Load Diff

58
VirtualTreeview/units/gtk/virtualpanningwindow.pas Normal file
View File

@@ -0,0 +1,58 @@
unit virtualpanningwindow;
{$mode objfpc}{$H+}
interface
uses
LCLType, Graphics, Classes, SysUtils;
type
{ TVirtualPanningWindow }
TVirtualPanningWindow = class
private
FHandle: THandle;
FOwnerHandle: THandle;
FImage: TBitmap;
procedure HandlePaintMessage;
public
procedure Start(OwnerHandle: THandle; const Position: TPoint);
procedure Stop;
procedure Show(ClipRegion: HRGN);
property Image: TBitmap read FImage;
property Handle: THandle read FHandle;
end;
implementation
{$ifdef DEBUG_VTV}
uses
vtlogger;
{$endif}
{ TVirtualPanningWindow }
procedure TVirtualPanningWindow.HandlePaintMessage;
begin
end;
procedure TVirtualPanningWindow.Start(OwnerHandle: THandle; const Position: TPoint);
begin
FImage := TBitmap.Create;
end;
procedure TVirtualPanningWindow.Stop;
begin
FImage.Free;
FImage := nil;
end;
procedure TVirtualPanningWindow.Show(ClipRegion: HRGN);
begin
{$ifdef DEBUG_VTV}Logger.SendBitmap([lcPanning],'Panning Image',FImage);{$endif}
end;
end.

3
VirtualTreeview/units/gtk2/fakeactivex.pas Normal file
View File

@@ -0,0 +1,3 @@
unit FakeActiveX;
{$i ../dummyactivex.inc}

34
VirtualTreeview/units/gtk2/fakemmsystem.pas Normal file
View File

@@ -0,0 +1,34 @@
unit fakemmsystem;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Types, LCLIntf;
function timeBeginPeriod(x1: DWord): DWord;
function timeEndPeriod(x1: DWord): DWord;
function timeGetTime: DWORD;
implementation
function timeBeginPeriod(x1: DWord): DWord;
begin
//
end;
function timeEndPeriod(x1: DWord): DWord;
begin
//
end;
function timeGetTime: DWORD;
begin
Result := GetTickCount;
end;
end.

1623
VirtualTreeview/units/gtk2/virtualdragmanager.pas Normal file
View File

File diff suppressed because it is too large Load Diff

58
VirtualTreeview/units/gtk2/virtualpanningwindow.pas Normal file
View File

@@ -0,0 +1,58 @@
unit virtualpanningwindow;
{$mode objfpc}{$H+}
interface
uses
LCLType, Graphics, Classes, SysUtils;
type
{ TVirtualPanningWindow }
TVirtualPanningWindow = class
private
FHandle: THandle;
FOwnerHandle: THandle;
FImage: TBitmap;
procedure HandlePaintMessage;
public
procedure Start(OwnerHandle: THandle; const Position: TPoint);
procedure Stop;
procedure Show(ClipRegion: HRGN);
property Image: TBitmap read FImage;
property Handle: THandle read FHandle;
end;
implementation
{$ifdef DEBUG_VTV}
uses
vtlogger;
{$endif}
{ TVirtualPanningWindow }
procedure TVirtualPanningWindow.HandlePaintMessage;
begin
end;
procedure TVirtualPanningWindow.Start(OwnerHandle: THandle; const Position: TPoint);
begin
FImage := TBitmap.Create;
end;
procedure TVirtualPanningWindow.Stop;
begin
FImage.Free;
FImage := nil;
end;
procedure TVirtualPanningWindow.Show(ClipRegion: HRGN);
begin
{$ifdef DEBUG_VTV}Logger.SendBitmap([lcPanning],'Panning Image',FImage);{$endif}
end;
end.

3
VirtualTreeview/units/qt/fakeactivex.pas Normal file
View File

@@ -0,0 +1,3 @@
unit FakeActiveX;
{$i ../dummyactivex.inc}

38
VirtualTreeview/units/qt/fakemmsystem.pas Normal file
View File

@@ -0,0 +1,38 @@
unit fakemmsystem;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Types;
function timeBeginPeriod(x1: DWord): DWord;
function timeEndPeriod(x1: DWord): DWord;
function timeGetTime: DWORD;
implementation
function timeBeginPeriod(x1: DWord): DWord;
begin
end;
function timeEndPeriod(x1: DWord): DWord;
begin
end;
function timeGetTime: DWORD;
var
ATime: TSystemTime;
begin
//todo: properly implement
GetLocalTime(ATime);
Result := ATime.MilliSecond;
end;
end.

1623
VirtualTreeview/units/qt/virtualdragmanager.pas Normal file
View File

File diff suppressed because it is too large Load Diff

58
VirtualTreeview/units/qt/virtualpanningwindow.pas Normal file
View File

@@ -0,0 +1,58 @@
unit virtualpanningwindow;
{$mode objfpc}{$H+}
interface
uses
LCLType, Graphics, Classes, SysUtils;
type
{ TVirtualPanningWindow }
TVirtualPanningWindow = class
private
FHandle: THandle;
FOwnerHandle: THandle;
FImage: TBitmap;
procedure HandlePaintMessage;
public
procedure Start(OwnerHandle: THandle; const Position: TPoint);
procedure Stop;
procedure Show(ClipRegion: HRGN);
property Image: TBitmap read FImage;
property Handle: THandle read FHandle;
end;
implementation
{$ifdef DEBUG_VTV}
uses
vtlogger;
{$endif}
{ TVirtualPanningWindow }
procedure TVirtualPanningWindow.HandlePaintMessage;
begin
end;
procedure TVirtualPanningWindow.Start(OwnerHandle: THandle; const Position: TPoint);
begin
FImage := TBitmap.Create;
end;
procedure TVirtualPanningWindow.Stop;
begin
FImage.Free;
FImage := nil;
end;
procedure TVirtualPanningWindow.Show(ClipRegion: HRGN);
begin
{$ifdef DEBUG_VTV}Logger.SendBitmap([lcPanning],'Panning Image',FImage);{$endif}
end;
end.

1134
VirtualTreeview/units/win32/virtualdragmanager.pas Normal file
View File

File diff suppressed because it is too large Load Diff

113
VirtualTreeview/units/win32/virtualpanningwindow.pas Normal file
View File

@@ -0,0 +1,113 @@
unit virtualpanningwindow;
{Adapted from VirtualTrees by Luiz Am<41>rico to work in LCL/Lazarus}
{$mode objfpc}{$H+}
interface
uses
Windows, Graphics, Classes, SysUtils;
type
{ TVirtualPanningWindow }
TVirtualPanningWindow = class
private
FHandle: THandle;
FImage: TBitmap;
procedure HandlePaintMessage;
public
procedure Start(OwnerHandle: THandle; const Position: TPoint);
procedure Stop;
procedure Show(ClipRegion: HRGN);
property Image: TBitmap read FImage;
property Handle: THandle read FHandle;
end;
implementation
{$ifdef DEBUG_VTV}
uses
vtlogger;
{$endif}
function PanningWindowProc(Window: HWnd; Msg: UInt;WPara: WParam; LPara: LParam): LResult; stdcall;
var
PanningObject: TVirtualPanningWindow;
begin
if Msg = WM_PAINT then
begin
PanningObject:=TVirtualPanningWindow(GetWindowLongPtrW(Window,GWL_USERDATA));
if Assigned(PanningObject) then
PanningObject.HandlePaintMessage;
end
else
DefWindowProc(Window,Msg,WPara,LPara);
end;
var
PanningWindowClass: TWndClass = (
style: 0;
lpfnWndProc: @PanningWindowProc;
cbClsExtra: 0;
cbWndExtra: 0;
hInstance: 0;
hIcon: 0;
hCursor: 0;
hbrBackground: 0;
lpszMenuName: nil;
lpszClassName: 'VTPanningWindow'
);
{ TVirtualPanningWindow }
procedure TVirtualPanningWindow.HandlePaintMessage;
var
PS: PaintStruct;
begin
BeginPaint(FHandle, PS);
BitBlt(PS.hdc,0,0,FImage.Width,FImage.Height,FImage.Canvas.Handle,0,0,SRCCOPY);
EndPaint(FHandle, PS);
end;
procedure TVirtualPanningWindow.Start(OwnerHandle: THandle; const Position: TPoint);
var
TempClass: TWndClass;
begin
// Register the helper window class.
if not GetClassInfo(HInstance, PanningWindowClass.lpszClassName, TempClass) then
begin
PanningWindowClass.hInstance := HInstance;
Windows.RegisterClass(PanningWindowClass);
end;
// Create the helper window and show it at the given position without activating it.
with Position do
FHandle := CreateWindowEx(WS_EX_TOOLWINDOW, PanningWindowClass.lpszClassName, nil, WS_POPUP, X - 16, Y - 16,
32, 32, OwnerHandle, 0, HInstance, nil);
//todo use SetWindowLongPtr later
SetWindowLong(FHandle,GWL_USERDATA,PtrInt(Self));
FImage := TBitmap.Create;
end;
procedure TVirtualPanningWindow.Stop;
begin
// Destroy the helper window.
DestroyWindow(FHandle);
FImage.Free;
FImage := nil;
end;
procedure TVirtualPanningWindow.Show(ClipRegion: HRGN);
begin
{$ifdef DEBUG_VTV}Logger.SendBitmap([lcPanning],'Panning Image',FImage);{$endif}
//todo: move SetWindowRgn to DelphiCompat
SetWindowRgn(FHandle, ClipRegion, False);
ShowWindow(FHandle, SW_SHOWNOACTIVATE);
end;
end.

103
VirtualTreeview/virtualtreeview_package.lpk Normal file
View File

@@ -0,0 +1,103 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<Package Version="4">
<Name Value="virtualtreeview_package"/>
<Type Value="RunAndDesignTime"/>
<Author Value="Mike Lischke (LCL Port: Luiz Américo)"/>
<CompilerOptions>
<Version Value="11"/>
<SearchPaths>
<IncludeFiles Value="include/intf/$(LCLWidgetType);units;include/intf"/>
<OtherUnitFiles Value="units/$(LCLWidgetType)"/>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)-$(LCLWidgetType)"/>
</SearchPaths>
<Conditionals Value="if VirtualTreeView_Debug = 'True' then
begin
CustomOptions := '-dDEBUG_VTV';
UnitPath += ';$PkgOutDir(multiloglaz)';
UsageUnitPath += ';$PkgOutDir(multiloglaz)';
end;"/>
<BuildMacros>
<Count Value="1"/>
<Item1>
<Identifier Value="VirtualTreeView_Debug"/>
<Description Value="Enables debugging of VTV. Requires MultiLog package"/>
<Values Count="2">
<Item1 Value="True"/>
<Item2 Value="False"/>
</Values>
<ValueDescriptions Count="2"/>
</Item1>
</BuildMacros>
<Parsing>
<SyntaxOptions>
<CStyleMacros Value="True"/>
<UseAnsiStrings Value="False"/>
</SyntaxOptions>
</Parsing>
</CompilerOptions>
<Description Value="Virtual Treeview is an advanced TreeView component
"/>
<License Value=" Mozilla Public License 1.1 (MPL 1.1) or GNU Lesser General Public License
"/>
<Version Major="5" Minor="5" Release="3" Build="1"/>
<Files Count="8">
<Item1>
<Filename Value="VirtualTrees.pas"/>
<UnitName Value="VirtualTrees"/>
</Item1>
<Item2>
<Filename Value="VTHeaderPopup.pas"/>
<UnitName Value="VTHeaderPopup"/>
</Item2>
<Item3>
<Filename Value="registervirtualtreeview.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="registervirtualtreeview"/>
</Item3>
<Item4>
<Filename Value="ideicons.lrs"/>
<Type Value="LRS"/>
</Item4>
<Item5>
<Filename Value="VTConfig.inc"/>
<Type Value="Include"/>
</Item5>
<Item6>
<Filename Value="VTGraphics.pas"/>
<UnitName Value="VTGraphics"/>
</Item6>
<Item7>
<Filename Value="VirtualTrees.res"/>
<Type Value="Binary"/>
</Item7>
<Item8>
<Filename Value="VTIDEEditors.pas"/>
<UnitName Value="VTIDEEditors"/>
</Item8>
</Files>
<RequiredPkgs Count="3">
<Item1>
<PackageName Value="IDEIntf"/>
</Item1>
<Item2>
<PackageName Value="lclextensions_package"/>
<MaxVersion Minor="6"/>
<MinVersion Minor="6" Valid="True"/>
</Item2>
<Item3>
<PackageName Value="LCL"/>
</Item3>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
</PublishOptions>
<CustomOptions Items="ExternHelp" Version="2">
<_ExternHelp Items="Count"/>
</CustomOptions>
</Package>
</CONFIG>

22
VirtualTreeview/virtualtreeview_package.pas Normal file
View File

@@ -0,0 +1,22 @@
{ This file was automatically created by Lazarus. Do not edit!
This source is only used to compile and install the package.
}
unit virtualtreeview_package;
interface
uses
VirtualTrees, VTHeaderPopup, registervirtualtreeview, VTGraphics,
VTIDEEditors, LazarusPackageIntf;
implementation
procedure Register;
begin
RegisterUnit('registervirtualtreeview', @registervirtualtreeview.Register);
end;
initialization
RegisterPackage('virtualtreeview_package', @Register);
end.

88
VirtualTreeview/vtlogger.pas Normal file
View File

@@ -0,0 +1,88 @@
unit VTLogger;
{$mode objfpc}{$H+}
interface
uses
LCLLogger, MultiLog;
const
lcAll = [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31];
lcDebug = 0;
lcError = 1;
lcInfo = 2;
lcWarning = 3;
lcEvents = 4;
//reserved
lcUser = 8;
lcVTEvents = lcUser + 1;
lcPaint = lcUser + 2;
lcPaintHeader = lcUser + 3;
lcDummyFunctions = lcUser + 4;
lcMessages = lcUser + 5;
lcPaintSelection = lcUser + 6;
lcSetCursor = lcUser + 7;//it generates a lot of messages. so it will be debugged alone
lcPaintBitmap = lcUser + 8;
lcScroll = lcUser + 8;
lcPaintDetails = lcUser + 9;
lcCheck = lcUser + 10;
lcEditLink = lcUser + 11;
lcEraseBkgnd = lcUser + 12;
lcColumnPosition = lcUser + 13;
lcTimer = lcUser + 14;
lcDrag = lcUser + 15;
lcOle = lcUser + 16;
lcPanning = lcUser + 17;
lcHeaderOffset = lcUser + 18;
lcSelection = lcUser + 19;
lcAlphaBlend = lcUser + 20;
lcHint = lcUser + 21;
lcMouseEvent = lcUser + 22;
lcVT = [lcEvents..lcMouseEvent];
var
Logger: TLCLLogger;
function GetSelectedNodes(Sender: TLogger; Data: Pointer; var DoSend: Boolean): String;
implementation
uses
VirtualTrees, sysutils;
type
TNodeData = record
Title: String;
end;
PNodeData = ^TNodeData;
function GetSelectedNodes(Sender: TLogger; Data: Pointer; var DoSend: Boolean): String;
var
i: Integer;
TempNode: PVirtualNode;
begin
with TBaseVirtualTree(Data) do
begin
Result:='SelectedCount: '+IntToStr(SelectedCount)+LineEnding;
TempNode:=GetFirstSelected;
if TempNode = nil then exit;
Result:=Result+PNodeData(GetNodeData(TempNode))^.Title+LineEnding;
for i:= 1 to SelectedCount -1 do
begin
TempNode:=GetNextSelected(TempNode);
Result:=Result+PNodeData(GetNodeData(TempNode))^.Title+LineEnding;
end;
end;
end;
initialization
Logger:=TLCLLogger.Create;
finalization
Logger.Free;
end.