unit TagCloud;
{$mode ObjFPC}{$H+}
interface
uses
Classes, SysUtils, Graphics, Forms, Themes, Math,
{$IfDef LCLGtk2}
Gtk2Def,
{$EndIf}
{$If Defined(LCLQt5) or Defined(LCLQt6)}
qtobjects,
{$EndIf}
LazLogger,
LCLIntf, LCLType;
type
TTagCloudStyle = record
Padding: TPoint;
Spacing: TPoint;
Margin: TPoint;
BorderWidth: Word;
BorderRadius: Word;
BorderColor: TColor;
BackgroundColor: TColor;
FontColor: TColor;
Themed: Boolean;
Scaled: Boolean;
end;
function GetDefaultCloudStyle: TTagCloudStyle;
procedure ScaleTagCloudDesignToForm(var ACloudStyle: TTagCloudStyle; const AForm: TCustomForm);
procedure ScaleTagCloud(var ACloudStyle: TTagCloudStyle);
procedure DrawTagCloud(ACanvas: TCanvas; ATagList, ATagSeparator: String; ANoBackground: Boolean = False;
ASingleLine: Boolean = False);
procedure DrawTagCloud(ACanvas: TCanvas; ATagList, ATagSeparator: String; ANoBackground: Boolean;
ASingleLine: Boolean; ACloudStyle: TTagCloudStyle);
implementation
function GetDefaultCloudStyle: TTagCloudStyle;
const
PADDING_HORIZONTAL = 4;
PADDING_VERTICAL = 2;
SPACING_HORIZONTAL = 6;
SPACING_VERTICAL = 4;
OUTER_MARGIN_HORIZONTAL = 2;
OUTER_MARGIN_VERTICAL = 2;
BORDER_WIDTH = 0;
BORDER_RADIUS = 4;
var
LCloudStyle: TTagCloudStyle;
begin
with LCloudStyle do
begin
Padding := Point(PADDING_HORIZONTAL, PADDING_VERTICAL);
Spacing := Point(SPACING_HORIZONTAL, SPACING_VERTICAL);
Margin := Point(OUTER_MARGIN_HORIZONTAL, OUTER_MARGIN_VERTICAL);
BorderRadius := BORDER_RADIUS;
BorderWidth := BORDER_WIDTH;
BorderColor := clNone;
BackgroundColor := clHighlight;
FontColor := clHighlightText;
Themed := True;
Scaled := True;
end;
Result := LCloudStyle;
end;
procedure ScaleTagCloudDesignToForm(var ACloudStyle: TTagCloudStyle; const AForm: TCustomForm);
begin
if not Assigned(AForm) then
Exit;
with ACloudStyle do
begin
Padding := Point(AForm.ScaleDesignToForm(Padding.X), AForm.ScaleDesignToForm(Padding.Y));
Spacing := Point(AForm.ScaleDesignToForm(Spacing.X), AForm.ScaleDesignToForm(Spacing.Y));
Margin := Point(AForm.ScaleDesignToForm(Margin.X), AForm.ScaleDesignToForm(Margin.Y));
BorderWidth := AForm.ScaleDesignToForm(BorderWidth);
BorderRadius := AForm.ScaleDesignToForm(BorderRadius);
Scaled := False;
end;
end;
procedure ScaleTagCloud(var ACloudStyle: TTagCloudStyle);
begin
with ACloudStyle do
begin
Padding := Point(ScaleX(Padding.X, 96), ScaleY(Padding.Y, 96));
Spacing := Point(ScaleX(Spacing.X, 96), ScaleY(Spacing.Y, 96));
Margin := Point(ScaleX(Margin.X, 96), ScaleY(Margin.Y, 96));
BorderWidth := ScaleX(BorderWidth, 96);
BorderRadius := ScaleX(BorderRadius, 96);
Scaled := False;
end;
end;
procedure DrawTagCloud(ACanvas: TCanvas; ATagList, ATagSeparator: String; ANoBackground: Boolean = False;
ASingleLine: Boolean = False);
begin
DrawTagCloud(ACanvas, ATagList, ATagSeparator, ANoBackground, ASingleLine, GetDefaultCloudStyle);
end;
// ANoBackground: Don't paint background. In some cases, like it's in selected row.
// ASingleLine: Do not wrap. Useful to fill cells in VirtualStringTree. Height will be measured from ACanvas.ClipRect.
// Debug: LCLGTK3 reports incorrect ClipRect?
// Review: Bounds check. Final X and Y shouldn't be more than half of rect width and hight.
// Review: Font is not well vertically aligned in multiline.
procedure DrawTagCloud(ACanvas: TCanvas; ATagList, ATagSeparator: String; ANoBackground: Boolean;
ASingleLine: Boolean; ACloudStyle: TTagCloudStyle);
const
TEXT_STYLE = (DT_CENTER or DT_VCENTER or DT_SINGLELINE or DT_END_ELLIPSIS or DT_MODIFYSTRING);
var
LThemeDetails: TThemedElementDetails;
iTextWidth, iTextHeight: integer;
sTag: string;
arTagArray: array of String;
rcBubbleRect, rcBubbleTextRect: TRect;
ptPosition: TPoint;
function ThemeCapeable(DC: HDC): Boolean;
{$IfDef LCLGtk2}
var
DevCtx: TGtkDeviceContext absolute DC;
{$EndIf}
{$If Defined(LCLQt5) or Defined(LCLQt6)}
var
Context: TQtDeviceContext;
{$EndIf}
begin
Result := False;
if not ThemeServices.ThemesEnabled then
Exit;
if not ThemeServices.ThemesAvailable then
Exit;
{$IfDef LCLWin32}
if (Win32MajorVersion >= 6) then
Exit(True);
{$EndIf}
{$IfDef LCLGtk2}
// In some occasions Widget could not be found, like VirtualStringTree's cell.
if DevCtx.Widget <> nil then
Exit(True);
{$EndIf}
{$IfDef LCLGtk3}
// No theme service for GTK3 as of moment
Exit;
{$EndIf}
{$If Defined(LCLQt5) or Defined(LCLQt6)}
// In some occasions Context could not be found, like VirtualStringTree's cell.
Context := TQtDeviceContext(DC);
if Context.Parent <> nil then
Exit(True);
{$EndIf}
end;
begin
if (Trim(ATagList) = '') then
Exit;
// Splitting text into array of tags
arTagArray := Trim(ATagList).Split([ATagSeparator], TStringSplitOptions.ExcludeEmpty);
// Scaling all dimensions to screen
if ACloudStyle.Scaled then
ScaleTagCloud(ACloudStyle);
// Styling
if not ThemeCapeable (ACanvas.Handle) then
ACloudStyle.Themed := False;
if ACloudStyle.Themed then
begin
LThemeDetails := ThemeServices.GetElementDetails(TThemedTreeview.ttItemSelected);
end
else
begin
ACanvas.Pen.Style := psSolid;
ACanvas.Pen.Width := ACloudStyle.BorderWidth;
ACanvas.Pen.Color := ACloudStyle.BorderColor;
ACanvas.Brush.Color := ACloudStyle.BackgroundColor;
ACanvas.Brush.Style := bsClear;
if not ANoBackground then
ACanvas.Font.Color := ACloudStyle.FontColor;
end;
if ACloudStyle.Themed or (ACloudStyle.BorderWidth = 0) then
begin
ACloudStyle.BorderWidth := 0;
ACanvas.Pen.Style := psClear;
end;
// Dimensions
// If border width is 1, then there no external border
if ACloudStyle.BorderWidth = 1 then
ACloudStyle.BorderWidth := 0;
// If odd external border is 1 px smaller than internal. Making even for dimensions.
if Odd(ACloudStyle.BorderWidth) then
Inc(ACloudStyle.BorderWidth, 1);
// Applying half of two borders, as half is rendered outside
ptPosition := Point(ACanvas.ClipRect.Left + ACloudStyle.BorderWidth, ACanvas.ClipRect.Top + ACloudStyle.BorderWidth);
// Initial position
Inc(ptPosition.X, ACloudStyle.Margin.X);
Inc(ptPosition.Y, ACloudStyle.Margin.Y);
// Calculating height
if ASingleLine then
iTextHeight := ACanvas.ClipRect.Height - ACloudStyle.Margin.Y*2 + ACloudStyle.BorderWidth
else
iTextHeight := ACanvas.TextHeight('Ay') + ACloudStyle.Padding.Y*2 + ACloudStyle.BorderWidth;
// Iterating tags
for sTag in arTagArray do
begin
// Calculating width
iTextWidth := ACanvas.TextWidth(Trim(sTag)) + ACloudStyle.Padding.X*2 + ACloudStyle.BorderWidth;
// New line, if overflows
if ((ptPosition.X + iTextWidth + ACloudStyle.Margin.X) > ACanvas.ClipRect.Right) and not(ASingleLine) then
begin
ptPosition.Y := ptPosition.Y + iTextHeight + ACloudStyle.Spacing.Y + ACloudStyle.BorderWidth;
ptPosition.X := ACanvas.ClipRect.Left + ACloudStyle.Margin.X + ACloudStyle.BorderWidth;
end;
// Edging by right, if we are not going for new line
if (ptPosition.X + iTextWidth + ACloudStyle.Margin.X) > ACanvas.ClipRect.Right then
iTextWidth := ACanvas.ClipRect.Right - ptPosition.X - ACloudStyle.Margin.X;
//Calculating main rectangle
rcBubbleRect := Rect(ptPosition.X, ptPosition.Y, ptPosition.X + iTextWidth, ptPosition.Y + iTextHeight);
// Calculating text rectangle
rcBubbleTextRect := rcBubbleRect;
Inc(rcBubbleTextRect.Left, ACloudStyle.Padding.X + Math.Ceil(ACloudStyle.BorderWidth/2));
Dec(rcBubbleTextRect.Right, ACloudStyle.Padding.X + Math.Ceil(ACloudStyle.BorderWidth/2));
// Drawing
if ACloudStyle.Themed then
begin
ACanvas.Brush.Style := bsSolid;
if (not ANoBackground) then
ThemeServices.DrawElement(ACanvas.Handle, LThemeDetails, rcBubbleRect);
ACanvas.Brush.Style := bsClear;
ThemeServices.DrawText(ACanvas, LThemeDetails, Trim(sTag), rcBubbleTextRect, TEXT_STYLE, 0);
end
else
begin
if ACloudStyle.BackgroundColor <> clNone then
ACanvas.Brush.Style := bsSolid;
if not ANoBackground then
ACanvas.RoundRect(rcBubbleRect, ACloudStyle.BorderRadius, ACloudStyle.BorderRadius);
ACanvas.Brush.Style := bsClear;
LCLIntf.DrawText(ACanvas.Handle, PChar(Trim(sTag)), Length(Trim(sTag)), rcBubbleTextRect, TEXT_STYLE);
end;
// Calculating position for next tag
ptPosition.X := ptPosition.X + iTextWidth + ACloudStyle.Spacing.X + ACloudStyle.BorderWidth;
// Abort, if we reached the end in single line mode
if (ptPosition.X >= ACanvas.ClipRect.Right) and ASingleLine then
Exit;
end;
end;
end.
Recent
