SHARE
TWEET

Untitled

TLama Sep 4th, 2015 (edited) 180 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. uses
  2.   Winapi.ShlObj, Vcl.Themes, Winapi.UxTheme, VirtualTrees, VirtualTrees.Utils;
  3.  
  4. type
  5.   TVirtualStringTree = class(VirtualTrees.TVirtualStringTree)
  6.   end;
  7.  
  8. procedure ColorBlend(Canvas: TCanvas; const Rect: TRect; BlendColor: TColor; BlendValue: Integer);
  9. var
  10.   Bitmap: TBitmap;
  11. begin
  12.   if VirtualTrees.MMXAvailable then
  13.     VirtualTrees.Utils.AlphaBlend(0, Canvas.Handle, Rect, Rect.TopLeft, bmConstantAlphaAndColor,
  14.       BlendValue, ColorToRGB(BlendColor))
  15.   else
  16.   begin
  17.     Bitmap := TBitmap.Create;
  18.     try
  19.       Bitmap.Canvas.Brush.Color := BlendColor;
  20.       Bitmap.SetSize(Rect.Width, Rect.Height);
  21.       Bitmap.Canvas.FillRect(Rect);
  22.       Canvas.Draw(Rect.Left, Rect.Top, Bitmap, BlendValue);
  23.     finally
  24.       Bitmap.Free;
  25.     end;
  26.   end;
  27. end;
  28.  
  29. procedure TForm1.VirtualStringTree1AdvancedHeaderDraw(Sender: TVTHeader; var PaintInfo: THeaderPaintInfo; const Elements: THeaderPaintElements);
  30. var
  31.   R: TRect;
  32.   Tree: TVirtualStringTree;
  33.   Theme: HTHEME;
  34.   Alpha: Integer;
  35.   Color: TColor;
  36.   State: Integer;
  37.   Details: TThemedElementDetails;
  38.   RightBorderFlag: Cardinal;
  39.   NormalButtonStyle: Cardinal;
  40.   NormalButtonFlags: Cardinal;
  41.   PressedButtonStyle: Cardinal;
  42.   PressedButtonFlags: Cardinal;
  43.   RaisedButtonStyle: Cardinal;
  44.   RaisedButtonFlags: Cardinal;
  45.  
  46.   procedure PrepareButtonStyles;
  47.   begin
  48.     RaisedButtonStyle := 0;
  49.     RaisedButtonFlags := 0;
  50.     case Sender.Style of
  51.       hsThickButtons:
  52.       begin
  53.         NormalButtonStyle := BDR_RAISEDINNER or BDR_RAISEDOUTER;
  54.         NormalButtonFlags := BF_LEFT or BF_TOP or BF_BOTTOM or BF_MIDDLE or BF_SOFT or BF_ADJUST;
  55.         PressedButtonStyle := BDR_RAISEDINNER or BDR_RAISEDOUTER;
  56.         PressedButtonFlags := NormalButtonFlags or BF_RIGHT or BF_FLAT or BF_ADJUST;
  57.       end;
  58.       hsFlatButtons:
  59.       begin
  60.         NormalButtonStyle := BDR_RAISEDINNER;
  61.         NormalButtonFlags := BF_LEFT or BF_TOP or BF_BOTTOM or BF_MIDDLE or BF_ADJUST;
  62.         PressedButtonStyle := BDR_SUNKENOUTER;
  63.         PressedButtonFlags := BF_RECT or BF_MIDDLE or BF_ADJUST;
  64.       end;
  65.     else
  66.       begin
  67.         NormalButtonStyle := BDR_RAISEDINNER;
  68.         NormalButtonFlags := BF_RECT or BF_MIDDLE or BF_SOFT or BF_ADJUST;
  69.         PressedButtonStyle := BDR_SUNKENOUTER;
  70.         PressedButtonFlags := BF_RECT or BF_MIDDLE or BF_ADJUST;
  71.         RaisedButtonStyle := BDR_RAISEDINNER;
  72.         RaisedButtonFlags := BF_LEFT or BF_TOP or BF_BOTTOM or BF_MIDDLE or BF_ADJUST;
  73.       end;
  74.     end;
  75.   end;
  76.  
  77. begin
  78.   if hpeBackground in Elements then
  79.   begin
  80.     R := PaintInfo.PaintRectangle;
  81.     Tree := TVirtualStringTree(Sender.Treeview);
  82.  
  83.     // if there is no column assigned, the header background is painted
  84.     if not Assigned(PaintInfo.Column) then
  85.     begin
  86.       Alpha := 40;
  87.       Color := clLime;
  88.  
  89.       // let VCL Styles draw the stuff by themselves
  90.       if (Tree.VclStyleEnabled and (seClient in Tree.StyleElements)) then
  91.       begin
  92.         Details := StyleServices.GetElementDetails(thHeaderItemRightNormal);
  93.         StyleServices.DrawElement(PaintInfo.TargetCanvas.Handle, Details, R, @R);
  94.       end
  95.       else
  96.       // otherwise, if themes are enabled for the tree, then...
  97.       if tsUseThemes in Tree.TreeStates then
  98.       begin
  99.         // paint the themed header background
  100.         Theme := OpenThemeData(Tree.Handle, 'HEADER');
  101.         DrawThemeBackground(Theme, PaintInfo.TargetCanvas.Handle, HP_HEADERITEM, HIS_NORMAL, R, nil);
  102.         CloseThemeData(Theme);
  103.         // and alpha blend a colored rectangle over it
  104.         ColorBlend(PaintInfo.TargetCanvas, R, Color, Alpha);
  105.       end
  106.       else
  107.       // otherwise just fill the rectangle
  108.       begin
  109.         PaintInfo.TargetCanvas.Brush.Color := Sender.Background;
  110.         PaintInfo.TargetCanvas.FillRect(R);
  111.       end;
  112.     end
  113.     else
  114.     // header plate is painted
  115.     begin
  116.       Alpha := 80;
  117.       Color := $000080FF;
  118.  
  119.       // let VCL Styles draw the stuff by themselves
  120.       if Tree.VclStyleEnabled and (seClient in Tree.StyleElements) then
  121.       begin
  122.         if PaintInfo.IsDownIndex then
  123.           Details := StyleServices.GetElementDetails(thHeaderItemPressed)
  124.         else
  125.         if PaintInfo.IsHoverIndex then
  126.           Details := StyleServices.GetElementDetails(thHeaderItemHot)
  127.         else
  128.           Details := StyleServices.GetElementDetails(thHeaderItemNormal);
  129.         StyleServices.DrawElement(PaintInfo.TargetCanvas.Handle, Details, R, @R);
  130.       end
  131.       else
  132.       begin
  133.         // themes are enabled for the tree, so...
  134.         if tsUseThemes in Tree.TreeStates then
  135.         begin
  136.           // paint the themed header plate
  137.           Theme := OpenThemeData(Tree.Handle, 'HEADER');
  138.           if PaintInfo.IsDownIndex then
  139.             State := HIS_PRESSED
  140.           else
  141.           if PaintInfo.IsHoverIndex then
  142.             State := HIS_HOT
  143.           else
  144.             State := HIS_NORMAL;
  145.           DrawThemeBackground(Theme, PaintInfo.TargetCanvas.Handle, HP_HEADERITEM, State, R, nil);
  146.           CloseThemeData(Theme);
  147.           // and alpha blend a colored rectangle over it
  148.           ColorBlend(PaintInfo.TargetCanvas, R, Color, Alpha);
  149.         end
  150.         else
  151.         begin
  152.           // draw non-themed plate
  153.           PrepareButtonStyles;
  154.  
  155.           if PaintInfo.ShowRightBorder or (PaintInfo.Column.Index < Sender.Columns.Count - 1) then
  156.             RightBorderFlag := BF_RIGHT
  157.           else
  158.             RightBorderFlag := 0;
  159.  
  160.           if PaintInfo.IsDownIndex then
  161.             DrawEdge(PaintInfo.TargetCanvas.Handle, R, PressedButtonStyle, PressedButtonFlags)
  162.           else
  163.           if (Sender.Style = hsPlates) and PaintInfo.IsHoverIndex and (coAllowClick in PaintInfo.Column.Options) and
  164.             (coEnabled in PaintInfo.Column.Options)
  165.           then
  166.             DrawEdge(PaintInfo.TargetCanvas.Handle, R, RaisedButtonStyle, RaisedButtonFlags or RightBorderFlag)
  167.           else
  168.             DrawEdge(PaintInfo.TargetCanvas.Handle, R, NormalButtonStyle, NormalButtonFlags or RightBorderFlag);
  169.         end;
  170.       end;
  171.     end;
  172.   end;
  173. end;
  174.  
  175. procedure TForm1.VirtualStringTree1HeaderDrawQueryElements(Sender: TVTHeader; var PaintInfo: THeaderPaintInfo; var Elements: THeaderPaintElements);
  176. begin
  177.   Elements := [hpeBackground];
  178. end;
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
 
Top