Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- uses
- Winapi.ShlObj, Vcl.Themes, Winapi.UxTheme, VirtualTrees, VirtualTrees.Utils;
- type
- TVirtualStringTree = class(VirtualTrees.TVirtualStringTree)
- end;
- procedure ColorBlend(Canvas: TCanvas; const Rect: TRect; BlendColor: TColor; BlendValue: Integer);
- var
- Bitmap: TBitmap;
- begin
- if VirtualTrees.MMXAvailable then
- VirtualTrees.Utils.AlphaBlend(0, Canvas.Handle, Rect, Rect.TopLeft, bmConstantAlphaAndColor,
- BlendValue, ColorToRGB(BlendColor))
- else
- begin
- Bitmap := TBitmap.Create;
- try
- Bitmap.Canvas.Brush.Color := BlendColor;
- Bitmap.SetSize(Rect.Width, Rect.Height);
- Bitmap.Canvas.FillRect(Rect);
- Canvas.Draw(Rect.Left, Rect.Top, Bitmap, BlendValue);
- finally
- Bitmap.Free;
- end;
- end;
- end;
- procedure TForm1.VirtualStringTree1AdvancedHeaderDraw(Sender: TVTHeader; var PaintInfo: THeaderPaintInfo; const Elements: THeaderPaintElements);
- var
- R: TRect;
- Tree: TVirtualStringTree;
- Theme: HTHEME;
- Alpha: Integer;
- Color: TColor;
- State: Integer;
- Details: TThemedElementDetails;
- RightBorderFlag: Cardinal;
- NormalButtonStyle: Cardinal;
- NormalButtonFlags: Cardinal;
- PressedButtonStyle: Cardinal;
- PressedButtonFlags: Cardinal;
- RaisedButtonStyle: Cardinal;
- RaisedButtonFlags: Cardinal;
- procedure PrepareButtonStyles;
- begin
- RaisedButtonStyle := 0;
- RaisedButtonFlags := 0;
- case Sender.Style of
- hsThickButtons:
- begin
- NormalButtonStyle := BDR_RAISEDINNER or BDR_RAISEDOUTER;
- NormalButtonFlags := BF_LEFT or BF_TOP or BF_BOTTOM or BF_MIDDLE or BF_SOFT or BF_ADJUST;
- PressedButtonStyle := BDR_RAISEDINNER or BDR_RAISEDOUTER;
- PressedButtonFlags := NormalButtonFlags or BF_RIGHT or BF_FLAT or BF_ADJUST;
- end;
- hsFlatButtons:
- begin
- NormalButtonStyle := BDR_RAISEDINNER;
- NormalButtonFlags := BF_LEFT or BF_TOP or BF_BOTTOM or BF_MIDDLE or BF_ADJUST;
- PressedButtonStyle := BDR_SUNKENOUTER;
- PressedButtonFlags := BF_RECT or BF_MIDDLE or BF_ADJUST;
- end;
- else
- begin
- NormalButtonStyle := BDR_RAISEDINNER;
- NormalButtonFlags := BF_RECT or BF_MIDDLE or BF_SOFT or BF_ADJUST;
- PressedButtonStyle := BDR_SUNKENOUTER;
- PressedButtonFlags := BF_RECT or BF_MIDDLE or BF_ADJUST;
- RaisedButtonStyle := BDR_RAISEDINNER;
- RaisedButtonFlags := BF_LEFT or BF_TOP or BF_BOTTOM or BF_MIDDLE or BF_ADJUST;
- end;
- end;
- end;
- begin
- if hpeBackground in Elements then
- begin
- R := PaintInfo.PaintRectangle;
- Tree := TVirtualStringTree(Sender.Treeview);
- // if there is no column assigned, the header background is painted
- if not Assigned(PaintInfo.Column) then
- begin
- Alpha := 40;
- Color := clLime;
- // let VCL Styles draw the stuff by themselves
- if (Tree.VclStyleEnabled and (seClient in Tree.StyleElements)) then
- begin
- Details := StyleServices.GetElementDetails(thHeaderItemRightNormal);
- StyleServices.DrawElement(PaintInfo.TargetCanvas.Handle, Details, R, @R);
- end
- else
- // otherwise, if themes are enabled for the tree, then...
- if tsUseThemes in Tree.TreeStates then
- begin
- // paint the themed header background
- Theme := OpenThemeData(Tree.Handle, 'HEADER');
- DrawThemeBackground(Theme, PaintInfo.TargetCanvas.Handle, HP_HEADERITEM, HIS_NORMAL, R, nil);
- CloseThemeData(Theme);
- // and alpha blend a colored rectangle over it
- ColorBlend(PaintInfo.TargetCanvas, R, Color, Alpha);
- end
- else
- // otherwise just fill the rectangle
- begin
- PaintInfo.TargetCanvas.Brush.Color := Sender.Background;
- PaintInfo.TargetCanvas.FillRect(R);
- end;
- end
- else
- // header plate is painted
- begin
- Alpha := 80;
- Color := $000080FF;
- // let VCL Styles draw the stuff by themselves
- if Tree.VclStyleEnabled and (seClient in Tree.StyleElements) then
- begin
- if PaintInfo.IsDownIndex then
- Details := StyleServices.GetElementDetails(thHeaderItemPressed)
- else
- if PaintInfo.IsHoverIndex then
- Details := StyleServices.GetElementDetails(thHeaderItemHot)
- else
- Details := StyleServices.GetElementDetails(thHeaderItemNormal);
- StyleServices.DrawElement(PaintInfo.TargetCanvas.Handle, Details, R, @R);
- end
- else
- begin
- // themes are enabled for the tree, so...
- if tsUseThemes in Tree.TreeStates then
- begin
- // paint the themed header plate
- Theme := OpenThemeData(Tree.Handle, 'HEADER');
- if PaintInfo.IsDownIndex then
- State := HIS_PRESSED
- else
- if PaintInfo.IsHoverIndex then
- State := HIS_HOT
- else
- State := HIS_NORMAL;
- DrawThemeBackground(Theme, PaintInfo.TargetCanvas.Handle, HP_HEADERITEM, State, R, nil);
- CloseThemeData(Theme);
- // and alpha blend a colored rectangle over it
- ColorBlend(PaintInfo.TargetCanvas, R, Color, Alpha);
- end
- else
- begin
- // draw non-themed plate
- PrepareButtonStyles;
- if PaintInfo.ShowRightBorder or (PaintInfo.Column.Index < Sender.Columns.Count - 1) then
- RightBorderFlag := BF_RIGHT
- else
- RightBorderFlag := 0;
- if PaintInfo.IsDownIndex then
- DrawEdge(PaintInfo.TargetCanvas.Handle, R, PressedButtonStyle, PressedButtonFlags)
- else
- if (Sender.Style = hsPlates) and PaintInfo.IsHoverIndex and (coAllowClick in PaintInfo.Column.Options) and
- (coEnabled in PaintInfo.Column.Options)
- then
- DrawEdge(PaintInfo.TargetCanvas.Handle, R, RaisedButtonStyle, RaisedButtonFlags or RightBorderFlag)
- else
- DrawEdge(PaintInfo.TargetCanvas.Handle, R, NormalButtonStyle, NormalButtonFlags or RightBorderFlag);
- end;
- end;
- end;
- end;
- end;
- procedure TForm1.VirtualStringTree1HeaderDrawQueryElements(Sender: TVTHeader; var PaintInfo: THeaderPaintInfo; var Elements: THeaderPaintElements);
- begin
- Elements := [hpeBackground];
- end;
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement