VirtualTrees.AncestorVcl.pas

unit VirtualTrees.AncestorVCL;

{$SCOPEDENUMS ON}

{****************************************************************************************************************}
{ Project          : VirtualTrees                                                                                }
{                                                                                                                }
{ author           : Karol Bieniaszewski, look at VirtualTrees.pas as some code moved from there                 }
{ year             : 2022                                                                                        }
{ contibutors      :                                                                                             }
{****************************************************************************************************************}

interface

uses
  Vcl.Controls,
  Vcl.Themes,
  Winapi.Messages,
  Winapi.Windows,
  Winapi.oleacc,
  Winapi.ActiveX,
  VirtualTrees.Types,
  VirtualTrees.BaseTree;

type
  TVTRenderOLEDataEvent = procedure(Sender: TBaseVirtualTree; const FormatEtcIn: TFormatEtc; out Medium: TStgMedium;
    ForClipboard: Boolean; var Result: HRESULT) of object;

  TVTAncestorVcl = class abstract(TBaseVirtualTree)
  private
    FOnRenderOLEData: TVTRenderOLEDataEvent;     // application/descendant defined clipboard formats

  protected
    function GetHintWindowClass: THintWindowClass; override;
    class function GetTreeFromDataObject(const DataObject: TVTDragDataObject): TBaseVirtualTree; deprecated 'Use class TVTDragManager.GetTreeFromDataObject() instead';
    function DoRenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium; ForClipboard: Boolean): HRESULT; override;
    property OnRenderOLEData: TVTRenderOLEDataEvent read FOnRenderOLEData write FOnRenderOLEData;
  public //methods
    function PasteFromClipboard(): Boolean; override;
 end;

   // The trees need an own hint window class because of Unicode output and adjusted font.
  TVirtualTreeHintWindow = class(THintWindow)
  strict private
    FHintData: TVTHintData;
    FTextHeight: TDimension;
    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
  strict protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure Paint; override;
    // Mitigator function to use the correct style service for this context (either the style assigned to the control for Delphi > 10.4 or the application style)
    function StyleServices(AControl: TControl = nil): TCustomStyleServices;
  public
    function CalcHintRect(MaxWidth: TDimension; const AHint: string; AData: Pointer): TRect; override;
    function IsHintMsg(var Msg: TMsg): Boolean; override;
  end;

implementation
uses
  System.Classes,
  Vcl.Graphics,
  System.UITypes,
  Vcl.AxCtrls,
  Vcl.Forms,
  Vcl.GraphUtil,
  VirtualTrees.ClipBoard,
  VirtualTrees.DataObject,
  VirtualTrees.DragnDrop,
  VirtualTrees.StyleHooks;

resourcestring
  SClipboardFailed = 'Clipboard operation failed.';

type
  TBVTCracker = class(TBaseVirtualTree);

//----------------------------------------------------------------------------------------------------------------------

function TVTAncestorVcl.DoRenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium; ForClipboard: Boolean): HRESULT;
begin
  Result := E_FAIL;
  if Assigned(FOnRenderOLEData) then
    FOnRenderOLEData(Self, FormatEtcIn, Medium, ForClipboard, Result);
end;

//----------------------------------------------------------------------------------------------------------------------

function TVTAncestorVcl.GetHintWindowClass: THintWindowClass;

// Returns the default hint window class used for the tree. Descendants can override it to use their own classes.

begin
  Result := TVirtualTreeHintWindow;
end;

//----------------------------------------------------------------------------------------------------------------------

class function TVTAncestorVcl.GetTreeFromDataObject(const DataObject: TVTDragDataObject): 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 TVTAncestorVcl.PasteFromClipboard(): Boolean;

// Reads what is currently on the clipboard into the tree (if the format is supported).
// Note: If the application wants to have text or special formats to be inserted then it must implement
//       its own code (OLE). Here only the native tree format is accepted.

var
  Data: IDataObject;
  Source: TBaseVirtualTree;

begin
  Result := False;
  if not (toReadOnly in TreeOptions.MiscOptions) then
  begin
    if OleGetClipboard(Data) <> S_OK then
      RaiseVTError(SClipboardFailed, hcTFClipboardFailed)
    else
    begin
      // Try to get the source tree of the operation to optimize the operation.
      Source := TVTDragManager.GetTreeFromDataObject(Data);
      Result := ProcessOLEData(Source, Data, FocusedNode, DefaultPasteMode, Assigned(Source) and
        (tsCutPending in Source.TreeStates));
      if Assigned(Source) then
      begin
        if Source <> Self then
          Source.FinishCutOrCopy
        else
          DoStateChange([], [tsCutPending]);
      end;
    end;
  end;
end;

//----------------- TVirtualTreeHintWindow -----------------------------------------------------------------------------

procedure TVirtualTreeHintWindow.CMTextChanged(var Message: TMessage);

begin
  // swallow this message to prevent the ancestor from resizing the window (we don't use the caption anyway)
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TVirtualTreeHintWindow.WMEraseBkgnd(var Message: TWMEraseBkgnd);

// The control is fully painted by own code so don't erase its background as this causes flickering.

begin
  Message.Result := 1;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TVirtualTreeHintWindow.CreateParams(var Params: TCreateParams);

begin
  inherited CreateParams(Params);

  with Params do
  begin
    Style := WS_POPUP;
    ExStyle := ExStyle and not WS_EX_CLIENTEDGE;
  end;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TVirtualTreeHintWindow.Paint();
var
  R: TRect;
  Y: Integer;
  S: string;
  DrawFormat: Cardinal;
  HintKind: TVTHintKind;
  LClipRect: TRect;

  LColor: TColor;
  LDetails: TThemedElementDetails;
  LGradientStart: TColor;
  LGradientEnd: TColor;

begin
  with FHintData do
  begin
    // Do actual painting only in the very first run.
    // If the given node is nil then we have to display a header hint.
    if (Node = nil) or (TBVTCracker(Tree).HintMode <> hmToolTip) then
    begin
      Canvas.Font := Screen.HintFont;
      Canvas.Font.Height := MulDiv(Canvas.Font.Height, Tree.ScaledPixels(96), Screen.PixelsPerInch); // See issue #992
      Y := 2;
    end
    else
    begin
      Tree.GetTextInfo(Node, Column, Canvas.Font, R, S);
      if LineBreakStyle = hlbForceMultiLine then
        Y := 1
      else
        Y := (R.Top - R.Bottom  + Self.Height) div 2;
    end;

    R := Rect(0, 0, Width, Height);

    HintKind := vhkText;
    if Assigned(Node) then
      TBVTCracker(Tree).DoGetHintKind(Node, Column, HintKind);

    if HintKind = vhkOwnerDraw then
    begin
      TBVTCracker(Tree).DoDrawHint(Canvas, Node, R, Column);
    end
    else
      with Canvas do
      begin
        if TBVTCracker(Tree).VclStyleEnabled  then
        begin
          InflateRect(R, -1, -1); // Fixes missing border when VCL styles are used
          LDetails := StyleServices(Tree).GetElementDetails(thHintNormal);
          if StyleServices(Tree).GetElementColor(LDetails, ecGradientColor1, LColor) and (LColor <> clNone) then
            LGradientStart := LColor
          else
            LGradientStart := clInfoBk;
          if StyleServices(Tree).GetElementColor(LDetails, ecGradientColor2, LColor) and (LColor <> clNone) then
            LGradientEnd := LColor
          else
            LGradientEnd := clInfoBk;
          if StyleServices(Tree).GetElementColor(LDetails, ecTextColor, LColor) and (LColor <> clNone) then
            Font.Color := LColor
          else
            Font.Color := Screen.HintFont.Color;
          GradientFillCanvas(Canvas, LGradientStart, LGradientEnd, R, gdVertical);
        end
        else
        begin
          // Still force tooltip back and text color.
          Font.Color := clInfoText;
          Pen.Color := clBlack;
          Brush.Color := clInfoBk;
          if StyleServices(Tree).Enabled and ((toThemeAware in TBVTCracker(Tree).TreeOptions.PaintOptions) or
             (toUseExplorerTheme in TBVTCracker(Tree).TreeOptions.PaintOptions)) then
          begin
            if toUseExplorerTheme in TBVTCracker(Tree).TreeOptions.PaintOptions then // ToolTip style
              StyleServices(Tree).DrawElement(Canvas.Handle, StyleServices(Tree).GetElementDetails(tttStandardNormal), R {$IF CompilerVersion >= 34}, nil, FCurrentPPI{$IFEND})
            else
              begin // Hint style
                LClipRect := R;
                InflateRect(R, 4, 4);
                StyleServices(Tree).DrawElement(Handle, StyleServices(Tree).GetElementDetails(tttStandardNormal), R, @LClipRect{$IF CompilerVersion >= 34}, FCurrentPPI{$IFEND});
                R := LClipRect;
                StyleServices(Tree).DrawEdge(Handle, StyleServices(Tree).GetElementDetails(twWindowRoot), R, [eeRaisedOuter], [efRect]);
              end;
          end
          else
            if TBVTCracker(Tree).VclStyleEnabled then
              StyleServices(Tree).DrawElement(Canvas.Handle, StyleServices(Tree).GetElementDetails(tttStandardNormal), R {$IF CompilerVersion >= 34}, nil, FCurrentPPI{$IFEND})
            else
              Rectangle(R);
        end;
        // Determine text position and don't forget the border.
        InflateRect(R, -1, -1);
        DrawFormat := DT_TOP or DT_NOPREFIX;
        SetBkMode(Handle, Winapi.Windows.TRANSPARENT);
        R.Top := Y;
        R.Left := R.Left + 3; // Make the text more centered
        if Assigned(Node) and (LineBreakStyle = hlbForceMultiLine) then
          DrawFormat := DrawFormat or DT_WORDBREAK;
        Winapi.Windows.DrawTextW(Handle, PWideChar(HintText), Length(HintText), R, DrawFormat);
      end;
  end;
end;

//----------------------------------------------------------------------------------------------------------------------

function TVirtualTreeHintWindow.StyleServices(AControl: TControl): TCustomStyleServices;
begin
  Result := VTStyleServices(AControl);
end;

//----------------------------------------------------------------------------------------------------------------------

function TVirtualTreeHintWindow.CalcHintRect(MaxWidth: Integer; const AHint: string; AData: Pointer): TRect;

var
  TM: TTextMetric;
  R: TRect;

begin
  try
    if AData = nil then
      // Defensive approach, it *can* happen that AData is nil. Maybe when several user defined hint classes are used.
      Result := Rect(0, 0, 0, 0)
    else
    begin
      // The hint window does not need any bidi mode setting but the caller of this method (TApplication.ActivateHint)
      // does some unneccessary actions if the hint window is not left-to-right.
      // The text alignment is based on the bidi mode passed in the hint data, hence we can
      // simply set the window's mode to left-to-right (it might have been modified by the caller, if the
      // tree window is right-to-left aligned).
      BidiMode := bdLeftToRight;

      FHintData := PVTHintData(AData)^;

      with FHintData do
      begin
        // The draw tree gets its hint size by the application (but only if not a header hint is about to show).
        // If the user will be drawing the hint, it gets its hint size by the application
        // (but only if not a header hint is about to show).
        // This size has already been determined in CMHintShow.
        if Assigned(Node) and (not IsRectEmpty(HintRect)) then
          Result := HintRect
        else
        begin
          if Column <= NoColumn then
          begin
            BidiMode := Tree.BidiMode;
            Alignment := TBVTCracker(Tree).Alignment;
          end
          else
          begin
            BidiMode := Tree.Header.Columns[Column].BidiMode;
            Alignment := Tree.Header.Columns[Column].Alignment;
          end;

          if BidiMode <> bdLeftToRight then
            ChangeBidiModeAlignment(Alignment);

          if (Node = nil) or (TBVTCracker(Tree).HintMode <> hmToolTip) then
          begin
            Canvas.Font := Screen.HintFont;
            Canvas.Font.Height := MulDiv(Canvas.Font.Height, Tree.ScaledPixels(96), Screen.PixelsPerInch); // See issue #992
          end
          else
          begin
            Canvas.Font := Tree.Font;
            with TBVTCracker(Tree) do
              DoPaintText(Node, Self.Canvas, Column, ttNormal);
          end;

          GetTextMetrics(Canvas.Handle, TM);
          FTextHeight := TM.tmHeight;

          if Length(HintText) = 0 then
            Result := Rect(0, 0, 0, 0)
          else
          begin
            if Assigned(Node) and (TBVTCracker(Tree).HintMode = hmToolTip) then
            begin
              // Determine actual line break style depending on what was returned by the methods and what's in the node.
              if LineBreakStyle = hlbDefault then
                if (vsMultiline in Node.States) or HintText.Contains(#13) then
                  LineBreakStyle := hlbForceMultiLine
                else
                  LineBreakStyle := hlbForceSingleLine;

              // Hint for a node.
              if LineBreakStyle = hlbForceMultiLine then
              begin
                // Multiline tooltips use the columns width but extend the bottom border to fit the whole caption.
                Result := Tree.GetDisplayRect(Node, Column, True, False);
                R := Result;

                // On Windows NT/2K/XP the behavior of the tooltip is slightly different to that on Windows 9x/Me.
                // We don't have Unicode word wrap on the latter so the tooltip gets as wide as the largest line
                // in the caption (limited by carriage return), which results in unoptimal overlay of the tooltip.
                Winapi.Windows.DrawTextW(Canvas.Handle, PWideChar(HintText), Length(HintText), R, DT_CALCRECT or DT_WORDBREAK);
                if BidiMode = bdLeftToRight then
                  Result.Right := R.Right + TBVTCracker(Tree).TextMargin
                else
                  Result.Left := R.Left - TBVTCracker(Tree).TextMargin + 1;
                Result.Bottom := R.Bottom;

                Inc(Result.Right);

                // If the node height and the column width are both already large enough to cover the entire text,
                // then we don't need the hint, though.
                // However if the text is partially scrolled out of the client area then a hint is useful as well.
                if (Tree.Header.Columns.Count > 0) and ((Tree.NodeHeight[Node] + 2) >= (Result.Bottom - Result.Top)) and
                   ((Tree.Header.Columns[Column].Width + 2) >= (Result.Right - Result.Left)) and not
                   ((Result.Left < 0) or (Result.Right > Tree.ClientWidth + 3) or
                    (Result.Top < 0) or (Result.Bottom > Tree.ClientHeight + 3)) then
                begin
                  Result := Rect(0, 0, 0, 0);
                  Exit;
                end;
              end
              else
              begin
                Result := TBVTCracker(Tree).LastHintRect; // = Tree.GetDisplayRect(Node, Column, True, True, True); see TBaseVirtualTree.CMHintShow

                { Fixes issue #623

                  Measure the rectangle to draw the text. The width of the result
                  is always adjusted according to the hint text because it may
                  be a custom hint coming in which can be larger or smaller than
                  the node text.
                  Earlier logic was using the current width of the node that was
                  either cutting off the hint text or producing undesired space
                  on the right.
                }
                R := Rect(0, 0, MaxWidth, FTextHeight);
                Winapi.Windows.DrawTextW(Canvas.Handle, PWideChar(HintText), Length(HintText), R, DT_CALCRECT or DT_TOP or DT_NOPREFIX or DT_WORDBREAK);
                if R.Right <> result.right - result.left then
                begin
                  result.Right := result.Left + r.Right;

                  //Space on right--taken from the code in the hmHint branch below.
                  if Assigned(Tree) then
                    Inc(Result.Right, TBVTCracker(Tree).TextMargin + TBVTCracker(Tree).Margin + Tree.ScaledPixels(4));
                end;
                // Fix ends.

                if toShowHorzGridLines in TBVTCracker(Tree).TreeOptions.PaintOptions then
                  Dec(Result.Bottom);
              end;

              // Include a one pixel border.
              InflateRect(Result, 1, 1);

              // Make the coordinates relative. They will again be offset by the caller code.
              OffsetRect(Result, -Result.Left - 1, -Result.Top - 1);
            end
            else
            begin
              // Hint for a header or non-tooltip hint.

              // Start with the base size of the hint in client coordinates.
              Result := Rect(0, 0, MaxWidth, FTextHeight);
              // Calculate the true size of the text rectangle.
              Winapi.Windows.DrawTextW(Canvas.Handle, PWideChar(HintText), Length(HintText), Result, DT_CALCRECT or DT_TOP or DT_NOPREFIX or DT_WORDBREAK);
              // The height of the text plus 2 pixels vertical margin plus the border determine the hint window height.
              // Minus 4 because THintWindow.ActivateHint adds 4 to Rect.Bottom anyway. Note that it is not scaled because the RTL itself does not do any scaling either.
              Inc(Result.Bottom, Tree.ScaledPixels(6) - 4);
              // The text is centered horizontally with usual text margin for left and right borders (plus border).
              if not Assigned(Tree) then
                Exit; // Workaround, because we have seen several exceptions here caught by Eurekalog. Submitted as issue #114 to http://code.google.com/p/virtual-treeview/
              { Issue #623 Fix for strange space on the right.
                Original logic was adding FTextHeight. Changed it to add FMargin instead and
                it looks OK even if the hint font is larger.
              }
              Inc(Result.Right, TBVTCracker(Tree).TextMargin
                  + TBVTCracker(Tree).Margin + Tree.ScaledPixels(4)); //Issue #623 space on right
                  //+ FTextHeight); // Old code: We are extending the width here, but the text height scales with the text width and has a similar value as AveCharWdith * 2.
            end;
          end;
        end;
      end;
    end;
  except
    Application.HandleException(Self);
  end;
end;

//----------------------------------------------------------------------------------------------------------------------

function TVirtualTreeHintWindow.IsHintMsg(var Msg: TMsg): Boolean;

// The VCL is a bit too generous when telling that an existing hint can be cancelled. Need to specify further here.

begin
  Result := inherited IsHintMsg(Msg) and HandleAllocated and IsWindowVisible(Handle);
  // Avoid that mouse moves over the non-client area or cursor key presses cancel the current hint.
  if Result and ((Msg.Message = WM_NCMOUSEMOVE) or ((Msg.Message >= WM_KEYFIRST) and (Msg.Message <= WM_KEYLAST) and (Msg.wparam in [VK_UP, VK_DOWN, VK_LEFT, VK_RIGHT]))) then
    Result := False;
end;

end.