diff --git a/Ext/SVGIconImageList/Image32/source/Clipper.Core.pas b/Ext/SVGIconImageList/Image32/source/Clipper.Core.pas index 4e710bd..0a76571 100644 --- a/Ext/SVGIconImageList/Image32/source/Clipper.Core.pas +++ b/Ext/SVGIconImageList/Image32/source/Clipper.Core.pas @@ -2,9 +2,9 @@ (******************************************************************************* * Author : Angus Johnson * -* Date : 17 July 2023 * +* Date : 14 February 2024 * * Website : http://www.angusj.com * -* Copyright : Angus Johnson 2010-2023 * +* Copyright : Angus Johnson 2010-2024 * * Purpose : Core Clipper Library module * * Contains structures and functions used throughout the library * * License : http://www.boost.org/LICENSE_1_0.txt * @@ -64,6 +64,7 @@ TPointD = record function GetWidth: Int64; {$IFDEF INLINING} inline; {$ENDIF} function GetHeight: Int64; {$IFDEF INLINING} inline; {$ENDIF} function GetIsEmpty: Boolean; {$IFDEF INLINING} inline; {$ENDIF} + function GetIsValid: Boolean; {$IFDEF INLINING} inline; {$ENDIF} function GetMidPoint: TPoint64; {$IFDEF INLINING} inline; {$ENDIF} public Left : Int64; @@ -78,6 +79,7 @@ TPointD = record property Width: Int64 read GetWidth; property Height: Int64 read GetHeight; property IsEmpty: Boolean read GetIsEmpty; + property IsValid: Boolean read GetIsValid; property MidPoint: TPoint64 read GetMidPoint; end; @@ -86,6 +88,7 @@ TPointD = record function GetWidth: double; {$IFDEF INLINING} inline; {$ENDIF} function GetHeight: double; {$IFDEF INLINING} inline; {$ENDIF} function GetIsEmpty: Boolean; {$IFDEF INLINING} inline; {$ENDIF} + function GetIsValid: Boolean; {$IFDEF INLINING} inline; {$ENDIF} function GetMidPoint: TPointD; {$IFDEF INLINING} inline; {$ENDIF} public Left : double; @@ -99,6 +102,7 @@ TPointD = record property Width: double read GetWidth; property Height: double read GetHeight; property IsEmpty: Boolean read GetIsEmpty; + property IsValid: Boolean read GetIsValid; property MidPoint: TPointD read GetMidPoint; end; @@ -168,8 +172,8 @@ function DistanceSqr(const pt1, pt2: TPoint64): double; overload; {$IFDEF INLINING} inline; {$ENDIF} function DistanceSqr(const pt1, pt2: TPointD): double; overload; {$IFDEF INLINING} inline; {$ENDIF} -function DistanceFromLineSqrd(const pt, linePt1, linePt2: TPoint64): double; overload; -function DistanceFromLineSqrd(const pt, linePt1, linePt2: TPointD): double; overload; +function PerpendicDistFromLineSqrd(const pt, linePt1, linePt2: TPoint64): double; overload; +function PerpendicDistFromLineSqrd(const pt, linePt1, linePt2: TPointD): double; overload; function SegmentsIntersect(const s1a, s1b, s2a, s2b: TPoint64; inclusive: Boolean = false): boolean; {$IFDEF INLINING} inline; {$ENDIF} @@ -311,7 +315,7 @@ procedure AppendPaths(var paths: TPathsD; const extra: TPathsD); overload; function ArrayOfPathsToPaths(const ap: TArrayOfPaths): TPaths64; -function GetIntersectPoint(const ln1a, ln1b, ln2a, ln2b: TPoint64; +function GetSegmentIntersectPt(const ln1a, ln1b, ln2a, ln2b: TPoint64; out ip: TPoint64): Boolean; function PointInPolygon(const pt: TPoint64; const polygon: TPath64): TPointInPolygonResult; @@ -333,8 +337,14 @@ procedure QuickSort(SortList: TPointerList; procedure CheckPrecisionRange(var precision: integer); +function Iif(eval: Boolean; trueVal, falseVal: Boolean): Boolean; overload; +function Iif(eval: Boolean; trueVal, falseVal: integer): integer; overload; +function Iif(eval: Boolean; trueVal, falseVal: Int64): Int64; overload; +function Iif(eval: Boolean; trueVal, falseVal: double): double; overload; + const MaxInt64 = 9223372036854775807; + MinInt64 = -MaxInt64; MaxCoord = MaxInt64 div 4; MinCoord = - MaxCoord; invalid64 = MaxInt64; @@ -346,6 +356,11 @@ procedure CheckPrecisionRange(var precision: integer); InvalidPtD : TPointD = (X: invalidD; Y: invalidD); NullRectD : TRectD = (left: 0; top: 0; right: 0; Bottom: 0); + InvalidRect64 : TRect64 = + (left: invalid64; top: invalid64; right: invalid64; bottom: invalid64); + InvalidRectD : TRectD = + (left: invalidD; top: invalidD; right: invalidD; bottom: invalidD); + Tolerance : Double = 1.0E-12; //https://github.com/AngusJohnson/Clipper2/discussions/564 @@ -378,6 +393,12 @@ function TRect64.GetIsEmpty: Boolean; end; //------------------------------------------------------------------------------ +function TRect64.GetIsValid: Boolean; +begin + result := left <> invalid64; +end; +//------------------------------------------------------------------------------ + function TRect64.GetMidPoint: TPoint64; begin result := Point64((Left + Right) div 2, (Top + Bottom) div 2); @@ -450,6 +471,12 @@ function TRectD.GetIsEmpty: Boolean; end; //------------------------------------------------------------------------------ +function TRectD.GetIsValid: Boolean; +begin + result := left <> invalidD; +end; +//------------------------------------------------------------------------------ + function TRectD.GetMidPoint: TPointD; begin result := PointD((Left + Right) *0.5, (Top + Bottom) *0.5); @@ -633,6 +660,34 @@ procedure TListEx.Swap(idx1, idx2: integer); // Miscellaneous Functions ... //------------------------------------------------------------------------------ +function Iif(eval: Boolean; trueVal, falseVal: Boolean): Boolean; + {$IFDEF INLINING} inline; {$ENDIF} +begin + if eval then Result := trueVal else Result := falseVal; +end; +//------------------------------------------------------------------------------ + +function Iif(eval: Boolean; trueVal, falseVal: integer): integer; + {$IFDEF INLINING} inline; {$ENDIF} +begin + if eval then Result := trueVal else Result := falseVal; +end; +//------------------------------------------------------------------------------ + +function Iif(eval: Boolean; trueVal, falseVal: Int64): Int64; + {$IFDEF INLINING} inline; {$ENDIF} +begin + if eval then Result := trueVal else Result := falseVal; +end; +//------------------------------------------------------------------------------ + +function Iif(eval: Boolean; trueVal, falseVal: double): double; + {$IFDEF INLINING} inline; {$ENDIF} +begin + if eval then Result := trueVal else Result := falseVal; +end; +//------------------------------------------------------------------------------ + procedure CheckPrecisionRange(var precision: integer); begin if (precision < -MaxDecimalPrecision) or (precision > MaxDecimalPrecision) then @@ -1831,7 +1886,7 @@ function DistanceSqr(const pt1, pt2: TPointD): double; end; //------------------------------------------------------------------------------ -function DistanceFromLineSqrd(const pt, linePt1, linePt2: TPoint64): double; +function PerpendicDistFromLineSqrd(const pt, linePt1, linePt2: TPoint64): double; var a,b,c: double; begin @@ -1842,11 +1897,13 @@ function DistanceFromLineSqrd(const pt, linePt1, linePt2: TPoint64): double; b := (linePt2.X - linePt1.X); c := a * linePt1.X + b * linePt1.Y; c := a * pt.x + b * pt.y - c; - Result := (c * c) / (a * a + b * b); + if (a = 0) and (b = 0) then + Result := 0 else + Result := (c * c) / (a * a + b * b); end; //--------------------------------------------------------------------------- -function DistanceFromLineSqrd(const pt, linePt1, linePt2: TPointD): double; +function PerpendicDistFromLineSqrd(const pt, linePt1, linePt2: TPointD): double; var a,b,c: double; begin @@ -1854,7 +1911,9 @@ function DistanceFromLineSqrd(const pt, linePt1, linePt2: TPointD): double; b := (linePt2.X - linePt1.X); c := a * linePt1.X + b * linePt1.Y; c := a * pt.x + b * pt.y - c; - Result := (c * c) / (a * a + b * b); + if (a = 0) and (b = 0) then + Result := 0 else + Result := (c * c) / (a * a + b * b); end; //--------------------------------------------------------------------------- @@ -1934,7 +1993,7 @@ function __Trunc(val: double): Int64; {$IFDEF INLINE} inline; {$ENDIF} end; //------------------------------------------------------------------------------ -function GetIntersectPoint(const ln1a, ln1b, ln2a, ln2b: TPoint64; +function GetSegmentIntersectPt(const ln1a, ln1b, ln2a, ln2b: TPoint64; out ip: TPoint64): Boolean; var dx1,dy1, dx2,dy2, t, cp: double; @@ -2119,20 +2178,6 @@ function GetClosestPointOnSegment(const pt, seg1, seg2: TPoint64): TPoint64; end; //------------------------------------------------------------------------------ -function PerpendicDistFromLineSqrd(const pt, line1, line2: TPoint64): double; overload; -var - a,b,c,d: double; -begin - a := pt.X - line1.X; - b := pt.Y - line1.Y; - c := line2.X - line1.X; - d := line2.Y - line1.Y; - if (c = 0) and (d = 0) then - result := 0 else - result := Sqr(a * d - c * b) / (c * c + d * d); -end; -//------------------------------------------------------------------------------ - procedure RDP(const path: TPath64; startIdx, endIdx: integer; epsilonSqrd: double; var boolArray: TArrayOfBoolean); overload; var @@ -2162,20 +2207,6 @@ procedure RDP(const path: TPath64; startIdx, endIdx: integer; end; //------------------------------------------------------------------------------ -function PerpendicDistFromLineSqrd(const pt, line1, line2: TPointD): double; overload; -var - a,b,c,d: double; -begin - a := pt.X - line1.X; - b := pt.Y - line1.Y; - c := line2.X - line1.X; - d := line2.Y - line1.Y; - if (c = 0) and (d = 0) then - result := 0 else - result := Sqr(a * d - c * b) / (c * c + d * d); -end; -//------------------------------------------------------------------------------ - procedure RDP(const path: TPathD; startIdx, endIdx: integer; epsilonSqrd: double; var boolArray: TArrayOfBoolean); overload; var diff --git a/Ext/SVGIconImageList/Image32/source/Clipper.Engine.pas b/Ext/SVGIconImageList/Image32/source/Clipper.Engine.pas index e78e7f7..26ac220 100644 --- a/Ext/SVGIconImageList/Image32/source/Clipper.Engine.pas +++ b/Ext/SVGIconImageList/Image32/source/Clipper.Engine.pas @@ -2,9 +2,9 @@ (******************************************************************************* * Author : Angus Johnson * -* Date : 27 August 2023 * +* Date : 14 February 2024 * * Website : http://www.angusj.com * -* Copyright : Angus Johnson 2010-2023 * +* Copyright : Angus Johnson 2010-2024 * * Purpose : This is the main polygon clipping module * * License : http://www.boost.org/LICENSE_1_0.txt * *******************************************************************************) @@ -347,10 +347,9 @@ TPolyPathBase = class TPolyPath64 = class(TPolyPathBase) {$IFDEF STRICT}strict{$ENDIF} private FPath : TPath64; - function GetChild64(index: Integer): TPolyPath64; - protected - function AddChild(const path: TPath64): TPolyPathBase; override; + function GetChild64(index: Integer): TPolyPath64; public + function AddChild(const path: TPath64): TPolyPathBase; override; property Child[index: Integer]: TPolyPath64 read GetChild64; default; property Polygon: TPath64 read FPath; end; @@ -403,8 +402,9 @@ TPolyPathD = class(TPolyPathBase) function GetChildD(index: Integer): TPolyPathD; protected FScale : double; - function AddChild(const path: TPath64): TPolyPathBase; override; public + function AddChild(const path: TPath64): TPolyPathBase; overload; override; + function AddChild(const path: TPathD): TPolyPathBase; reintroduce; overload; property Polygon: TPathD read FPath; property Child[index: Integer]: TPolyPathD read GetChildD; default; end; @@ -862,6 +862,7 @@ function GetCleanPath(op: POutPt): TPath64; ((op2.pt.Y <> op2.next.pt.Y) or (op2.pt.Y <> prevOp.pt.Y))) then begin result[cnt] := op2.pt; + inc(cnt); prevOp := op2; end; op2 := op2.next; @@ -958,11 +959,16 @@ function Path1InsidePath2(const op1, op2: POutPt): Boolean; else if pipResult = pipInside then dec(outsideCnt); op := op.next; until (op = op1) or (Abs(outsideCnt) = 2); - // if path1's location is still equivocal then check its midpoint - path := GetCleanPath(op1); - mp := Clipper.Core.GetBounds(path).MidPoint; - path := GetCleanPath(op2); - Result := PointInPolygon(mp, path) <> pipOutside; + if (Abs(outsideCnt) < 2) then + begin + // if path1's location is still equivocal then check its midpoint + path := GetCleanPath(op1); + mp := Clipper.Core.GetBounds(path).MidPoint; + path := GetCleanPath(op2); + Result := PointInPolygon(mp, path) <> pipOutside; + end + else + Result := (outsideCnt < 0); end; //------------------------------------------------------------------------------ @@ -1119,7 +1125,7 @@ function BuildPath(op: POutPt; reverse, isOpen: Boolean; Exit; end; - if (cnt = 3) and IsVerySmallTriangle(op) then + if (cnt = 3) and not IsOpen and IsVerySmallTriangle(op) then begin Result := false; Exit; @@ -1715,23 +1721,18 @@ procedure TClipperBase.SetWindCountForClosedPathEdge(e: PActive); if (Abs(e2.windCnt) > 1) then begin // outside prev poly but still inside another. - if (e2.windDx * e.windDx < 0) then - // reversing direction so use the same WC - e.windCnt := e2.windCnt else - // otherwise keep 'reducing' the WC by 1 (ie towards 0) ... - e.windCnt := e2.windCnt + e.windDx; + e.windCnt := Iif(e2.windDx * e.windDx < 0, + e2.windCnt, // reversing direction so use the same WC + e2.windCnt + e.windDx); end // now outside all polys of same polytype so set own WC ... else e.windCnt := e.windDx; end else begin //'e' must be inside 'e2' - if (e2.windDx * e.windDx < 0) then - // reversing direction so use the same WC - e.windCnt := e2.windCnt - else - // otherwise keep 'increasing' the WC by 1 (ie away from 0) ... - e.windCnt := e2.windCnt + e.windDx; + e.windCnt := Iif(e2.windDx * e.windDx < 0, + e2.windCnt, // reversing direction so use the same WC + e2.windCnt + e.windDx); // else keep 'increasing' the WC end; e.windCnt2 := e2.windCnt2; e2 := e2.nextInAEL; @@ -1772,8 +1773,8 @@ procedure TClipperBase.SetWindCountForOpenPathEdge(e: PActive); else if not IsOpen(e2) then inc(cnt1); e2 := e2.nextInAEL; end; - if Odd(cnt1) then e.windCnt := 1 else e.windCnt := 0; - if Odd(cnt2) then e.windCnt2 := 1 else e.windCnt2 := 0; + e.windCnt := Iif(Odd(cnt1), 1, 0); + e.windCnt2 := Iif(Odd(cnt2), 1, 0); end else begin // if FClipType in [ctUnion, ctDifference] then e.WindCnt := e.WindDx; @@ -2149,7 +2150,7 @@ procedure TClipperBase.DoSplitOp(outrec: POutRec; splitOp: POutPt); prevOp := splitOp.prev; nextNextOp := splitOp.next.next; outrec.pts := prevOp; - GetIntersectPoint( + GetSegmentIntersectPt( prevOp.pt, splitOp.pt, splitOp.next.pt, nextNextOp.pt, ip); {$IFDEF USINGZ} if Assigned(fZCallback) then @@ -2336,22 +2337,10 @@ procedure TClipperBase.JoinOutrecPaths(e1, e2: PActive); begin e2.outrec.pts := e1.outrec.pts; e1.outrec.pts := nil; - end else - begin + end + else SetOwner(e2.outrec, e1.outrec); -// if FUsingPolytree then -// begin -// e := GetPrevHotEdge(e1); -// if not Assigned(e) then -// outRec.owner := nil else -// SetOwner(outRec, e.outrec); -// // nb: outRec.owner here is likely NOT the real -// // owner but this will be checked in DeepCheckOwner() -// end; - - end; - // and e1 and e2 are maxima and are about to be dropped from the Actives list. e1.outrec := nil; e2.outrec := nil; @@ -2380,14 +2369,16 @@ procedure TClipperBase.CheckJoinLeft(e: PActive; prev: PActive; begin prev := e.prevInAEL; - if IsOpen(e) or not IsHotEdge(e) or not Assigned(prev) or - IsOpen(prev) or not IsHotEdge(prev) then Exit; + if not Assigned(prev) or + not IsHotEdge(e) or not IsHotEdge(prev) or + IsHorizontal(e) or IsHorizontal(prev) or + IsOpen(e) or IsOpen(prev) then Exit; if ((pt.Y < e.top.Y +2) or (pt.Y < prev.top.Y +2)) and ((e.bot.Y > pt.Y) or (prev.bot.Y > pt.Y)) then Exit; // (#490) if checkCurrX then begin - if DistanceFromLineSqrd(pt, prev.bot, prev.top) > 0.25 then Exit + if PerpendicDistFromLineSqrd(pt, prev.bot, prev.top) > 0.25 then Exit end else if (e.currX <> prev.currX) then Exit; if (CrossProduct(e.top, pt, prev.top) <> 0) then Exit; @@ -2409,14 +2400,16 @@ procedure TClipperBase.CheckJoinRight(e: PActive; next: PActive; begin next := e.nextInAEL; - if IsOpen(e) or not IsHotEdge(e) or not Assigned(next) or - not IsHotEdge(next) or IsOpen(next) then Exit; + if not Assigned(next) or + not IsHotEdge(e) or not IsHotEdge(next) or + IsHorizontal(e) or IsHorizontal(next) or + IsOpen(e) or IsOpen(next) then Exit; if ((pt.Y < e.top.Y +2) or (pt.Y < next.top.Y +2)) and ((e.bot.Y > pt.Y) or (next.bot.Y > pt.Y)) then Exit; // (#490) if (checkCurrX) then begin - if DistanceFromLineSqrd(pt, next.bot, next.top) > 0.25 then Exit + if PerpendicDistFromLineSqrd(pt, next.bot, next.top) > 0.25 then Exit end else if (e.currX <> next.currX) then Exit; @@ -2486,6 +2479,31 @@ function TClipperBase.StartOpenPath(e: PActive; const pt: TPoint64): POutPt; end; //------------------------------------------------------------------------------ +procedure TrimHorz(horzEdge: PActive; preserveCollinear: Boolean); +var + pt: TPoint64; + wasTrimmed: Boolean; +begin + wasTrimmed := false; + pt := NextVertex(horzEdge).pt; + while (pt.Y = horzEdge.top.Y) do + begin + // always trim 180 deg. spikes (in closed paths) + // but otherwise break if preserveCollinear = true + if preserveCollinear and + ((pt.X < horzEdge.top.X) <> (horzEdge.bot.X < horzEdge.top.X)) then + break; + + horzEdge.vertTop := NextVertex(horzEdge); + horzEdge.top := pt; + wasTrimmed := true; + if IsMaxima(horzEdge) then Break; + pt := NextVertex(horzEdge).pt; + end; + if wasTrimmed then SetDx(horzEdge); // +/-infinity +end; +//------------------------------------------------------------------------------ + procedure TClipperBase.UpdateEdgeIntoAEL(var e: PActive); begin e.bot := e.top; @@ -2496,7 +2514,11 @@ procedure TClipperBase.UpdateEdgeIntoAEL(var e: PActive); if IsJoined(e) then UndoJoin(e, e.bot); - if IsHorizontal(e) then Exit; + if IsHorizontal(e) then + begin + if not IsOpen(e) then TrimHorz(e, PreserveCollinear); + Exit; + end; InsertScanLine(e.top.Y); CheckJoinLeft(e, e.bot); @@ -2610,12 +2632,10 @@ function TClipperBase.IntersectEdges(e1, e2: PActive; pt: TPoint64): POutPt; e2.windCnt := e1WindCnt; end else begin - if e1.windCnt + e2.windDx = 0 then - e1.windCnt := -e1.windCnt else - Inc(e1.windCnt, e2.windDx); - if e2.windCnt - e1.windDx = 0 then - e2.windCnt := -e2.windCnt else - Dec(e2.windCnt, e1.windDx); + e1.windCnt := Iif(e1.windCnt + e2.windDx = 0, + -e1.windCnt, e1.windCnt + e2.windDx); + e2.windCnt := Iif(e2.windCnt - e1.windDx = 0, + -e2.windCnt, e2.windCnt - e1.windDx); end; end else begin @@ -2882,14 +2902,14 @@ function HorzontalsOverlap(const horz1a, horz1b, horz2a, horz2b: TPoint64): bool begin if horz1a.X < horz1b.X then begin - if horz2a.X < horz2b.X then - Result := HorzOverlapWithLRSet(horz1a, horz1b, horz2a, horz2b) else - Result := HorzOverlapWithLRSet(horz1a, horz1b, horz2b, horz2a); + Result := Iif(horz2a.X < horz2b.X, + HorzOverlapWithLRSet(horz1a, horz1b, horz2a, horz2b), + HorzOverlapWithLRSet(horz1a, horz1b, horz2b, horz2a)); end else begin - if horz2a.X < horz2b.X then - Result := HorzOverlapWithLRSet(horz1b, horz1a, horz2a, horz2b) else - Result := HorzOverlapWithLRSet(horz1b, horz1a, horz2b, horz2a); + Result := Iif(horz2a.X < horz2b.X, + HorzOverlapWithLRSet(horz1b, horz1a, horz2a, horz2b), + HorzOverlapWithLRSet(horz1b, horz1a, horz2b, horz2a)); end; end; //------------------------------------------------------------------------------ @@ -3128,7 +3148,7 @@ procedure TClipperBase.AddNewIntersectNode(e1, e2: PActive; topY: Int64); absDx1, absDx2: double; node: PIntersectNode; begin - if not GetIntersectPoint(e1.bot, e1.top, e2.bot, e2.top, ip) then + if not GetSegmentIntersectPt(e1.bot, e1.top, e2.bot, e2.top, ip) then ip := Point64(e1.currX, topY); // Rounding errors can occasionally place the calculated intersection // point either below or above the scanbeam, so check and correct ... @@ -3148,12 +3168,8 @@ procedure TClipperBase.AddNewIntersectNode(e1, e2: PActive; topY: Int64); ip := GetClosestPointOnSegment(ip, e2.bot, e2.top) else begin - if (ip.Y < topY) then - ip.Y := topY else - ip.Y := fBotY; - if (absDx1 < absDx2) then - ip.X := TopX(e1, ip.Y) else - ip.X := TopX(e2, ip.Y); + ip.Y := Iif(ip.Y < topY, topY , fBotY); + ip.X := Iif(absDx1 < absDx2, TopX(e1, ip.Y), TopX(e2, ip.Y)); end; end; new(node); @@ -3339,41 +3355,6 @@ procedure TClipperBase.SwapPositionsInAEL(e1, e2: PActive); end; //------------------------------------------------------------------------------ -function HorzIsSpike(horzEdge: PActive): Boolean; -var - nextPt: TPoint64; -begin - nextPt := NextVertex(horzEdge).pt; - Result := (nextPt.Y = horzEdge.top.Y) and - (horzEdge.bot.X < horzEdge.top.X) <> (horzEdge.top.X < nextPt.X); -end; -//------------------------------------------------------------------------------ - -procedure TrimHorz(horzEdge: PActive; preserveCollinear: Boolean); -var - pt: TPoint64; - wasTrimmed: Boolean; -begin - wasTrimmed := false; - pt := NextVertex(horzEdge).pt; - while (pt.Y = horzEdge.top.Y) do - begin - // always trim 180 deg. spikes (in closed paths) - // but otherwise break if preserveCollinear = true - if preserveCollinear and - ((pt.X < horzEdge.top.X) <> (horzEdge.bot.X < horzEdge.top.X)) then - break; - - horzEdge.vertTop := NextVertex(horzEdge); - horzEdge.top := pt; - wasTrimmed := true; - if IsMaxima(horzEdge) then Break; - pt := NextVertex(horzEdge).pt; - end; - if wasTrimmed then SetDx(horzEdge); // +/-infinity -end; -//------------------------------------------------------------------------------ - function GetLastOp(hotEdge: PActive): POutPt; {$IFDEF INLINING} inline; {$ENDIF} var @@ -3450,10 +3431,6 @@ procedure TClipperBase.DoHorizontal(horzEdge: PActive); maxVertex := GetCurrYMaximaVertexOpen(horzEdge) else maxVertex := GetCurrYMaximaVertex(horzEdge); - if Assigned(maxVertex) and not horzIsOpen and - (maxVertex <> horzEdge.vertTop) then - TrimHorz(horzEdge, FPreserveCollinear); - isLeftToRight := ResetHorzDirection; // nb: TrimHorz above hence not using Bot.X here @@ -3533,12 +3510,14 @@ procedure TClipperBase.DoHorizontal(horzEdge: PActive); begin IntersectEdges(horzEdge, e, pt); SwapPositionsInAEL(horzEdge, e); + CheckJoinLeft(e, pt); horzEdge.currX := e.currX; e := horzEdge.nextInAEL; end else begin IntersectEdges(e, horzEdge, pt); SwapPositionsInAEL(e, horzEdge); + CheckJoinRight(e, pt); horzEdge.currX := e.currX; e := horzEdge.prevInAEL; end; @@ -3573,11 +3552,6 @@ procedure TClipperBase.DoHorizontal(horzEdge: PActive); if IsHotEdge(horzEdge) then AddOutPt(horzEdge, horzEdge.top); UpdateEdgeIntoAEL(horzEdge); - - if PreserveCollinear and - not horzIsOpen and HorzIsSpike(horzEdge) then - TrimHorz(horzEdge, true); - isLeftToRight := ResetHorzDirection; end; // end while horizontal @@ -4046,9 +4020,7 @@ function TPolyPathBase.GetLevel: Integer; function TPolyPathBase.GetIsHole: Boolean; begin - if not Assigned(Parent) then - Result := false else - Result := not Odd(GetLevel); + Result := Iif(Assigned(Parent), not Odd(GetLevel), false); end; //------------------------------------------------------------------------------ @@ -4256,6 +4228,16 @@ function TPolyPathD.AddChild(const path: TPath64): TPolyPathBase; end; //------------------------------------------------------------------------------ +function TPolyPathD.AddChild(const path: TPathD): TPolyPathBase; +begin + Result := TPolyPathD.Create; + Result.Parent := self; + TPolyPathD(Result).fScale := fScale; + TPolyPathD(Result).FPath := path; + ChildList.Add(Result); +end; +//------------------------------------------------------------------------------ + function TPolyPathD.GetChildD(index: Integer): TPolyPathD; begin Result := TPolyPathD(GetChild(index)); diff --git a/Ext/SVGIconImageList/Image32/source/Clipper.Minkowski.pas b/Ext/SVGIconImageList/Image32/source/Clipper.Minkowski.pas index 1d7a82b..bacb3ea 100644 --- a/Ext/SVGIconImageList/Image32/source/Clipper.Minkowski.pas +++ b/Ext/SVGIconImageList/Image32/source/Clipper.Minkowski.pas @@ -2,7 +2,7 @@ (******************************************************************************* * Author : Angus Johnson * -* Date : 15 October 2022 * +* Date : 21 December 2023 * * Copyright : Angus Johnson 2010-2022 * * Purpose : Minkowski Addition and Difference * * License : http://www.boost.org/LICENSE_1_0.txt * @@ -51,9 +51,7 @@ function Minkowski(const Base, Path: TPath64; tmp: TPaths64; quad: TPath64; begin - if IsClosed then - delta := 0 else - delta := 1; + delta := Iif(IsClosed, 0 , 1); baseLen := Length(Base); pathLen := Length(Path); setLength(tmp, pathLen); @@ -71,10 +69,7 @@ function Minkowski(const Base, Path: TPath64; SetLength(quad, 4); SetLength(Result, (pathLen - delta) * baseLen); - - if IsClosed then - g := pathLen - 1 else - g := 0; + g := Iif(IsClosed, pathLen - 1, 0); for i := delta to pathLen - 1 do begin diff --git a/Ext/SVGIconImageList/Image32/source/Clipper.Offset.pas b/Ext/SVGIconImageList/Image32/source/Clipper.Offset.pas index f3bf669..bf95bf8 100644 --- a/Ext/SVGIconImageList/Image32/source/Clipper.Offset.pas +++ b/Ext/SVGIconImageList/Image32/source/Clipper.Offset.pas @@ -2,9 +2,9 @@ (******************************************************************************* * Author : Angus Johnson * -* Date : 24 September 2023 * +* Date : 14 March 2024 * * Website : http://www.angusj.com * -* Copyright : Angus Johnson 2010-2023 * +* Copyright : Angus Johnson 2010-2024 * * Purpose : Path Offset (Inflate/Shrink) * * License : http://www.boost.org/LICENSE_1_0.txt * *******************************************************************************) @@ -32,13 +32,18 @@ interface TDeltaCallback64 = function (const path: TPath64; const path_norms: TPathD; currIdx, prevIdx: integer): double of object; + TDoubleArray = array of double; + BooleanArray = array of Boolean; TGroup = class - paths : TPaths64; - reversed : Boolean; - joinType : TJoinType; - endType : TEndType; - constructor Create(jt: TJoinType; et: TEndType); + paths : TPaths64; + joinType : TJoinType; + endType : TEndType; + reversed : Boolean; + lowestPathIdx : integer; + areasList : TDoubleArray; + isHoleList : BooleanArray; + constructor Create(const pathsIn: TPaths64; jt: TJoinType; et: TEndType); end; TClipperOffset = class @@ -58,9 +63,10 @@ TClipperOffset = class fGroupList : TListEx; fInPath : TPath64; fOutPath : TPath64; - fOutPaths : TPaths64; fOutPathLen : Integer; fSolution : TPaths64; + fSolutionLen : Integer; + fSolutionTree : TPolyTree64; fPreserveCollinear : Boolean; fReverseSolution : Boolean; fDeltaCallback64 : TDeltaCallback64; @@ -80,9 +86,13 @@ TClipperOffset = class procedure BuildNormals; procedure DoGroupOffset(group: TGroup); - procedure OffsetPolygon; + procedure OffsetPolygon(isShrinking: Boolean; area_: double); procedure OffsetOpenJoined; procedure OffsetOpenPath; + function CalcSolutionCapacity: integer; + procedure UpdateSolution; {$IFDEF INLINING} inline; {$ENDIF} + + function CheckReverseOrientation: Boolean; procedure ExecuteInternal(delta: Double); public constructor Create(miterLimit: double = 2.0; @@ -119,6 +129,10 @@ implementation uses Math; +resourcestring + rsClipper_CoordRangeError = + 'Offsetting will exceed the valid coordinate range'; + const TwoPi : Double = 2 * PI; InvTwoPi : Double = 1/(2 * PI); @@ -186,21 +200,21 @@ function GetUnitNormal(const pt1, pt2: TPoint64): TPointD; function GetLowestPolygonIdx(const paths: TPaths64): integer; var i,j: integer; - lp: TPoint64; - p: TPath64; + botPt: TPoint64; begin Result := -1; - lp := Point64(0, -MaxInt64); - for i := 0 to High(paths) do - begin - p := paths[i]; - for j := 0 to High(p) do - begin - if (p[j].Y < lp.Y) or - ((p[j].Y = lp.Y) and (p[j].X >= lp.X)) then Continue; - Result := i; - lp := p[j]; - end; + botPt := Point64(MaxInt64, MinInt64); + for i := 0 to High(paths) do + begin + for j := 0 to High(paths[i]) do + with paths[i][j] do + begin + if (Y < botPt.Y) or + ((Y = botPt.Y) and (X >= botPt.X)) then Continue; + result := i; + botPt.X := X; + botPt.Y := Y; + end; end; end; //------------------------------------------------------------------------------ @@ -215,10 +229,48 @@ function UnsafeGet(List: TList; Index: Integer): Pointer; // TGroup methods //------------------------------------------------------------------------------ -constructor TGroup.Create(jt: TJoinType; et: TEndType); +constructor TGroup.Create(const pathsIn: TPaths64; jt: TJoinType; et: TEndType); +var + i, len: integer; + a: double; + isJoined: boolean; + pb: PBoolean; begin Self.joinType := jt; Self.endType := et; + + isJoined := et in [etPolygon, etJoined]; + len := Length(pathsIn); + SetLength(paths, len); + for i := 0 to len -1 do + paths[i] := StripDuplicates(pathsIn[i], isJoined); + + reversed := false; + SetLength(isHoleList, len); + SetLength(areasList, len); + if (et = etPolygon) then + begin + pb := @isHoleList[0]; + for i := 0 to len -1 do + begin + a := Area(paths[i]); + pb^ := a < 0; + inc(pb); + end; + + // the lowermost path must be an outer path, so if its orientation is + // negative, then flag that the whole group is 'reversed' (so negate + // delta etc.) as this is much more efficient than reversing every path. + lowestPathIdx := GetLowestPolygonIdx(pathsIn); + reversed := (lowestPathIdx >= 0) and isHoleList[lowestPathIdx]; + if not reversed then Exit; + pb := @isHoleList[0]; + for i := 0 to len -1 do + begin + pb^ := not pb^; inc(pb); + end; + end else + lowestPathIdx := -1; end; //------------------------------------------------------------------------------ @@ -253,6 +305,7 @@ procedure TClipperOffset.Clear; TGroup(fGroupList[i]).Free; fGroupList.Clear; fSolution := nil; + fSolutionLen := 0; end; //------------------------------------------------------------------------------ @@ -274,8 +327,7 @@ procedure TClipperOffset.AddPaths(const paths: TPaths64; group: TGroup; begin if Length(paths) = 0 then Exit; - group := TGroup.Create(joinType, endType); - AppendPaths(group.paths, paths); + group := TGroup.Create(paths, joinType, endType); fGroupList.Add(group); end; //------------------------------------------------------------------------------ @@ -302,45 +354,38 @@ function GetPerpendicD(const pt: TPoint64; const norm: TPointD; delta: double): procedure TClipperOffset.DoGroupOffset(group: TGroup); var - i,j, len, lowestIdx, steps: Integer; - r, stepsPer360, arcTol, area: Double; + i,j, len, steps: Integer; + r, stepsPer360, arcTol: Double; absDelta: double; + isShrinking: Boolean; rec: TRect64; - isJoined: Boolean; + pt0: TPoint64; begin + if group.endType = etPolygon then begin - // the lowermost polygon must be an outer polygon. So we can use that as the - // designated orientation for outer polygons (needed for tidy-up clipping) - lowestIdx := GetLowestPolygonIdx(group.paths); - if lowestIdx < 0 then Exit; - // nb: don't use the default orientation here ... - area := Clipper.Core.Area(group.paths[lowestIdx]); - //if area = 0 then Exit; // this is probably unhelpful (#430) - group.reversed := (area < 0); - if group.reversed then fGroupDelta := -fDelta - else fGroupDelta := fDelta; - end else - begin - group.reversed := false; - fGroupDelta := Abs(fDelta) * 0.5; - end; + if (group.lowestPathIdx < 0) then fDelta := Abs(fDelta); + fGroupDelta := Iif(group.reversed, -fDelta, fDelta); + end + else + fGroupDelta := Abs(fDelta); + + absDelta := Abs(fGroupDelta); + fJoinType := group.joinType; fEndType := group.endType; - // calculate a sensible number of steps (for 360 deg for the given offset - if (not Assigned(fDeltaCallback64) and - (group.joinType = jtRound) or (group.endType = etRound)) then + if (group.joinType = jtRound) or (group.endType = etRound) then begin - absDelta := Abs(fGroupDelta); - // arcTol - when fArcTolerance is undefined (0), the amount of - // curve imprecision that's allowed is based on the size of the - // offset (delta). Obviously very large offsets will almost always - // require much less precision. See also offset_triginometry2.svg - if fArcTolerance > 0.01 then - arcTol := Min(absDelta, fArcTolerance) else - arcTol := Log10(2 + absDelta) * 0.25; // empirically derived - //http://www.angusj.com/clipper2/Docs/Trigonometry.htm + // calculate the number of steps required to approximate a circle + // (see http://www.angusj.com/clipper2/Docs/Trigonometry.htm) + // arcTol - when arc_tolerance_ is undefined (0) then curve imprecision + // will be relative to the size of the offset (delta). Obviously very + //large offsets will almost always require much less precision. + arcTol := Iif(fArcTolerance > 0.01, + Min(absDelta, fArcTolerance), + Log10(2 + absDelta) * 0.25); // empirically derived + stepsPer360 := Pi / ArcCos(1 - arcTol / absDelta); if (stepsPer360 > absDelta * Pi) then stepsPer360 := absDelta * Pi; // avoid excessive precision @@ -350,72 +395,67 @@ procedure TClipperOffset.DoGroupOffset(group: TGroup); fStepsPerRad := stepsPer360 / TwoPi; end; - fOutPaths := nil; - isJoined := fEndType in [etPolygon, etJoined]; for i := 0 to High(group.paths) do begin - fInPath := StripDuplicates(group.paths[i], IsJoined); - len := Length(fInPath); - if (len = 0) or ((len < 3) and (fEndType = etPolygon)) then - Continue; + isShrinking := (group.endType = etPolygon) and + (group.reversed = ((fGroupDelta < 0) = group.isHoleList[i])); + fInPath := group.paths[i]; fNorms := nil; - fOutPath := nil; - fOutPathLen := 0; + len := Length(fInPath); //if a single vertex then build a circle or a square ... if len = 1 then begin if fGroupDelta < 1 then Continue; - absDelta := Abs(fGroupDelta); + pt0 := fInPath[0]; + + if Assigned(fDeltaCallback64) then + begin + fGroupDelta := fDeltaCallback64(fInPath, fNorms, 0, 0); + if TGroup(fGroupList[0]).reversed then fGroupDelta := -fGroupDelta; + absDelta := Abs(fGroupDelta); + end; + if (group.endType = etRound) then begin r := absDelta; - with fInPath[0] do - begin - steps := Ceil(fStepsPerRad * TwoPi); //#617 - fOutPath := Path64(Ellipse(RectD(X-r, Y-r, X+r, Y+r), steps)); + steps := Ceil(fStepsPerRad * TwoPi); //#617 + fOutPath := Path64(Ellipse( + RectD(pt0.X-r, pt0.Y-r, pt0.X+r, pt0.Y+r), steps)); {$IFDEF USINGZ} - for j := 0 to high(fOutPath) do - fOutPath[j].Z := Z; + for j := 0 to high(fOutPath) do + fOutPath[j].Z := pt0.Z; {$ENDIF} - end; end else begin j := Round(absDelta); - with fInPath[0] do - begin - rec := Rect64(X -j, Y -j, X+j, Y+j); - fOutPath := rec.AsPath; + rec := Rect64(pt0.X -j, pt0.Y -j, pt0.X+j, pt0.Y+j); + fOutPath := rec.AsPath; {$IFDEF USINGZ} - for j := 0 to high(fOutPath) do - fOutPath[j].Z := Z; + for j := 0 to high(fOutPath) do + fOutPath[j].Z := pt0.Z; {$ENDIF} - end end; - AppendPath(fOutPaths, fOutPath); + UpdateSolution; Continue; - end else - begin - if (len = 2) and (group.endType = etJoined) then - begin - if fJoinType = jtRound then - fEndType := etRound else - fEndType := etSquare; - end; - BuildNormals; + end; // end of offsetting a single point - if fEndType = etPolygon then OffsetPolygon - else if fEndType = etJoined then OffsetOpenJoined - else OffsetOpenPath; + if (len = 2) and (group.endType = etJoined) then + begin + if fJoinType = jtRound then + fEndType := etRound else + fEndType := etSquare; end; - if fOutPathLen = 0 then Continue; - SetLength(fOutPath, fOutPathLen); - AppendPath(fOutPaths, fOutPath); + BuildNormals; + if fEndType = etPolygon then + OffsetPolygon(isShrinking, group.areasList[i]) + else if fEndType = etJoined then + OffsetOpenJoined + else + OffsetOpenPath; end; - // finally copy the working 'outPaths' to the solution - AppendPaths(fSolution, fOutPaths); end; //------------------------------------------------------------------------------ @@ -431,44 +471,57 @@ procedure TClipperOffset.BuildNormals; end; //------------------------------------------------------------------------------ -procedure TClipperOffset.OffsetPolygon; +procedure TClipperOffset.UpdateSolution; +begin + if fOutPathLen = 0 then Exit; + SetLength(fOutPath, fOutPathLen); + fSolution[fSolutionLen] := fOutPath; + inc(fSolutionLen); + fOutPath := nil; + fOutPathLen := 0; +end; +//------------------------------------------------------------------------------ + +function TClipperOffset.CalcSolutionCapacity: integer; var - i,j: integer; - a, offsetMinDim: double; - rec: TRect64; + i: integer; begin - //when the path is contracting, make sure - //there is sufficient space to do so. //#593 - //nb: this will have a small impact on performance - a := Area(fInPath); - if (a < 0) <> (fGroupDelta < 0) then - begin - rec := GetBounds(fInPath); - offsetMinDim := Abs(fGroupDelta) * 2; - if (offsetMinDim >= rec.Width) or (offsetMinDim >= rec.Height) then Exit; - end; + Result := 0; + for i := 0 to fGroupList.Count -1 do + with TGroup(fGroupList[i]) do + if endType = etJoined then + inc(Result, Length(paths) *2) else + inc(Result, Length(paths)); +end; +//------------------------------------------------------------------------------ +procedure TClipperOffset.OffsetPolygon(isShrinking: Boolean; area_: double); +var + i,j: integer; +begin j := high(fInPath); for i := 0 to high(fInPath) do OffsetPoint(i, j); + + // make sure that polygon areas aren't reversing which would indicate + // that the polygon has shrunk too far and that it should be discarded. + // See also - #593 & #715 + if isShrinking and (area_ <> 0) and // area = 0.0 when JoinType.Joined + ((area_ < 0) <> (Area(fOutPath) < 0)) then Exit; + + UpdateSolution; end; //------------------------------------------------------------------------------ procedure TClipperOffset.OffsetOpenJoined; begin - OffsetPolygon; - SetLength(fOutPath, fOutPathLen); - AppendPath(fOutPaths, fOutPath); - fOutPath := nil; - fOutPathLen := 0; + OffsetPolygon(false, 0); fInPath := ReversePath(fInPath); - // Rebuild normals // BuildNormals; fNorms := ReversePath(fNorms); fNorms := ShiftPath(fNorms, 1); fNorms := NegatePath(fNorms); - - OffsetPolygon; + OffsetPolygon(true, 0); end; //------------------------------------------------------------------------------ @@ -481,17 +534,29 @@ procedure TClipperOffset.OffsetOpenPath; if Assigned(fDeltaCallback64) then fGroupDelta := fDeltaCallback64(fInPath, fNorms, 0, 0); - // do the line start cap - if Abs(fGroupDelta) < Tolerance then + if (Abs(fGroupDelta) < Tolerance) and + not Assigned(fDeltaCallback64) then begin - AddPoint(fInPath[0]); - end else - case fEndType of - etButt: DoBevel(0, 0); - etRound: DoRound(0,0, PI); - else DoSquare(0, 0); + inc(highI); + SetLength(fOutPath, highI); + Move(fInPath[0], fOutPath, highI + SizeOf(TPointD)); + fOutPathLen := highI; + Exit; end; + // do the line start cap + if Assigned(fDeltaCallback64) then + fGroupDelta := fDeltaCallback64(fInPath, fNorms, 0, 0); + + if (Abs(fGroupDelta) < Tolerance) then + AddPoint(fInPath[0]) + else + case fEndType of + etButt: DoBevel(0, 0); + etRound: DoRound(0,0, PI); + else DoSquare(0, 0); + end; + // offset the left side going forward k := 0; for i := 1 to highI -1 do //nb: -1 is important @@ -520,19 +585,26 @@ procedure TClipperOffset.OffsetOpenPath; end; // offset the left side going back - k := 0; - for i := highI downto 1 do //and stop at 1! + k := highI; + for i := highI -1 downto 1 do //and stop at 1! OffsetPoint(i, k); + + UpdateSolution; end; //------------------------------------------------------------------------------ procedure TClipperOffset.ExecuteInternal(delta: Double); var - i: integer; + i,j: integer; group: TGroup; + pathsReversed: Boolean; + fillRule: TFillRule; + dummy: TPaths64; begin fSolution := nil; + fSolutionLen := 0; if fGroupList.Count = 0 then Exit; + SetLength(fSolution, CalcSolutionCapacity); fMinLenSqrd := 1; if abs(delta) < Tolerance then @@ -541,7 +613,11 @@ procedure TClipperOffset.ExecuteInternal(delta: Double); for i := 0 to fGroupList.Count -1 do begin group := TGroup(fGroupList[i]); - AppendPaths(fSolution, group.paths); + for j := 0 to High(group.paths) do + begin + fSolution[fSolutionLen] := group.paths[i]; + inc(fSolutionLen); + end; end; Exit; end; @@ -558,45 +634,52 @@ procedure TClipperOffset.ExecuteInternal(delta: Double); group := TGroup(fGroupList[i]); DoGroupOffset(group); end; + SetLength(fSolution, fSolutionLen); + + pathsReversed := CheckReverseOrientation(); + if pathsReversed then + fillRule := frNegative else + fillRule := frPositive; // clean up self-intersections ... with TClipper64.Create do try PreserveCollinear := fPreserveCollinear; // the solution should retain the orientation of the input - ReverseSolution := - fReverseSolution <> TGroup(fGroupList[0]).reversed; + ReverseSolution := fReverseSolution <> pathsReversed; AddSubject(fSolution); - if TGroup(fGroupList[0]).reversed then - Execute(ctUnion, frNegative, fSolution) else - Execute(ctUnion, frPositive, fSolution); + if assigned(fSolutionTree) then + Execute(ctUnion, fillRule, fSolutionTree, dummy); + Execute(ctUnion, fillRule, fSolution); finally free; end; end; //------------------------------------------------------------------------------ +function TClipperOffset.CheckReverseOrientation: Boolean; +var + i: integer; +begin + Result := false; + // find the orientation of the first closed path + for i := 0 to fGroupList.Count -1 do + with TGroup(fGroupList[i]) do + if endType = etPolygon then + begin + Result := reversed; + break; + end; +end; +//------------------------------------------------------------------------------ + procedure TClipperOffset.Execute(delta: Double; out solution: TPaths64); begin - fSolution := nil; solution := nil; - ExecuteInternal(delta); + fSolutionTree := nil; if fGroupList.Count = 0 then Exit; - - // clean up self-intersections ... - with TClipper64.Create do - try - PreserveCollinear := fPreserveCollinear; - // the solution should retain the orientation of the input - ReverseSolution := - fReverseSolution <> TGroup(fGroupList[0]).reversed; - AddSubject(fSolution); - if TGroup(fGroupList[0]).reversed then - Execute(ctUnion, frNegative, solution) else - Execute(ctUnion, frPositive, solution); - finally - free; - end; + ExecuteInternal(delta); + solution := fSolution; end; //------------------------------------------------------------------------------ @@ -608,29 +691,12 @@ procedure TClipperOffset.Execute(DeltaCallback: TDeltaCallback64; out solution: //------------------------------------------------------------------------------ procedure TClipperOffset.Execute(delta: Double; polytree: TPolyTree64); -var - dummy: TPaths64; begin - fSolution := nil; if not Assigned(polytree) then Raise EClipper2LibException(rsClipper_PolyTreeErr); - + fSolutionTree := polytree; + fSolutionTree.Clear; ExecuteInternal(delta); - - // clean up self-intersections ... - with TClipper64.Create do - try - PreserveCollinear := fPreserveCollinear; - // the solution should retain the orientation of the input - ReverseSolution := - fReverseSolution <> TGroup(fGroupList[0]).reversed; - AddSubject(fSolution); - if TGroup(fGroupList[0]).reversed then - Execute(ctUnion, frNegative, polytree, dummy) else - Execute(ctUnion, frPositive, polytree, dummy); - finally - free; - end; end; //------------------------------------------------------------------------------ @@ -718,20 +784,38 @@ procedure TClipperOffset.DoBevel(j, k: Integer); if k = j then begin absDelta := abs(fGroupDelta); +{$IFDEF USINGZ} + AddPoint( + fInPath[j].x - absDelta * fNorms[j].x, + fInPath[j].y - absDelta * fNorms[j].y, fInPath[j].z); + AddPoint( + fInPath[j].x + absDelta * fNorms[j].x, + fInPath[j].y + absDelta * fNorms[j].y, fInPath[j].z); +{$ELSE} AddPoint( fInPath[j].x - absDelta * fNorms[j].x, fInPath[j].y - absDelta * fNorms[j].y); AddPoint( fInPath[j].x + absDelta * fNorms[j].x, fInPath[j].y + absDelta * fNorms[j].y); +{$ENDIF} end else begin +{$IFDEF USINGZ} + AddPoint( + fInPath[j].x + fGroupDelta * fNorms[k].x, + fInPath[j].y + fGroupDelta * fNorms[k].y, fInPath[j].z); + AddPoint( + fInPath[j].x + fGroupDelta * fNorms[j].x, + fInPath[j].y + fGroupDelta * fNorms[j].y, fInPath[j].z); +{$ELSE} AddPoint( fInPath[j].x + fGroupDelta * fNorms[k].x, fInPath[j].y + fGroupDelta * fNorms[k].y); AddPoint( fInPath[j].x + fGroupDelta * fNorms[j].x, fInPath[j].y + fGroupDelta * fNorms[j].y); +{$ENDIF} end; end; //------------------------------------------------------------------------------ @@ -827,9 +911,9 @@ procedure TClipperOffset.DoRound(j, k: Integer; angle: double); // when fDeltaCallback64 is assigned, fGroupDelta won't be constant, // so we'll need to do the following calculations for *every* vertex. absDelta := Abs(fGroupDelta); - if fArcTolerance > 0.01 then - arcTol := Min(absDelta, fArcTolerance) else - arcTol := Log10(2 + absDelta) * 0.25; // empirically derived + arcTol := Iif(fArcTolerance > 0.01, + Min(absDelta, fArcTolerance), + Log10(2 + absDelta) * 0.25); // empirically derived //http://www.angusj.com/clipper2/Docs/Trigonometry.htm stepsPer360 := Pi / ArcCos(1 - arcTol / absDelta); if (stepsPer360 > absDelta * Pi) then @@ -864,7 +948,7 @@ procedure TClipperOffset.DoRound(j, k: Integer; angle: double); end; //------------------------------------------------------------------------------ -procedure TClipperOffset.OffsetPoint(j: Integer; var k: integer); + procedure TClipperOffset.OffsetPoint(j: Integer; var k: integer); var sinA, cosA: Double; begin @@ -897,7 +981,7 @@ procedure TClipperOffset.OffsetPoint(j: Integer; var k: integer); end; //test for concavity first (#593) - if (cosA > -0.99) and (sinA * fGroupDelta < 0) then + if (cosA > -0.999) and (sinA * fGroupDelta < 0) then begin // is concave AddPoint(GetPerpendic(fInPath[j], fNorms[k], fGroupDelta)); @@ -906,20 +990,21 @@ procedure TClipperOffset.OffsetPoint(j: Integer; var k: integer); AddPoint(fInPath[j]); // (#405) AddPoint(GetPerpendic(fInPath[j], fNorms[j], fGroupDelta)); end - else if (cosA > 0.999) then - // almost straight - less than 2.5 degree (#424, #526) - DoMiter(j, k, cosA) + else if (cosA > 0.999) and (fJoinType <> jtRound) then + begin + // almost straight - less than 2.5 degree (#424, #482, #526 & #724) + DoMiter(j, k, cosA); + end else if (fJoinType = jtMiter) then begin - // miter unless the angle is so acute the miter would exceeds ML + // miter unless the angle is sufficiently acute to exceed ML if (cosA > fTmpLimit -1) then DoMiter(j, k, cosA) else DoSquare(j, k); end - else if (cosA > 0.99) or (fJoinType = jtBevel) then - // ie > 2.5 deg (see above) but less than ~8 deg ( acos(0.99) ) - DoBevel(j, k) else if (fJoinType = jtRound) then DoRound(j, k, ArcTan2(sinA, cosA)) + else if (fJoinType = jtBevel) then + DoBevel(j, k) else DoSquare(j, k); diff --git a/Ext/SVGIconImageList/Image32/source/Clipper.RectClip.pas b/Ext/SVGIconImageList/Image32/source/Clipper.RectClip.pas index c687a1f..4e2da7d 100644 --- a/Ext/SVGIconImageList/Image32/source/Clipper.RectClip.pas +++ b/Ext/SVGIconImageList/Image32/source/Clipper.RectClip.pas @@ -2,9 +2,9 @@ (******************************************************************************* * Author : Angus Johnson * -* Date : 9 September 2023 * +* Date : 14 February 2024 * * Website : http://www.angusj.com * -* Copyright : Angus Johnson 2010-2023 * +* Copyright : Angus Johnson 2010-2024 * * Purpose : FAST rectangular clipping * * License : http://www.boost.org/LICENSE_1_0.txt * *******************************************************************************) @@ -121,7 +121,7 @@ function IsHorizontal(pt1: TPoint64; pt2: TPoint64): Boolean; end; //------------------------------------------------------------------------------ -function GetSegmentIntersection(p1: TPoint64; +function GetSegmentIntersectPt2(p1: TPoint64; p2: TPoint64; p3: TPoint64; p4: TPoint64; out ip: TPoint64): Boolean; var res1, res2, res3, res4: double; @@ -189,7 +189,7 @@ function GetSegmentIntersection(p1: TPoint64; end else // segments must intersect to get here - Result := GetIntersectPoint(p1, p2, p3, p4, ip); + Result := GetSegmentIntersectPt(p1, p2, p3, p4, ip); end; //------------------------------------------------------------------------------ @@ -201,60 +201,60 @@ function GetIntersection(const rectPath: TPath64; Result := True; case loc of locLeft: - if GetSegmentIntersection(p, p2, rectPath[0], rectPath[3], ip) then + if GetSegmentIntersectPt2(p, p2, rectPath[0], rectPath[3], ip) then //Result := True else if (p.Y < rectPath[0].Y) and - GetSegmentIntersection(p, p2, rectPath[0], rectPath[1], ip) then + GetSegmentIntersectPt2(p, p2, rectPath[0], rectPath[1], ip) then loc := locTop - else if GetSegmentIntersection(p, p2, rectPath[2], rectPath[3], ip) then + else if GetSegmentIntersectPt2(p, p2, rectPath[2], rectPath[3], ip) then loc := locBottom else Result := False; locRight: - if GetSegmentIntersection(p, p2, rectPath[1], rectPath[2], ip) then + if GetSegmentIntersectPt2(p, p2, rectPath[1], rectPath[2], ip) then //Result := True else if (p.Y < rectPath[0].Y) and - GetSegmentIntersection(p, p2, rectPath[0], rectPath[1], ip) then + GetSegmentIntersectPt2(p, p2, rectPath[0], rectPath[1], ip) then loc := locTop - else if GetSegmentIntersection(p, p2, rectPath[2], rectPath[3], ip) then + else if GetSegmentIntersectPt2(p, p2, rectPath[2], rectPath[3], ip) then loc := locBottom else Result := False; locTop: - if GetSegmentIntersection(p, p2, rectPath[0], rectPath[1], ip) then + if GetSegmentIntersectPt2(p, p2, rectPath[0], rectPath[1], ip) then //Result := True else if (p.X < rectPath[0].X) and - GetSegmentIntersection(p, p2, rectPath[0], rectPath[3], ip) then + GetSegmentIntersectPt2(p, p2, rectPath[0], rectPath[3], ip) then loc := locLeft else if (p.X > rectPath[1].X) and - GetSegmentIntersection(p, p2, rectPath[1], rectPath[2], ip) then + GetSegmentIntersectPt2(p, p2, rectPath[1], rectPath[2], ip) then loc := locRight else Result := False; locBottom: - if GetSegmentIntersection(p, p2, rectPath[2], rectPath[3], ip) then + if GetSegmentIntersectPt2(p, p2, rectPath[2], rectPath[3], ip) then //Result := True else if (p.X < rectPath[3].X) and - GetSegmentIntersection(p, p2, rectPath[0], rectPath[3], ip) then + GetSegmentIntersectPt2(p, p2, rectPath[0], rectPath[3], ip) then loc := locLeft else if (p.X > rectPath[2].X) and - GetSegmentIntersection(p, p2, rectPath[1], rectPath[2], ip) then + GetSegmentIntersectPt2(p, p2, rectPath[1], rectPath[2], ip) then loc := locRight else Result := False; else // loc = rInside begin - if GetSegmentIntersection(p, p2, rectPath[0], rectPath[3], ip) then + if GetSegmentIntersectPt2(p, p2, rectPath[0], rectPath[3], ip) then loc := locLeft - else if GetSegmentIntersection(p, p2, rectPath[0], rectPath[1], ip) then + else if GetSegmentIntersectPt2(p, p2, rectPath[0], rectPath[1], ip) then loc := locTop - else if GetSegmentIntersection(p, p2, rectPath[1], rectPath[2], ip) then + else if GetSegmentIntersectPt2(p, p2, rectPath[1], rectPath[2], ip) then loc := locRight - else if GetSegmentIntersection(p, p2, rectPath[2], rectPath[3], ip) then + else if GetSegmentIntersectPt2(p, p2, rectPath[2], rectPath[3], ip) then loc := locBottom else Result := False; @@ -282,7 +282,7 @@ function GetAdjacentLocation(loc: TLocation; isClockwise: Boolean): TLocation; var delta: integer; begin - if isClockwise then delta := 1 else delta := 3; + delta := Iif(isClockwise, 1 , 3); Result := TLocation((Ord(loc) + delta) mod 4); end; //------------------------------------------------------------------------------ @@ -291,9 +291,9 @@ function IsClockwise(prev, curr: TLocation; const prevPt, currPt, rectMidPt: TPoint64): Boolean; {$IFDEF INLINING} inline; {$ENDIF} begin - if AreOpposites(prev, curr) then - Result := CrossProduct(prevPt, rectMidPt, currPt) < 0 else - Result := HeadingClockwise(prev, curr); + Result := Iif(AreOpposites(prev, curr), + CrossProduct(prevPt, rectMidPt, currPt) < 0, + HeadingClockwise(prev, curr)); end; //------------------------------------------------------------------------------ @@ -517,9 +517,7 @@ procedure TRectClip64.AddCorner(prev, curr: TLocation); cnrIdx: integer; begin if prev = curr then Exit; - if (HeadingClockwise(prev, curr)) then - cnrIdx := Ord(prev) else - cnrIdx := Ord(curr); + cnrIdx := Iif(HeadingClockwise(prev, curr), Ord(prev), Ord(curr)); Add(fRectPath[cnrIdx]); end; //------------------------------------------------------------------------------ diff --git a/Ext/SVGIconImageList/Image32/source/Clipper.inc b/Ext/SVGIconImageList/Image32/source/Clipper.inc index 066d5dc..5b15f92 100644 --- a/Ext/SVGIconImageList/Image32/source/Clipper.inc +++ b/Ext/SVGIconImageList/Image32/source/Clipper.inc @@ -14,21 +14,21 @@ {$DEFINE INLINING} {$MODE DELPHI} {$ELSE} - {$IF CompilerVersion < 14} + {$IF COMPILERVERSION < 14} Requires Delphi version 6 or above. {$IFEND} - {$IF CompilerVersion >= 18} //Delphi 2007 + {$IF COMPILERVERSION >= 18} //Delphi 2007 {$DEFINE RECORD_METHODS} {$DEFINE STRICT} - {$IF CompilerVersion >= 19} //Delphi 2009 + {$IF COMPILERVERSION >= 19} //Delphi 2009 //While "inlining" is supported from D2005, it's buggy (see QC41166) until D2009 {$DEFINE INLINING} - {$IFEND} - {$IF COMPILERVERSION >= 23} //Delphi XE2+ - {$DEFINE XPLAT_GENERICS} - {$DEFINE ROUNDINGMODE} - {$IF COMPILERVERSION >= 24} //Delphi XE3+ - {$LEGACYIFEND ON} + {$IF COMPILERVERSION >= 23} //Delphi XE2+ + {$DEFINE XPLAT_GENERICS} + {$DEFINE ROUNDINGMODE} + {$IF COMPILERVERSION >= 24} //Delphi XE3+ + {$LEGACYIFEND ON} + {$IFEND} {$IFEND} {$IFEND} {$IFEND} diff --git a/Ext/SVGIconImageList/Image32/source/Clipper.pas b/Ext/SVGIconImageList/Image32/source/Clipper.pas index 73fb326..1c36223 100644 --- a/Ext/SVGIconImageList/Image32/source/Clipper.pas +++ b/Ext/SVGIconImageList/Image32/source/Clipper.pas @@ -2,7 +2,7 @@ (******************************************************************************* * Author : Angus Johnson * -* Date : 17 July 2023 * +* Date : 21 December 2023 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2010-2023 * * Purpose : This module provides a simple interface to the Clipper Library * @@ -17,9 +17,8 @@ interface Math, SysUtils, Classes, Clipper.Core, Clipper.Engine, Clipper.Offset, Clipper.RectClip; -// Redeclare here a number of structures defined in -// other units so those units won't need to be declared -// just to use the following functions. +// A number of structures defined in other units are redeclared here +// so those units won't also need to be declared in your own units clauses. type TClipper = Clipper.Engine.TClipper64; TClipper64 = Clipper.Engine.TClipper64; @@ -148,9 +147,13 @@ function PointInPolygon(const pt: TPoint64; const polygon: TPath64): TPointInPolygonResult; function SimplifyPath(const path: TPath64; - shapeTolerance: double; isOpenPath: Boolean): TPath64; + shapeTolerance: double; isClosedPath: Boolean = true): TPath64; overload; function SimplifyPaths(const paths: TPaths64; - shapeTolerance: double; isOpenPaths: Boolean): TPaths64; + shapeTolerance: double; isClosedPath: Boolean = true): TPaths64; overload; +function SimplifyPath(const path: TPathD; shapeTolerance: double; + isClosedPath: Boolean = true; decimalPrecision: integer = 2): TPathD; overload; +function SimplifyPaths(const paths: TPathsD; shapeTolerance: double; + isClosedPath: Boolean = true; decimalPrecision: integer = 2): TPathsD; overload; implementation @@ -833,9 +836,8 @@ function PerpendicDistSqrd(const pt, line1, line2: TPoint64): double; b := pt.Y - line1.Y; c := line2.X - line1.X; d := line2.Y - line1.Y; - if (c = 0) and (d = 0) then - result := 0 else - result := Sqr(a * d - c * b) / (c * c + d * d); + result := Iif((c = 0) and (d = 0), + 0, Sqr(a * d - c * b) / (c * c + d * d)); end; //------------------------------------------------------------------------------ @@ -848,22 +850,22 @@ TSimplifyRec = record pdSqrd : double; prev : PSimplifyRec; next : PSimplifyRec; - isEnd : Boolean; + //isEnd : Boolean; end; function SimplifyPath(const path: TPath64; - shapeTolerance: double; isOpenPath: Boolean): TPath64; + shapeTolerance: double; isClosedPath: Boolean): TPath64; var - i, highI, minLen: integer; + i, highI, minHigh: integer; tolSqrd: double; srArray: array of TSimplifyRec; first, last: PSimplifyRec; begin Result := nil; highI := High(path); - if isOpenPath then minLen := 2 else minLen := 3; - if highI +1 < minLen then Exit; + minHigh := Iif(isClosedPath, 2, 1); + if highI < minHigh then Exit; SetLength(srArray, highI +1); with srArray[0] do @@ -871,15 +873,8 @@ function SimplifyPath(const path: TPath64; pt := path[0]; prev := @srArray[highI]; next := @srArray[1]; - if isOpenPath then - begin - pdSqrd := MaxDouble; - isEnd := true; - end else - begin - pdSqrd := PerpendicDistSqrd(path[0], path[highI], path[1]); - isEnd := false; - end; + pdSqrd := Iif(isClosedPath, + PerpendicDistSqrd(path[0], path[highI], path[1]), invalidD); end; with srArray[highI] do @@ -887,15 +882,8 @@ function SimplifyPath(const path: TPath64; pt := path[highI]; prev := @srArray[highI-1]; next := @srArray[0]; - if isOpenPath then - begin - pdSqrd := MaxDouble; - isEnd := true; - end else - begin - pdSqrd := PerpendicDistSqrd(path[highI], path[highI-1], path[0]); - isEnd := false; - end; + pdSqrd := Iif(isClosedPath, + PerpendicDistSqrd(path[highI], path[highI-1], path[0]), invalidD); end; for i := 1 to highI -1 do @@ -905,7 +893,6 @@ function SimplifyPath(const path: TPath64; prev := @srArray[i-1]; next := @srArray[i+1]; pdSqrd := PerpendicDistSqrd(path[i], path[i-1], path[i+1]); - isEnd := false; end; first := @srArray[0]; @@ -914,26 +901,23 @@ function SimplifyPath(const path: TPath64; tolSqrd := Sqr(shapeTolerance); while first <> last do begin - if first.isEnd or (first.pdSqrd > tolSqrd) or + if (first.pdSqrd > tolSqrd) or (first.next.pdSqrd < first.pdSqrd) then begin first := first.next; - end else - begin - first.prev.next := first.next; - first.next.prev := first.prev; - last := first.prev; - dec(highI); - if last.next = last.prev then break; - last.pdSqrd := - PerpendicDistSqrd(last.pt, last.prev.pt, last.next.pt); - first := last.next; - first.pdSqrd := - PerpendicDistSqrd(first.pt, first.prev.pt, first.next.pt); + Continue; end; + dec(highI); + first.prev.next := first.next; + first.next.prev := first.prev; + last := first.prev; + first := last.next; + if first.next = first.prev then break; + last.pdSqrd := PerpendicDistSqrd(last.pt, last.prev.pt, first.pt); + first.pdSqrd := PerpendicDistSqrd(first.pt, last.pt, first.next.pt); end; - if highI +1 < minLen then Exit; - if isOpenPath then first := @srArray[0]; + if highI < minHigh then Exit; + if not isClosedPath then first := @srArray[0]; SetLength(Result, highI +1); for i := 0 to HighI do begin @@ -944,15 +928,43 @@ function SimplifyPath(const path: TPath64; //------------------------------------------------------------------------------ function SimplifyPaths(const paths: TPaths64; - shapeTolerance: double; isOpenPaths: Boolean): TPaths64; + shapeTolerance: double; isClosedPath: Boolean): TPaths64; var i, len: integer; begin len := Length(paths); SetLength(Result, len); for i := 0 to len -1 do - result[i] := SimplifyPath(paths[i], shapeTolerance, isOpenPaths); + result[i] := SimplifyPath(paths[i], shapeTolerance, isClosedPath); end; +//------------------------------------------------------------------------------ + +function SimplifyPath(const path: TPathD; shapeTolerance: double; + isClosedPath: Boolean; decimalPrecision: integer): TPathD; +var + p: TPath64; + scale: double; +begin + scale := power(10, decimalPrecision); + p := ScalePath(path, scale); + p := SimplifyPath(p, shapeTolerance, isClosedPath); + Result := ScalePathD(p, 1/scale); +end; +//------------------------------------------------------------------------------ + +function SimplifyPaths(const paths: TPathsD; shapeTolerance: double; + isClosedPath: Boolean; decimalPrecision: integer): TPathsD; +var + pp: TPaths64; + scale: double; +begin + scale := power(10, decimalPrecision); + pp := ScalePaths(paths, scale); + pp := SimplifyPaths(pp, shapeTolerance, isClosedPath); + Result := ScalePathsD(pp, 1/scale); +end; +//------------------------------------------------------------------------------ + end. diff --git a/Ext/SVGIconImageList/Image32/source/Img32.CQ.pas b/Ext/SVGIconImageList/Image32/source/Img32.CQ.pas index cd8d5f6..8acea08 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.CQ.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.CQ.pas @@ -3,9 +3,9 @@ (******************************************************************************* * Author : Angus Johnson * * Version : 4.4 * -* Date : 4 July 2023 * +* Date : 10 April 2024 * * Website : http://www.angusj.com * -* Copyright : Angus Johnson 2019-2021 * +* Copyright : Angus Johnson 2019-2024 * * Purpose : Color reduction for TImage32 * * : Uses Octree Color Quantization & Floyd / Steinberg Dithering * * License : http://www.boost.org/LICENSE_1_0.txt * @@ -90,6 +90,7 @@ TOctree = class destructor Destroy; override; procedure Reset; procedure BuildTree(image: TImage32); + procedure ApplyPalette(image: TImage32); function GetColorFreqArray: TArrayOfColFreq; property ColorCount: cardinal read fLeaves; // PixelCount: = Sum( leaves[ 0 .. n-1 ].Count ) @@ -343,12 +344,16 @@ procedure PaletteSort(var ptrArray: TArrayOfColFreq; function RoundDownNearestPower2(val: Cardinal): Cardinal; begin - Result := val or val shr 1; - Result := Result or Result shr 2; - Result := Result or Result shr 3; - Result := Result or Result shr 4; - Result := Result or Result shr 16; - Result := Result - Result shr 1; + if (val and (val - 1)) > 0 then + begin + Result := val or val shr 1; + Result := Result or (Result shr 2); + Result := Result or (Result shr 3); + Result := Result or (Result shr 4); + Result := Result or (Result shr 16); + Result := Result - (Result shr 1); + end else + Result := val; end; //------------------------------------------------------------------------------ @@ -630,6 +635,25 @@ procedure TOctree.BuildTree(image: TImage32); end; //------------------------------------------------------------------------------ +type TImg32 = class(TImage32); + +procedure TOctree.ApplyPalette(image: TImage32); +var + i: integer; + pc: PARGB; +begin + pc := PARGB(image.PixelBase); + for i := 0 to image.Width * image.Height -1 do + begin + if pc.A < OpacityThreshold then + pc.Color := clNone32 else + fTop.GetNodeColor(pc.Color); + inc(pc); + end; + TImg32(image).ResetColorCount; +end; +//------------------------------------------------------------------------------ + function TOctree.ReduceOne: Boolean; var lvl, i, childCnt: integer; @@ -985,6 +1009,7 @@ function ReduceImage(image: TImage32; maxColors: Cardinal; if octree.fReduceType = rtSimple then begin Result := octree.BasicReduce(maxColors); + octree.ApplyPalette(image); Exit; end; @@ -1043,6 +1068,7 @@ function ReduceImage(image: TImage32; maxColors: Cardinal; finally octree.Free; end; + TImg32(image).ResetColorCount; end; //------------------------------------------------------------------------------ @@ -1078,8 +1104,8 @@ procedure DrawPalette(image: TImage32; const palette: TArrayOfColor32); begin image.FillRect(rec, palette[i] or $FF000000); if (i + 1) mod w = 0 then - Types.OffsetRect(rec, -15 * w, 16) else - Types.OffsetRect(rec, 16, 0); + TranslateRect(rec, -15 * w, 16) else + TranslateRect(rec, 16, 0); end; end; diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Clipper2.pas b/Ext/SVGIconImageList/Image32/source/Img32.Clipper2.pas index feb61d9..4fa6708 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.Clipper2.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.Clipper2.pas @@ -94,9 +94,10 @@ function InflatePaths(const paths: Img32.TPathsD; jt: Clipper.Offset.TJoinType; begin case joinStyle of - jsSquare: jt := jtSquare; - jsMiter: jt := jtMiter; - jsRound: jt := jtRound; + jsSquare : jt := jtSquare; + jsButt : jt := jtBevel; + jsMiter : jt := jtMiter; + jsRound : jt := jtRound; else if endType = etRound then jt := jtRound else jt := jtSquare; end; diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Draw.pas b/Ext/SVGIconImageList/Image32/source/Img32.Draw.pas index 5c98383..e7b89c4 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.Draw.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.Draw.pas @@ -3,9 +3,9 @@ (******************************************************************************* * Author : Angus Johnson * * Version : 4.4 * -* Date : 15 December 2023 * +* Date : 23 March 2024 * * Website : http://www.angusj.com * -* Copyright : Angus Johnson 2019-2023 * +* Copyright : Angus Johnson 2019-2024 * * * * Purpose : Polygon renderer for TImage32 * * * @@ -18,7 +18,13 @@ interface {$I Img32.inc} -{.$DEFINE MemCheck} //for debugging only (adds a minimal cost to performance) +// MemCheck may be useful for debugging (adds a minimal cost to performance) +{.$DEFINE MemCheck} + +// UseTrunc makes rendering thread safe, +// so it's generally preferred over Round and SetRoundMode(). +// See https://github.com/AngusJohnson/Image32/issues/45 +{$DEFINE UseTrunc} uses SysUtils, Classes, Types, Math, Img32, Img32.Vector; @@ -424,27 +430,6 @@ procedure ApplyClearType(img: TImage32; textColor: TColor32 = clBlack32; // Other miscellaneous functions // ------------------------------------------------------------------------------ -// //__Trunc: An efficient Trunc() algorithm (ie rounds toward zero) -// function __Trunc(val: double): integer; {$IFDEF INLINE} inline; {$ENDIF} -// var -// exp: integer; -// i64: UInt64 absolute val; -// begin -// //https://en.wikipedia.org/wiki/Double-precision_floating-point_format -// Result := 0; -// if i64 = 0 then Exit; -// exp := Integer(Cardinal(i64 shr 52) and $7FF) - 1023; -// //nb: when exp == 1024 then val == INF or NAN. -// if exp < 0 then -// Exit -// else if exp > 52 then -// Result := ((i64 and $1FFFFFFFFFFFFF) shl (exp - 52)) or (UInt64(1) shl exp) -// else -// Result := ((i64 and $1FFFFFFFFFFFFF) shr (52 - exp)) or (UInt64(1) shl exp); -// if val < 0 then Result := -Result; -// end; -// ------------------------------------------------------------------------------ - function ClampByte(val: double): byte; {$IFDEF INLINE} inline; {$ENDIF} begin if val < 0 then result := 0 @@ -534,9 +519,15 @@ function MirrorQ(q, endQ: integer): integer; function MirrorD(d: double; colorCnt: integer): integer; begin dec(colorCnt); +{$IFDEF UseTrunc} // used in TSvgRadialGradientRenderer.RenderProc + if Odd(Trunc(d)) then + result := Trunc((1 - frac(d)) * colorCnt) else + result := Trunc(frac(d) * colorCnt); +{$ELSE} if Odd(Round(d)) then result := Round((1 - frac(d)) * colorCnt) else result := Round(frac(d) * colorCnt); +{$ENDIF} end; // ------------------------------------------------------------------------------ @@ -564,9 +555,15 @@ function SoftRptQ(q, endQ: integer): integer; function RepeatD(d: double; colorCnt: integer): integer; begin dec(colorCnt); +{$IFDEF UseTrunc} // used in TSvgRadialGradientRenderer.RenderProc + if (d < 0) then + result := Trunc((1 + frac(d)) * colorCnt) else + result := Trunc(frac(d) * colorCnt); +{$ELSE} if (d < 0) then result := Round((1 + frac(d)) * colorCnt) else result := Round(frac(d) * colorCnt); +{$ENDIF} end; // ------------------------------------------------------------------------------ @@ -659,10 +656,18 @@ procedure AllocateScanlines(const polygons: TPathsD; begin highJ := high(polygons[i]); if highJ < 2 then continue; +{$IFDEF UseTrunc} + y1 := Trunc(polygons[i][highJ].Y); +{$ELSE} y1 := Round(polygons[i][highJ].Y); +{$ENDIF} for j := 0 to highJ do begin +{$IFDEF UseTrunc} + y2 := Trunc(polygons[i][j].Y); +{$ELSE} y2 := Round(polygons[i][j].Y); +{$ENDIF} if y1 < y2 then begin // descending (but ignore edges outside the clipping range) @@ -758,8 +763,13 @@ procedure SplitEdgeIntoFragments(const pt1, pt2: TPointD; // but still update maxX for each scanline the edge passes if bot.X > maxX then begin +{$IFDEF UseTrunc} + for i := Min(maxY, Trunc(bot.Y)) downto Max(0, Trunc(top.Y)) do + scanlines[i].maxX := maxX; +{$ELSE} for i := Min(maxY, Round(bot.Y)) downto Max(0, Round(top.Y)) do scanlines[i].maxX := maxX; +{$ENDIF} Exit; end; @@ -776,14 +786,24 @@ procedure SplitEdgeIntoFragments(const pt1, pt2: TPointD; begin if top.X >= maxX then begin +{$IFDEF UseTrunc} + for i := Min(maxY, Trunc(bot.Y)) downto Max(0, Trunc(top.Y)) do + scanlines[i].maxX := maxX; +{$ELSE} for i := Min(maxY, Round(bot.Y)) downto Max(0, Round(top.Y)) do scanlines[i].maxX := maxX; +{$ENDIF} Exit; end; // here the edge must be oriented bottom-right to top-left y := bot.Y - (bot.X - maxX) * Abs(dydx); +{$IFDEF UseTrunc} + for i := Min(maxY, Trunc(bot.Y)) downto Max(0, Trunc(y)) do + scanlines[i].maxX := maxX; +{$ELSE} for i := Min(maxY, Round(bot.Y)) downto Max(0, Round(y)) do scanlines[i].maxX := maxX; +{$ENDIF} bot.Y := y; if bot.Y <= 0 then Exit; bot.X := maxX; @@ -792,8 +812,13 @@ procedure SplitEdgeIntoFragments(const pt1, pt2: TPointD; begin // here the edge must be oriented bottom-left to top-right y := top.Y + (top.X - maxX) * Abs(dydx); +{$IFDEF UseTrunc} + for i := Min(maxY, Trunc(y)) downto Max(0, Trunc(top.Y)) do + scanlines[i].maxX := maxX; +{$ELSE} for i := Min(maxY, Round(y)) downto Max(0, Round(top.Y)) do scanlines[i].maxX := maxX; +{$ENDIF} top.Y := y; if top.Y >= maxY then Exit; top.X := maxX; @@ -812,7 +837,11 @@ procedure SplitEdgeIntoFragments(const pt1, pt2: TPointD; end; // SPLIT THE EDGE INTO MULTIPLE SCANLINE FRAGMENTS +{$IFDEF UseTrunc} + scanlineY := Trunc(bot.Y); +{$ELSE} scanlineY := Round(bot.Y); +{$ENDIF} if bot.Y = scanlineY then dec(scanlineY); // at the lower-most extent of the edge 'split' the first fragment @@ -920,8 +949,13 @@ procedure ProcessScanlineFragments(var scanline: TScanLine; right := q; end; +{$IFDEF UseTrunc} + leftXi := Max(0, Trunc(left)); + rightXi := Max(0, Trunc(right)); +{$ELSE} leftXi := Max(0, Round(left)); rightXi := Max(0, Round(right)); +{$ENDIF} if (leftXi = rightXi) then begin @@ -992,20 +1026,24 @@ procedure Rasterize(const paths: TPathsD; const clipRec: TRect; scanlines: TArrayOfScanline; fragments: PDouble; scanline: PScanline; +{$IFnDEF UseTrunc} savedRoundMode: TRoundingMode; +{$ENDIF} begin // See also https://nothings.org/gamedev/rasterize/ if not assigned(renderer) then Exit; Types.IntersectRect(clipRec2, clipRec, GetBounds(paths)); if IsEmptyRect(clipRec2) then Exit; - paths2 := OffsetPath(paths, -clipRec2.Left, -clipRec2.Top); + paths2 := TranslatePath(paths, -clipRec2.Left, -clipRec2.Top); // Delphi's Round() function is *much* faster than Trunc(), - // and even a little faster than __Trunc() above (except + // and even a little faster than Trunc() above (except // when the FastMM4 memory manager is enabled.) fragments := nil; +{$IFnDEF UseTrunc} savedRoundMode := SetRoundMode(rmDown); +{$ENDIF} try RectWidthHeight(clipRec2, maxW, maxH); SetLength(scanlines, maxH +1); @@ -1041,14 +1079,22 @@ procedure Rasterize(const paths: TPathsD; const clipRec: TRect; case fillRule of frEvenOdd: begin +{$IFDEF UseTrunc} + aa := Trunc(Abs(accum) * 1275) mod 2550; // *5 +{$ELSE} aa := Round(Abs(accum) * 1275) mod 2550; // *5 +{$ENDIF} if aa > 1275 then byteBuffer[j] := Min(255, (2550 - aa) shr 2) else // /4 byteBuffer[j] := Min(255, aa shr 2); // /4 end; frNonZero: begin +{$IFDEF UseTrunc} + byteBuffer[j] := Min(255, Trunc(Abs(accum) * 318)); +{$ELSE} byteBuffer[j] := Min(255, Round(Abs(accum) * 318)); +{$ENDIF} end; {$IFDEF REVERSE_ORIENTATION} frPositive: @@ -1056,8 +1102,13 @@ procedure Rasterize(const paths: TPathsD; const clipRec: TRect; frNegative: {$ENDIF} begin +{$IFDEF UseTrunc} + if accum > 0.002 then + byteBuffer[j] := Min(255, Trunc(accum * 318)); +{$ELSE} if accum > 0.002 then byteBuffer[j] := Min(255, Round(accum * 318)); +{$ENDIF} end; {$IFDEF REVERSE_ORIENTATION} frNegative: @@ -1065,8 +1116,13 @@ procedure Rasterize(const paths: TPathsD; const clipRec: TRect; frPositive: {$ENDIF} begin +{$IFDEF UseTrunc} + if accum < -0.002 then + byteBuffer[j] := Min(255, Trunc(-accum * 318)); +{$ELSE} if accum < -0.002 then byteBuffer[j] := Min(255, Round(-accum * 318)); +{$ENDIF} end; end; end; @@ -1079,7 +1135,9 @@ procedure Rasterize(const paths: TPathsD; const clipRec: TRect; end; finally FreeMem(fragments); +{$IFnDEF UseTrunc} SetRoundMode(savedRoundMode); +{$ENDIF} end; end; @@ -1500,7 +1558,11 @@ procedure TRadialGradientRenderer.RenderProc(x1, x2, y: integer; alpha: PByte); for i := x1 to x2 do begin dist := Hypot((y - fCenterPt.Y) *fScaleY, (i - fCenterPt.X) *fScaleX); +{$IFDEF UseTrunc} + color.Color := fColors[fBoundsProc(Trunc(dist), fColorsCnt)]; +{$ELSE} color.Color := fColors[fBoundsProc(Round(dist), fColorsCnt)]; +{$ENDIF} pDst^ := BlendToAlpha(pDst^, MulBytes(color.A, Ord(alpha^)) shl 24 or (color.Color and $FFFFFF)); inc(pDst); inc(alpha); @@ -1551,7 +1613,7 @@ procedure TSvgRadialGradientRenderer.SetParameters(const ellipseRect: TRect; procedure TSvgRadialGradientRenderer.RenderProc(x1, x2, y: integer; alpha: PByte); var i: integer; - q,m,c, qa,qb,qc,qs: double; + q,qq, m,c, qa,qb,qc,qs: double; dist, dist2: double; color: TARGB; pDst: PColor32; @@ -1567,7 +1629,10 @@ procedure TSvgRadialGradientRenderer.RenderProc(x1, x2, y: integer; alpha: PByte if (pt.X = fFocusPt.X) then //vertical line begin // let x = pt.X, then y*y = b*b(1 - Sqr(pt.X)/aa) - q := Sqrt(fBB*(1 - Sqr(pt.X)/fAA)); + qq := (1 - Sqr(pt.X)/fAA); + if (qq > 1) then qq := 1 + else if (qq < 0) then qq := 0; + q := Sqrt(fBB*qq); ellipsePt.X := pt.X; if pt.Y >= fFocusPt.Y then ellipsePt.Y := q else @@ -1834,7 +1899,7 @@ procedure DrawLine(img: TImage32; const lines: TPathsD; begin if not assigned(lines) then exit; if (lineWidth < MinStrokeWidth) then lineWidth := MinStrokeWidth; - lines2 := Outline(lines, lineWidth, joinStyle, endStyle, miterLimit); + lines2 := RoughOutline(lines, lineWidth, joinStyle, endStyle, miterLimit); if img.AntiAliased then cr := TColorRenderer.Create(color) else @@ -1860,7 +1925,7 @@ procedure DrawLine(img: TImage32; const lines: TPathsD; begin if (not assigned(lines)) or (not assigned(renderer)) then exit; if (lineWidth < MinStrokeWidth) then lineWidth := MinStrokeWidth; - lines2 := Outline(lines, lineWidth, joinStyle, endStyle, miterLimit); + lines2 := RoughOutline(lines, lineWidth, joinStyle, endStyle, miterLimit); if renderer.Initialize(img) then begin Rasterize(lines2, img.bounds, frNonZero, renderer); @@ -1878,7 +1943,7 @@ procedure DrawInvertedLine(img: TImage32; begin if not assigned(lines) then exit; if (lineWidth < MinStrokeWidth) then lineWidth := MinStrokeWidth; - lines2 := Outline(lines, lineWidth, joinStyle, endStyle, 2); + lines2 := RoughOutline(lines, lineWidth, joinStyle, endStyle, 2); ir := TInverseRenderer.Create; try if ir.Initialize(img) then @@ -1908,15 +1973,20 @@ procedure DrawDashedLine(img: TImage32; const line: TPathD; lines := GetDashedPath(line, endStyle = esPolygon, dashPattern, patternOffset); if Length(lines) = 0 then Exit; + case joinStyle of + jsAuto: + if endStyle = esRound then + joinStyle := jsRound else + joinStyle := jsSquare; jsSquare, jsMiter: endStyle := esSquare; jsRound: endStyle := esRound; - else + jsButt: endStyle := esButt; end; - lines := Outline(lines, lineWidth, joinStyle, endStyle); + lines := RoughOutline(lines, lineWidth, joinStyle, endStyle); cr := TColorRenderer.Create(color); try if cr.Initialize(img) then @@ -1958,7 +2028,7 @@ procedure DrawDashedLine(img: TImage32; const line: TPathD; lines := GetDashedPath(line, endStyle = esPolygon, dashPattern, patternOffset); if Length(lines) = 0 then Exit; - lines := Outline(lines, lineWidth, joinStyle, endStyle); + lines := RoughOutline(lines, lineWidth, joinStyle, endStyle); if renderer.Initialize(img) then begin Rasterize(lines, img.bounds, frNonZero, renderer); @@ -1997,7 +2067,7 @@ procedure DrawInvertedDashedLine(img: TImage32; lines := GetDashedPath(line, endStyle = esPolygon, dashPattern, patternOffset); if Length(lines) = 0 then Exit; - lines := Outline(lines, lineWidth, joinStyle, endStyle); + lines := RoughOutline(lines, lineWidth, joinStyle, endStyle); renderer := TInverseRenderer.Create; try if renderer.Initialize(img) then @@ -2132,7 +2202,7 @@ procedure DrawPolygon_ClearType(img: TImage32; const polygons: TPathsD; RectWidthHeight(rec, w, h); tmpImg := TImage32.Create(w *3, h); try - tmpPolygons := OffsetPath(polygons, -rec.Left, -rec.Top); + tmpPolygons := TranslatePath(polygons, -rec.Left, -rec.Top); tmpPolygons := ScalePath(tmpPolygons, 3, 1); cr := TColorRenderer.Create(clBlack32); try diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Extra.pas b/Ext/SVGIconImageList/Image32/source/Img32.Extra.pas index 7436f6c..b0f5b5d 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.Extra.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.Extra.pas @@ -3,9 +3,9 @@ (******************************************************************************* * Author : Angus Johnson * * Version : 4.4 * -* Date : 17 December 2023 * +* Date : 2 May 2024 * * Website : http://www.angusj.com * -* Copyright : Angus Johnson 2019-2023 * +* Copyright : Angus Johnson 2019-2024 * * Purpose : Miscellaneous routines that don't belong in other modules. * * License : http://www.boost.org/LICENSE_1_0.txt * *******************************************************************************) @@ -22,46 +22,6 @@ interface TButtonAttribute = (baShadow, ba3D, baEraseBeneath); TButtonAttributes = set of TButtonAttribute; -type - PPt = ^TPt; - TPt = record - pt : TPointD; - vec : TPointD; - len : double; - next : PPt; - prev : PPt; - end; - - TFitCurveContainer = class - private - ppts : PPt; - solution : TPathD; - tolSqrd : double; - function Count(first, last: PPt): integer; - function AddPt(const pt: TPointD): PPt; - procedure Clear; - function ComputeLeftTangent(p: PPt): TPointD; - function ComputeRightTangent(p: PPt): TPointD; - function ComputeCenterTangent(p: PPt): TPointD; - function ChordLengthParameterize( - first: PPt; cnt: integer): TArrayOfDouble; - function GenerateBezier(first, last: PPt; cnt: integer; - const u: TArrayOfDouble; const firstTan, lastTan: TPointD): TPathD; - function Reparameterize(first: PPt; cnt: integer; - const u: TArrayOfDouble; const bezier: TPathD): TArrayOfDouble; - function NewtonRaphsonRootFind(const q: TPathD; - const pt: TPointD; u: double): double; - function ComputeMaxErrorSqrd(first, last: PPt; - const bezier: TPathD; const u: TArrayOfDouble; - out SplitPoint: PPt): double; - function FitCubic(first, last: PPt; - firstTan, lastTan: TPointD): Boolean; - procedure AppendSolution(const bezier: TPathD); - public - function FitCurve(const path: TPathD; closed: Boolean; - tolerance: double; minSegLength: double): TPathD; - end; - procedure DrawEdge(img: TImage32; const rec: TRect; topLeftColor, bottomRightColor: TColor32; penWidth: double = 1.0); overload; procedure DrawEdge(img: TImage32; const rec: TRectD; @@ -85,9 +45,6 @@ procedure DrawGlow(img: TImage32; const polygon: TPathD; procedure DrawGlow(img: TImage32; const polygons: TPathsD; fillRule: TFillRule; color: TColor32; blurRadius: integer); overload; -procedure TileImage(img: TImage32; const rec: TRect; tile: TImage32); overload; -procedure TileImage(img: TImage32; const rec: TRect; tile: TImage32; const tileRec: TRect); overload; - //FloodFill: If no CompareFunc is provided, FloodFill will fill whereever //adjoining pixels exactly match the starting pixel - Point(x,y). procedure FloodFill(img: TImage32; x, y: Integer; newColor: TColor32; @@ -178,36 +135,42 @@ function RamerDouglasPeucker(const path: TPathD; function RamerDouglasPeucker(const paths: TPathsD; epsilon: double): TPathsD; overload; +{$IFDEF USE_OLD_SIMPLIFYPATHS} +// SimplifyPath: Better than RDP when simplifying closed paths +function SimplifyPath(const path: TPathD; + shapeTolerance: double = 0.1; isOpenPath: Boolean = false): TPathD; +function SimplifyPaths(const paths: TPathsD; + shapeTolerance: double = 0.1; isOpenPath: Boolean = false): TPathsD; +{$ELSE} // SimplifyPath: Better than RDP when simplifying closed paths function SimplifyPath(const path: TPathD; - shapeTolerance: double; isOpenPath: Boolean = false): TPathD; + shapeTolerance: double = 0.1; isClosedPath: Boolean = true): TPathD; function SimplifyPaths(const paths: TPathsD; - shapeTolerance: double; isOpenPath: Boolean = false): TPathsD; + shapeTolerance: double = 0.1; isClosedPath: Boolean = true): TPathsD; +{$ENDIF} // SimplifyPathEx: this is mainly useful following Vectorize() -function SimplifyPathEx(const path: TPathD; - shapeTolerance: double): TPathD; -function SimplifyPathsEx(const paths: TPathsD; - shapeTolerance: double): TPathsD; - -// SmoothToCubicBezier - produces a series of cubic bezier control points. -// This function is very useful in the following combination: -// SimplifyPath(), SmoothToCubicBezier(), FlattenCBezier(). +// Also removes very short segments that zig-zag (rather than curve) +function SimplifyPathEx(const path: TPathD; shapeTolerance: double): TPathD; +function SimplifyPathsEx(const paths: TPathsD; shapeTolerance: double): TPathsD; + +// SmoothToCubicBezier and SmoothToCubicBezier2 have been deprecated in +// favour of SmoothPath that's much simpler function SmoothToCubicBezier(const path: TPathD; - pathIsClosed: Boolean; maxOffset: integer = 0): TPathD; overload; + pathIsClosed: Boolean; maxOffset: integer = 0): TPathD; overload; deprecated; function SmoothToCubicBezier(const paths: TPathsD; - pathIsClosed: Boolean; maxOffset: integer = 0): TPathsD; overload; - -// SmoothToCubicBezier2 - similar to SmoothToCubicBezier but is -// insensitive to join angles + pathIsClosed: Boolean; maxOffset: integer = 0): TPathsD; overload; deprecated; function SmoothToCubicBezier2(const path: TPathD; - pathIsClosed: Boolean; maxOffset: integer = 0): TPathD; overload; + pathIsClosed: Boolean; maxOffset: integer = 0): TPathD; overload; deprecated; function SmoothToCubicBezier2(const paths: TPathsD; - pathIsClosed: Boolean; maxOffset: integer = 0): TPathsD; overload; + pathIsClosed: Boolean; maxOffset: integer = 0): TPathsD; overload; deprecated; -//InterpolatePoints: smooths a simple line chart. -//Points should be left to right and equidistant along the X axis -function InterpolatePoints(const points: TPathD; tension: integer = 0): TPathD; +// SmoothPath - smooths a path using bicubic interpolation +// tension (range -1 to 1): from least to most curve constraint +function SmoothPath(const path: TPathD; isClosedPath: Boolean; + tension: double = 0; shapeTolerance: double = 0.1): TPathD; +function SmoothPaths(const paths: TPathsD; isClosedPath: Boolean; + tension: double = 0; shapeTolerance: double = 0.1): TPathsD; function GetFloodFillMask(imgIn, imgMaskOut: TImage32; x, y: Integer; tolerance: Byte; compareFunc: TCompareFunctionEx): Boolean; @@ -219,25 +182,12 @@ function BlendAverage(bgColor, fgColor: TColor32): TColor32; function BlendLinearBurn(bgColor, fgColor: TColor32): TColor32; function BlendColorDodge(bgColor, fgColor: TColor32): TColor32; -//CurveFit: this function is based on - -//"An Algorithm for Automatically Fitting Digitized Curves" -//by Philip J. Schneider in "Graphics Gems", Academic Press, 1990 -//Smooths out many very closely positioned points -//tolerance range: 1..10 where 10 == max tolerance. - -function CurveFit(const path: TPathD; closed: Boolean; - tolerance: double; minSegLength: double = 2): TPathD; overload; -function CurveFit(const paths: TPathsD; closed: Boolean; - tolerance: double; minSegLength: double = 2): TPathsD; overload; - implementation uses - {$IFNDEF MSWINDOWS} - {$IFNDEF FPC} + {$IFDEF USING_FMX} Img32.FMX, {$ENDIF} - {$ENDIF} Img32.Transform; const @@ -395,7 +345,7 @@ procedure DrawEdge(img: TImage32; const path: TPathD; p := path; if closePath and not PointsNearEqual(p[0], p[highI], 0.01) then begin - AppendPath(p, p[0]); + AppendToPath(p, p[0]); inc(highI); end; for i := 1 to highI do @@ -596,8 +546,8 @@ procedure DrawShadow(img: TImage32; const polygons: TPathsD; y := depth * y; blurSize := Max(1,Round(depth / 2)); Img32.Vector.InflateRect(rec, Ceil(depth*2), Ceil(depth*2)); - polys := OffsetPath(polygons, -rec.Left, -rec.Top); - shadowPolys := OffsetPath(polys, x, y); + polys := TranslatePath(polygons, -rec.Left, -rec.Top); + shadowPolys := TranslatePath(polys, x, y); RectWidthHeight(rec, w, h); shadowImg := TImage32.Create(w, h); try @@ -631,7 +581,7 @@ procedure DrawGlow(img: TImage32; const polygons: TPathsD; glowImg: TImage32; begin rec := GetBounds(polygons); - glowPolys := OffsetPath(polygons, + glowPolys := TranslatePath(polygons, blurRadius -rec.Left +1, blurRadius -rec.Top +1); Img32.Vector.InflateRect(rec, blurRadius +1, blurRadius +1); RectWidthHeight(rec, w, h); @@ -647,41 +597,6 @@ procedure DrawGlow(img: TImage32; const polygons: TPathsD; end; //------------------------------------------------------------------------------ -procedure TileImage(img: TImage32; const rec: TRect; tile: TImage32); -begin - TileImage(img, rec, tile, tile.Bounds); -end; -//------------------------------------------------------------------------------ - -procedure TileImage(img: TImage32; - const rec: TRect; tile: TImage32; const tileRec: TRect); -var - i, dstW, dstH, srcW, srcH, cnt: integer; - dstRec, srcRec: TRect; -begin - if tile.IsEmpty or IsEmptyRect(tileRec) then Exit; - RectWidthHeight(rec, dstW,dstH); - RectWidthHeight(tileRec, srcW, srcH); - cnt := Ceil(dstW / srcW); - dstRec := Img32.Vector.Rect(rec.Left, rec.Top, - rec.Left + srcW, rec.Top + srcH); - for i := 1 to cnt do - begin - img.Copy(tile, tileRec, dstRec); - Types.OffsetRect(dstRec, srcW, 0); - end; - cnt := Ceil(dstH / srcH) -1; - srcRec := Img32.Vector.Rect(rec.Left, rec.Top, - rec.Right, rec.Top + srcH); - dstRec := srcRec; - for i := 1 to cnt do - begin - Types.OffsetRect(dstRec, 0, srcH); - img.Copy(img, srcRec, dstRec); - end; -end; -//------------------------------------------------------------------------------ - procedure Sharpen(img: TImage32; radius: Integer; amount: Integer); var i: Integer; @@ -1019,7 +934,7 @@ procedure EraseOutsidePath(img: TImage32; const path: TPathD; RectWidthHeight(outsideBounds, w,h); mask := TImage32.Create(w, h); try - p := OffsetPath(path, -outsideBounds.Left, -outsideBounds.top); + p := TranslatePath(path, -outsideBounds.Left, -outsideBounds.top); DrawPolygon(mask, p, fillRule, clBlack32); img.CopyBlend(mask, mask.Bounds, outsideBounds, BlendMask); finally @@ -1039,7 +954,7 @@ procedure EraseOutsidePaths(img: TImage32; const paths: TPathsD; RectWidthHeight(outsideBounds, w,h); mask := TImage32.Create(w, h); try - pp := OffsetPath(paths, -outsideBounds.Left, -outsideBounds.top); + pp := TranslatePath(paths, -outsideBounds.Left, -outsideBounds.top); DrawPolygon(mask, pp, fillRule, clBlack32); img.CopyBlend(mask, mask.Bounds, outsideBounds, BlendMask); finally @@ -1074,14 +989,14 @@ procedure Draw3D(img: TImage32; const polygons: TPathsD; if IsEmptyRect(rec) then Exit; if not ClockwiseRotationIsAnglePositive then angleRads := -angleRads; GetSinCos(angleRads, y, x); - paths := OffsetPath(polygons, -rec.Left, -rec.Top); + paths := TranslatePath(polygons, -rec.Left, -rec.Top); RectWidthHeight(rec, w, h); tmp := TImage32.Create(w, h); try if GetAlpha(colorLt) > 0 then begin tmp.Clear(colorLt); - paths2 := OffsetPath(paths, -height*x, -height*y); + paths2 := TranslatePath(paths, -height*x, -height*y); EraseInsidePaths(tmp, paths2, fillRule); FastGaussianBlur(tmp, tmp.Bounds, Round(blurRadius), 0); EraseOutsidePaths(tmp, paths, fillRule, tmp.Bounds); @@ -1090,7 +1005,7 @@ procedure Draw3D(img: TImage32; const polygons: TPathsD; if GetAlpha(colorDk) > 0 then begin tmp.Clear(colorDk); - paths2 := OffsetPath(paths, height*x, height*y); + paths2 := TranslatePath(paths, height*x, height*y); EraseInsidePaths(tmp, paths2, fillRule); FastGaussianBlur(tmp, tmp.Bounds, Round(blurRadius), 0); EraseOutsidePaths(tmp, paths, fillRule, tmp.Bounds); @@ -1750,7 +1665,7 @@ TSimplifyRec = record end; function SimplifyPath(const path: TPathD; - shapeTolerance: double; isOpenPath: Boolean = false): TPathD; + shapeTolerance: double; isClosedPath: Boolean): TPathD; var i, highI, minLen: integer; tolSqrd: double; @@ -1759,7 +1674,7 @@ function SimplifyPath(const path: TPathD; begin Result := nil; highI := High(path); - if isOpenPath then minLen := 2 else minLen := 3; + if not isClosedPath then minLen := 2 else minLen := 3; if highI +1 < minLen then Exit; @@ -1769,14 +1684,14 @@ function SimplifyPath(const path: TPathD; pt := path[0]; prev := @srArray[highI]; next := @srArray[1]; - if isOpenPath then - begin - pdSqrd := MaxDouble; - isEnd := true; - end else + if isClosedPath then begin pdSqrd := PerpendicularDistSqrd(path[0], path[highI], path[1]); isEnd := false; + end else + begin + pdSqrd := MaxDouble; + isEnd := true; end; end; @@ -1785,14 +1700,14 @@ function SimplifyPath(const path: TPathD; pt := path[highI]; prev := @srArray[highI-1]; next := @srArray[0]; - if isOpenPath then - begin - pdSqrd := MaxDouble; - isEnd := true; - end else + if isClosedPath then begin pdSqrd := PerpendicularDistSqrd(path[highI], path[highI-1], path[0]); isEnd := false; + end else + begin + pdSqrd := MaxDouble; + isEnd := true; end; end; @@ -1831,7 +1746,7 @@ function SimplifyPath(const path: TPathD; end; end; if highI +1 < minLen then Exit; - if isOpenPath then first := @srArray[0]; + if not isClosedPath then first := @srArray[0]; SetLength(Result, highI +1); for i := 0 to HighI do begin @@ -1842,7 +1757,7 @@ function SimplifyPath(const path: TPathD; //------------------------------------------------------------------------------ function SimplifyPaths(const paths: TPathsD; - shapeTolerance: double; isOpenPath: Boolean = false): TPathsD; + shapeTolerance: double; isClosedPath: Boolean): TPathsD; var i,j, len: integer; begin @@ -1851,7 +1766,7 @@ function SimplifyPaths(const paths: TPathsD; j := 0; for i := 0 to len -1 do begin - result[j] := SimplifyPath(paths[i], shapeTolerance, isOpenPath); + result[j] := SimplifyPath(paths[i], shapeTolerance, isClosedPath); if Length(result[j]) > 0 then inc(j); end; SetLength(Result, j); @@ -2034,11 +1949,11 @@ function SmoothToCubicBezier(const path: TPathD; end; if i = 0 then - Result[len*3-1] := OffsetPoint(path[0], -vec.X * d1, -vec.Y * d1) + Result[len*3-1] := TranslatePoint(path[0], -vec.X * d1, -vec.Y * d1) else - Result[i*3-1] := OffsetPoint(path[i], -vec.X * d1, -vec.Y * d1); + Result[i*3-1] := TranslatePoint(path[i], -vec.X * d1, -vec.Y * d1); Result[i*3] := path[i]; - Result[i*3+1] := OffsetPoint(path[i], vec.X * d2, vec.Y * d2); + Result[i*3+1] := TranslatePoint(path[i], vec.X * d2, vec.Y * d2); end; Result[len*3] := path[0]; @@ -2105,11 +2020,11 @@ function SmoothToCubicBezier2(const path: TPathD; end; if i = 0 then - Result[len*3-1] := OffsetPoint(path[0], -vec.X * d1, -vec.Y * d1) + Result[len*3-1] := TranslatePoint(path[0], -vec.X * d1, -vec.Y * d1) else - Result[i*3-1] := OffsetPoint(path[i], -vec.X * d1, -vec.Y * d1); + Result[i*3-1] := TranslatePoint(path[i], -vec.X * d1, -vec.Y * d1); Result[i*3] := path[i]; - Result[i*3+1] := OffsetPoint(path[i], vec.X * d2, vec.Y * d2); + Result[i*3+1] := TranslatePoint(path[i], vec.X * d2, vec.Y * d2); end; Result[len*3] := path[0]; @@ -2133,67 +2048,130 @@ function SmoothToCubicBezier2(const paths: TPathsD; end; //------------------------------------------------------------------------------ -function HermiteInterpolation(y1, y2, y3, y4: double; - mu, tension: double): double; +function Clamp(val, endVal: integer): integer; inline; +begin + if val < 0 then Result := 0 + else if val >= endVal then Result := endVal -1 + else Result := val; +end; +//------------------------------------------------------------------------------ + +function ModEx(val, endVal: integer): integer; inline; +begin + Result := val mod endVal; + if Result < 0 then Result := endVal + Result; +end; +//------------------------------------------------------------------------------ + +function CubicInterpolate(v1, v2, v3, v4: double; + t: double; tension: double = 0): double; var - m0,m1,mu2,mu3: double; - a0,a1,a2,a3: double; + m0, m1, tt, ttt, tensionEx: double; + a, b: double; begin - // http://paulbourke.net/miscellaneous/interpolation/ - // nb: optional bias toward left or right has been disabled. - mu2 := mu * mu; - mu3 := mu2 * mu; - m0 := (y2-y1)*(1-tension)/2; - m0 := m0 + (y3-y2)*(1-tension)/2; - m1 := (y3-y2)*(1-tension)/2; - m1 := m1 + (y4-y3)*(1-tension)/2; - a0 := 2*mu3 - 3*mu2 + 1; - a1 := mu3 - 2*mu2 + mu; - a2 := mu3 - mu2; - a3 := -2*mu3 + 3*mu2; - Result := a0*y2+a1*m0+a2*m1+a3*y3; + tt := t * t; + ttt := tt * t; + tensionEx := (1-tension) * 0.5; + m0 := (v3 - v1)*tensionEx; + m1 := (v4 - v2)*tensionEx; + a := 2*v2 - 2*v3 + m0 + m1; + b := 3*v3 -3*v2 -2*m0 - m1; + Result := a*ttt + b*tt + m0*t + v2; end; //------------------------------------------------------------------------------ -function InterpolateY(const y1,y2,y3,y4: double; - dx: integer; tension: double): TArrayOfDouble; +procedure Append(var path: TPathD; const pt: TPointD); inline; var - i: integer; + len: integer; begin - SetLength(Result, dx); - if dx = 0 then Exit; - Result[0] := y2; - for i := 1 to dx-1 do - Result[i] := HermiteInterpolation(y1,y2,y3,y4, i/dx, tension); + len := Length(path); + SetLength(path, len +1); + path[len] := pt; end; //------------------------------------------------------------------------------ -function InterpolatePoints(const points: TPathD; tension: integer): TPathD; +function SmoothPath(const path: TPathD; isClosedPath: Boolean; + tension: double; shapeTolerance: double): TPathD; var - i, j, len, len2: integer; - p, p2: TPathD; - ys: TArrayOfDouble; + i, j, highI, len, cnt: integer; + pt: TPointD; + dists: TArrayOfDouble; +const + maxInterval = 1.5; begin - if tension < -1 then tension := -1 - else if tension > 1 then tension := 1; Result := nil; - len := Length(points); - if len < 2 then Exit; - SetLength(p, len +2); - p[0] := points[0]; - p[len+1] := points[len -1]; - Move(points[0],p[1], len * SizeOf(TPointD)); - for i := 1 to len-1 do + len := Length(path); + if len < 3 then Exit; + SetLength(dists, len); + highI := len -1; + dists[highI] := Distance(path[highI], path[0]); + for i := 0 to highI-1 do + dists[i] := Distance(path[i], path[i+1]); + + if tension > 1 then tension := 1 + else if tension < -1 then tension := -1; + if tension > 0.9 then begin - ys := InterpolateY(p[i-1].Y,p[i].Y,p[i+1].Y,p[i+2].Y, - Trunc(p[i+1].X - p[i].X), tension); - len2 := Length(ys); - SetLength(p2, len2); - for j := 0 to len2 -1 do - p2[j] := PointD(p[i].X +j, ys[j]); - AppendPath(Result, p2); + Result := path; + Exit; end; - AppendPoint(Result, p[len]); + + if isClosedPath then + for i := 0 to highI do + begin + cnt := Ceil(dists[i]/maxInterval); + Append(Result, path[i]); + for j := 1 to cnt -1 do + begin + pt.X := CubicInterpolate( + path[ModEx(i-1, len)].X, + path[i].X, + path[ModEx(i+1, len)].X, + path[ModEx(i+2, len)].X, j/cnt, tension); + pt.Y := CubicInterpolate( + path[ModEx(i-1, len)].Y, + path[i].Y, + path[ModEx(i+1, len)].Y, + path[ModEx(i+2, len)].Y, j/cnt, tension); + Append(Result, pt); + end; + end + else + begin + for i := 0 to highI -1 do + begin + cnt := Ceil(dists[i]/maxInterval); + Append(Result, path[i]); + for j := 1 to cnt -1 do + begin + pt.X := CubicInterpolate( + path[Clamp(i-1, len)].X, + path[Clamp(i, len)].X, + path[Clamp(i+1, len)].X, + path[Clamp(i+2, len)].X, j/cnt, tension); + pt.Y := CubicInterpolate( + path[Clamp(i-1, len)].Y, + path[Clamp(i, len)].Y, + path[Clamp(i+1, len)].Y, + path[Clamp(i+2, len)].Y, j/cnt, tension); + Append(Result, pt); + end; + end; + Append(Result, path[highi]); + end; + Result := SimplifyPath(Result, shapeTolerance, false); +end; +//------------------------------------------------------------------------------ + +function SmoothPaths(const paths: TPathsD; isClosedPath: Boolean; + tension: double = 0; shapeTolerance: double = 0.1): TPathsD; +var + i, len: integer; +begin + len := Length(paths); + SetLength(Result, len); + for i := 0 to len -1 do + Result[i] := SmoothPath(paths[i], isClosedPath, tension, shapeTolerance); end; //------------------------------------------------------------------------------ @@ -2450,595 +2428,4 @@ procedure FastGaussianBlur(img: TImage32; end; //------------------------------------------------------------------------------ -//------------------------------------------------------------------------------ -// CurveFit() support structures and functions -//------------------------------------------------------------------------------ - -//CurveFit: this function is based on - -//"An Algorithm for Automatically Fitting Digitized Curves" -//by Philip J. Schneider in "Graphics Gems", Academic Press, 1990 -//Smooths out many very closely positioned points -//tolerance range: 1..10 where 10 == max tolerance. - -//This function has been archived as I believe that -//RamerDouglasPeuker(), GetSmoothPath() and FlattenCBezier() -//will usually achieve a better result - -function Scale(const vec: TPointD; newLen: double): TPointD; - {$IFDEF INLINE} inline; {$ENDIF} -begin - Result.X := vec.X * newLen; - Result.Y := vec.Y * newLen; -end; -//------------------------------------------------------------------------------ - -function Mul(const vec: TPointD; val: double): TPointD; - {$IFDEF INLINE} inline; {$ENDIF} -begin - Result.X := vec.X * val; - Result.Y := vec.Y * val; -end; -//------------------------------------------------------------------------------ - -function AddVecs(const vec1, vec2: TPointD): TPointD; - {$IFDEF INLINE} inline; {$ENDIF} -begin - Result.X := vec1.X + vec2.X; - Result.Y := vec1.Y + vec2.Y; -end; -//------------------------------------------------------------------------------ - -function SubVecs(const vec1, vec2: TPointD): TPointD; - {$IFDEF INLINE} inline; {$ENDIF} -begin - Result.X := vec1.X - vec2.X; - Result.Y := vec1.Y - vec2.Y; -end; -//------------------------------------------------------------------------------ - -function NormalizeVec(const vec: TPointD): TPointD; - {$IFDEF INLINE} inline; {$ENDIF} -var - len: double; -begin - len := Sqrt(vec.X * vec.X + vec.Y * vec.Y); - if len <> 0 then - begin - Result.X := vec.X / len; - Result.Y := vec.Y / len; - end else - result := vec; -end; -//------------------------------------------------------------------------------ - -function NormalizeTPt(const pt: PPt): TPointD; - {$IFDEF INLINE} inline; {$ENDIF} -begin - with pt^ do - if len <> 0 then - begin - Result.X := vec.X / len; - Result.Y := vec.Y / len; - end else - result := vec; -end; -//------------------------------------------------------------------------------ - -function NegateVec(vec: TPointD): TPointD; - {$IFDEF INLINE} inline; {$ENDIF} -begin - Result.X := -vec.X; - Result.Y := -vec.Y; -end; -//------------------------------------------------------------------------------ - -function B0(u: double): double; {$IFDEF INLINE} inline; {$ENDIF} -var - tmp: double; -begin - tmp := 1.0 - u; - result := tmp * tmp * tmp; -end; -//------------------------------------------------------------------------------ - -function B1(u: double): double; {$IFDEF INLINE} inline; {$ENDIF} -var - tmp: double; -begin - tmp := 1.0 - u; - result := 3 * u * tmp * tmp; -end; -//------------------------------------------------------------------------------ - -function B2(u: double): double; {$IFDEF INLINE} inline; {$ENDIF} -begin - result := 3 * u * u * (1.0 - u); -end; -//------------------------------------------------------------------------------ - -function B3(u: double): double; {$IFDEF INLINE} inline; {$ENDIF} -begin - result := u * u * u; -end; -//------------------------------------------------------------------------------ - -function TFitCurveContainer.AddPt(const pt: TPointD): PPt; -begin - new(Result); - Result.pt := pt; - if not assigned(ppts) then - begin - Result.prev := Result; - Result.next := Result; - ppts := Result; - end else - begin - Result.prev := ppts.prev; - ppts.prev.next := Result; - ppts.prev := Result; - Result.next := ppts; - end; -end; -//------------------------------------------------------------------------------ - -procedure TFitCurveContainer.Clear; -var - p: PPt; -begin - solution := nil; - ppts.prev.next := nil; //break loop - while assigned(ppts) do - begin - p := ppts; - ppts := ppts.next; - Dispose(p); - end; -end; -//------------------------------------------------------------------------------ - -function TFitCurveContainer.Count(first, last: PPt): integer; -begin - if first = last then - result := 0 else - result := 1; - repeat - inc(Result); - first := first.next; - until (first = last); -end; -//------------------------------------------------------------------------------ - -function TFitCurveContainer.ComputeLeftTangent(p: PPt): TPointD; -begin - Result := NormalizeTPt(p); -end; -//------------------------------------------------------------------------------ - -function TFitCurveContainer.ComputeRightTangent(p: PPt): TPointD; -begin - Result := NegateVec(NormalizeTPt(p.prev)); -end; -//------------------------------------------------------------------------------ - -function TFitCurveContainer.ComputeCenterTangent(p: PPt): TPointD; -var - v1, v2: TPointD; -begin - v1 := SubVecs(p.pt, p.prev.pt); - v2 := SubVecs(p.next.pt, p.pt); - Result := AddVecs(v1, v2); - Result := NormalizeVec(Result); -end; -//------------------------------------------------------------------------------ - -function TFitCurveContainer.ChordLengthParameterize( - first: PPt; cnt: integer): TArrayOfDouble; -var - d: double; - i: integer; -begin - SetLength(Result, cnt); - Result[0] := 0; - d := 0; - for i := 1 to cnt -1 do - begin - d := d + first.len; - Result[i] := d; - first := first.next; - end; - for i := 1 to cnt -1 do - Result[i] := Result[i] / d; -end; -//------------------------------------------------------------------------------ - -function TFitCurveContainer.GenerateBezier(first, last: PPt; cnt: integer; - const u: TArrayOfDouble; const firstTan, lastTan: TPointD): TPathD; -var - i: integer; - p: PPt; - dist, epsilon: double; - v1,v2, tmp: TPointD; - a0, a1: TPathD; - c: array [0..1, 0..1] of double; - x: array [0..1] of double; - det_c0_c1, det_c0_x, det_x_c1, alphaL, alphaR: double; -begin - SetLength(a0, cnt); - SetLength(a1, cnt); - dist := Distance(first.pt, last.pt); - for i := 0 to cnt -1 do - begin - v1 := Scale(firstTan, B1(u[i])); - v2 := Scale(lastTan, B2(u[i])); - a0[i] := v1; - a1[i] := v2; - end; - FillChar(c[0][0], 4 * SizeOf(double), 0); - FillChar(x[0], 2 * SizeOf(double), 0); - p := first; - for i := 0 to cnt -1 do - begin - c[0][0] := c[0][0] + DotProdVecs(a0[i], (a0[i])); - c[0][1] := c[0][1] + DotProdVecs(a0[i], (a1[i])); - c[1][0] := c[0][1]; - c[1][1] := c[1][1] + DotProdVecs(a1[i], (a1[i])); - tmp := SubVecs(p.pt, - AddVecs(Mul(first.pt, B0(u[i])), - AddVecs(Mul(first.pt, B1(u[i])), - AddVecs(Mul(last.pt, B2(u[i])), - Mul(last.pt, B3(u[i])))))); - x[0] := x[0] + DotProdVecs(a0[i], tmp); - x[1] := x[1] + DotProdVecs(a1[i], tmp); - p := p.next; - end; - det_c0_c1 := c[0][0] * c[1][1] - c[1][0] * c[0][1]; - det_c0_x := c[0][0] * x[1] - c[1][0] * x[0]; - det_x_c1 := x[0] * c[1][1] - x[1] * c[0][1]; - if det_c0_c1 = 0 then - alphaL := 0 else - alphaL := det_x_c1 / det_c0_c1; - if det_c0_c1 = 0 then - alphaR := 0 else - alphaR := det_c0_x / det_c0_c1; - //check for unlikely fit - if (alphaL > dist * 2) then alphaL := 0 - else if (alphaR > dist * 2) then alphaR := 0; - epsilon := 1.0e-6 * dist; - SetLength(Result, 4); - Result[0] := first.pt; - Result[3] := last.pt; - if (alphaL < epsilon) or (alphaR < epsilon) then - begin - dist := dist / 3; - Result[1] := AddVecs(Result[0], Scale(firstTan, dist)); - Result[2] := AddVecs(Result[3], Scale(lastTan, dist)); - end else - begin - Result[1] := AddVecs(Result[0], Scale(firstTan, alphaL)); - Result[2] := AddVecs(Result[3], Scale(lastTan, alphaR)); - end; -end; -//------------------------------------------------------------------------------ - -function TFitCurveContainer.Reparameterize(first: PPt; cnt: integer; - const u: TArrayOfDouble; const bezier: TPathD): TArrayOfDouble; -var - i: integer; -begin - SetLength(Result, cnt); - for i := 0 to cnt -1 do - begin - Result[i] := NewtonRaphsonRootFind(bezier, first.pt, u[i]); - first := first.next; - end; -end; -//------------------------------------------------------------------------------ - -function BezierII(degree: integer; const v: array of TPointD; t: double): TPointD; -var - i,j: integer; - tmp: array[0..3] of TPointD; -begin - Move(v[0], tmp[0], degree * sizeOf(TPointD)); - for i := 1 to degree do - for j := 0 to degree - i do - begin - tmp[j].x := (1.0 - t) * tmp[j].x + t * tmp[j+1].x; - tmp[j].y := (1.0 - t) * tmp[j].y + t * tmp[j+1].y; - end; - Result := tmp[0]; -end; -//------------------------------------------------------------------------------ - -function TFitCurveContainer.ComputeMaxErrorSqrd(first, last: PPt; - const bezier: TPathD; const u: TArrayOfDouble; - out SplitPoint: PPt): double; -var - i: integer; - distSqrd: double; - pt: TPointD; - p: PPt; -begin - Result := 0; - i := 1; - SplitPoint := first.next; - p := first.next; - while p <> last do - begin - pt := BezierII(3, bezier, u[i]); - distSqrd := DistanceSqrd(pt, p.pt); - if (distSqrd >= Result) then - begin - Result := distSqrd; - SplitPoint := p; - end; - inc(i); - p := p.next; - end; -end; -//------------------------------------------------------------------------------ - -function TFitCurveContainer.NewtonRaphsonRootFind(const q: TPathD; - const pt: TPointD; u: double): double; -var - numerator, denominator: double; - qu, q1u, q2u: TPointD; - q1: array[0..2] of TPointD; - q2: array[0..1] of TPointD; -begin - q1[0].x := (q[1].x - q[0].x) * 3.0; - q1[0].y := (q[1].y - q[0].y) * 3.0; - q1[1].x := (q[2].x - q[1].x) * 3.0; - q1[1].y := (q[2].y - q[1].y) * 3.0; - q1[2].x := (q[3].x - q[2].x) * 3.0; - q1[2].y := (q[3].y - q[2].y) * 3.0; - q2[0].x := (q1[1].x - q1[0].x) * 2.0; - q2[0].y := (q1[1].y - q1[0].y) * 2.0; - q2[1].x := (q1[2].x - q1[1].x) * 2.0; - q2[1].y := (q1[2].y - q1[1].y) * 2.0; - qu := BezierII(3, q, u); - q1u := BezierII(2, q1, u); - q2u := BezierII(1, q2, u); - numerator := (qu.x - pt.x) * (q1u.x) + (qu.y - pt.y) * (q1u.y); - denominator := (q1u.x) * (q1u.x) + (q1u.y) * (q1u.y) + - (qu.x - pt.x) * (q2u.x) + (qu.y - pt.y) * (q2u.y); - if (denominator = 0) then - Result := u else - Result := u - (numerator / denominator); -end; -//------------------------------------------------------------------------------ - -function TFitCurveContainer.FitCubic(first, last: PPt; - firstTan, lastTan: TPointD): Boolean; -var - i, cnt: integer; - splitPoint: PPt; - centerTan: TPointD; - bezier: TPathD; - clps, uPrime: TArrayOfDouble; - maxErrorSqrd: double; -const - maxRetries = 4; -begin - Result := true; - cnt := Count(first, last); - if cnt = 2 then - begin - SetLength(bezier, 4); - bezier[0] := first.pt; - bezier[3] := last.pt; - bezier[1] := bezier[0]; - bezier[2] := bezier[3]; - AppendSolution(bezier); - Exit; - end - else if cnt = 3 then - begin - if TurnsLeft(first.prev.pt, first.pt, first.next.pt) = - TurnsLeft(first.pt, first.next.pt, last.pt) then - firstTan := ComputeCenterTangent(first); - if TurnsLeft(last.prev.pt, last.pt, last.next.pt) = - TurnsLeft(first.pt, first.next.pt, last.pt) then - lastTan := NegateVec(ComputeCenterTangent(last)); - end; - - clps := ChordLengthParameterize(first, cnt); - bezier := GenerateBezier(first, last, cnt, clps, firstTan, lastTan); - maxErrorSqrd := ComputeMaxErrorSqrd(first, last, bezier, clps, splitPoint); - if (maxErrorSqrd < tolSqrd) then - begin - AppendSolution(bezier); - Exit; - end; - if (maxErrorSqrd < tolSqrd * 4) then //close enough to try again - begin - for i := 1 to maxRetries do - begin - uPrime := Reparameterize(first, cnt, clps, bezier); - bezier := GenerateBezier(first, last, cnt, uPrime, firstTan, lastTan); - maxErrorSqrd := - ComputeMaxErrorSqrd(first, last, bezier, uPrime, splitPoint); - if (maxErrorSqrd < tolSqrd) then - begin - AppendSolution(bezier); - Exit; - end; - clps := uPrime; - end; - end; - //We need to break the curve because it's too complex for a single Bezier. - //If we're changing direction then make this a 'hard' break (see below). - if TurnsLeft(splitPoint.prev.prev.pt, splitPoint.prev.pt, splitPoint.pt) <> - TurnsLeft(splitPoint.prev.pt, splitPoint.pt, splitPoint.next.pt) then - begin - centerTan := ComputeRightTangent(splitPoint); - FitCubic(first, splitPoint, firstTan, centerTan); - centerTan := ComputeLeftTangent(splitPoint); - FitCubic(splitPoint, last, centerTan, lastTan); - end else - begin - centerTan := ComputeCenterTangent(splitPoint); - FitCubic(first, splitPoint, firstTan, NegateVec(centerTan)); - FitCubic(splitPoint, last, centerTan, lastTan); - end; -end; -//------------------------------------------------------------------------------ - -function HardBreakCheck(ppt: PPt; compareLen: double): Boolean; -var - q: double; -const - longLen = 15; -begin - //A 'break' means starting a new Bezier. A 'hard' break avoids smoothing - //whereas a 'soft' break will still be smoothed. There is as much art as - //science in determining where to smooth and where not to. For example, - //long edges should generally remain straight but how long does an edge - //have to be to be considered a 'long' edge? - if (ppt.prev.len * 4 < ppt.len) or (ppt.len * 4 < ppt.prev.len) then - begin - //We'll hard break whenever there's significant asymmetry between - //segment lengths because GenerateBezier() will perform poorly. - result := true; - end - else if ((ppt.prev.len > longLen) and (ppt.len > longLen)) then - begin - //hard break long segments only when turning by more than ~45 degrees - q := (Sqr(ppt.prev.len) + Sqr(ppt.len) - DistanceSqrd(ppt.prev.pt, ppt.next.pt)) / - (2 * ppt.prev.len * ppt.len); //Cosine Rule. - result := (1 - abs(q)) > 0.3; - end - else if ((TurnsLeft(ppt.prev.prev.pt, ppt.prev.pt, ppt.pt) = - TurnsRight(ppt.prev.pt, ppt.pt, ppt.next.pt)) and - (ppt.prev.len > compareLen) and (ppt.len > compareLen)) then - begin - //we'll also hard break whenever there's a significant inflection point - result := true; - end else - begin - //Finally, we'll also force a 'hard' break when there's a significant bend. - //Again uses the Cosine Rule. - q :=(Sqr(ppt.prev.len) + Sqr(ppt.len) - - DistanceSqrd(ppt.prev.pt, ppt.next.pt)) / (2 * ppt.prev.len * ppt.len); - Result := (q > -0.2); //ie more than 90% - end; -end; -//------------------------------------------------------------------------------ - -function TFitCurveContainer.FitCurve(const path: TPathD; - closed: Boolean; tolerance: double; minSegLength: double): TPathD; -var - i, highI: integer; - d: double; - p, p2, pEnd: PPt; -begin - //tolerance: specifies the maximum allowed variance between the existing - //vertices and the new Bezier curves. More tolerance will produce - //fewer Beziers and simpler paths, but at the cost of less precison. - tolSqrd := Sqr(Max(1, Min(10, tolerance))); //range 1..10 - //minSegLength: Typically when vectorizing raster images, the produced - //vector paths will have many series of axis aligned segments that trace - //pixel boundaries. These paths will also contain many 1 unit segments at - //right angles to adjacent segments. Importantly, these very short segments - //will cause artifacts in the solution unless they are trimmed. - highI := High(path); - if closed then - while (highI > 0) and (Distance(path[highI], path[0]) < minSegLength) do - dec(highI); - p := AddPt(path[0]); - for i := 1 to highI do - begin - d := Distance(p.pt, path[i]); - //skip line segments with lengths less than 'minSegLength' - if d < minSegLength then Continue; - p := AddPt(path[i]); - p.prev.len := d; - p.prev.vec := SubVecs(p.pt, p.prev.pt); - end; - p.len := Distance(ppts.pt, p.pt); - p.vec := SubVecs(p.next.pt, p.pt); - p := ppts; - if (p.next = p) or (closed and (p.next = p.prev)) then - begin - Clear; - result := nil; - Exit; - end; - //for closed paths, find a good starting point - if closed then - begin - repeat - if HardBreakCheck(p, tolerance) then break; - p := p.next; - until p = ppts; - pEnd := p; - end else - pEnd := ppts.prev; - p2 := p.next; - repeat - if HardBreakCheck(p2, tolerance) then - begin - FitCubic(p, p2, ComputeLeftTangent(p), ComputeRightTangent(p2)); - p := p2; - end; - p2 := p2.next; - until (p2 = pEnd); - FitCubic(p, p2, ComputeLeftTangent(p), ComputeRightTangent(p2)); - Result := solution; - Clear; -end; -//------------------------------------------------------------------------------ - -procedure TFitCurveContainer.AppendSolution(const bezier: TPathD); -var - i, len: integer; -begin - len := Length(solution); - if len > 0 then - begin - SetLength(solution, len + 3); - for i := 0 to 2 do - solution[len +i] := bezier[i +1]; - end else - solution := bezier; -end; -//------------------------------------------------------------------------------ - -function CurveFit(const path: TPathD; closed: Boolean; - tolerance: double; minSegLength: double): TPathD; -var - paths, solution: TPathsD; -begin - SetLength(paths, 1); - paths[0] := path; - solution := CurveFit(paths, closed, tolerance, minSegLength); - if solution <> nil then - Result := solution[0]; -end; -//------------------------------------------------------------------------------ - -function CurveFit(const paths: TPathsD; closed: Boolean; - tolerance: double; minSegLength: double): TPathsD; -var - i,j, len: integer; -begin - j := 0; - len := Length(paths); - SetLength(Result, len); - with TFitCurveContainer.Create do - try - for i := 0 to len -1 do - if (paths[i] <> nil) and (Abs(Area(paths[i])) > Sqr(tolerance)) then - begin - Result[j] := FitCurve(paths[i], closed, tolerance, minSegLength); - inc(j); - end; - finally - Free; - end; - SetLength(Result, j); -end; -//------------------------------------------------------------------------------ - - end. diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Fmt.BMP.pas b/Ext/SVGIconImageList/Image32/source/Img32.Fmt.BMP.pas index 6612c58..c1c0837 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.Fmt.BMP.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.Fmt.BMP.pas @@ -3,9 +3,9 @@ (******************************************************************************* * Author : Angus Johnson * * Version : 4.4 * -* Date : 12 October 2023 * +* Date : 28 March 2024 * * Website : http://www.angusj.com * -* Copyright : Angus Johnson 2019-2023 * +* Copyright : Angus Johnson 2010-2024 * * Purpose : BMP file format extension for TImage32 * * License : http://www.boost.org/LICENSE_1_0.txt * *******************************************************************************) @@ -487,7 +487,7 @@ function TImageFormat_BMP.LoadFromStream(stream: TStream; isTopDown := bih.biHeight < 0; bih.biHeight := abs(bih.biHeight); - if (bih.biBitCount < 32) and + if //(bih.biBitCount < 32) and ((bih.biCompression and BI_BITFIELDS) = BI_BITFIELDS) then begin stream.Position := bihStart + 40; @@ -536,16 +536,14 @@ function TImageFormat_BMP.LoadFromStream(stream: TStream; //read pixels .... if stream.Position < bfh.bfOffBits then stream.Position := bfh.bfOffBits; - if (bih.biBitCount = 32) then + if hasValidBitFields then + tmp := StreamReadImageWithBitfields( + stream, img32.Width, img32.Height, bih.biBitCount, bitfields) + else if (bih.biBitCount = 32) then begin Read(img32.Pixels[0], bih.biWidth * bih.biHeight * sizeof(TColor32)); if AlphaChannelAllZero(img32) then ResetAlphaChannel(img32); end - - else if hasValidBitFields then - tmp := StreamReadImageWithBitfields( - stream, img32.Width, img32.Height, bih.biBitCount, bitfields) - else if (bih.biCompression = BI_RLE8) or (bih.biCompression = BI_RLE4) then tmp := ReadRLE4orRLE8Compression( stream, img32.Width, img32.Height, bih.biBitCount, pal) diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Fmt.SVG.pas b/Ext/SVGIconImageList/Image32/source/Img32.Fmt.SVG.pas index 0c6666c..2166d71 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.Fmt.SVG.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.Fmt.SVG.pas @@ -3,9 +3,9 @@ (******************************************************************************* * Author : Angus Johnson * * Version : 4.4 * -* Date : 22 October 2023 * +* Date : 11 March 2024 * * Website : http://www.angusj.com * -* Copyright : Angus Johnson 2019-2023 * +* Copyright : Angus Johnson 2019-2024 * * Purpose : SVG file format extension for TImage32 * * License : http://www.boost.org/LICENSE_1_0.txt * *******************************************************************************) @@ -91,101 +91,8 @@ TSvgImageList32 = class(TInterfacedObj, INotifySender) {$ENDIF} end; -function GetImageSize(const filename: string): TSize; - -var - defaultSvgWidth: integer = 800; - defaultSvgHeight: integer = 600; - implementation -function GetImageSize(const filename: string): TSize; -var - i,j, l,t,r,b: integer; - s: AnsiString; - ms: TMemoryStream; - - function GetValAndIgnoreFracs(var i: integer): integer; - begin - Result := 0; - while (s[i] >= '0') and (s[i] <= '9') do - begin - Result := Result * 10 + Ord(s[i]) - Ord('0'); - inc(i); - end; - - // ignore fractions - if s[i] <> '.' then Exit; - inc(i); - while (s[i] >= '0') and (s[i] <= '9') do inc(i); - end; - -begin - // this is quick and dirty code that - // needs to be made much more reliable - FillChar(Result.cx, SizeOf(TSize), 0); - if not FileExists(filename) then Exit; - ms := TMemoryStream.Create; - try - ms.LoadFromFile(filename); - ConvertUnicodeToUtf8(ms); - {$IFDEF UNICODE} - s := AnsiStrings.StrPas(ms.Memory); - {$ELSE} - s := StrPas(ms.Memory); - {$ENDIF} - finally - ms.Free; - end; - {$IFDEF UNICODE} - i := AnsiStrings.PosEx('', s, i); //watch out for inside '>' - {$ELSE} - j := PosEx('>', s, i); - {$ENDIF} - - if j < i then Exit; - s := Lowercase(Copy(s, i + 5, j - i -5)); - {$IFDEF UNICODE} - i := AnsiStrings.PosEx('width="', s); //watch out for space before = - j := AnsiStrings.PosEx('height="', s); - {$ELSE} - i := PosEx('width="', s); //watch out for space before = - j := PosEx('height="', s); - {$ENDIF} - if (i > 0) and (j > 0) then - begin - inc(i,7); - Result.cx := GetValAndIgnoreFracs(i); - inc(j,8); - Result.cy := GetValAndIgnoreFracs(j); - end else - begin - {$IFDEF UNICODE} - i := AnsiStrings.PosEx('viewbox="', s); - {$ELSE} - i := PosEx('viewbox="', s); - {$ENDIF} - if i < 1 then Exit; - inc(i, 9); - l := GetValAndIgnoreFracs(i); - while (s[i] <= #32) do inc(i); - t := GetValAndIgnoreFracs(i); - while (s[i] <= #32) do inc(i); - r := GetValAndIgnoreFracs(i); - while (s[i] <= #32) do inc(i); - b := GetValAndIgnoreFracs(i); - Result.cx := r - l; - Result.cy := b - t; - end; -end; - //------------------------------------------------------------------------------ // Three routines used to enumerate a resource type //------------------------------------------------------------------------------ @@ -463,32 +370,23 @@ function TImageFormat_SVG.LoadFromStream(stream: TStream; img32: TImage32; imgIndex: integer = 0): Boolean; var r: TRectWH; - w,h, sx,sy: double; + sx: double; begin with TSvgReader.Create do try Result := LoadFromStream(stream); if not Result then Exit; - r := GetViewbox(img32.Width, img32.Height); + r := RootElement.GetViewbox; img32.BeginUpdate; try if img32.IsEmpty and not r.IsEmpty then img32.SetSize(Round(r.Width), Round(r.Height)) else if not r.IsEmpty then begin - //then scale the SVG to fit image - w := r.Width; - h := r.Height; - sx := img32.Width / w; - sy := img32.Height / h; - if sy < sx then sx := sy; - if not(SameValue(sx, 1, 0.00001)) then - begin - w := w * sx; - h := h * sx; - end; - img32.SetSize(Round(w), Round(h)); + // scale the SVG to best fit the image dimensions + sx := GetScaleForBestFit(r.Width, r.Height, img32.Width, img32.Height); + img32.SetSize(Round(r.Width * sx), Round(r.Height * sx)); end else img32.SetSize(defaultSvgWidth, defaultSvgHeight); diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Layers.pas b/Ext/SVGIconImageList/Image32/source/Img32.Layers.pas index 7a846ee..c91b417 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.Layers.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.Layers.pas @@ -2,16 +2,12 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 4.3 * -* Date : 3 September 2023 * +* Version : 4.4 * +* Date : 16 April 2024 * * Website : http://www.angusj.com * -* Copyright : Angus Johnson 2019-2023 * -* * +* Copyright : Angus Johnson 2019-2024 * * Purpose : Layered images support * -* * -* License : Use, modification & distribution is subject to * -* Boost Software License Ver 1 * -* http://www.boost.org/LICENSE_1_0.txt * +* License : http://www.boost.org/LICENSE_1_0.txt * *******************************************************************************) interface @@ -254,26 +250,22 @@ TVectorLayer32 = class(TRotLayer32) property OnDraw: TNotifyEvent read fOnDraw write fOnDraw; end; - TRasterLayer32 = class(TRotLayer32) //display laer for raster images + TRasterLayer32 = class(TRotLayer32) //display layer for raster images private fMasterImg : TImage32; //fMatrix: allows combining any number of scaling & rotating ops. fMatrix : TMatrixD; fRotating : Boolean; - fSavedMidPt : TPointD; fPreScaleSize : TSize; fAutoHitTest : Boolean; procedure DoAutoHitTest; - function GetMatrix: TMatrixD; protected procedure ImageChanged(Sender: TImage32); override; - procedure SetPivotPt(const pivot: TPointD); override; procedure UpdateHitTestMaskTranspar(compareFunc: TCompareFunction; referenceColor: TColor32; tolerance: integer); public constructor Create(parent: TLayer32 = nil; const name: string = ''); override; destructor Destroy; override; - procedure Offset(dx,dy: double); override; procedure UpdateHitTestMaskOpaque; virtual; procedure UpdateHitTestMaskTransparent(alphaValue: Byte = 127); overload; virtual; procedure SetInnerBounds(const newBounds: TRectD); override; @@ -281,7 +273,6 @@ TRasterLayer32 = class(TRotLayer32) //display laer for raster images property AutoSetHitTestMask: Boolean read fAutoHitTest write fAutoHitTest; property MasterImage: TImage32 read fMasterImg; - property Matrix: TMatrixD read GetMatrix; end; TButtonDesignerLayer32 = class; @@ -466,11 +457,9 @@ function UpdateRotatingButtonGroup(rotateButton: TLayer32): double; implementation - {$IFNDEF MSWINDOWS} - {$IFNDEF FPC} + {$IFDEF USING_FMX} uses Img32.FMX; {$ENDIF} - {$ENDIF} resourcestring rsRoot = 'root'; @@ -726,17 +715,10 @@ function TLayer32.GetPrevLayerInGroup: TLayer32; //------------------------------------------------------------------------------ procedure TLayer32.ImageChanged(Sender: TImage32); -var - w,h: integer; begin if (StorageState = ssLoading) then Exit; - w := Ceil(fLeft + fWidth + fOuterMargin *2); - h := Ceil(fTop + fHeight + fOuterMargin *2); - if (Image.Width <> w) or (Image.Height <> h) then - begin - fWidth := Image.Width -fOuterMargin *2; - fHeight := Image.Height -fOuterMargin *2; - end; + fWidth := Image.Width -fOuterMargin *2; + fHeight := Image.Height -fOuterMargin *2; Invalidate; end; //------------------------------------------------------------------------------ @@ -747,8 +729,8 @@ procedure TLayer32.SetSize(width, height: double); begin if StorageState = ssDestroying then Exit; fWidth := width; fHeight := height; - w := Ceil(fLeft + fWidth + fOuterMargin *2); - h := Ceil(fTop + fHeight + fOuterMargin *2); + w := Ceil(fWidth + fOuterMargin *2); + h := Ceil(fHeight + fOuterMargin *2); Image.SetSize(w, h); end; //------------------------------------------------------------------------------ @@ -821,8 +803,7 @@ procedure TLayer32.PositionCenteredAt(const pt: TPointD); procedure TLayer32.Offset(dx, dy: double); begin - if (dx <> 0) or (dy <> 0) then - PositionAt(fLeft + dx, fTop + dy); + PositionAt(fLeft + dx, fTop + dy); end; //------------------------------------------------------------------------------ @@ -976,7 +957,7 @@ function TLayer32.MakeAbsolute(const pt: TPointD): TPointD; while assigned(layer) do begin if not (layer is TGroupLayer32) then - Result := OffsetPoint(Result, layer.Left, layer.Top); + Result := TranslatePoint(Result, layer.Left, layer.Top); layer := layer.Parent; end; end; @@ -1128,7 +1109,7 @@ procedure TLayer32.SetClipPath(const path: TPathsD); if Assigned(fClipImage) then fClipImage.SetSize(Image.Width, Image.Height) else fClipImage := TImage32.Create(Image.Width, Image.Height); - pp := OffsetPath(path, fOuterMargin, fOuterMargin); + pp := TranslatePath(path, fOuterMargin, fOuterMargin); DrawPolygon(fClipImage, pp, frEvenOdd, clWhite32); end else FreeAndNil(fClipImage); @@ -1194,7 +1175,7 @@ procedure TLayer32.Merge(hideDesigners: Boolean; updateRect: TRect); //that fMergeImage will then merge with its parent fMergeImage until root. if not (self is TGroupLayer32) then - Types.OffsetRect(updateRect, -Floor(fLeft), -Floor(fTop)); + TranslateRect(updateRect, -Floor(fLeft), -Floor(fTop)); if (self is TGroupLayer32) or (ChildCount = 0) then begin @@ -1236,7 +1217,7 @@ procedure TLayer32.Merge(hideDesigners: Boolean; updateRect: TRect); //childs of group layers are positioned //independently of the group layer's positioning if (self is TGroupLayer32) then - Types.OffsetRect(dstRect, Floor(-self.Left), Floor(-self.Top)); + TranslateRect(dstRect, Floor(-self.Left), Floor(-self.Top)); Types.IntersectRect(dstRect, dstRect, self.Image.Bounds); end; @@ -1251,9 +1232,9 @@ procedure TLayer32.Merge(hideDesigners: Boolean; updateRect: TRect); end; if (self is TGroupLayer32) then - Types.OffsetRect(srcRect, Floor(fLeft), Floor(fTop)) + TranslateRect(srcRect, Floor(fLeft), Floor(fTop)) else //nb: offsetting **dstRect** below - Types.OffsetRect(dstRect, + TranslateRect(dstRect, Round(fOuterMargin), Round(fOuterMargin)); //DRAW THE CHILD ONTO THE PARENT'S IMAGE @@ -1270,7 +1251,7 @@ procedure TLayer32.Merge(hideDesigners: Boolean; updateRect: TRect); //use the clipping mask to 'trim' childLayer's image rec := fClipImage.Bounds; rec2 := rec; - Types.OffsetRect(rec2, + TranslateRect(rec2, Floor(childLayer.fOuterMargin -childLayer.Left -fOuterMargin), Floor(childLayer.fOuterMargin -childLayer.Top -fOuterMargin)); childImg2.CopyBlend(fClipImage, rec, rec2, BlendMask); @@ -1307,7 +1288,7 @@ function TLayer32.GetLayerAt(const pt: TPointD; ignoreDesigners: Boolean): TLaye if (self is TGroupLayer32) then pt2 := pt else - pt2 := OffsetPoint(pt, -Left, -Top); + pt2 := TranslatePoint(pt, -Left, -Top); //if 'pt2' is outside the clip mask then don't continue if Assigned(fClipImage) then @@ -1660,9 +1641,9 @@ procedure TVectorLayer32.SetInnerBounds(const newBounds: TRectD); procedure TVectorLayer32.Offset(dx,dy: double); begin inherited; - fPaths := OffsetPath(fPaths, dx,dy); + fPaths := TranslatePath(fPaths, dx,dy); if fAutoPivot and not PointsEqual(fPivotPt, InvalidPointD) then - fPivotPt := OffsetPoint(fPivotPt, dx,dy); + fPivotPt := TranslatePoint(fPivotPt, dx,dy); end; //------------------------------------------------------------------------------ @@ -1804,20 +1785,6 @@ procedure TRasterLayer32.ImageChanged(Sender: TImage32); end; //------------------------------------------------------------------------------ -procedure TRasterLayer32.Offset(dx,dy: double); -begin - inherited; - fSavedMidPt := OffsetPoint(fSavedMidPt, dx,dy); -end; -//------------------------------------------------------------------------------ - -procedure TRasterLayer32.SetPivotPt(const pivot: TPointD); -begin - inherited; - fSavedMidPt := MidPoint; -end; -//------------------------------------------------------------------------------ - procedure TRasterLayer32.SetInnerBounds(const newBounds: TRectD); var newWidth, newHeight: double; @@ -1826,28 +1793,30 @@ procedure TRasterLayer32.SetInnerBounds(const newBounds: TRectD); if fRotating and Assigned(Image) then begin + //rotation has just ended fRotating := false; - //rotation has just ended so add the rotation angle to fMatrix + //update fMatrix with the new rotation angle if (fAngle <> 0) then MatrixRotate(fMatrix, Image.MidPoint, fAngle); - fAngle := 0; + //and since we're about to start scaling, we need //to store the starting size, and reset the angle fPreScaleSize := Size(Image.Width, Image.Height); + fAngle := 0; end; newWidth := newBounds.Width; newHeight := newBounds.Height; //make sure the image is large enough to scale safely - if (MasterImage.Width > 1) and (MasterImage.Height > 1) and - (newWidth > 1) and (newHeight > 1) then + if not MasterImage.IsEmpty and (newWidth > 1) and (newHeight > 1) then begin Image.BeginUpdate; try Image.Assign(MasterImage); //apply any prior transformations - AffineTransformImage(Image, fMatrix); + Image.Resampler := rWeightedBilinear; + AffineTransformImage(Image, fMatrix, true); // assumes no skew //cropping is very important with rotation SymmetricCropTransparent(Image); w := Ceil(newBounds.Right) - Floor(newBounds.Left); @@ -1863,31 +1832,20 @@ procedure TRasterLayer32.SetInnerBounds(const newBounds: TRectD); end; //------------------------------------------------------------------------------ -function TRasterLayer32.GetMatrix: TMatrixD; -begin - Result := fMatrix; - //update for transformations not yet unapplied to fMatrix - if fRotating then - begin - if fAngle <> 0 then - MatrixRotate(Result, MidPoint, fAngle); - end else - begin - MatrixScale(Result, Image.Width/fPreScaleSize.cx, - Image.Height/fPreScaleSize.cy); - end; -end; -//------------------------------------------------------------------------------ - function TRasterLayer32.Rotate(angleDelta: double): Boolean; var mat: TMatrixD; + pt, mp: TPointD; begin - Result := not MasterImage.IsEmpty and + Result := (angleDelta <> 0) and + not MasterImage.IsEmpty and inherited Rotate(angleDelta); + if not Result then Exit; - //if not already rotating, then update scaling in fMatrix + mp := MidPoint; + + //if not already rotating, then update fMatrix with prior scaling if not fRotating then begin Assert((fPreScaleSize.cx > 0) and (fPreScaleSize.cy > 0), 'oops!'); @@ -1896,25 +1854,26 @@ function TRasterLayer32.Rotate(angleDelta: double): Boolean; Image.Height/fPreScaleSize.cy); fRotating := true; - fSavedMidPt := MidPoint; - if fAutoPivot then fPivotPt := fSavedMidPt; + if fAutoPivot then fPivotPt := mp; end; - if not fAutoPivot then - RotatePoint(fSavedMidPt, PivotPt, angleDelta); + RotatePoint(mp, PivotPt, angleDelta); - Image.BeginUpdate; + Image.BlockNotify; try Image.Assign(MasterImage); mat := fMatrix; - MatrixRotate(mat, NullPointD, Angle); - AffineTransformImage(Image, mat); - SymmetricCropTransparent(Image); + pt := PointD(PivotPt.X - fLeft, PivotPt.Y - fTop); + MatrixRotate(mat, pt, Angle); + Image.Resampler := rWeightedBilinear; + AffineTransformImage(Image, mat, true); // assumes no skew finally - Image.EndUpdate; + Image.UnblockNotify; end; - PositionCenteredAt(fSavedMidPt); + fWidth := Image.Width; + fHeight := Image.Height; + PositionCenteredAt(mp); DoAutoHitTest; end; @@ -1958,7 +1917,7 @@ procedure TRotatingGroupLayer32.Init(const rec: TRect; begin SetInnerBounds(rec2); q := DPIAware(2); - pt := OffsetPoint(pivot, -Left, -Top); + pt := TranslatePoint(pivot, -Left, -Top); DrawDashedLine(Image, Circle(pt, dist - q), dashes, nil, q, clRed32, esPolygon); end; @@ -2663,7 +2622,7 @@ function UpdateRotatingButtonGroup(rotateButton: TLayer32): double; rec := RectD(mp.X -radius, mp.Y -radius, mp.X +radius,mp.Y +radius); designer := DesignLayer; designer.SetInnerBounds(rec); - pt2 := OffsetPoint(mp, -rec.Left, -rec.Top); + pt2 := TranslatePoint(mp, -rec.Left, -rec.Top); DrawDashedLine(designer.Image, Circle(pt2, radius -dpiAwareOne), dashes, nil, DPIAware(2), clRed32, esPolygon); diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Panels.pas b/Ext/SVGIconImageList/Image32/source/Img32.Panels.pas index 74fbe09..8083609 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.Panels.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.Panels.pas @@ -3,9 +3,9 @@ (******************************************************************************* * Author : Angus Johnson * * Version : 4.4 * -* Date : 26 March 2023 * +* Date : 24 April 2024 * * Website : http://www.angusj.com * -* Copyright : Angus Johnson 2019-2021 * +* Copyright : Angus Johnson 2019-2024 * * Purpose : Component that displays images on a TPanel descendant * * License : http://www.boost.org/LICENSE_1_0.txt * *******************************************************************************) @@ -207,7 +207,7 @@ procedure Register; implementation uses - Img32.Extra; + Img32.Extra, Img32.Vector; procedure Register; begin @@ -325,13 +325,6 @@ function GetThemeColor(const className: widestring; end; //------------------------------------------------------------------------------ -function OffsetPoint(const pt: TPoint; dx, dy: integer): TPoint; -begin - Result.X := pt.X + dx; - Result.Y := pt.Y + dy; -end; -//------------------------------------------------------------------------------ - function LeftMouseBtnDown: Boolean; begin Result := (GetKeyState(VK_LBUTTON) shr 8 > 0); @@ -422,7 +415,7 @@ procedure TBaseImgPanel.WMSize(var Message: TWMSize); function TBaseImgPanel.GetDstOffset: TPoint; begin if not fAutoCenter then - Result := Point(0,0) + Result := Types.Point(0,0) else with GetInnerClientRect do begin @@ -491,7 +484,7 @@ procedure TBaseImgPanel.ScaleToFit; h,w: integer; begin if IsEmpty then Exit; - fScale := 1; + //fScale := 1; fScrollbarHorz.srcOffset := 0; fScrollbarVert.srcOffset := 0; rec := GetInnerClientRect; @@ -521,7 +514,7 @@ procedure TBaseImgPanel.ScaleAtPoint(scaleDelta: double; const pt: TPoint); q := 1 - 1/scaleDelta; marg := GetInnerMargin; pt1 := ClientToImage(pt); - pt2 := ClientToImage(Point(marg, marg)); + pt2 := ClientToImage(Types.Point(marg, marg)); SetScale(fScale * scaleDelta); with fScrollbarHorz do inc(srcOffset, Round((pt1.X - pt2.X) * q)); @@ -726,7 +719,7 @@ function TBaseImgPanel.RecenterImageAt(const imagePt: TPoint): Boolean; innerW := ClientWidth - marg*2; innerH := ClientHeight - marg*2; pt1 := imagePt; - pt2 := ClientToImage(Point(marg + innerW div 2, marg + innerH div 2)); + pt2 := ClientToImage(Types.Point(marg + innerW div 2, marg + innerH div 2)); with fScrollbarHorz do begin q := (pt1.X - pt2.X); @@ -781,7 +774,7 @@ procedure TBaseImgPanel.MouseMove(Shift: TShiftState; X, Y: Integer); inDrawRegion: Boolean; begin rec := GetInnerClientRect; - inDrawRegion := PtInRect(rec, Point(X,Y)); + inDrawRegion := PtInRect(rec, Types.Point(X,Y)); if inDrawRegion and not (fScrollbarHorz.MouseDown or fScrollbarVert.MouseDown) then begin @@ -934,8 +927,8 @@ procedure TBaseImgPanel.Paint; Canvas.Pen.Width := 1; while width > 0 do begin - tr := Point(rec.Right, rec.Top); - bl := Point(rec.Left, rec.Bottom); + tr := Types.Point(rec.Right, rec.Top); + bl := Types.Point(rec.Left, rec.Bottom); Canvas.Pen.Color := tlColor; Canvas.PolyLine([bl, rec.TopLeft, tr]); Canvas.Pen.Color := brColor; @@ -969,7 +962,7 @@ procedure TBaseImgPanel.Paint; dpiAwareBW := DpiAware(BorderWidth); dstRec := innerRec; srcRec := dstRec; - OffsetRect(srcRec, -marg, -marg); + TranslateRect(srcRec, -marg, -marg); ScaleRect(srcRec, 1/fScale); //if the scaled drawing is smaller than InnerClientRect then center it pt := GetDstOffset; @@ -996,7 +989,7 @@ procedure TBaseImgPanel.Paint; fScrollbarVert.srcOffset := Round(fScrollbarVert.maxSrcOffset); if fScrollbarHorz.srcOffset > fScrollbarHorz.maxSrcOffset then fScrollbarHorz.srcOffset := Round(fScrollbarHorz.maxSrcOffset); - OffsetRect(srcRec, fScrollbarHorz.srcOffset, fScrollbarVert.srcOffset); + TranslateRect(srcRec, fScrollbarHorz.srcOffset, fScrollbarVert.srcOffset); //paint innerRec background backgroundPainted := ParentBackground and {$IFDEF STYLESERVICES} @@ -1202,7 +1195,7 @@ procedure TBaseImgPanel.WMKeyDown(var Message: TWMKey); begin if not fAllowZoom then Exit; //zoom in and out with CTRL+UP and CTRL+DOWN respectively - midPoint := Point(ClientWidth div 2, ClientHeight div 2); + midPoint := Types.Point(ClientWidth div 2, ClientHeight div 2); case Message.CharCode of VK_UP: ScaleAtPoint(1.1, midPoint); VK_DOWN: ScaleAtPoint(0.9, midPoint); diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Resamplers.pas b/Ext/SVGIconImageList/Image32/source/Img32.Resamplers.pas index 7024ed2..d708832 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.Resamplers.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.Resamplers.pas @@ -2,10 +2,10 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 4.3 * -* Date : 17 December 2023 * +* Version : 4.4 * +* Date : 2 May 2024 * * Website : http://www.angusj.com * -* Copyright : Angus Johnson 2019-2021 * +* Copyright : Angus Johnson 2019-2024 * * Purpose : For image transformations (scaling, rotating etc.) * * License : http://www.boost.org/LICENSE_1_0.txt * *******************************************************************************) @@ -15,119 +15,253 @@ interface {$I Img32.inc} uses - SysUtils, Classes, Img32; - -//BoxDownSampling: As the name implies, this routine is only intended for -//image down-sampling (ie when shrinking images) where it generally performs -//better than other resamplers which tend to lose too much detail. However, -//because this routine is inferior to other resamplers when performing other -//transformations (ie when enlarging, rotating, and skewing images), it's not -//intended as a general purpose resampler. -procedure BoxDownSampling(Image: TImage32; newWidth, newHeight: Integer); - -(* The following functions are registered in the initialization section below -function NearestResampler(img: TImage32; x256, y256: Integer): TColor32; -function BilinearResample(img: TImage32; x256, y256: Integer): TColor32; -function BicubicResample(img: TImage32; x256, y256: Integer): TColor32; -*) + SysUtils, Classes, Math, Img32; + +// BoxDownSampling: As the name implies, is only intended for image +// down-sampling (ie shrinking images) where it performs a little better +// than other resamplers which tend toward pixelation. Nevertheless, this +// routine is inferior to other resamplers when performing other +// types of transformations (ie when enlarging, rotating, and skewing images), +// so BoxDownSampling should not be used as a general purpose resampler. +procedure BoxDownSampling(Image: TImage32; scale: double); overload; +procedure BoxDownSampling(Image: TImage32; scaleX, scaleY: double); overload; +procedure BoxDownSampling(Image: TImage32; newWidth, newHeight: Integer); overload; + +// The following general purpose resamplers are registered below: +// function NearestResampler(img: TImage32; x, y: double): TColor32; +// function BilinearResample(img: TImage32; x, y: double): TColor32; +// function BicubicResample (img: TImage32; x, y: double): TColor32; +// function WeightedBilinear(img: TImage32; x, y: double): TColor32; implementation uses Img32.Transform; +var + sinWeighted: array [0..255] of Cardinal; + //------------------------------------------------------------------------------ // NearestNeighbor resampler //------------------------------------------------------------------------------ -function NearestResampler(img: TImage32; x256, y256: Integer): TColor32; +function NearestResampler(img: TImage32; x, y: double): TColor32; +var + xi, yi: integer; begin - if (x256 < -$7f) then + xi := Round(x); yi := Round(y); + if (xi < 0) or (yi < 0) or (xi >= img.Width) or (yi >= img.Height) then + Result := clNone32 else + Result := img.Pixels[xi + yi * img.Width]; +end; + +//------------------------------------------------------------------------------ +// BiLinear resampler +//------------------------------------------------------------------------------ + +function BilinearResample(img: TImage32; x, y: double): TColor32; +var + iw, ih: integer; + xx, yy, xR, yB: integer; + weight: Cardinal; + pixels: TArrayOfColor32; + weightedColor: TWeightedColor; + xf, yf: double; +begin + iw := img.Width; + ih := img.Height; + pixels := img.Pixels; + + if (x < 0) then begin - Result := clNone32; - Exit; + if (x < -0.5) then + begin + xf := -x; + end else + begin + x := 0; + xf := 0; + end; + xx := 0; + xR := 0; + end else + begin + xf := 1-frac(x); + if x >= iw -1 then + begin + xx := iw -1; + xR := xx; + end else + begin + xx := Trunc(x); + xR := xx +1; + end; end; - if (y256 < -$7f) then + if (y < 0) then begin - Result := clNone32; - Exit; + if (y < -0.5) then + begin + yf := -y; + end else + begin + y := 0; + yf := 0; + end; + yy := 0; + yB := 0; + end else + begin + yf := 1-frac(y); + if y >= ih -1 then + begin + yy := ih -1; + yB := yy; + end else + begin + yy := Trunc(y); + yB := yy +1; + end; end; - if (x256 and $FF > $7F) then inc(x256, $100); - x256 := x256 shr 8; - if y256 and $FF > $7F then inc(y256, $100); - y256 := y256 shr 8; + weightedColor.Reset; - if (x256 < 0) or (x256 >= img.Width) or - (y256 < 0) or (y256 >= img.Height) then - Result := clNone32 else - Result := img.Pixels[y256 * img.Width + x256]; -end; + weight := Round(xf * yf * 255); //top-left + if weight > 0 then + begin + if (x < 0) or (y < 0) then + weightedColor.AddWeight(weight) else + weightedColor.Add(pixels[xx + yy * iw], weight); + end; -//------------------------------------------------------------------------------ -// BiLinear resampler + weight := Round((1-xf) * yf * 255); //top-right + if weight > 0 then + begin + if (x > iw - 0.5) or (y < 0) then + weightedColor.AddWeight(weight) else + weightedColor.Add(pixels[xR + yy * iw], weight); + end; + + weight := Round(xf * (1-yf) * 255); //bottom-left + if weight > 0 then + begin + if (x < 0) or (y > ih - 0.5) then + weightedColor.AddWeight(weight) else + weightedColor.Add(pixels[xx + yB * iw], weight); + end; + + weight := Round((1-xf) * (1-yf) * 255); //bottom-right + if weight > 0 then + begin + if (x > iw - 0.5) or (y > ih - 0.5) then + weightedColor.AddWeight(weight) else + weightedColor.Add(pixels[xR + yB * iw], weight); + end; + Result := weightedColor.Color; +end; //------------------------------------------------------------------------------ -function BilinearResample(img: TImage32; x256, y256: Integer): TColor32; +// WeightedBilinearResample: A modified bilinear resampler that's +// less blurry but also a little more pixelated. +function WeightedBilinearResample(img: TImage32; x, y: double): TColor32; var - xi,yi, weight: Integer; iw, ih: integer; + xx, yy, xR, yB: integer; + weight: Cardinal; pixels: TArrayOfColor32; - color: TWeightedColor; - xf, yf: cardinal; + weightedColor: TWeightedColor; + xf, yf: double; begin iw := img.Width; ih := img.Height; pixels := img.Pixels; - if (x256 <= -$100) or (x256 >= iw *$100) or - (y256 <= -$100) or (y256 >= ih *$100) then + if (x < 0) then begin - result := clNone32; - Exit; + if (x < -0.5) then + begin + xf := -x; + end else + begin + x := 0; + xf := 0; + end; + xx := 0; + xR := 0; + end else + begin + xf := 1-frac(x); + if x >= iw -1 then + begin + xx := iw -1; + xR := xx; + end else + begin + xx := Trunc(x); + xR := xx +1; + end; end; - if x256 < 0 then xi := -1 - else xi := x256 shr 8; - - if y256 < 0 then yi := -1 - else yi := y256 shr 8; - - xf := x256 and $FF; - yf := y256 and $FF; + if (y < 0) then + begin + if (y < -0.5) then + begin + yf := -y; + end else + begin + y := 0; + yf := 0; + end; + yy := 0; + yB := 0; + end else + begin + yf := 1-frac(y); + if y >= ih -1 then + begin + yy := ih -1; + yB := yy; + end else + begin + yy := Trunc(y); + yB := yy +1; + end; + end; - color.Reset; + weightedColor.Reset; - weight := (($100 - xf) * ($100 - yf)) shr 8; //top-left + weight := sinWeighted[Round(xf * yf * 255)]; //top-left if weight > 0 then begin - if (xi < 0) or (yi < 0) then color.AddWeight(weight) - else color.Add(pixels[xi + yi * iw], weight); + if (x < 0) or (y < 0) then + weightedColor.AddWeight(weight) else + weightedColor.Add(pixels[xx + yy * iw], weight); end; - weight := (xf * ($100 - yf)) shr 8; //top-right + weight := sinWeighted[Round((1-xf) * yf * 255)]; //top-right if weight > 0 then begin - if ((xi+1) >= iw) or (yi < 0) then color.AddWeight(weight) - else color.Add(pixels[(xi+1) + yi * iw], weight); + if (x > iw - 0.5) or (y < 0) then + weightedColor.AddWeight(weight) else + weightedColor.Add(pixels[xR + yy * iw], weight); end; - weight := (($100 - xf) * yf) shr 8; //bottom-left + weight := sinWeighted[Round(xf * (1-yf) * 255)]; //bottom-left if weight > 0 then begin - if (xi < 0) or ((yi+1) >= ih) then color.AddWeight(weight) - else color.Add(pixels[(xi) + (yi+1) * iw], weight); + if (x < 0) or (y > ih - 0.5) then + weightedColor.AddWeight(weight) else + weightedColor.Add(pixels[xx + yB * iw], weight); end; - weight := (xf * yf) shr 8; //bottom-right + weight := sinWeighted[Round((1-xf) * (1-yf) * 255)]; //bottom-right if weight > 0 then begin - if (xi + 1 >= iw) or (yi + 1 >= ih) then color.AddWeight(weight) - else color.Add(pixels[(xi+1) + (yi+1) * iw], weight); + if (x > iw - 0.5) or (y > ih - 0.5) then + weightedColor.AddWeight(weight) else + weightedColor.Add(pixels[xR + yB * iw], weight); end; - - Result := color.Color; + Result := weightedColor.Color; end; //------------------------------------------------------------------------------ @@ -135,7 +269,8 @@ function BilinearResample(img: TImage32; x256, y256: Integer): TColor32; //------------------------------------------------------------------------------ type - TBiCubicEdgeAdjust = (eaNone, eaOne, eaTwo, eaThree, eaFour); + TBiCubicEdgeAdjust = (eaCenterFill, + eaPreStart, eaStart, eaPostStart, eaEnd, eaPostEnd); var byteFrac: array [0..255] of double; @@ -144,48 +279,49 @@ function BilinearResample(img: TImage32; x256, y256: Integer): TColor32; //------------------------------------------------------------------------------ -function CubicHermite(aclr: PColor32; t: Byte; bce: TBiCubicEdgeAdjust): TColor32; +function CubicInterpolate(aclr: PColor32; + t: Byte; bce: TBiCubicEdgeAdjust): TColor32; var a,b,c,d: PARGB; q: TARGB; - aa, bb, cc: integer; + aa, bb, m0, m1: double; t1, t2, t3: double; res: TARGB absolute Result; const clTrans: TColor32 = clNone32; begin case bce of - eaOne: + eaPreStart: begin a := @clTrans; b := @clTrans; c := PARGB(aclr); - Inc(aclr); - d := PARGB(aclr); + d := c; end; - eaTwo: + eaStart: + begin + Result := aclr^; + Exit; + end; + eaPostStart: begin a := PARGB(aclr); b := a; Inc(aclr); c := PARGB(aclr); - Inc(aclr); - d := PARGB(aclr); + d := c; end; - eaThree: + eaEnd: begin - a := PARGB(aclr); - Inc(aclr); - b := PARGB(aclr); Inc(aclr); - c := PARGB(aclr); - d := c; + Result := aclr^; + Exit; end; - eaFour: + eaPostEnd: begin - a := PARGB(aclr); Inc(aclr); - b := PARGB(aclr); + a := PARGB(aclr); + b := a; c := @clTrans; d := @clTrans; end; @@ -206,14 +342,21 @@ function CubicHermite(aclr: PColor32; t: Byte; bce: TBiCubicEdgeAdjust): TColor3 result := clNone32; Exit; end + else if (b = c) then + begin + result := b.Color; + Exit; + end else if b.A = 0 then begin + // ignore differences between b & c's color channels q := c^; q.A := 0; b := @q; end; if c.A = 0 then begin + // ignore differences between b & c's color channels q := b^; q.A := 0; c := @q; @@ -223,76 +366,147 @@ function CubicHermite(aclr: PColor32; t: Byte; bce: TBiCubicEdgeAdjust): TColor3 t2 := byteFracSq[t]; t3 := byteFracCubed[t]; - aa := Integer(-a.A + 3*b.A - 3*c.A + d.A) div 2; - bb := Integer(2*a.A - 5*b.A + 4*c.A - d.A) div 2; - cc := Integer(-a.A + c.A) div 2; - Res.A := ClampByte(aa*t3 + bb*t2 + cc*t1 + b.A); - - aa := Integer(-a.R + 3*b.R - 3*c.R + d.R) div 2; - bb := Integer(2*a.R - 5*b.R + 4*c.R - d.R) div 2; - cc := Integer(-a.R + c.R) div 2; - Res.R := ClampByte(aa*t3 + bb*t2 + cc*t1 + b.R); - - aa := Integer(-a.G + 3*b.G - 3*c.G + d.G) div 2; - bb := Integer(2*a.G - 5*b.G + 4*c.G - d.G) div 2; - cc := Integer(-a.G + c.G) div 2; - Res.G := ClampByte(aa*t3 + bb*t2 + cc*t1 + b.G); - - aa := Integer(-a.B + 3*b.B - 3*c.B + d.B) div 2; - bb := Integer(2*a.B - 5*b.B + 4*c.B - d.B) div 2; - cc := Integer(-a.B + c.B) div 2; - Res.B := ClampByte(aa*t3 + bb*t2 + cc*t1 + b.B); + // find piecewise bicubic interpolation between pixel_b and pixel_c + // at point 't' (as byte div 255) ... + // given parametric equation aa(t^3) + bb(t^2) + cc(t)+ dd = 0 + // where t(0) = pixel_b and t(1) = pixel_c + // let m1 = slope at pixel_b (using slope of pixel_c - pixel_a) + // let m2 = slope at pixel_c (using slope of pixel_d - pixel_b) + // then t(0) = aa(0^3) + bb(0^2) + cc(0) + dd = dd + // then t(1) = aa(1^3) + bb(1^2) + cc(1) + dd = aa + bb + cc + dd + // differentiating parametic equation at t'(0) and t'(1) ... + // t'(0) = m0 = 3*aa(0^2) + 2*bb(0) + cc = cc + // t'(1) = m1 = 3*aa(1^2) + 2*bb(1) + cc = 3*aa + 2*bb + cc + // t(0) = dd ::EQ1 + // t(1) = aa+bb+cc+dd ::EQ2 + // t'(0) = cc ::EQ3 + // t'(1) = 3*aa + 2*bb + cc ::EQ4 + // solving simultaneous equations + // aa = 2*t(0) -2*t(1) +t'(0) +t'(1) + // bb = 3*t(1) -3*t(0) -2*t'(0) -t'(1) + // cc = m0 + // dd = t(0) + + m0 {aka t'(0)} := (c.A - a.A) /2; + m1 {aka t'(1)} := (d.A - b.A) /2; + aa := 2*b.A - 2*c.A + m0 + m1; + bb := 3*c.A -3*b.A -2*m0 - m1; + Res.A := ClampByte(aa*t3 + bb*t2 + m0*t1 + b.A); + + m0 := (c.R - a.R) /2; + m1 := (d.R - b.R) /2; + aa := 2*b.R - 2*c.R + m0 + m1; + bb := 3*c.R -3*b.R -2*m0 - m1; + Res.R := ClampByte(aa*t3 + bb*t2 + m0*t1 + b.R); + + m0 := (c.G - a.G) /2; + m1 := (d.G - b.G) /2; + aa := 2*b.G - 2*c.G + m0 + m1; + bb := 3*c.G -3*b.G -2*m0 - m1; + Res.G := ClampByte(aa*t3 + bb*t2 + m0*t1 + b.G); + + m0 := (c.B - a.B) /2; + m1 := (d.B - b.B) /2; + aa := 2*b.B - 2*c.B + m0 + m1; + bb := 3*c.B -3*b.B -2*m0 - m1; + Res.B := ClampByte(aa*t3 + bb*t2 + m0*t1 + b.B); end; //------------------------------------------------------------------------------ -function BicubicResample(img: TImage32; x256, y256: Integer): TColor32; +function BicubicResample(img: TImage32; x, y: double): TColor32; var - i, dx,dy, pi, iw, w,h: Integer; + i, pi, iw, ih, last: Integer; c: array[0..3] of TColor32; - x, y: Integer; + xFrac, yFrac: byte; bceX, bceY: TBiCubicEdgeAdjust; begin - Result := clNone32; - iw := img.Width; - w := iw -1; - h := img.Height -1; - - x := Abs(x256) shr 8; - y := Abs(y256) shr 8; - - if (x256 < -$FF) or (x > w) or (y256 < -$FF) or (y > h) then Exit; - - if (x256 < 0) then bceX := eaOne - else if (x = 0) then bceX := eaTwo - else if (x256 > w shl 8) then bceX := eaFour - else if (x256 > (w -1) shl 8) then bceX := eaThree - else bceX := eaNone; - - if (bceX = eaOne) or (bceX = eaTwo) then dx := 1 - else dx := 0; - - if (y256 < 0) then bceY := eaOne - else if y = 0 then bceY := eaTwo - else if y = h -1 then bceY := eaThree - else if y = h then bceY := eaFour - else bceY := eaNone; + ih := img.Height; + last := iw * ih -1; - if (bceY = eaOne) or (bceY = eaTwo) then dy := 1 - else dy := 0; + if x < 1 then + begin + if x < -0.5 then + begin + xFrac := Round((1+x) *255); + bceX := eaPreStart; + end + else if (x < 0) or + ((iw = 1) and (x < 0.5)) then + begin + x := 0; + xFrac := 0; + bceX := eaStart; + end + else if (iw = 1) and (x > 0.5) then + begin + // the following is a workaround to avoid the increment in eaPostEnd + bceX := eaPreStart; // ie anti-aliase but without increment + xFrac := Round((1-x) *127); // reversed because 'end' not 'start' + end else + begin + xFrac := Round(frac(x) *255); + bceX := eaPostStart; + end; + end else + begin + xFrac := Round(frac(x) *255); + if x > iw - 1 then + begin + if x > iw - 0.5 then bceX := eaPostEnd + else bceX := eaEnd + end + else + bceX := eaCenterFill; + end; - pi := (y -1 +dy) * iw + (x -1 + dx); + if y < 1 then + begin + if y < -0.5 then + begin + yFrac := Round((1+y) *255); + bceY := eaPreStart; + end + else if (y < 0) or + ((ih = 1) and (y < 0.5)) then + begin + y := 0; + yFrac := 0; + bceY := eaStart; + end + else if (ih = 1) and (y > 0.5) then + begin + // the following is a workaround to avoid the increment in eaPostEnd + bceY := eaPreStart; // ie anti-aliase but without increment + yFrac := Round((1-y) *127); // reversed because 'end' not 'start' + end else + begin + yFrac := Round(frac(y) *255); + bceY := eaPostStart; + end; + end else + begin + yFrac := Round(frac(y) *255); + if y > ih - 1 then + begin + if y > ih - 0.5 then bceY := eaPostEnd + else bceY := eaEnd + end + else + bceY := eaCenterFill; + end; - if bceY = eaFour then dx := 2 - else if bceY = eaThree then dx := 1 - else dx := 0; + x := Max(0, Min(iw -1, x -1)); + y := Max(0, Min(ih -1, y -1)); + pi := Trunc(y) * iw + Trunc(x); - for i := dy to 3 -dx do + for i := 0 to 3 do begin - c[i] := CubicHermite(@img.Pixels[pi], x256 and $FF, bceX); + c[i] := CubicInterpolate(@img.Pixels[pi], xFrac, bceX); inc(pi, iw); + if pi > last then break; end; - Result := CubicHermite(@c[dy], y256 and $FF, bceY); + Result := CubicInterpolate(@c[0], yFrac, bceY); end; //------------------------------------------------------------------------------ @@ -363,6 +577,22 @@ function GetWeightedColor(const srcBits: TArrayOfColor32; end; //------------------------------------------------------------------------------ +procedure BoxDownSampling(Image: TImage32; scaleX, scaleY: double); +begin + BoxDownSampling(Image, + Max(1, Integer(Round(Image.Width * scaleX))), + Max(1, Integer(Round(Image.Height * scaleY)))); +end; +//------------------------------------------------------------------------------ + +procedure BoxDownSampling(Image: TImage32; scale: double); +begin + BoxDownSampling(Image, + Max(1, Integer(Round(Image.Width * scale))), + Max(1, Integer(Round(Image.Height * scale)))); +end; +//------------------------------------------------------------------------------ + procedure BoxDownSampling(Image: TImage32; newWidth, newHeight: Integer); var x,y, x256,y256,xx256,yy256: Integer; @@ -411,12 +641,15 @@ procedure InitByteExponents; inv255 : double = 1/255; inv255sqrd : double = 1/(255*255); inv255cubed: double = 1/(255*255*255); + piDiv256 : double = Pi / 256; begin for i := 0 to 255 do begin byteFrac[i] := i *inv255; byteFracSq[i] := i*i *inv255sqrd; byteFracCubed[i] := i*i*i *inv255cubed; + + sinWeighted[i] := Round((Sin(i * piDiv256 - Pi/2) +1) /2 * 255); end; end; //------------------------------------------------------------------------------ @@ -427,6 +660,7 @@ initialization rNearestResampler := RegisterResampler(NearestResampler, 'NearestNeighbor'); rBilinearResampler := RegisterResampler(BilinearResample, 'Bilinear'); rBicubicResampler := RegisterResampler(BicubicResample, 'HermiteBicubic'); + rWeightedBilinear := RegisterResampler(WeightedBilinearResample, 'WeightedBilinear'); DefaultResampler := rBilinearResampler; end. diff --git a/Ext/SVGIconImageList/Image32/source/Img32.SVG.Core.pas b/Ext/SVGIconImageList/Image32/source/Img32.SVG.Core.pas index dd64e9f..afe6b31 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.SVG.Core.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.SVG.Core.pas @@ -3,9 +3,9 @@ (******************************************************************************* * Author : Angus Johnson * * Version : 4.4 * -* Date : 22 October 2023 * +* Date : 13 March 2024 * * Website : http://www.angusj.com * -* Copyright : Angus Johnson 2019-2022 * +* Copyright : Angus Johnson 2019-2024 * * * * Purpose : Essential structures and functions to read SVG files * * * @@ -245,6 +245,11 @@ TSvgParser = class procedure ConvertUnicodeToUtf8(memStream: TMemoryStream); + function GetScale(src, dst: double): double; + function GetScaleForBestFit(srcW, srcH, dstW, dstH: double): double; + + function Base64Decode(const str: PAnsiChar; len: integer; memStream: TMemoryStream): Boolean; + type TSetOfUTF8Char = set of UTF8Char; UTF8Strings = array of UTF8String; @@ -285,10 +290,106 @@ TColorObj = class //include hashed html entity constants {$I Img32.SVG.HtmlHashConsts.inc} +//------------------------------------------------------------------------------ +// Base64 (MIME) Encode & Decode and other encoding functions ... +//------------------------------------------------------------------------------ + +type + PFourChars = ^TFourChars; + TFourChars = record + c1: ansichar; + c2: ansichar; + c3: ansichar; + c4: ansichar; + end; + +function Chr64ToVal(c: ansiChar): integer; {$IFDEF INLINE} inline; {$ENDIF} +begin + case c of + '+': result := 62; + '/': result := 63; + '0'..'9': result := ord(c) + 4; + 'A'..'Z': result := ord(c) -65; + 'a'..'z': result := ord(c) -71; + else Raise Exception.Create('Corrupted MIME encoded text'); + end; +end; +//------------------------------------------------------------------------------ + +function FrstChr(c: PFourChars): ansichar; {$IFDEF INLINE} inline; {$ENDIF} +begin + result := ansichar(Chr64ToVal(c.c1) shl 2 or Chr64ToVal(c.c2) shr 4); +end; +//------------------------------------------------------------------------------ + +function ScndChr(c: PFourChars): ansichar; {$IFDEF INLINE} inline; {$ENDIF} +begin + result := ansichar(Chr64ToVal(c.c2) shl 4 or Chr64ToVal(c.c3) shr 2); +end; +//------------------------------------------------------------------------------ + +function ThrdChr(c: PFourChars): ansichar; {$IFDEF INLINE} inline; {$ENDIF} +begin + result := ansichar( Chr64ToVal(c.c3) shl 6 or Chr64ToVal(c.c4) ); +end; +//------------------------------------------------------------------------------ + +function Base64Decode(const str: PAnsiChar; len: integer; memStream: TMemoryStream): Boolean; +var + i, j, extra: integer; + Chars4: PFourChars; + dst: PAnsiChar; +begin + result := false; + if (len = 0) or (len mod 4 > 0) or not Assigned(memStream) then exit; + if str[len-2] = '=' then extra := 2 + else if str[len-1] = '=' then extra := 1 + else extra := 0; + memStream.SetSize(LongInt((len div 4 * 3) - extra)); + dst := memStream.Memory; + Chars4 := @str[0]; + i := 0; + try + for j := 1 to (len div 4) -1 do + begin + dst[i] := FrstChr(Chars4); + dst[i+1] := ScndChr(Chars4); + dst[i+2] := ThrdChr(Chars4); + inc(pbyte(Chars4),4); + inc(i,3); + end; + dst[i] := FrstChr(Chars4); + if extra < 2 then dst[i+1] := ScndChr(Chars4); + if extra < 1 then dst[i+2] := ThrdChr(Chars4); + except + Exit; + end; + Result := true; +end; + //------------------------------------------------------------------------------ // Miscellaneous functions ... //------------------------------------------------------------------------------ +function GetScale(src, dst: double): double; +begin + Result := dst / src; + if (SameValue(Result, 1, 0.00001)) then Result := 1; +end; +//------------------------------------------------------------------------------ + +function GetScaleForBestFit(srcW, srcH, dstW, dstH: double): double; +var + sx,sy: double; +begin + sx := dstW / srcW; + sy := dstH / srcH; + if sy < sx then sx := sy; + if (SameValue(sx, 1, 0.00001)) then + Result := 1 else + Result := sx; +end; + function ClampRange(val, min, max: double): double; {$IFDEF INLINE} inline; {$ENDIF} begin diff --git a/Ext/SVGIconImageList/Image32/source/Img32.SVG.HashConsts.inc b/Ext/SVGIconImageList/Image32/source/Img32.SVG.HashConsts.inc index 25904f2..08db2ca 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.SVG.HashConsts.inc +++ b/Ext/SVGIconImageList/Image32/source/Img32.SVG.HashConsts.inc @@ -46,6 +46,7 @@ const hfeFuncG = $E45FE81A; // feFuncG hfeFuncR = $F8BB10C8; // feFuncR hfeGaussianBlur = $B2225552; // feGaussianBlur + hfeImage = $905096A0; // feImage hfeMerge = $A2C358C0; // feMerge hfeMergeNode = $F5F1E90F; // feMergeNode hfeOffset = $04493A72; // feOffset @@ -74,6 +75,7 @@ const hhidden = $4C4D777D; // hidden hHref = $8E926F4B; // Href hId = $1B60404D; // Id + hImage = $D58C8637; // Image hIn = $4D5FA44B; // In hIn2 = $FBFE02B1; // In2 hIntercept = $7CBB607F; // Intercept diff --git a/Ext/SVGIconImageList/Image32/source/Img32.SVG.Path.pas b/Ext/SVGIconImageList/Image32/source/Img32.SVG.Path.pas index 944dab6..7941f87 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.SVG.Path.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.SVG.Path.pas @@ -3,9 +3,9 @@ (******************************************************************************* * Author : Angus Johnson * * Version : 4.4 * -* Date : 14 October 2023 * +* Date : 16 March 2024 * * Website : http://www.angusj.com * -* Copyright : Angus Johnson 2019-2021 * +* Copyright : Angus Johnson 2019-2024 * * * * Purpose : Essential structures and functions to read SVG Path elements * * * @@ -276,7 +276,6 @@ implementation resourcestring rsSvgPathRangeError = 'TSvgPath.GetPath range error'; rsSvgSubPathRangeError = 'TSvgSubPath.GetSeg range error'; - //rsSvgSegmentRangeError = 'TSvgSegment.GetVal range error'; //------------------------------------------------------------------------------ // Miscellaneous functions ... @@ -418,22 +417,22 @@ procedure TSvgPathSeg.Scale(value: double); function TSvgPathSeg.DescaleAndOffset(const pt: TPointD): TPointD; begin Result := pt; - OffsetPoint(Result, -parent.PathOffset.X, -parent.PathOffset.Y); + TranslatePoint(Result, -parent.PathOffset.X, -parent.PathOffset.Y); Result := ScalePoint(Result, 1/Owner.Scale); end; //------------------------------------------------------------------------------ function TSvgPathSeg.DescaleAndOffset(const p: TPathD): TPathD; begin - Result := OffsetPath(p, -parent.PathOffset.X, -parent.PathOffset.Y); + Result := TranslatePath(p, -parent.PathOffset.X, -parent.PathOffset.Y); Result := ScalePath(Result, 1/Owner.Scale); end; //------------------------------------------------------------------------------ procedure TSvgPathSeg.Offset(dx, dy: double); begin - fFirstPt := OffsetPoint(fFirstPt, dx, dy); - fCtrlPts := OffsetPath(fCtrlPts, dx, dy); + fFirstPt := TranslatePoint(fFirstPt, dx, dy); + fCtrlPts := TranslatePath(fCtrlPts, dx, dy); end; //------------------------------------------------------------------------------ @@ -562,9 +561,9 @@ procedure TSvgASegment.SetArcInfo(ai: TArcInfo); begin dx := ai.startPos.X - startPos.X; dy := ai.startPos.Y - startPos.Y; - OffsetRect(rec, dx, dy); + TranslateRect(rec, dx, dy); startPos := ai.startPos; - endPos := OffsetPoint(endPos, dx, dy); + endPos := TranslatePoint(endPos, dx, dy); end; end; SetCtrlPtsFromArcInfo; @@ -669,9 +668,9 @@ procedure TSvgASegment.Offset(dx, dy: double); inherited; with fArcInfo do begin - OffsetRect(rec, dx, dy); - startPos := OffsetPoint(startPos, dx, dy); - endPos := OffsetPoint(endPos, dx, dy); + TranslateRect(rec, dx, dy); + startPos := TranslatePoint(startPos, dx, dy); + endPos := TranslatePoint(endPos, dx, dy); end; end; //------------------------------------------------------------------------------ @@ -1287,7 +1286,6 @@ procedure TSvgSubPath.Offset(dx, dy: double); var i: integer; begin - //fPathOffset := OffsetPoint(pathOffset, dx,dy); //DON'T DO THIS! for i := 0 to High(fSegs) do fSegs[i].Offset(dx, dy); end; //------------------------------------------------------------------------------ @@ -1592,16 +1590,26 @@ function TSvgPath.GetControlBounds: TRectD; for i := 0 to Count -1 do with fSubPaths[i] do begin - AppendPath(p, GetFirstPt); + AppendToPath(p, GetFirstPt); for j := 0 to High(fSegs) do AppendPath(p, fSegs[j].fCtrlPts); end; Result := GetBoundsD(p); //watch out for straight horizontal or vertical lines - if not IsEmptyRect(Result) then Exit; - p := Grow(p, nil, 1, jsSquare, 0); - Result := GetBoundsD(p); + if IsEmptyRect(Result) then + begin + if Result.Width = 0 then + begin + Result.Left := Result.Left - 0.5; + Result.Right := Result.Left + 1.0; + end + else if Result.Height = 0 then + begin + Result.Top := Result.Top - 0.5; + Result.Bottom := Result.Top + 1.0; + end; + end; end; //------------------------------------------------------------------------------ diff --git a/Ext/SVGIconImageList/Image32/source/Img32.SVG.PathDesign.pas b/Ext/SVGIconImageList/Image32/source/Img32.SVG.PathDesign.pas index 2adfe95..d1b33a1 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.SVG.PathDesign.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.SVG.PathDesign.pas @@ -2,8 +2,8 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 4.2 * -* Date : 30 May 2022 * +* Version : 4.0 * +* Date : 10 January 2022 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2022 * * * @@ -1111,7 +1111,6 @@ procedure TSubPathLayer.Init(subPath: TSvgSubPath); begin fOwner := Parent as TSvgPathLayer; fSubPath := subPath; - seg := nil; for i := 0 to subPath.Count -1 do begin case subPath[i].segType of diff --git a/Ext/SVGIconImageList/Image32/source/Img32.SVG.Reader.pas b/Ext/SVGIconImageList/Image32/source/Img32.SVG.Reader.pas index 977bd0c..6508841 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.SVG.Reader.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.SVG.Reader.pas @@ -3,9 +3,9 @@ (******************************************************************************* * Author : Angus Johnson * * Version : 4.4 * -* Date : 22 October 2023 * +* Date : 23 March 2024 * * Website : http://www.angusj.com * -* Copyright : Angus Johnson 2019-2022 * +* Copyright : Angus Johnson 2019-2024 * * * * Purpose : Read SVG 2.0 files * * * @@ -29,7 +29,9 @@ interface {$ENDIF} type - TSvgElement = class; + + TBaseElement = class; + TElementClass = class of TBaseElement; TDrawData = record currentColor : TColor32; @@ -56,29 +58,28 @@ TDrawData = record opacity : integer; matrix : TMatrixD; visible : Boolean; - useEl : TSvgElement; //to check for and prevent recursion + useEl : TBaseElement; //to check for and prevent recursion bounds : TRectD; end; TSvgReader = class; - TElementClass = class of TSvgElement; - TSvgElement = class + TBaseElement = class private - fParent : TSvgElement; + fParent : TBaseElement; fParserEl : TSvgTreeEl; fReader : TSvgReader; {$IFDEF XPLAT_GENERICS} - fChilds : TList; + fChilds : TList; {$ELSE} fChilds : TList; {$ENDIF} fId : UTF8String; fDrawData : TDrawData; //currently both static and dynamic vars - function FindRefElement(refname: UTF8String): TSvgElement; + function FindRefElement(refname: UTF8String): TBaseElement; function GetChildCount: integer; - function GetChild(index: integer): TSvgElement; - function FindChild(const idName: UTF8String): TSvgElement; + function GetChild(index: integer): TBaseElement; + function FindChild(const idName: UTF8String): TBaseElement; protected elRectWH : TValueRecWH; //multifunction variable function IsFirstChild: Boolean; @@ -90,19 +91,20 @@ TSvgElement = class procedure Draw(image: TImage32; drawDat: TDrawData); virtual; procedure DrawChildren(image: TImage32; drawDat: TDrawData); virtual; public - constructor Create(parent: TSvgElement; svgEl: TSvgTreeEl); virtual; + constructor Create(parent: TBaseElement; svgEl: TSvgTreeEl); virtual; destructor Destroy; override; - property Child[index: integer]: TSvgElement read GetChild; default; + property Child[index: integer]: TBaseElement read GetChild; default; property ChildCount: integer read GetChildCount; property DrawData: TDrawData read fDrawData write fDrawData; property Id: UTF8String read fId; end; - TSvgRootElement = class(TSvgElement) + TSvgElement = class(TBaseElement) protected viewboxWH : TRectWH; + procedure Draw(image: TImage32; drawDat: TDrawData); override; public - constructor Create(parent: TSvgElement; svgEl: TSvgTreeEl); override; + function GetViewbox: TRectWH; end; TSvgReader = class @@ -116,8 +118,7 @@ TSvgReader = class fClassStyles : TClassStylesList; fLinGradRenderer : TLinearGradientRenderer; fRadGradRenderer : TSvgRadialGradientRenderer; - fImgRenderer : TImageRenderer; - fRootElement : TSvgRootElement; + fRootElement : TSvgElement; fFontCache : TFontCache; fUsePropScale : Boolean; fSimpleDraw : Boolean; @@ -131,14 +132,12 @@ TSvgReader = class procedure GetBestFontForFontCache(const svgFontInfo: TSVGFontInfo); property RadGradRenderer: TSvgRadialGradientRenderer read fRadGradRenderer; property LinGradRenderer: TLinearGradientRenderer read fLinGradRenderer; - property ImageRenderer : TImageRenderer read fImgRenderer; property BackgndImage : TImage32 read fBackgndImage; property TempImage : TImage32 read fTempImage; public constructor Create; destructor Destroy; override; procedure Clear; - function GetViewbox(containerWidth, containerHeight: integer): TRectWH; procedure DrawImage(img: TImage32; scaleToImage: Boolean); function LoadFromStream(stream: TStream): Boolean; function LoadFromFile(const filename: string): Boolean; @@ -149,7 +148,7 @@ TSvgReader = class procedure SetOverrideFillColor(color: TColor32); //deprecated; procedure SetOverrideStrokeColor(color: TColor32); //deprecated; - function FindElement(const idName: UTF8String): TSvgElement; + function FindElement(const idName: UTF8String): TBaseElement; property BackgroundColor : TColor32 read fBkgndColor write fBkgndColor; property BlurQuality : integer read fBlurQuality write SetBlurQuality; property IsEmpty : Boolean read GetIsEmpty; @@ -157,7 +156,7 @@ TSvgReader = class //the third-party SVGIconImageList. (IMHO it should always = true) property KeepAspectRatio: Boolean read fUsePropScale write fUsePropScale; - property RootElement : TSvgRootElement read fRootElement; + property RootElement : TSvgElement read fRootElement; //RecordSimpleDraw: record simple drawing instructions property RecordSimpleDraw: Boolean read fSimpleDraw write fSimpleDraw; //SimpleDrawList: list of PSimpleDrawData records; @@ -172,6 +171,12 @@ TSimpleDrawData = record tag : integer; end; +var + // https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/width + defaultSvgWidth: integer = 300; + // https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/height + defaultSvgHeight: integer = 150; + implementation uses @@ -180,14 +185,29 @@ implementation type TFourDoubles = array [0..3] of double; - TDefsElement = class(TSvgElement) + TDefsElement = class(TBaseElement) public - constructor Create(parent: TSvgElement; svgEl: TSvgTreeEl); override; + constructor Create(parent: TBaseElement; svgEl: TSvgTreeEl); override; + end; + + //------------------------------------- + + // TImageElement only supports *embedded* jpg & png images. + // And it requires Img32.Fmt.JPG & Img32.Fmt.PNG to be included + // in the USES clause of at least one of the application's units. + // (nb: If using the FMX framework, then add Img32.FMX instead of + // Img32.Fmt.JPG & Img32.Fmt.PNG to the USES clause.) + + TImageElement = class(TBaseElement) + private + refEl: UTF8String; + protected + procedure Draw(image: TImage32; drawDat: TDrawData); override; end; //------------------------------------- - TShapeElement = class(TSvgElement) + TShapeElement = class(TBaseElement) private procedure SimpleDrawFill(const paths: TPathsD; fillRule: TFillRule; color: TColor32); @@ -208,7 +228,7 @@ TShapeElement = class(TSvgElement) procedure DrawMarkers(img: TImage32; drawDat: TDrawData); procedure Draw(image: TImage32; drawDat: TDrawData); override; public - constructor Create(parent: TSvgElement; svgEl: TSvgTreeEl); override; + constructor Create(parent: TBaseElement; svgEl: TSvgTreeEl); override; end; TGroupElement = class(TShapeElement) @@ -223,8 +243,8 @@ TSwitchElement = class(TShapeElement) TUseElement = class(TShapeElement) private - callerUse: TSvgElement; - function ValidateNonRecursion(el: TSvgElement): Boolean; + callerUse: TBaseElement; + function ValidateNonRecursion(el: TBaseElement): Boolean; protected refEl: UTF8String; procedure GetPaths(const drawDat: TDrawData); override; @@ -242,7 +262,7 @@ TSymbolElement = class(TShapeElement) protected viewboxWH: TRectWH; public - constructor Create(parent: TSvgElement; svgEl: TSvgTreeEl); override; + constructor Create(parent: TBaseElement; svgEl: TSvgTreeEl); override; end; //------------------------------------- @@ -258,7 +278,7 @@ TPathElement = class(TShapeElement) procedure GetPaths(const drawDat: TDrawData); override; function GetSimplePath(const drawDat: TDrawData): TPathsD; override; public - constructor Create(parent: TSvgElement; svgEl: TSvgTreeEl); override; + constructor Create(parent: TBaseElement; svgEl: TSvgTreeEl); override; destructor Destroy; override; end; @@ -278,7 +298,7 @@ TLineElement = class(TShapeElement) procedure GetPaths(const drawDat: TDrawData); override; function GetSimplePath(const drawDat: TDrawData): TPathsD; override; public - constructor Create(parent: TSvgElement; svgEl: TSvgTreeEl); override; + constructor Create(parent: TBaseElement; svgEl: TSvgTreeEl); override; end; TCircleElement = class(TShapeElement) @@ -288,7 +308,7 @@ TCircleElement = class(TShapeElement) function GetBounds: TRectD; override; procedure GetPaths(const drawDat: TDrawData); override; public - constructor Create(parent: TSvgElement; svgEl: TSvgTreeEl); override; + constructor Create(parent: TBaseElement; svgEl: TSvgTreeEl); override; end; TEllipseElement = class(TShapeElement) @@ -298,7 +318,7 @@ TEllipseElement = class(TShapeElement) function GetBounds: TRectD; override; procedure GetPaths(const drawDat: TDrawData); override; public - constructor Create(parent: TSvgElement; svgEl: TSvgTreeEl); override; + constructor Create(parent: TBaseElement; svgEl: TSvgTreeEl); override; end; TRectElement = class(TShapeElement) @@ -308,7 +328,7 @@ TRectElement = class(TShapeElement) procedure GetPaths(const drawDat: TDrawData); override; function GetSimplePath(const drawDat: TDrawData): TPathsD; override; public - constructor Create(parent: TSvgElement; svgEl: TSvgTreeEl); override; + constructor Create(parent: TBaseElement; svgEl: TSvgTreeEl); override; end; //TTextElement: although this is a TShapeElement descendant, it's really @@ -325,12 +345,12 @@ TTextElement = class(TShapeElement) function LoadContent: Boolean; override; procedure Draw(img: TImage32; drawDat: TDrawData); override; public - constructor Create(parent: TSvgElement; svgEl: TSvgTreeEl); override; + constructor Create(parent: TBaseElement; svgEl: TSvgTreeEl); override; end; TTSpanElement = class(TTextElement) public - constructor Create(parent: TSvgElement; svgEl: TSvgTreeEl); override; + constructor Create(parent: TBaseElement; svgEl: TSvgTreeEl); override; end; TSubtextElement = class(TShapeElement) @@ -339,7 +359,7 @@ TSubtextElement = class(TShapeElement) procedure GetPaths(const drawDat: TDrawData); override; function GetBounds: TRectD; override; public - constructor Create(parent: TSvgElement; svgEl: TSvgTreeEl); override; + constructor Create(parent: TBaseElement; svgEl: TSvgTreeEl); override; end; //------------------------------------- @@ -363,7 +383,7 @@ TMarkerElement = class(TShapeElement) function SetMiddlePoints(const points: TPathD): Boolean; procedure Draw(img: TImage32; drawDat: TDrawData); override; public - constructor Create(parent: TSvgElement; svgEl: TSvgTreeEl); override; + constructor Create(parent: TBaseElement; svgEl: TSvgTreeEl); override; end; TSvgColorStop = record @@ -372,7 +392,7 @@ TSvgColorStop = record end; TSvgColorStops = array of TSvgColorStop; - TFillElement = class(TSvgElement) + TFillElement = class(TBaseElement) protected refEl : UTF8String; units : Cardinal; @@ -381,11 +401,13 @@ TFillElement = class(TSvgElement) TPatternElement = class(TFillElement) protected - pattBoxWH : TRectWH; + ImgRenderer : TImageRenderer; + pattBoxWH : TRectWH; function PrepareRenderer(renderer: TImageRenderer; drawDat: TDrawData): Boolean; virtual; public - constructor Create(parent: TSvgElement; svgEl: TSvgTreeEl); override; + constructor Create(parent: TBaseElement; svgEl: TSvgTreeEl); override; + destructor Destroy; override; end; //nb: gradients with objectBoundingBox should not be applied to @@ -396,7 +418,7 @@ TGradientElement = class(TFillElement) spreadMethod : TGradientFillStyle; function LoadContent: Boolean; override; procedure AddStop(color: TColor32; offset: double); - procedure AssignTo(other: TSvgElement); virtual; + procedure AssignTo(other: TBaseElement); virtual; function PrepareRenderer(renderer: TCustomGradientRenderer; drawDat: TDrawData): Boolean; virtual; end; @@ -405,32 +427,32 @@ TRadGradElement = class(TGradientElement) protected radius: TValuePt; F, C: TValuePt; - procedure AssignTo(other: TSvgElement); override; + procedure AssignTo(other: TBaseElement); override; function PrepareRenderer(renderer: TCustomGradientRenderer; drawDat: TDrawData): Boolean; override; public - constructor Create(parent: TSvgElement; svgEl: TSvgTreeEl); override; + constructor Create(parent: TBaseElement; svgEl: TSvgTreeEl); override; end; TLinGradElement = class(TGradientElement) protected startPt, endPt: TValuePt; - procedure AssignTo(other: TSvgElement); override; + procedure AssignTo(other: TBaseElement); override; function PrepareRenderer(renderer: TCustomGradientRenderer; drawDat: TDrawData): Boolean; override; public - constructor Create(parent: TSvgElement; svgEl: TSvgTreeEl); override; + constructor Create(parent: TBaseElement; svgEl: TSvgTreeEl); override; end; - TGradStopElement = class(TSvgElement) + TGradStopElement = class(TBaseElement) protected offset: double; color: TColor32; public - constructor Create(parent: TSvgElement; svgEl: TSvgTreeEl); override; + constructor Create(parent: TBaseElement; svgEl: TSvgTreeEl); override; end; - TFilterElement = class(TSvgElement) + TFilterElement = class(TBaseElement) private fSrcImg : TImage32; fLastImg : TImage32; @@ -449,11 +471,11 @@ TFilterElement = class(TSvgElement) procedure Apply(img: TImage32; const filterBounds: TRect; const matrix: TMatrixD); public - constructor Create(parent: TSvgElement; svgEl: TSvgTreeEl); override; + constructor Create(parent: TBaseElement; svgEl: TSvgTreeEl); override; destructor Destroy; override; end; - TFeBaseElement = class(TSvgElement) + TFeBaseElement = class(TBaseElement) private function GetParentAsFilterEl: TFilterElement; protected @@ -473,6 +495,13 @@ TFeBlendElement = class(TFeBaseElement) procedure Apply; override; end; + TFeImageElement = class(TFeBaseElement) + private + refEl: UTF8String; + protected + procedure Apply; override; + end; + TCompositeOp = (coOver, coIn, coOut, coAtop, coXOR, coArithmetic); TFeCompositeElement = class(TFeBaseElement) @@ -481,7 +510,7 @@ TFeCompositeElement = class(TFeBaseElement) compositeOp: TCompositeOp; procedure Apply; override; public - constructor Create(parent: TSvgElement; svgEl: TSvgTreeEl); override; + constructor Create(parent: TBaseElement; svgEl: TSvgTreeEl); override; end; TFeColorMatrixElement = class(TFeBaseElement) @@ -506,7 +535,7 @@ TFeDropShadowElement = class(TFeBaseElement) floodColor : TColor32; procedure Apply; override; public - constructor Create(parent: TSvgElement; svgEl: TSvgTreeEl); override; + constructor Create(parent: TBaseElement; svgEl: TSvgTreeEl); override; end; TFeFloodElement = class(TFeBaseElement) @@ -514,7 +543,7 @@ TFeFloodElement = class(TFeBaseElement) floodColor : TColor32; procedure Apply; override; public - constructor Create(parent: TSvgElement; svgEl: TSvgTreeEl); override; + constructor Create(parent: TBaseElement; svgEl: TSvgTreeEl); override; end; TFeGaussElement = class(TFeBaseElement) @@ -522,7 +551,7 @@ TFeGaussElement = class(TFeBaseElement) stdDev: double; procedure Apply; override; public - constructor Create(parent: TSvgElement; svgEl: TSvgTreeEl); override; + constructor Create(parent: TBaseElement; svgEl: TSvgTreeEl); override; end; TFeMergeElement = class(TFeBaseElement) @@ -558,7 +587,7 @@ TClipPathElement = class(TShapeElement) units: Cardinal; procedure GetPaths(const drawDat: TDrawData); override; public - constructor Create(parent: TSvgElement; svgEl: TSvgTreeEl); override; + constructor Create(parent: TBaseElement; svgEl: TSvgTreeEl); override; end; //------------------------------------- @@ -612,12 +641,14 @@ function HashToElementClass(hash: Cardinal): TElementClass; hfeDropShadow : Result := TFeDropShadowElement; hfeFlood : Result := TFeFloodElement; hFeGaussianBlur : Result := TFeGaussElement; + hFeImage : Result := TFeImageElement; hfeMerge : Result := TFeMergeElement; hfeMergeNode : Result := TFeMergeNodeElement; hfeOffset : Result := TFeOffsetElement; hfePointLight : Result := TFePointLightElement; hfeSpecularLighting : Result := TFeSpecLightElement; hG : Result := TGroupElement; + hImage : Result := TImageElement; hLine : Result := TLineElement; hLineargradient : Result := TLinGradElement; hMarker : Result := TMarkerElement; @@ -629,19 +660,19 @@ function HashToElementClass(hash: Cardinal): TElementClass; hRadialgradient : Result := TRadGradElement; hRect : Result := TRectElement; hStop : Result := TGradStopElement; - hSvg : Result := TSvgRootElement; + hSvg : Result := TSvgElement; hSwitch : Result := TSwitchElement; hSymbol : Result := TSymbolElement; hText : Result := TTextElement; hTextPath : Result := TTextPathElement; hTSpan : Result := TTSpanElement; hUse : Result := TUseElement; - else Result := TSvgElement; //use generic class + else Result := TBaseElement; //use generic class end; end; //------------------------------------------------------------------------------ -procedure UpdateDrawInfo(var drawDat: TDrawData; thisElement: TSvgElement); +procedure UpdateDrawInfo(var drawDat: TDrawData; thisElement: TBaseElement); begin with thisElement.fDrawData do begin @@ -824,20 +855,89 @@ function MatrixApply(const paths: TPathsD; const matrix: TMatrixD): TPathsD; ove // TDefsElement //------------------------------------------------------------------------------ -constructor TDefsElement.Create(parent: TSvgElement; svgEl: TSvgTreeEl); +constructor TDefsElement.Create(parent: TBaseElement; svgEl: TSvgTreeEl); begin inherited; fDrawData.visible := false; end; +//------------------------------------------------------------------------------ +// TImageElement +//------------------------------------------------------------------------------ + +function TrimSpaces(const s: UTF8String): UTF8String; +var + i, j, len: integer; +begin + len := Length(s); + SetLength(Result, len); + j := 0; + for i := 1 to len do + if s[i] > #32 then + begin + inc(j); + Result[j] := s[i]; + end; + SetLength(Result, j); +end; +//------------------------------------------------------------------------------ + +function DrawRefElImage(const refEl: UTF8String; + image: TImage32; dstRec: TRect): Boolean; +var + len, offset: integer; + s: UTF8String; + ms: TMemoryStream; + img: TImage32; +begin + Result := false; + // unfortunately white spaces are sometimes found inside encoded base64 + s := TrimSpaces(refEl); + + len := Length(s); + // currently only accepts **embedded** images + if (len = 0) then Exit; + if Match(@s[1], 'data:image/jpg;base64,') then offset := 22 + else if Match(@s[1], 'data:image/jpeg;base64,') then offset := 23 + else if Match(@s[1], 'data:image/png;base64,') then offset := 22 + else if Match(@s[1], 'data:img/jpg;base64,') then offset := 20 + else if Match(@s[1], 'data:img/jpeg;base64,') then offset := 21 + else if Match(@s[1], 'data:img/png;base64,') then offset := 20 + else Exit; + + ms := TMemoryStream.Create; + img := TImage32.Create; + try + if not Base64Decode(@s[offset +1], len -offset, ms) or + not img.LoadFromStream(ms) then Exit; + image.Copy(img, img.Bounds, dstRec); + finally + ms.Free; + img.Free; + end; + Result := true; +end; +//------------------------------------------------------------------------------ + +procedure TImageElement.Draw(image: TImage32; drawDat: TDrawData); +var + dstRecD: TRectD; +begin + dstRecD := Self.elRectWH.GetRectD(0,0); + drawDat.matrix := MatrixMultiply(drawDat.matrix, fDrawData.matrix); + + MatrixApply(drawDat.matrix, dstRecD); + DrawRefElImage(refEl, image, Rect(dstRecD)); +end; + //------------------------------------------------------------------------------ // TGroupElement //------------------------------------------------------------------------------ procedure TGroupElement.Draw(image: TImage32; drawDat: TDrawData); var - clipEl : TSvgElement; - maskEl : TSvgElement; + clipEl : TBaseElement; + maskEl : TBaseElement; tmpImg : TImage32; clipPaths : TPathsD; clipRec : TRect; @@ -908,7 +1008,7 @@ procedure TSwitchElement.Draw(image: TImage32; drawDat: TDrawData); i: integer; begin for i := 0 to fChilds.Count -1 do - if TSvgElement(fChilds[i]) is TShapeElement then + if TBaseElement(fChilds[i]) is TShapeElement then with TShapeElement(fChilds[i]) do if fDrawData.visible then begin @@ -923,7 +1023,7 @@ procedure TSwitchElement.Draw(image: TImage32; drawDat: TDrawData); procedure TUseElement.GetPaths(const drawDat: TDrawData); var - el: TSvgElement; + el: TBaseElement; dx, dy: double; begin if Assigned(drawPathsF) or (refEl = '') then Exit; @@ -946,8 +1046,8 @@ procedure TUseElement.GetPaths(const drawDat: TDrawData); if (dx <> 0) or (dy <> 0) then begin - drawPathsC := OffsetPath(drawPathsC, dx, dy); - drawPathsO := OffsetPath(drawPathsO, dx, dy); + drawPathsC := TranslatePath(drawPathsC, dx, dy); + drawPathsO := TranslatePath(drawPathsO, dx, dy); end; drawPathsF := CopyPaths(drawPathsC); @@ -955,7 +1055,7 @@ procedure TUseElement.GetPaths(const drawDat: TDrawData); end; //------------------------------------------------------------------------------ -function TUseElement.ValidateNonRecursion(el: TSvgElement): Boolean; +function TUseElement.ValidateNonRecursion(el: TBaseElement): Boolean; begin Result := false; while assigned(el) do @@ -970,7 +1070,7 @@ function TUseElement.ValidateNonRecursion(el: TSvgElement): Boolean; procedure TUseElement.Draw(img: TImage32; drawDat: TDrawData); var - el: TSvgElement; + el: TBaseElement; s, dx, dy: double; scale, scale2: TSizeD; mat: TMatrixD; @@ -1055,6 +1155,8 @@ procedure TUseElement.Draw(img: TImage32; drawDat: TDrawData); DrawChildren(img, drawDat); end; end + else if el is TImageElement then + el.Draw(img, drawDat) else if el is TShapeElement then el.Draw(img, drawDat); end; @@ -1070,7 +1172,7 @@ procedure TMaskElement.GetPaths(const drawDat: TDrawData); begin maskRec := NullRect; for i := 0 to fChilds.Count -1 do - if TSvgElement(fChilds[i]) is TShapeElement then + if TBaseElement(fChilds[i]) is TShapeElement then begin el := TShapeElement(fChilds[i]); el.GetPaths(drawDat); @@ -1098,7 +1200,7 @@ procedure TMaskElement.ApplyMask(img: TImage32; const drawDat: TDrawData); // TSymbolElement //------------------------------------------------------------------------------ -constructor TSymbolElement.Create(parent: TSvgElement; svgEl: TSvgTreeEl); +constructor TSymbolElement.Create(parent: TBaseElement; svgEl: TSvgTreeEl); begin inherited; fDrawData.visible := false; @@ -1114,7 +1216,7 @@ function TGradientElement.LoadContent: Boolean; begin Result := inherited LoadContent; for i := 0 to fChilds.Count -1 do - if TSvgElement(fChilds[i]) is TGradStopElement then + if TBaseElement(fChilds[i]) is TGradStopElement then with TGradStopElement(fChilds[i]) do AddStop(color, offset); end; @@ -1135,7 +1237,7 @@ procedure TGradientElement.AddStop(color: TColor32; offset: double); end; //------------------------------------------------------------------------------ -procedure TGradientElement.AssignTo(other: TSvgElement); +procedure TGradientElement.AssignTo(other: TBaseElement); var i, len: integer; begin @@ -1164,7 +1266,7 @@ procedure TGradientElement.AssignTo(other: TSvgElement); function TGradientElement.PrepareRenderer( renderer: TCustomGradientRenderer; drawDat: TDrawData): Boolean; var - el: TSvgElement; + el: TBaseElement; begin if (refEl <> '') then begin @@ -1179,7 +1281,7 @@ function TGradientElement.PrepareRenderer( // TRadGradElement //------------------------------------------------------------------------------ -constructor TRadGradElement.Create(parent: TSvgElement; svgEl: TSvgTreeEl); +constructor TRadGradElement.Create(parent: TBaseElement; svgEl: TSvgTreeEl); begin inherited; radius.Init; @@ -1188,7 +1290,7 @@ constructor TRadGradElement.Create(parent: TSvgElement; svgEl: TSvgTreeEl); end; //------------------------------------------------------------------------------ -procedure TRadGradElement.AssignTo(other: TSvgElement); +procedure TRadGradElement.AssignTo(other: TBaseElement); begin if not Assigned(other) or not (other is TGradientElement) then Exit; inherited; @@ -1238,7 +1340,7 @@ function TRadGradElement.PrepareRenderer(renderer: TCustomGradientRenderer; if C.X.HasFontUnits then cp := C.GetPoint(drawDat.fontInfo.size, GetRelFracLimit) else cp := C.GetPoint(rec2, GetRelFracLimit); - cp := OffsetPoint(cp, rec2.Left, rec2.Top); + cp := TranslatePoint(cp, rec2.Left, rec2.Top); end else cp := rec2.MidPoint; MatrixApply(fDrawData.matrix, cp); @@ -1251,7 +1353,7 @@ function TRadGradElement.PrepareRenderer(renderer: TCustomGradientRenderer; if F.X.HasFontUnits then fp := F.GetPoint(drawDat.fontInfo.size, GetRelFracLimit) else fp := F.GetPoint(rec2, GetRelFracLimit); - fp := OffsetPoint(fp, rec2.Left, rec2.Top); + fp := TranslatePoint(fp, rec2.Left, rec2.Top); MatrixApply(fDrawData.matrix, fp); MatrixApply(drawDat.matrix, fp); end else @@ -1271,7 +1373,7 @@ function TRadGradElement.PrepareRenderer(renderer: TCustomGradientRenderer; // TLinGradElement //------------------------------------------------------------------------------ -constructor TLinGradElement.Create(parent: TSvgElement; svgEl: TSvgTreeEl); +constructor TLinGradElement.Create(parent: TBaseElement; svgEl: TSvgTreeEl); begin inherited; startPt.Init; @@ -1279,7 +1381,7 @@ constructor TLinGradElement.Create(parent: TSvgElement; svgEl: TSvgTreeEl); end; //------------------------------------------------------------------------------ -procedure TLinGradElement.AssignTo(other: TSvgElement); +procedure TLinGradElement.AssignTo(other: TBaseElement); begin if not Assigned(other) or not (other is TGradientElement) then Exit; inherited; @@ -1338,7 +1440,7 @@ function TLinGradElement.PrepareRenderer( pt2.X := rec2.Width else pt2.X := endPt.X.GetValue(rec2.Width, GetRelFracLimit); pt2.Y := endPt.Y.GetValue(rec2.Height, GetRelFracLimit); - pt2 := OffsetPoint(pt2, rec2.Left, rec2.Top); + pt2 := TranslatePoint(pt2, rec2.Left, rec2.Top); MatrixApply(fDrawData.matrix, pt2); MatrixApply(drawDat.matrix, pt2); @@ -1361,7 +1463,7 @@ function TLinGradElement.PrepareRenderer( // TGradStopElement //------------------------------------------------------------------------------ -constructor TGradStopElement.Create(parent: TSvgElement; svgEl: TSvgTreeEl); +constructor TGradStopElement.Create(parent: TBaseElement; svgEl: TSvgTreeEl); begin inherited; color := clBlack32; @@ -1371,7 +1473,7 @@ constructor TGradStopElement.Create(parent: TSvgElement; svgEl: TSvgTreeEl); // TFilterElement //------------------------------------------------------------------------------ -constructor TFilterElement.Create(parent: TSvgElement; svgEl: TSvgTreeEl); +constructor TFilterElement.Create(parent: TBaseElement; svgEl: TSvgTreeEl); begin inherited; fDrawData.visible := false; @@ -1571,13 +1673,14 @@ procedure TFilterElement.Apply(img: TImage32; try for i := 0 to fChilds.Count -1 do begin - case TSvgElement(fChilds[i]).fParserEl.hash of + case TBaseElement(fChilds[i]).fParserEl.hash of hfeBlend : TFeBlendElement(fChilds[i]).Apply; hfeColorMatrix : TFeColorMatrixElement(fChilds[i]).Apply; hfeComposite : TFeCompositeElement(fChilds[i]).Apply; hfeDefuseLighting : TFeDefuseLightElement(fChilds[i]).Apply; hfeDropShadow : TFeDropShadowElement(fChilds[i]).Apply; hfeFlood : TFeFloodElement(fChilds[i]).Apply; + hfeImage : TFeImageElement(fChilds[i]).Apply; hFeGaussianBlur : TFeGaussElement(fChilds[i]).Apply; hfeMerge : TFeMergeElement(fChilds[i]).Apply; hfeOffset : TFeOffsetElement(fChilds[i]).Apply; @@ -1597,7 +1700,7 @@ procedure TFilterElement.Apply(img: TImage32; function TFeBaseElement.GetParentAsFilterEl: TFilterElement; var - el: TSvgElement; + el: TBaseElement; begin el := fParent; while Assigned(el) and not (el is TFilterElement) do @@ -1668,11 +1771,21 @@ procedure TFeBlendElement.Apply; dstImg.Copy(dstImg2, dstRec2, dstRec); end; +//------------------------------------------------------------------------------ +// TFeImageElement +//------------------------------------------------------------------------------ + +procedure TFeImageElement.Apply; +begin + if GetSrcAndDst then + DrawRefElImage(refEl, dstImg, dstRec); +end; + //------------------------------------------------------------------------------ // TFeCompositeElement //------------------------------------------------------------------------------ -constructor TFeCompositeElement.Create(parent: TSvgElement; svgEl: TSvgTreeEl); +constructor TFeCompositeElement.Create(parent: TBaseElement; svgEl: TSvgTreeEl); begin inherited; fourKs[0] := InvalidD; fourKs[1] := InvalidD; @@ -1847,7 +1960,7 @@ procedure TFeDefuseLightElement.Apply; // TFeDropShadowElement //------------------------------------------------------------------------------ -constructor TFeDropShadowElement.Create(parent: TSvgElement; svgEl: TSvgTreeEl); +constructor TFeDropShadowElement.Create(parent: TBaseElement; svgEl: TSvgTreeEl); begin inherited; stdDev := InvalidD; @@ -1873,7 +1986,7 @@ procedure TFeDropShadowElement.Apply; off := offset.GetPoint(RectD(pfe.fObjectBounds), GetRelFracLimit); off := ScalePoint(off, pfe.fScale); dstOffRec := dstRec; - with Point(off) do Types.OffsetRect(dstOffRec, X, Y); + with Point(off) do TranslateRect(dstOffRec, X, Y); dstImg.Copy(srcImg, srcRec, dstOffRec); dstImg.SetRGB(floodColor); alpha := GetAlpha(floodColor); @@ -1889,7 +2002,7 @@ procedure TFeDropShadowElement.Apply; // TFeFloodElement //------------------------------------------------------------------------------ -constructor TFeFloodElement.Create(parent: TSvgElement; svgEl: TSvgTreeEl); +constructor TFeFloodElement.Create(parent: TBaseElement; svgEl: TSvgTreeEl); begin inherited; floodColor := clInvalid; @@ -1911,7 +2024,7 @@ procedure TFeFloodElement.Apply; // TFeGaussElement //------------------------------------------------------------------------------ -constructor TFeGaussElement.Create(parent: TSvgElement; svgEl: TSvgTreeEl); +constructor TFeGaussElement.Create(parent: TBaseElement; svgEl: TSvgTreeEl); begin inherited; stdDev := InvalidD; @@ -1921,15 +2034,11 @@ constructor TFeGaussElement.Create(parent: TSvgElement; svgEl: TSvgTreeEl); procedure TFeGaussElement.Apply; begin if not GetSrcAndDst or (stdDev = InvalidD) then Exit; - if srcImg <> dstImg then dstImg.Copy(srcImg, srcRec, dstRec); - ////True GaussianBlur is visually optimal, but it's also *extremely* slow. - //GaussianBlur(dstImg, dstRec, Ceil(stdDev *PI * ParentFilterEl.fScale)); - - //FastGaussianBlur is a very good approximation and also very much faster. - //Empirically stdDev * PI/4 more closely emulates other renderers. + // FastGaussianBlur is a very good approximation and also very much faster. + // Empirically stdDev * PI/4 more closely emulates other renderers. FastGaussianBlur(dstImg, dstRec, Ceil(stdDev * PI/4 * ParentFilterEl.fScale)); end; @@ -1948,7 +2057,7 @@ procedure TFeMergeElement.Apply; pfe := ParentFilterEl; for i := 0 to fChilds.Count -1 do - if TSvgElement(fChilds[i]) is TFeMergeNodeElement then + if TBaseElement(fChilds[i]) is TFeMergeNodeElement then with TFeMergeNodeElement(fChilds[i]) do begin if not GetSrcAndDst then Continue; @@ -1989,7 +2098,7 @@ procedure TFeOffsetElement.Apply; off := offset.GetPoint(RectD(pfe.fObjectBounds), GetRelFracLimit); off := ScalePoint(off, pfe.fScale); dstOffRec := dstRec; - with Point(off) do Types.OffsetRect(dstOffRec, X, Y); + with Point(off) do TranslateRect(dstOffRec, X, Y); if srcImg = dstImg then begin @@ -2020,7 +2129,7 @@ procedure TFeSpecLightElement.Apply; // TClipPathElement //------------------------------------------------------------------------------ -constructor TClipPathElement.Create(parent: TSvgElement; svgEl: TSvgTreeEl); +constructor TClipPathElement.Create(parent: TBaseElement; svgEl: TSvgTreeEl); begin inherited; fDrawData.visible := false; @@ -2033,7 +2142,7 @@ procedure TClipPathElement.GetPaths(const drawDat: TDrawData); begin if Assigned(drawPathsC) or Assigned(drawPathsO) then Exit; for i := 0 to fChilds.Count -1 do - if TSvgElement(fChilds[i]) is TShapeElement then + if TBaseElement(fChilds[i]) is TShapeElement then with TShapeElement(fChilds[i]) do begin GetPaths(drawDat); @@ -2048,7 +2157,7 @@ procedure TClipPathElement.GetPaths(const drawDat: TDrawData); // TShapeElement //------------------------------------------------------------------------------ -constructor TShapeElement.Create(parent: TSvgElement; svgEl: TSvgTreeEl); +constructor TShapeElement.Create(parent: TBaseElement; svgEl: TSvgTreeEl); begin inherited; elRectWH.Init; @@ -2064,7 +2173,7 @@ function TShapeElement.GetBounds: TRectD; begin Result := NullRectD; for i := 0 to fChilds.Count -1 do - if TSvgElement(fChilds[i]) is TShapeElement then + if TBaseElement(fChilds[i]) is TShapeElement then Result := UnionRect(Result, TShapeElement(fChilds[i]).GetBounds); end; //------------------------------------------------------------------------------ @@ -2084,9 +2193,9 @@ procedure TShapeElement.Draw(image: TImage32; drawDat: TDrawData); filled : Boolean; clipRec : TRectD; clipRec2 : TRect; - clipPathEl : TSvgElement; - filterEl : TSvgElement; - maskEl : TSvgElement; + clipPathEl : TBaseElement; + filterEl : TBaseElement; + maskEl : TBaseElement; clipPaths : TPathsD; di : TDrawData; usingTempImage: Boolean; @@ -2218,7 +2327,7 @@ procedure TShapeElement.DrawMarkers(img: TImage32; drawDat: TDrawData); var i,j: integer; sw: double; - markerEl: TSvgElement; + markerEl: TBaseElement; markerPaths: TPathsD; pt1, pt2: TPointD; di: TDrawData; @@ -2303,8 +2412,9 @@ function TShapeElement.GetSimplePath(const drawDat: TDrawData): TPathsD; procedure TShapeElement.DrawFilled(img: TImage32; drawDat: TDrawData); var - refEl: TSvgElement; + refEl: TBaseElement; fillPaths: TPathsD; + rec: TRect; begin if not assigned(drawPathsF) then Exit; if drawDat.fillColor = clCurrent then @@ -2332,9 +2442,13 @@ procedure TShapeElement.DrawFilled(img: TImage32; drawDat: TDrawData); end else if refEl is TPatternElement then begin - with TPatternElement(refEl), fReader do - if PrepareRenderer(ImageRenderer, drawDat) then - DrawPolygon(img, fillPaths, drawDat.fillRule, ImageRenderer); + with TPatternElement(refEl) do + if PrepareRenderer(ImgRenderer, drawDat) then + begin + rec := img32.Vector.GetBounds(fillPaths); + ImgRenderer.Offset := rec.TopLeft; + DrawPolygon(img, fillPaths, drawDat.fillRule, ImgRenderer); + end; end; end; end @@ -2364,7 +2478,7 @@ procedure TShapeElement.DrawStroke(img: TImage32; scale: Double; strokeClr: TColor32; strokePaths: TPathsD; - refEl: TSvgElement; + refEl: TBaseElement; endStyle: TEndStyle; joinStyle: TJoinStyle; bounds: TRectD; @@ -2432,12 +2546,12 @@ procedure TShapeElement.DrawStroke(img: TImage32; fReader.LinGradRenderer, endStyle, joinStyle, roundingScale); end else if refEl is TPatternElement then - begin with TPatternElement(refEl) do - PrepareRenderer(fReader.ImageRenderer, drawDat); - DrawLine(img, strokePaths, scaledStrokeWidth, - fReader.ImageRenderer, endStyle, joinStyle, roundingScale); - end; + begin + PrepareRenderer(imgRenderer, drawDat); + DrawLine(img, strokePaths, scaledStrokeWidth, + imgRenderer, endStyle, joinStyle, roundingScale); + end; end else if (joinStyle = jsMiter) then begin @@ -2488,7 +2602,7 @@ procedure TShapeElement.SimpleDrawStroke(const paths: TPathsD; // TPathElement //------------------------------------------------------------------------------ -constructor TPathElement.Create(parent: TSvgElement; svgEl: TSvgTreeEl); +constructor TPathElement.Create(parent: TBaseElement; svgEl: TSvgTreeEl); begin inherited; fSvgPaths := TSvgPath.Create; @@ -2627,7 +2741,7 @@ procedure TPolyElement.ParsePoints(const value: UTF8String); // TLineElement //------------------------------------------------------------------------------ -constructor TLineElement.Create(parent: TSvgElement; svgEl: TSvgTreeEl); +constructor TLineElement.Create(parent: TBaseElement; svgEl: TSvgTreeEl); begin inherited; SetLength(path, 2); @@ -2659,7 +2773,7 @@ function TLineElement.GetSimplePath(const drawDat: TDrawData): TPathsD; // TCircleElement //------------------------------------------------------------------------------ -constructor TCircleElement.Create(parent: TSvgElement; svgEl: TSvgTreeEl); +constructor TCircleElement.Create(parent: TBaseElement; svgEl: TSvgTreeEl); begin inherited; centerPt.Init; @@ -2703,7 +2817,7 @@ procedure TCircleElement.GetPaths(const drawDat: TDrawData); // TEllipseElement //------------------------------------------------------------------------------ -constructor TEllipseElement.Create(parent: TSvgElement; svgEl: TSvgTreeEl); +constructor TEllipseElement.Create(parent: TBaseElement; svgEl: TSvgTreeEl); begin inherited; centerPt.Init; @@ -2747,7 +2861,7 @@ procedure TEllipseElement.GetPaths(const drawDat: TDrawData); // TRectElement //------------------------------------------------------------------------------ -constructor TRectElement.Create(parent: TSvgElement; svgEl: TSvgTreeEl); +constructor TRectElement.Create(parent: TBaseElement; svgEl: TSvgTreeEl); begin inherited; radius.Init; @@ -2801,7 +2915,7 @@ function TRectElement.GetSimplePath(const drawDat: TDrawData): TPathsD; // TTextElement //------------------------------------------------------------------------------ -constructor TTextElement.Create(parent: TSvgElement; svgEl: TSvgTreeEl); +constructor TTextElement.Create(parent: TBaseElement; svgEl: TSvgTreeEl); begin inherited; offset.Init; @@ -2814,7 +2928,7 @@ function TTextElement.LoadContent: Boolean; i : integer; svgEl : TSvgTreeEl; elClass : TElementClass; - el : TSvgElement; + el : TBaseElement; begin Result := false; for i := 0 to fParserEl.childs.Count -1 do @@ -2829,7 +2943,7 @@ function TTextElement.LoadContent: Boolean; end else begin elClass := HashToElementClass(svgEl.hash); - if elClass = TSvgElement then Continue; + if elClass = TBaseElement then Continue; el := elClass.Create(self, svgEl); Self.fChilds.Add(el); el.LoadAttributes; @@ -2842,7 +2956,7 @@ function TTextElement.LoadContent: Boolean; function TTextElement.GetTopTextElement: TTextElement; var - el: TSvgElement; + el: TBaseElement; begin el := self; while Assigned(el.fParent) and (el.fParent is TTextElement) do @@ -2856,14 +2970,14 @@ procedure TTextElement.DoOffsetX(dx: double); i: integer; begin for i := 0 to fChilds.Count -1 do - if TSvgElement(fChilds[i]) is TTextElement then + if TBaseElement(fChilds[i]) is TTextElement then TTextElement(fChilds[i]).DoOffsetX(dx) - else if TSvgElement(fChilds[i]) is TSubTextElement then + else if TBaseElement(fChilds[i]) is TSubTextElement then with TSubTextElement(fChilds[i]) do begin - drawPathsC := OffsetPath(drawPathsC, dx, 0); - drawPathsO := OffsetPath(drawPathsO, dx, 0); - drawPathsF := OffsetPath(drawPathsF, dx, 0); + drawPathsC := TranslatePath(drawPathsC, dx, 0); + drawPathsO := TranslatePath(drawPathsO, dx, 0); + drawPathsF := TranslatePath(drawPathsF, dx, 0); end; end; //------------------------------------------------------------------------------ @@ -2872,7 +2986,7 @@ procedure TTextElement.GetPaths(const drawDat: TDrawData); var i : integer; dy : double; - el : TSvgElement; + el : TBaseElement; di : TDrawData; topTextEl : TTextElement; begin @@ -2931,7 +3045,7 @@ procedure TTextElement.GetPaths(const drawDat: TDrawData); end; for i := 0 to fChilds.Count -1 do - if TSvgElement(fChilds[i]) is TShapeElement then + if TBaseElement(fChilds[i]) is TShapeElement then TShapeElement(fChilds[i]).GetPaths(di); end; //------------------------------------------------------------------------------ @@ -2980,7 +3094,7 @@ procedure TTextElement.Draw(img: TImage32; drawDat: TDrawData); // TSubtextElement //------------------------------------------------------------------------------ -constructor TSubtextElement.Create(parent: TSvgElement; svgEl: TSvgTreeEl); +constructor TSubtextElement.Create(parent: TBaseElement; svgEl: TSvgTreeEl); begin inherited; hasPaths := true; @@ -3033,7 +3147,7 @@ function IsBlankText(const text: UnicodeString): Boolean; procedure TSubtextElement.GetPaths(const drawDat: TDrawData); var - el : TSvgElement; + el : TBaseElement; topTextEl : TTextElement; s: UnicodeString; tmpX, offsetX, scale, fontSize, bs: double; @@ -3115,7 +3229,7 @@ function TSubtextElement.GetBounds: TRectD; // TTSpanElement //------------------------------------------------------------------------------ -constructor TTSpanElement.Create(parent: TSvgElement; svgEl: TSvgTreeEl); +constructor TTSpanElement.Create(parent: TBaseElement; svgEl: TSvgTreeEl); begin inherited; fDrawData.FontInfo.decoration := fdUndefined; @@ -3142,7 +3256,7 @@ function GetPathDistance(const path: TPathD): double; procedure TTextPathElement.GetPaths(const drawDat: TDrawData); var parentTextEl, topTextEl: TTextElement; - el: TSvgElement; + el: TBaseElement; isFirst: Boolean; s: UnicodeString; i, dy, len, charsThatFit: integer; @@ -3178,11 +3292,11 @@ procedure TTextPathElement.GetPaths(const drawDat: TDrawData); if (fParserEl.text = '') then begin if (fChilds.Count = 0) or - not (TSvgElement(fChilds[0]) is TTSpanElement) then + not (TBaseElement(fChilds[0]) is TTSpanElement) then Exit; - el := TSvgElement(fChilds[0]); + el := TBaseElement(fChilds[0]); if (el.fChilds.Count = 0) or - not (TSvgElement(el.fChilds[0]) is TSubtextElement) then + not (TBaseElement(el.fChilds[0]) is TSubtextElement) then Exit; with TSubtextElement(el.fChilds[0]) do begin @@ -3266,7 +3380,7 @@ procedure TTextPathElement.GetPaths(const drawDat: TDrawData); // TMarkerElement //------------------------------------------------------------------------------ -constructor TMarkerElement.Create(parent: TSvgElement; svgEl: TSvgTreeEl); +constructor TMarkerElement.Create(parent: TBaseElement; svgEl: TSvgTreeEl); begin inherited; fDrawData.visible := false; @@ -3362,9 +3476,10 @@ function TFillElement.GetRelFracLimit: double; // TPatternElement //------------------------------------------------------------------------------ -constructor TPatternElement.Create(parent: TSvgElement; svgEl: TSvgTreeEl); +constructor TPatternElement.Create(parent: TBaseElement; svgEl: TSvgTreeEl); begin inherited; + imgRenderer := TImageRenderer.Create; elRectWH.Init; pattBoxWH.Width := InvalidD; pattBoxWH.Height := InvalidD; @@ -3372,12 +3487,19 @@ constructor TPatternElement.Create(parent: TSvgElement; svgEl: TSvgTreeEl); end; //------------------------------------------------------------------------------ +destructor TPatternElement.Destroy; +begin + imgRenderer.Free; + inherited; +end; +//------------------------------------------------------------------------------ + function TPatternElement.PrepareRenderer(renderer: TImageRenderer; drawDat: TDrawData): Boolean; var i : integer; recWH : TRectWH; - el : TSvgElement; + el : TBaseElement; rec : TRectD; mat : TMatrixD; sx,sy : double; @@ -3386,6 +3508,7 @@ function TPatternElement.PrepareRenderer(renderer: TImageRenderer; Result := false; scale := ExtractScaleFromMatrix(drawDat.matrix); + if units = hUserSpaceOnUse then rec := fReader.userSpaceBounds else rec := drawDat.bounds; @@ -3421,7 +3544,6 @@ function TPatternElement.PrepareRenderer(renderer: TImageRenderer; mat := IdentityMatrix; MatrixScale(mat, scale.cx * sx, scale.cy * sy); - //recWH.Left := 0; recWH.Top := 0; if (refEl <> '') then begin el := FindRefElement(refEl); @@ -3436,8 +3558,16 @@ function TPatternElement.PrepareRenderer(renderer: TImageRenderer; end; for i := 0 to fChilds.Count -1 do - if TSvgElement(fChilds[i]) is TShapeElement then + if TBaseElement(fChilds[i]) is TShapeElement then with TShapeElement(fChilds[i]) do + begin + drawDat := fDrawData; + drawDat.matrix := mat; + drawDat.bounds := rec; + Draw(renderer.Image, drawDat); + end + else if TBaseElement(fChilds[i]) is TImageElement then + with TImageElement(fChilds[i]) do begin drawDat := fDrawData; drawDat.matrix := mat; @@ -3447,22 +3577,41 @@ function TPatternElement.PrepareRenderer(renderer: TImageRenderer; end; //------------------------------------------------------------------------------ -// TSvgRootElement +// TSvgElement //------------------------------------------------------------------------------ -constructor TSvgRootElement.Create(parent: TSvgElement; svgEl: TSvgTreeEl); +procedure TSvgElement.Draw(image: TImage32; drawDat: TDrawData); +var + sx, sy: double; begin - inherited Create(parent, svgEl); + if (fReader.RootElement <> self) and not viewboxWH.IsEmpty then + begin + sx := image.Width / viewboxWH.Width; + sy := image.Height / viewboxWH.Height; + MatrixScale(drawDat.matrix, sx, sy); + end; + inherited; +end; +//------------------------------------------------------------------------------ + +function TSvgElement.GetViewbox: TRectWH; +begin + if viewboxWH.IsEmpty then + begin + viewboxWH.Width := elRectWH.width.GetValue(defaultSvgWidth, 0); + viewboxWH.height := elRectWH.height.GetValue(defaultSvgHeight, 0); + end; + Result := viewboxWH; end; //------------------------------------------------------------------------------ -// TElement +// TBaseElement //------------------------------------------------------------------------------ -constructor TSvgElement.Create(parent: TSvgElement; svgEl: TSvgTreeEl); +constructor TBaseElement.Create(parent: TBaseElement; svgEl: TSvgTreeEl); begin {$IFDEF XPLAT_GENERICS} - fChilds := TList.create; + fChilds := TList.create; {$ELSE} fChilds := TList.Create; {$ENDIF} @@ -3475,51 +3624,50 @@ constructor TSvgElement.Create(parent: TSvgElement; svgEl: TSvgTreeEl); fDrawData.strokeCap := parent.fDrawData.strokeCap; fDrawData.strokeJoin := parent.fDrawData.strokeJoin; fReader := parent.fReader; - end - else + end; end; //------------------------------------------------------------------------------ -destructor TSvgElement.Destroy; +destructor TBaseElement.Destroy; var i: integer; begin for i := 0 to fChilds.Count -1 do - TSvgElement(fChilds[i]).Free; + TBaseElement(fChilds[i]).Free; fChilds.Free; inherited; end; //------------------------------------------------------------------------------ -function TSvgElement.IsFirstChild: Boolean; +function TBaseElement.IsFirstChild: Boolean; begin Result := not Assigned(fParent) or (self = fParent.fChilds[0]); end; //------------------------------------------------------------------------------ -procedure TSvgElement.Draw(image: TImage32; drawDat: TDrawData); +procedure TBaseElement.Draw(image: TImage32; drawDat: TDrawData); begin DrawChildren(image, drawDat); end; //------------------------------------------------------------------------------ -procedure TSvgElement.DrawChildren(image: TImage32; drawDat: TDrawData); +procedure TBaseElement.DrawChildren(image: TImage32; drawDat: TDrawData); var i: integer; begin for i := 0 to fChilds.Count -1 do - with TSvgElement(fChilds[i]) do + with TBaseElement(fChilds[i]) do if fDrawData.visible then Draw(image, drawDat); end; //------------------------------------------------------------------------------ -function TSvgElement.GetChildCount: integer; +function TBaseElement.GetChildCount: integer; begin Result := fChilds.Count; end; //------------------------------------------------------------------------------ -function TSvgElement.FindChild(const idName: UTF8String): TSvgElement; +function TBaseElement.FindChild(const idName: UTF8String): TBaseElement; var i: integer; begin @@ -3538,15 +3686,15 @@ function TSvgElement.FindChild(const idName: UTF8String): TSvgElement; end; //------------------------------------------------------------------------------ -function TSvgElement.GetChild(index: integer): TSvgElement; +function TBaseElement.GetChild(index: integer): TBaseElement; begin if (index < 0) or (index >= fChilds.count) then Result := nil else - Result := TSvgElement(fChilds[index]); + Result := TBaseElement(fChilds[index]); end; //------------------------------------------------------------------------------ -function TSvgElement.FindRefElement(refname: UTF8String): TSvgElement; +function TBaseElement.FindRefElement(refname: UTF8String): TBaseElement; var i, len: integer; c, endC: PUTF8Char; @@ -3566,7 +3714,7 @@ function TSvgElement.FindRefElement(refname: UTF8String): TSvgElement; ref := ToUTF8String(c, endC); i := fReader.fIdList.IndexOf(string(ref)); if i >= 0 then - Result := TSvgElement(fReader.fIdList.Objects[i]) else + Result := TBaseElement(fReader.fIdList.Objects[i]) else Result := nil; end; @@ -3574,40 +3722,44 @@ function TSvgElement.FindRefElement(refname: UTF8String): TSvgElement; // dozens of function to process various element attributes //------------------------------------------------------------------------------ -procedure Id_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure Id_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); begin aOwnerEl.fId := value; aOwnerEl.fReader.fIdList.AddObject(string(value), aOwnerEl); end; //------------------------------------------------------------------------------ -procedure In_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure In_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); begin if aOwnerEl is TFeBaseElement then TFeBaseElement(aOwnerEl).in1 := value; end; //------------------------------------------------------------------------------ -procedure In2_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure In2_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); begin if aOwnerEl is TFeBaseElement then TFeBaseElement(aOwnerEl).in2 := value; end; //------------------------------------------------------------------------------ -procedure LetterSpacing_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure LetterSpacing_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); begin with TTextElement(aOwnerEl) do UTF8StringToFloat(value, fDrawData.FontInfo.spacing); end; //------------------------------------------------------------------------------ -procedure Href_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure Href_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var - el: TSvgElement; + el: TBaseElement; begin el := aOwnerEl; case el.fParserEl.Hash of + hFeImage: + TFeImageElement(el).refEl := ExtractRef(value); + hImage: + TImageElement(el).refEl := ExtractRef(value); hUse: TUseElement(el).refEl := ExtractRef(value); hTextPath: @@ -3618,7 +3770,7 @@ procedure Href_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure BaselineShift_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure BaselineShift_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var mu: TUnitType; val: double; @@ -3642,7 +3794,7 @@ procedure BaselineShift_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure Color_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure Color_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var color: TColor32; begin @@ -3655,7 +3807,7 @@ procedure Color_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure LightingColor_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure LightingColor_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var color: TColor32; begin @@ -3668,20 +3820,20 @@ procedure LightingColor_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure ClipPath_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure ClipPath_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); begin aOwnerEl.fDrawData.clipElRef := ExtractRef(value); end; //------------------------------------------------------------------------------ -procedure D_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure D_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); begin if aOwnerEl is TPathElement then TPathElement(aOwnerEl).ParseDAttrib(value); end; //------------------------------------------------------------------------------ -procedure Fill_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure Fill_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); begin case aOwnerEl.fParserEl.Hash of hfeDropShadow: @@ -3699,7 +3851,7 @@ procedure Fill_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure FillOpacity_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure FillOpacity_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var val: double; begin @@ -3717,7 +3869,7 @@ procedure FillOpacity_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure DashArray_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure DashArray_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var c, endC: PUTF8Char; val: double; @@ -3738,7 +3890,7 @@ procedure DashArray_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure DashOffset_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure DashOffset_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var c, endC: PUTF8Char; begin @@ -3749,20 +3901,20 @@ procedure DashOffset_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure Display_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure Display_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); begin if GetHash(value) = hNone then aOwnerEl.fDrawData.visible := false; end; //------------------------------------------------------------------------------ -procedure Font_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure Font_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); begin GetSvgFontInfo(value, aOwnerEl.fDrawData.FontInfo); end; //------------------------------------------------------------------------------ -procedure FontFamily_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure FontFamily_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var word: UTF8String; c, endC: PUTF8Char; @@ -3786,7 +3938,7 @@ procedure FontFamily_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure FontSize_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure FontSize_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var num: double; c, endC: PUTF8Char; @@ -3797,7 +3949,7 @@ procedure FontSize_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure FontStyle_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure FontStyle_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); begin with aOwnerEl.fDrawData.FontInfo do if GetHash(value) = hItalic then @@ -3806,7 +3958,7 @@ procedure FontStyle_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure FontWeight_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure FontWeight_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var num: double; @@ -3834,7 +3986,7 @@ procedure FontWeight_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure Fx_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure Fx_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); begin if (aOwnerEl is TRadGradElement) then with TRadGradElement(aOwnerEl) do @@ -3844,7 +3996,7 @@ procedure Fx_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure Fy_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure Fy_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); begin if (aOwnerEl is TRadGradElement) then with TRadGradElement(aOwnerEl) do @@ -3854,7 +4006,7 @@ procedure Fy_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure TextAlign_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure TextAlign_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); begin with aOwnerEl.fDrawData.FontInfo do case GetHash(value) of @@ -3866,7 +4018,7 @@ procedure TextAlign_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure TextDecoration_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure TextDecoration_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); begin with aOwnerEl.fDrawData.FontInfo do case GetHash(value) of @@ -3877,49 +4029,49 @@ procedure TextDecoration_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure TextLength_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure TextLength_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); begin UTF8StringToFloat(value, aOwnerEl.fDrawData.FontInfo.textLength); end; //------------------------------------------------------------------------------ -procedure MarkerStart_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure MarkerStart_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); begin if not (aOwnerEl is TShapeElement) then Exit; aOwnerEl.fDrawData.markerStart := ExtractRef(value); end; //------------------------------------------------------------------------------ -procedure MarkerMiddle_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure MarkerMiddle_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); begin if not (aOwnerEl is TShapeElement) then Exit; aOwnerEl.fDrawData.markerMiddle := ExtractRef(value); end; //------------------------------------------------------------------------------ -procedure MarkerEnd_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure MarkerEnd_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); begin if not (aOwnerEl is TShapeElement) then Exit; aOwnerEl.fDrawData.markerEnd := ExtractRef(value); end; //------------------------------------------------------------------------------ -procedure Filter_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure Filter_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); begin if (aOwnerEl is TShapeElement) then aOwnerEl.fDrawData.filterElRef := ExtractRef(value); end; //------------------------------------------------------------------------------ -procedure Mask_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure Mask_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); begin if (aOwnerEl is TShapeElement) then aOwnerEl.fDrawData.maskElRef := ExtractRef(value); end; //------------------------------------------------------------------------------ -procedure Offset_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure Offset_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var val: TValue; begin @@ -3933,7 +4085,7 @@ procedure Offset_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure Opacity_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure Opacity_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var opacity: double; begin @@ -3944,7 +4096,7 @@ procedure Opacity_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure Operator_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure Operator_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); begin if (aOwnerEl is TFeCompositeElement) then with TFeCompositeElement(aOwnerEl) do @@ -3959,7 +4111,7 @@ procedure Operator_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure Orient_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure Orient_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); begin if (aOwnerEl is TMarkerElement) and (GetHash(value) = hauto_045_start_045_reverse) then @@ -3967,7 +4119,7 @@ procedure Orient_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure StopColor_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure StopColor_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var acolor: TColor32; begin @@ -3983,30 +4135,32 @@ procedure StopColor_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure StopOpacity_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure StopOpacity_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); begin if aOwnerEl is TGradStopElement then UTF8StringToOpacity(value, TGradStopElement(aOwnerEl).color); end; //------------------------------------------------------------------------------ -procedure Points_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure Points_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); begin if aOwnerEl is TPolyElement then TPolyElement(aOwnerEl).ParsePoints(value); end; //------------------------------------------------------------------------------ -procedure Stroke_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure Stroke_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); begin if Match(PUTF8Char(value), 'url(') then aOwnerEl.fDrawData.strokeEl := ExtractRef(value) + else if Match(PUTF8Char(value), 'currentcolor') then + // do nothing else UTF8StringToColor32(value, aOwnerEl.fDrawData.strokeColor); end; //------------------------------------------------------------------------------ -procedure StrokeLineCap_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure StrokeLineCap_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var word: UTF8String; c, endC: PUTF8Char; @@ -4023,7 +4177,7 @@ procedure StrokeLineCap_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure StrokeLineJoin_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure StrokeLineJoin_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var word: UTF8String; c, endC: PUTF8Char; @@ -4040,13 +4194,13 @@ procedure StrokeLineJoin_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure StrokeMiterLimit_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure StrokeMiterLimit_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); begin UTF8StringToFloat(value, aOwnerEl.fDrawData.strokeMitLim); end; //------------------------------------------------------------------------------ -procedure StrokeOpacity_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure StrokeOpacity_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var val: double; begin @@ -4055,7 +4209,7 @@ procedure StrokeOpacity_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure StrokeWidth_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure StrokeWidth_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); begin with aOwnerEl do begin @@ -4065,7 +4219,7 @@ procedure StrokeWidth_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure FillRule_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure FillRule_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); begin if LowerCaseTable[value[1]] = 'e' then aOwnerEl.fDrawData.fillRule := frEvenOdd else @@ -4073,14 +4227,14 @@ procedure FillRule_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure Transform_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure Transform_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); begin with aOwnerEl.fDrawData do matrix := MatrixMultiply(matrix, ParseTransform(value)); end; //------------------------------------------------------------------------------ -procedure Values_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure Values_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var cnt: integer; c, endC: PUTF8Char; @@ -4099,7 +4253,7 @@ procedure Values_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure GradientTransform_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure GradientTransform_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var mat: TMatrixD; begin @@ -4110,7 +4264,7 @@ procedure GradientTransform_Attrib(aOwnerEl: TSvgElement; const value: UTF8Strin end; //------------------------------------------------------------------------------ -procedure GradientUnits_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure GradientUnits_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); begin if aOwnerEl is TFillElement then with TFillElement(aOwnerEl) do @@ -4118,7 +4272,7 @@ procedure GradientUnits_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure Viewbox_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure Viewbox_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); function LoadViewbox: TRectWH; var @@ -4136,7 +4290,7 @@ procedure Viewbox_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); begin case aOwnerEl.fParserEl.Hash of - hSvg : TSvgRootElement(aOwnerEl).viewboxWH := LoadViewbox; + hSvg : TSvgElement(aOwnerEl).viewboxWH := LoadViewbox; hMarker : TMarkerElement(aOwnerEl).markerBoxWH := LoadViewbox; hSymbol : TSymbolElement(aOwnerEl).viewboxWH := LoadViewbox; else if aOwnerEl is TPatternElement then @@ -4145,7 +4299,7 @@ procedure Viewbox_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure Visibility_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure Visibility_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); begin case GetHash(value) of hCollapse: aOwnerEl.fDrawData.visible := false; @@ -4156,7 +4310,7 @@ procedure Visibility_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); //------------------------------------------------------------------------------ -procedure Height_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure Height_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var mu: TUnitType; val: double; @@ -4169,7 +4323,7 @@ procedure Height_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure Width_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure Width_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var mu: TUnitType; val: double; @@ -4182,7 +4336,7 @@ procedure Width_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure Cx_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure Cx_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var mu: TUnitType; val: double; @@ -4202,7 +4356,7 @@ procedure Cx_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure Cy_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure Cy_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var mu: TUnitType; val: double; @@ -4222,7 +4376,7 @@ procedure Cy_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure Dx_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure Dx_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var mu: TUnitType; val: double; @@ -4239,7 +4393,7 @@ procedure Dx_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure Dy_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure Dy_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var mu: TUnitType; val: double; @@ -4256,14 +4410,14 @@ procedure Dy_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure Result_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure Result_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); begin if (aOwnerEl is TFeBaseElement) then TFeBaseElement(aOwnerEl).res := ExtractRef(value); end; //------------------------------------------------------------------------------ -procedure Rx_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure Rx_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var mu: TUnitType; val: double; @@ -4298,7 +4452,7 @@ procedure Rx_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure Ry_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure Ry_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var mu: TUnitType; val: double; @@ -4321,7 +4475,7 @@ procedure Ry_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure SpreadMethod_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure SpreadMethod_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var word: UTF8String; c, endC: PUTF8Char; @@ -4339,7 +4493,7 @@ procedure SpreadMethod_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure SpectacularExponent(aOwnerEl: TSvgElement; const value: UTF8String); +procedure SpectacularExponent(aOwnerEl: TBaseElement; const value: UTF8String); var se: double; begin @@ -4350,7 +4504,7 @@ procedure SpectacularExponent(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure StdDev_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure StdDev_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var sd: double; begin @@ -4365,7 +4519,7 @@ procedure StdDev_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure K1_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure K1_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var val: double; begin @@ -4375,7 +4529,7 @@ procedure K1_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure K2_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure K2_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var val: double; begin @@ -4385,7 +4539,7 @@ procedure K2_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure K3_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure K3_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var val: double; begin @@ -4395,7 +4549,7 @@ procedure K3_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure K4_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure K4_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var val: double; begin @@ -4405,7 +4559,7 @@ procedure K4_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure X1_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure X1_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var mu: TUnitType; val: double; @@ -4430,7 +4584,7 @@ procedure X1_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure X2_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure X2_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var mu: TUnitType; val: double; @@ -4448,7 +4602,7 @@ procedure X2_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure Y1_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure Y1_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var mu: TUnitType; val: double; @@ -4473,7 +4627,7 @@ procedure Y1_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure Y2_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure Y2_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var mu: TUnitType; val: double; @@ -4491,7 +4645,7 @@ procedure Y2_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); end; //------------------------------------------------------------------------------ -procedure Z_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); +procedure Z_Attrib(aOwnerEl: TBaseElement; const value: UTF8String); var val: double; begin @@ -4503,7 +4657,7 @@ procedure Z_Attrib(aOwnerEl: TSvgElement; const value: UTF8String); //------------------------------------------------------------------------------ //------------------------------------------------------------------------------ -procedure TSvgElement.LoadAttribute(attrib: PSvgAttrib); +procedure TBaseElement.LoadAttribute(attrib: PSvgAttrib); begin with attrib^ do case hash of @@ -4594,7 +4748,7 @@ procedure TSvgElement.LoadAttribute(attrib: PSvgAttrib); end; //------------------------------------------------------------------------------ -procedure TSvgElement.LoadAttributes; +procedure TBaseElement.LoadAttributes; var i: integer; begin @@ -4615,7 +4769,7 @@ function PreferRelativeFraction(val: TValue): TTriState; end; //------------------------------------------------------------------------------ -function TSvgElement.GetRelFracLimit: double; +function TBaseElement.GetRelFracLimit: double; begin //the default behaviour here is to assume untyped fractional values //below 1.0 are values relative (to the bounding size) BUT ONLY WHEN @@ -4635,12 +4789,12 @@ function TSvgElement.GetRelFracLimit: double; end; //------------------------------------------------------------------------------ -function TSvgElement.LoadContent: Boolean; +function TBaseElement.LoadContent: Boolean; var i : integer; svgEl : TSvgTreeEl; elClass : TElementClass; - el : TSvgElement; + el : TBaseElement; begin Result := false; for i := 0 to fParserEl.childs.Count -1 do @@ -4668,7 +4822,6 @@ constructor TSvgReader.Create; fClassStyles := TClassStylesList.Create; fLinGradRenderer := TLinearGradientRenderer.Create; fRadGradRenderer := TSvgRadialGradientRenderer.Create; - fImgRenderer := TImageRenderer.Create; fIdList := TStringList.Create; fIdList.Duplicates := dupIgnore; fIdList.CaseSensitive := false; @@ -4691,7 +4844,6 @@ destructor TSvgReader.Destroy; fLinGradRenderer.Free; fRadGradRenderer.Free; - fImgRenderer.Free; FreeAndNil(fFontCache); fSimpleDrawList.Free; @@ -4709,7 +4861,6 @@ procedure TSvgReader.Clear; fClassStyles.Clear; fLinGradRenderer.Clear; fRadGradRenderer.Clear; - fImgRenderer.Image.Clear; currentColor := clBlack32; userSpaceBounds := NullRectD; for i := 0 to fSimpleDrawList.Count -1 do @@ -4718,32 +4869,6 @@ procedure TSvgReader.Clear; end; //------------------------------------------------------------------------------ -function TSvgReader.GetViewbox(containerWidth, containerHeight: integer): TRectWH; -begin - if not Assigned(RootElement) then - begin - Result := RectWH(0,0,0,0); - Exit; - end; - - with RootElement do - begin - Result.Left := 0; - Result.Top := 0; - Result.Width := elRectWH.width.GetValue(containerWidth, 0); - Result.Height := elRectWH.height.GetValue(containerHeight, 0); - - if viewboxWH.IsEmpty then - begin - if Result.IsEmpty then - Result := RectWH(0, 0,containerWidth, containerHeight); - viewboxWH := Result; - end else if Result.IsEmpty then - Result := viewboxWH; - end; -end; -//------------------------------------------------------------------------------ - procedure TSvgReader.DrawImage(img: TImage32; scaleToImage: Boolean); var scale, scale2: double; @@ -4751,12 +4876,13 @@ procedure TSvgReader.DrawImage(img: TImage32; scaleToImage: Boolean); di: TDrawData; begin if not Assigned(fRootElement) or not assigned(img) then Exit; - vbox := GetViewbox(img.Width, img.Height); - if vbox.IsEmpty then Exit; - fBackgndImage := img; with fRootElement do begin + vbox := GetViewbox; + if vbox.IsEmpty then Exit; // this should never happen + fBackgndImage := img; + di := fDrawData; if di.currentColor = clInvalid then di.currentColor := currentColor; @@ -4767,9 +4893,7 @@ procedure TSvgReader.DrawImage(img: TImage32; scaleToImage: Boolean); //rendered image unless they are percentage values. Nevertheless, these //values can be still overridden by the scaleToImage parameter above - if vbox.IsEmpty then - di.bounds := RectD(img.Bounds) else - di.bounds := viewboxWH.RectD; + di.bounds := viewboxWH.RectD; userSpaceBounds := fDrawData.bounds; if scaleToImage and not img.IsEmpty then @@ -4777,13 +4901,15 @@ procedure TSvgReader.DrawImage(img: TImage32; scaleToImage: Boolean); //nb: the calculated vbox.width and vbox.height are ignored here since //we're scaling the SVG image to the display image. However we still //need to call GetViewbox (above) to make sure that viewboxWH is filled. - - scale := img.width / viewboxWH.Width; - scale2 := img.height / viewboxWH.Height; if fUsePropScale then begin - if scale2 < scale then scale := scale2 - else scale2 := scale; + scale := GetScaleForBestFit( + viewboxWH.Width, viewboxWH.Height, img.Width, img.Height); + scale2 := scale; + end else + begin + scale := GetScale(viewboxWH.Width, img.Width); + scale2 := GetScale(viewboxWH.Height, img.Height); end; MatrixScale(di.matrix, scale, scale2); img.SetSize( @@ -4818,7 +4944,7 @@ function TSvgReader.LoadInternal: Boolean; Result := false; if not Assigned(fSvgParser.svgTree) or (fSvgParser.svgTree.hash <> hSvg) then Exit; - fRootElement := TSvgRootElement.Create(nil, fSvgParser.svgTree); + fRootElement := TSvgElement.Create(nil, fSvgParser.svgTree); fRootElement.fReader := self; fRootElement.LoadAttributes; Result := fRootElement.LoadContent; @@ -4869,7 +4995,7 @@ procedure TSvgReader.SetOverrideStrokeColor(color: TColor32); end; //------------------------------------------------------------------------------ -function TSvgReader.FindElement(const idName: UTF8String): TSvgElement; +function TSvgReader.FindElement(const idName: UTF8String): TBaseElement; begin if Assigned(RootElement) then Result := RootElement.FindChild(idName) else diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Text.pas b/Ext/SVGIconImageList/Image32/source/Img32.Text.pas index 620d2eb..bf4821c 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.Text.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.Text.pas @@ -2036,7 +2036,7 @@ function TFontReader.GetWeight: integer; end; GetGlyphInfo(Ord('G'),glyph, dummy, gm); rec := GetBoundsD(glyph); - glyph := Img32.Vector.OffsetPath(glyph, -rec.Left, -rec.Top); + glyph := Img32.Vector.TranslatePath(glyph, -rec.Left, -rec.Top); glyph := Img32.Vector.ScalePath(glyph, imgSize/rec.Width, imgSize/rec.Height); img := TImage32.Create(imgSize,imgSize); @@ -2441,7 +2441,7 @@ function TFontCache.GetTextOutline(const rec: TRect; with wordList.GetWord(j) do if aWord > #32 then begin - app := OffsetPath(paths, x, y + Ascent); + app := TranslatePath(paths, x, y + Ascent); pp := MergePathsArray(app); AppendPath(Result, pp); x := x + width; @@ -2483,7 +2483,7 @@ function TFontCache.GetTextOutline(const rec: TRect; else Exit; end; - Result := OffsetPath(Result, 0, dy); + Result := TranslatePath(Result, 0, dy); finally wl.Free; end; @@ -2552,7 +2552,7 @@ function TFontCache.GetVerticalTextOutline(x, y: double; y := y + yMax * scale; //yMax = char ascent dy := - yMin * scale; //yMin = char descent end; - AppendPath(Result, Img32.Vector.OffsetPath( glyphInfo.contours, x + dx, y)); + AppendPath(Result, TranslatePath( glyphInfo.contours, x + dx, y)); if text[i] = #32 then y := y + dy - interCharSpace else y := y + dy + interCharSpace; @@ -2593,7 +2593,7 @@ function TFontCache.GetTextOutlineInternal(x, y: double; nextX := nextX + prevGlyphKernList[j].kernValue * fScale; end; - currGlyph := OffsetPath(glyphInfo.contours, nextX, y); + currGlyph := TranslatePath(glyphInfo.contours, nextX, y); dx := glyphInfo.metrics.hmtx.advanceWidth * fScale; if i = underlineIdx then @@ -2895,7 +2895,7 @@ function DrawVerticalText(image: TImage32; x, y, interCharSpace: double; y := y + yMax * scale; //yMax = char ascent dy := - yMin * scale; //yMin = char descent end; - glyphs := Img32.Vector.OffsetPath( glyphInfo.contours, x + dx, y); + glyphs := TranslatePath( glyphInfo.contours, x + dx, y); DrawPolygon(image, glyphs, frNonZero, textColor); if text[i] = #32 then y := y + dy - interCharSpace else @@ -3012,7 +3012,7 @@ function GetTextOutlineOnPath(const text: UnicodeString; pt.X := pathInfo.pt.X + pathInfo.vector.X * dx - rotatePt.X; pt.Y := pathInfo.pt.Y + pathInfo.vector.Y * dx - rotatePt.Y; - tmpPaths := OffsetPath(tmpPaths, pt.X, pt.Y); + tmpPaths := TranslatePath(tmpPaths, pt.X, pt.Y); AppendPath(Result, tmpPaths); end; end; diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Transform.pas b/Ext/SVGIconImageList/Image32/source/Img32.Transform.pas index 6bd833c..36dcf6c 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.Transform.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.Transform.pas @@ -3,15 +3,11 @@ (******************************************************************************* * Author : Angus Johnson * * Version : 4.4 * -* Date : 17 December 2023 * +* Date : 30 April 2024 * * Website : http://www.angusj.com * -* Copyright : Angus Johnson 2019-2021 * -* * +* Copyright : Angus Johnson 2019-2024 * * Purpose : Affine and projective transformation routines for TImage32 * -* * -* License : Use, modification & distribution is subject to * -* Boost Software License Ver 1 * -* http://www.boost.org/LICENSE_1_0.txt * +* License : http://www.boost.org/LICENSE_1_0.txt * *******************************************************************************) interface @@ -19,8 +15,7 @@ interface {$I Img32.inc} uses - SysUtils, Classes, Math, Types, - Img32, Img32.Vector; + SysUtils, Classes, Math, Types, Img32, Img32.Vector; type TMatrixD = array [0..2, 0..2] of double; @@ -41,12 +36,15 @@ interface procedure MatrixApply(const matrix: TMatrixD; var rec: TRectD); overload; procedure MatrixApply(const matrix: TMatrixD; var path: TPathD); overload; procedure MatrixApply(const matrix: TMatrixD; var paths: TPathsD); overload; + procedure MatrixApply(const matrix: TMatrixD; + img: TImage32; scaleAdjust: Boolean = false); overload; + function MatrixInvert(var matrix: TMatrixD): Boolean; - //MatrixSkew: dx represents the delta offset of an X coordinate as a - //fraction of its Y coordinate, and likewise for dy. For example, if dx = 0.1 - //and dy = 0, and the matrix is applied to the coordinate [20,15], then the - //transformed coordinate will become [20 + (15 * 0.1),10], ie [21.5,10]. + // MatrixSkew: dx represents the delta offset of an X coordinate as a + // fraction of its Y coordinate, and likewise for dy. Example: if dx = 0.1 + // and dy = 0, and the matrix is applied to the coordinate [20,15], then the + // transformed coordinate will become [20 + (15 * 0.1),10], ie [21.5,10]. procedure MatrixSkew(var matrix: TMatrixD; angleX, angleY: double); procedure MatrixScale(var matrix: TMatrixD; scale: double); overload; procedure MatrixScale(var matrix: TMatrixD; scaleX, scaleY: double); overload; @@ -54,10 +52,18 @@ interface const center: TPointD; angRad: double); procedure MatrixTranslate(var matrix: TMatrixD; dx, dy: double); - //AffineTransformImage: automagically resizes and translates the image - function AffineTransformImage(img: TImage32; matrix: TMatrixD): TPoint; + // The following MatrixExtract routines assume here is no skew + procedure MatrixExtractScale(const mat: TMatrixD; out sx, sy: double); + procedure MatrixExtractTranslation(const mat: TMatrixD; out dx, dy: double); + procedure MatrixExtractRotation(const mat: TMatrixD; out angle: double); + + // AffineTransformImage: will automagically translate the image + // Note: "scaleAdjust" prevents antialiasing extending way outside of images + // when they are being enlarged significantly and rotated concurrently + function AffineTransformImage(img: TImage32; matrix: TMatrixD; + scaleAdjust: Boolean = false): TPoint; - //ProjectiveTransform: + // ProjectiveTransform: // srcPts, dstPts => each path must contain 4 points // margins => the margins around dstPts (in the dest. projective). // Margins are only meaningful when srcPts are inside the image. @@ -106,6 +112,8 @@ interface implementation +uses Img32.Resamplers; + resourcestring rsInvalidScale = 'Invalid matrix scaling factor (0)'; @@ -204,15 +212,11 @@ procedure MatrixApply(const matrix: TMatrixD; var pt: TPointD); procedure MatrixApply(const matrix: TMatrixD; var rec: TRect); var - l,t,b,r,tmpX: double; + path: TPathD; begin - tmpX := rec.Left; - l := tmpX * matrix[0, 0] + rec.Top * matrix[1, 0] + matrix[2, 0]; - t := tmpX * matrix[0, 1] + rec.Top * matrix[1, 1] + matrix[2, 1]; - tmpX := rec.Right; - r := tmpX * matrix[0, 0] + rec.Bottom * matrix[1, 0] + matrix[2, 0]; - b := tmpX * matrix[0, 1] + rec.Bottom * matrix[1, 1] + matrix[2, 1]; - rec := Rect(RectD(l,t,r,b)); + path := Rectangle(rec); + MatrixApply(matrix, path); + rec := GetBounds(path); end; //------------------------------------------------------------------------------ @@ -270,6 +274,13 @@ procedure MatrixApply(const matrix: TMatrixD; var paths: TPathsD); end; //------------------------------------------------------------------------------ +procedure MatrixApply(const matrix: TMatrixD; + img: TImage32; scaleAdjust: Boolean); +begin + AffineTransformImage(img, matrix, scaleAdjust); +end; +//------------------------------------------------------------------------------ + function MatrixMultiply(const modifier, matrix: TMatrixD): TMatrixD; var i, j: Integer; @@ -376,6 +387,36 @@ procedure MatrixSkew(var matrix: TMatrixD; angleX, angleY: double); m[0, 1] := tan(angleY); matrix := MatrixMultiply(m, matrix); end; +//------------------------------------------------------------------------------ + +procedure MatrixExtractScale(const mat: TMatrixD; out sx, sy: double); +begin + sx := Sqrt(Sqr(mat[0,0]) + Sqr(mat[0,1])); + sy := Sqrt(Sqr(mat[1,0]) + Sqr(mat[1,1])); +end; +//------------------------------------------------------------------------------ + +procedure MatrixExtractTranslation(const mat: TMatrixD; out dx, dy: double); +begin + dx := mat[2,0]; + dy := mat[2,1]; +end; +//------------------------------------------------------------------------------ + +procedure MatrixExtractRotation(const mat: TMatrixD; out angle: double); +var + sx, sy: double; + mat2: TMatrixD; +begin + MatrixExtractScale(mat, sx, sy); + mat2 := mat; + mat2[0,0] := mat2[0,0] / sx; + mat2[0,1] := mat2[0,1] / sx; + mat2[1,0] := mat2[1,0] / sy; + mat2[1,1] := mat2[1,1] / sy; + + angle := ArcCos(mat2[0,0]); +end; //------------------------------------------------------------------------------ // Affine Transformation @@ -391,29 +432,58 @@ function GetTransformBounds(img: TImage32; const matrix: TMatrixD): TRect; end; //------------------------------------------------------------------------------ -function AffineTransformImage(img: TImage32; matrix: TMatrixD): TPoint; +function AffineTransformImage(img: TImage32; matrix: TMatrixD; + scaleAdjust: Boolean): TPoint; var i, j: integer; newWidth, newHeight: integer; - x,y: double; + sx, sy, x,y: double; + xLimLo, yLimLo, xLimHi, yLimHi: double; pc: PColor32; tmp: TArrayOfColor32; dstRec: TRect; resampler: TResamplerFunction; +{$IFDEF USE_DOWNSAMPLER_AUTOMATICALLY} + rx: double; + useBoxDownsampler: Boolean; +{$ENDIF} begin Result := NullPoint; + if IsIdentityMatrix(matrix) or + img.IsEmpty or (img.Resampler = 0) then Exit; - if img.Resampler = 0 then - resampler := nil else - resampler := GetResampler(img.Resampler); - - if not Assigned(resampler) or img.IsEmpty or - IsIdentityMatrix(matrix) then - Exit; + resampler := GetResampler(img.Resampler); + if not Assigned(resampler) then Exit; //auto-resize the image so it'll fit transformed image - dstRec := GetTransformBounds(img, matrix); + + dstRec := img.Bounds; + MatrixApply(matrix, dstRec); RectWidthHeight(dstRec, newWidth, newHeight); + + MatrixExtractScale(matrix, sx, sy); +{$IFDEF USE_DOWNSAMPLER_AUTOMATICALLY} + if (sx < 1.0) and (sy < 1.0) then + begin + //only use box downsampling when downsizing + MatrixExtractRotation(matrix, rx); + useBoxDownsampler := (rx = 0); + end else + useBoxDownsampler := false; + + if useBoxDownsampler then + begin + BoxDownSampling(img, sx, sy); + Exit; + end; +{$ENDIF} + + if scaleAdjust then + begin + sx := Max(1, sx * 0.5); + sy := Max(1, sy * 0.5); + end; + //auto-translate the image too Result := dstRec.TopLeft; @@ -423,17 +493,29 @@ function AffineTransformImage(img: TImage32; matrix: TMatrixD): TPoint; SetLength(tmp, newWidth * newHeight); pc := @tmp[0]; + xLimLo := -0.5/sx; + xLimHi := img.Width + 0.5/sx; + yLimLo := -0.5/sy; + yLimHi := img.Height + 0.5/sy; - for i := dstRec.Top to + dstRec.Bottom -1 do + for i := dstRec.Top to dstRec.Bottom -1 do + begin for j := dstRec.Left to dstRec.Right -1 do begin - //convert dest X,Y to src X,Y ... x := j; y := i; MatrixApply(matrix, x, y); - //get weighted pixel (slow) - pc^ := resampler(img, Round(x * 256), Round(y * 256)); + + if (x <= xLimLo) or (x >= xLimHi) or (y <= yLimLo) or (y >= yLimHi) then + pc^ := clNone32 + else + // nb: -0.5 below is needed to properly center the transformed image + // (and this is most obviously needed when there is large scaling) + pc^ := resampler(img, x - 0.5, y - 0.5); + inc(pc); end; + end; + img.BeginUpdate; try img.SetSize(newWidth, newHeight); @@ -505,6 +587,36 @@ procedure GetSrcCoords256(const matrix: TMatrixD; var x, y: integer); end; //------------------------------------------------------------------------------ +procedure GetSrcCoords(const matrix: TMatrixD; var x, y: double); +{$IFDEF INLINE} inline; {$ENDIF} +var + zz: double; +const + Q: integer = MaxInt div 256; +begin + //returns coords multiplied by 256 in anticipation of the following + //GetWeightedPixel function call which in turn expects the lower 8bits + //of the integer coord value to represent a fraction. + zz := 1; + MatrixMulCoord(matrix, x, y, zz); + + if zz = 0 then + begin + if x >= 0 then x := Q else x := -MaxDouble; + if y >= 0 then y := Q else y := -MaxDouble; + end else + begin + x := x/zz; + if x > Q then x := MaxDouble + else if x < -Q then x := -MaxDouble; + + y := y/zz; + if y > Q then y := MaxDouble + else if y < -Q then y := -MaxDouble + end; +end; +//------------------------------------------------------------------------------ + function GetProjectionMatrix(const srcPts, dstPts: TPathD): TMatrixD; var srcMat, dstMat: TMatrixD; @@ -526,7 +638,8 @@ function ProjectiveTransform(img: TImage32; const srcPts, dstPts: TPathD; const margins: TRect): Boolean; var w,h,i,j: integer; - x,y: integer; + x,y: double; + xLimLo, yLimLo, xLimHi, yLimHi: double; rec: TRect; dstPts2: TPathD; mat: TMatrixD; @@ -549,7 +662,12 @@ function ProjectiveTransform(img: TImage32; dec(rec.Top, margins.Top); inc(rec.Right, margins.Right); inc(rec.Bottom, margins.Bottom); - dstPts2 := OffsetPath(dstPts, -rec.Left, -rec.Top); + dstPts2 := TranslatePath(dstPts, -rec.Left, -rec.Top); + + xLimLo := -0.5; + xLimHi := img.Width + 0.5; + yLimLo := -0.5; + yLimHi := img.Height + 0.5; mat := GetProjectionMatrix(srcPts, dstPts2); RectWidthHeight(rec, w, h); @@ -559,8 +677,12 @@ function ProjectiveTransform(img: TImage32; for j := 0 to w -1 do begin x := j; y := i; - GetSrcCoords256(mat, x, y); - pc^ := resampler(img, x, y); + GetSrcCoords(mat, x, y); + + if (x <= xLimLo) or (x >= xLimHi) or (y <= yLimLo) or (y >= yLimHi) then + pc^ := clNone32 + else + pc^ := resampler(img, x -0.5, y -0.5); inc(pc); end; img.SetSize(w, h); @@ -686,7 +808,8 @@ function SplineVertTransform(img: TImage32; const topSpline: TPathD; splineType: TSplineType; backColor: TColor32; out offset: TPoint): Boolean; var i,j, w,h, len: integer; - y, q: double; + x,y, yy, q: double; + yLimLo, yLimHi: double; distances: TArrayOfDouble; pc: PColor32; rec: TRect; @@ -723,29 +846,34 @@ function SplineVertTransform(img: TImage32; const topSpline: TPathD; backColor := backColor and $00FFFFFF; distances := GetCumulativeDistances(topPath); - q := img.Width * 256 / distances[High(distances)];; + q := img.Width / distances[High(distances)]; + + yLimLo := -0.5; + yLimHi := img.Height + 0.5; + for i := 0 to len -1 do begin pc := @tmp[Round(topPath[i].X)-rec.Left]; backColoring := allowBackColoring and (prevX >= topPath[i].X); prevX := topPath[i].X; - y := topPath[i].Y; + yy := topPath[i].Y; for j := rec.top to rec.bottom -1 do begin - if (j > y-1.0) and (j < y + img.Height) then - if backColoring then - pc^ := BlendToAlpha(pc^, - ReColor(resampler(img, Round(Distances[i]*q) ,Round((j - y)*256)), backColor)) - else - pc^ := BlendToAlpha(pc^, - resampler(img, Round(Distances[i]*q) ,Round((j - y)*256))); + x := Distances[i]*q; + y := j - yy; + if (y < yLimLo) or (y > yLimHi) then + // do nothing ! + else if backColoring then + pc^ := BlendToAlpha(pc^, ReColor(resampler(img, x -0.5, y -0.5), backColor)) + else + pc^ := BlendToAlpha(pc^, resampler(img, x -0.5, y -0.5)); inc(pc, w); end; end; img.BeginUpdate; img.SetSize(w,h); - Move(tmp[0], img.Pixels[0], img.Width * img.Height * SizeOf(TColor32)); + Move(tmp[0], img.Pixels[0], w*h * SizeOf(TColor32)); img.EndUpdate; end; //------------------------------------------------------------------------------ @@ -754,7 +882,8 @@ function SplineHorzTransform(img: TImage32; const leftSpline: TPathD; splineType: TSplineType; backColor: TColor32; out offset: TPoint): Boolean; var i,j, len, w,h: integer; - x, q, prevY: double; + x,y, xx, q, prevY: double; + xLimLo, xLimHi: double; leftPath: TPathD; distances: TArrayOfDouble; rec: TRect; @@ -791,22 +920,28 @@ function SplineHorzTransform(img: TImage32; const leftSpline: TPathD; backColor := backColor and $00FFFFFF; distances := GetCumulativeDistances(leftPath); - q := img.Height * 256 / distances[High(distances)];; + q := img.Height / distances[High(distances)];; + xLimLo := -0.5; + xLimHi := img.Width + 0.5; + for i := 0 to len -1 do begin pc := @tmp[Round(leftPath[i].Y - rec.Top) * w]; backColoring := allowBackColoring and (prevY >= leftPath[i].Y); prevY := leftPath[i].Y; - x := leftPath[i].X; + xx := leftPath[i].X; + y := Distances[i]*q; for j := rec.left to rec.right -1 do begin - if (j > x-1.0) and (j < x + img.Width) then - if backColoring then - pc^ := BlendToAlpha(pc^, - ReColor(resampler(img, Round((j - x) *256), Round(Distances[i]*q)), backColor)) - else - pc^ := BlendToAlpha(pc^, - resampler(img, Round((j - x) *256), Round(Distances[i]*q))); + x := j - xx; + + if (x < xLimLo) or (x > xLimHi) then + // do nothing ! + else if backColoring then + pc^ := BlendToAlpha(pc^, ReColor(resampler(img, x -0.5, y -0.5), backColor)) + else + pc^ := BlendToAlpha(pc^, resampler(img, x -0.5, y -0.5)); + inc(pc); end; end; diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Vector.pas b/Ext/SVGIconImageList/Image32/source/Img32.Vector.pas index 72b2554..3fe1ac9 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.Vector.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.Vector.pas @@ -3,9 +3,9 @@ (******************************************************************************* * Author : Angus Johnson * * Version : 4.4 * -* Date : 14 October 2023 * +* Date : 2 May 2024 * * Website : http://www.angusj.com * -* Copyright : Angus Johnson 2019-2023 * +* Copyright : Angus Johnson 2019-2024 * * * * Purpose : Vector drawing for TImage32 * * * @@ -23,7 +23,16 @@ interface type TArrowStyle = (asNone, asSimple, asFancy, asDiamond, asCircle, asTail); - TJoinStyle = (jsAuto, jsSquare, jsMiter, jsRound); + // TJoinStyle: + // jsSquare - Convex joins will be truncated using a 'squaring' edge. + // The mid-points of these squaring edges will also be exactly the offset + // (ie delta) distance away from their origins (ie the starting vertices). + // jsButt - joins are similar to 'squared' joins except that squaring + // won't occur at a fixed distance. While bevelled joins may not be as + // pretty as squared joins, bevelling will be much faster than squaring. + // And perhaps this is why bevelling (rather than squaring) is preferred + // in numerous graphics display formats (including SVG & PDF documents). + TJoinStyle = (jsAuto, jsSquare, jsButt, jsMiter, jsRound); TEndStyle = (esPolygon = 0, esClosed = 0, esButt, esSquare, esRound); TPathEnd = (peStart, peEnd, peBothEnds); TSplineType = (stQuadratic, stCubic); @@ -158,14 +167,14 @@ interface patternOffset: PDouble; lineWidth: double; joinStyle: TJoinStyle; endStyle: TEndStyle): TPathsD; - function OffsetPoint(const pt: TPoint; dx, dy: integer): TPoint; overload; - function OffsetPoint(const pt: TPointD; dx, dy: double): TPointD; overload; + function TranslatePoint(const pt: TPoint; dx, dy: integer): TPoint; overload; + function TranslatePoint(const pt: TPointD; dx, dy: double): TPointD; overload; - function OffsetPath(const path: TPathD; + function TranslatePath(const path: TPathD; dx, dy: double): TPathD; overload; - function OffsetPath(const paths: TPathsD; + function TranslatePath(const paths: TPathsD; dx, dy: double): TPathsD; overload; - function OffsetPath(const ppp: TArrayOfPathsD; + function TranslatePath(const ppp: TArrayOfPathsD; dx, dy: double): TArrayOfPathsD; overload; function Paths(const path: TPathD): TPathsD; @@ -195,6 +204,9 @@ interface function ScaleRect(const rec: TRect; sx, sy: double): TRect; overload; function ScaleRect(const rec: TRectD; sx, sy: double): TRectD; overload; + function ScalePathToFit(const path: TPathD; const rec: TRect): TPathD; + function ScalePathsToFit(const paths: TPathsD; const rec: TRect): TPathsD; + function ReversePath(const path: TPathD): TPathD; overload; function ReversePath(const paths: TPathsD): TPathsD; overload; @@ -202,7 +214,7 @@ interface procedure AppendPoint(var path: TPathD; const extra: TPointD); - procedure AppendPath(var path: TPathD; const pt: TPointD); overload; + procedure AppendToPath(var path: TPathD; const pt: TPointD); overload; procedure AppendPath(var path1: TPathD; const path2: TPathD); overload; procedure AppendPath(var paths: TPathsD; const extra: TPathD); overload; procedure AppendPath(var paths: TPathsD; const extra: TPathsD); overload; @@ -261,7 +273,8 @@ interface function RectsEqual(const rec1, rec2: TRect): Boolean; - procedure OffsetRect(var rec: TRectD; dx, dy: double); overload; + procedure TranslateRect(var rec: TRect; dx, dy: integer); overload; + procedure TranslateRect(var rec: TRectD; dx, dy: double); overload; function MakeSquare(rec: TRect): TRect; @@ -389,8 +402,8 @@ interface function IsPointInEllipse(const ellipseRec: TRect; const pt: TPoint): Boolean; - //GetIntersectsEllipseAndLine: Gets the intersection of an ellipse and - //a line. The function result = true when the line either touches + //GetLineEllipseIntersects: Gets the intersection of a line and + //an ellipse. The function succeeds when the line either touches //tangentially or passes through the ellipse. If the line touches //tangentially, the coordintates returned in pt1 and pt2 will match. function GetLineEllipseIntersects(const ellipseRec: TRect; @@ -410,18 +423,20 @@ interface function GetClosestPtOnRotatedEllipse(const ellipseRect: TRectD; ellipseRotation: double; const pt: TPointD): TPointD; - function Outline(const line: TPathD; lineWidth: double; + // RoughOutline: these are **rough** because outlines are untidy with + // numerous self-intersections and negative area regions. Nevertheless + // these functions are **much** faster that Img32.Clipper.InflatePaths. + // (These two functions are really only intended for internal use.) + function RoughOutline(const line: TPathD; lineWidth: double; joinStyle: TJoinStyle; endStyle: TEndStyle; miterLimOrRndScale: double = 0): TPathsD; overload; - function Outline(const lines: TPathsD; lineWidth: double; + function RoughOutline(const lines: TPathsD; lineWidth: double; joinStyle: TJoinStyle; endStyle: TEndStyle; miterLimOrRndScale: double = 0): TPathsD; overload; - //Grow: Offsets path by 'delta' (positive is away from the left of the path). - //With a positive delta, clockwise paths will expand and counter-clockwise - //ones will contract. The reverse happens with negative deltas. - function Grow(const path, normals: TPathD; delta: double; joinStyle: TJoinStyle; - miterLim: double; isOpen: Boolean = false): TPathD; + // Grow: only intended for internal use + function Grow(const path, normals: TPathD; delta: double; + joinStyle: TJoinStyle; miterLim: double; isOpen: Boolean = false): TPathD; function ValueAlmostZero(val: double; epsilon: double = 0.001): Boolean; function ValueAlmostOne(val: double; epsilon: double = 0.001): Boolean; @@ -704,44 +719,27 @@ procedure GetSinCos(angle: double; out sinA, cosA: double); function GetRotatedRectBounds(const rec: TRect; angle: double): TRect; var - sinA, cosA: double; - w,h, recW, recH: integer; - mp: TPoint; + p: TPathD; + mp: TPointD; begin - NormalizeAngle(angle); + p := Rectangle(rec); + mp := PointD((rec.Left + rec.Right)/2, (rec.Top + rec.Bottom)/2); if angle <> 0 then - begin - GetSinCos(angle, sinA, cosA); //the sign of the angle isn't important - sinA := Abs(sinA); cosA := Abs(cosA); - RectWidthHeight(rec, recW, recH); - w := Ceil((recW *cosA + recH *sinA) /2); - h := Ceil((recW *sinA + recH *cosA) /2); - mp := MidPoint(rec); - Result := Rect(mp.X - w, mp.Y - h, mp.X + w, mp.Y +h); - end - else - Result := rec; + p := RotatePath(p, mp, angle); + Result := GetBounds(p); end; //------------------------------------------------------------------------------ function GetRotatedRectBounds(const rec: TRectD; angle: double): TRectD; var - sinA, cosA: double; - w,h: double; + p: TPathD; mp: TPointD; begin - NormalizeAngle(angle); + p := Rectangle(rec); + mp := PointD((rec.Left + rec.Right)/2, (rec.Top + rec.Bottom)/2); if angle <> 0 then - begin - GetSinCos(angle, sinA, cosA); //the sign of the angle isn't important - sinA := Abs(sinA); cosA := Abs(cosA); - w := (rec.Width *cosA + rec.Height *sinA) /2; - h := (rec.Width *sinA + rec.Height *cosA) /2; - mp := rec.MidPoint; - Result := RectD(mp.X - w, mp.Y - h, mp.X + w, mp.Y +h); - end - else - Result := rec; + p := RotatePath(p, mp, angle); + Result := GetBoundsD(p); end; //------------------------------------------------------------------------------ @@ -801,7 +799,16 @@ function Area(const path: TPathD): Double; end; //------------------------------------------------------------------------------ -procedure OffsetRect(var rec: TRectD; dx, dy: double); +procedure TranslateRect(var rec: TRect; dx, dy: integer); +begin + rec.Left := rec.Left + dx; + rec.Top := rec.Top + dy; + rec.Right := rec.Right + dx; + rec.Bottom := rec.Bottom + dy; +end; +//------------------------------------------------------------------------------ + +procedure TranslateRect(var rec: TRectD; dx, dy: double); begin rec.Left := rec.Left + dx; rec.Top := rec.Top + dy; @@ -1117,21 +1124,21 @@ function CopyPaths(const paths: TPathsD): TPathsD; end; //------------------------------------------------------------------------------ -function OffsetPoint(const pt: TPoint; dx, dy: integer): TPoint; +function TranslatePoint(const pt: TPoint; dx, dy: integer): TPoint; begin result.x := pt.x + dx; result.y := pt.y + dy; end; //------------------------------------------------------------------------------ -function OffsetPoint(const pt: TPointD; dx, dy: double): TPointD; +function TranslatePoint(const pt: TPointD; dx, dy: double): TPointD; begin result.x := pt.x + dx; result.y := pt.y + dy; end; //------------------------------------------------------------------------------ -function OffsetPath(const path: TPathD; dx, dy: double): TPathD; +function TranslatePath(const path: TPathD; dx, dy: double): TPathD; var i, len: integer; begin @@ -1145,7 +1152,7 @@ function OffsetPath(const path: TPathD; dx, dy: double): TPathD; end; //------------------------------------------------------------------------------ -function OffsetPath(const paths: TPathsD; +function TranslatePath(const paths: TPathsD; dx, dy: double): TPathsD; var i,len: integer; @@ -1153,18 +1160,18 @@ function OffsetPath(const paths: TPathsD; len := length(paths); setLength(result, len); for i := 0 to len -1 do - result[i] := OffsetPath(paths[i], dx, dy); + result[i] := TranslatePath(paths[i], dx, dy); end; //------------------------------------------------------------------------------ -function OffsetPath(const ppp: TArrayOfPathsD; dx, dy: double): TArrayOfPathsD; +function TranslatePath(const ppp: TArrayOfPathsD; dx, dy: double): TArrayOfPathsD; var i,len: integer; begin len := length(ppp); setLength(result, len); for i := 0 to len -1 do - result[i] := OffsetPath(ppp[i], dx, dy); + result[i] := TranslatePath(ppp[i], dx, dy); end; //------------------------------------------------------------------------------ @@ -1270,6 +1277,42 @@ function ScaleRect(const rec: TRectD; sx, sy: double): TRectD; end; //------------------------------------------------------------------------------ +function ScalePathToFit(const path: TPathD; const rec: TRect): TPathD; +var + pathWidth, pathHeight, outHeight, outWidth: integer; + pathBounds: TRect; + scale: double; +begin + pathBounds := GetBounds(path); + RectWidthHeight(pathBounds, pathWidth, pathHeight); + RectWidthHeight(rec, outWidth, outHeight); + Result := TranslatePath(path, + rec.Left - pathBounds.Left, rec.Top - pathBounds.Top); + if outWidth / pathWidth < outHeight / pathHeight then + scale := outWidth / pathWidth else + scale := outHeight / pathHeight; + Result := ScalePath(Result, scale, scale); +end; +//------------------------------------------------------------------------------ + +function ScalePathsToFit(const paths: TPathsD; const rec: TRect): TPathsD; +var + pathWidth, pathHeight, outHeight, outWidth: integer; + pathBounds: TRect; + scale: double; +begin + pathBounds := GetBounds(paths); + RectWidthHeight(pathBounds, pathWidth, pathHeight); + RectWidthHeight(rec, outWidth, outHeight); + Result := TranslatePath(paths, + rec.Left - pathBounds.Left, rec.Top - pathBounds.Top); + if outWidth / pathWidth < outHeight / pathHeight then + scale := outWidth / pathWidth else + scale := outHeight / pathHeight; + Result := ScalePath(Result, scale, scale); +end; +//------------------------------------------------------------------------------ + function ReversePath(const path: TPathD): TPathD; var i, highI: integer; @@ -1701,7 +1744,7 @@ function IsPointInEllipse(const ellipseRec: TRect; const pt: TPoint): Boolean; dx := ellipseRec.Left + a; dy := ellipseRec.Top + b; rec := RectD(ellipseRec); - OffsetRect(rec, -dx, -dy); + TranslateRect(rec, -dx, -dy); x := pt.X -dx; y := pt.Y -dy; //first make sure pt is inside rect Result := (abs(x) <= a) and (abs(y) <= b); @@ -1728,9 +1771,9 @@ function GetLineEllipseIntersects(const ellipseRec: TRect; b := rec.Height *0.5; //offset ellipseRect so it's centered over the coordinate origin dx := ellipseRec.Left + a; dy := ellipseRec.Top + b; - offsetRect(rec, -dx, -dy); - pt1 := OffsetPoint(linePt1, -dx, -dy); - pt2 := OffsetPoint(linePt2, -dx, -dy); + TranslateRect(rec, -dx, -dy); + pt1 := TranslatePoint(linePt1, -dx, -dy); + pt2 := TranslatePoint(linePt2, -dx, -dy); //equation of ellipse = (x*x)/(a*a) + (y*y)/(b*b) = 1 //equation of line = y = mx + c; if (pt1.X = pt2.X) then //vertical line (ie infinite slope) @@ -1767,8 +1810,8 @@ function GetLineEllipseIntersects(const ellipseRec: TRect; pt2.Y := m * pt2.X + c; end; //finally reverse initial offset - linePt1 := OffsetPoint(pt1, dx, dy); - linePt2 := OffsetPoint(pt2, dx, dy); + linePt1 := TranslatePoint(pt1, dx, dy); + linePt2 := TranslatePoint(pt2, dx, dy); end; //------------------------------------------------------------------------------ @@ -1787,267 +1830,7 @@ function ApplyNormal(const pt, norm: TPointD; delta: double): TPointD; end; //------------------------------------------------------------------------------ -function GetParallelOffests(const path, norms: TPathD; - delta: double): TPathD; -var - i, highI, len: integer; -begin - len := Length(path); - highI := len -1; - SetLength(Result, len *2); - Result[0] := ApplyNormal(path[0], norms[0], delta); - for i := 1 to highI do - begin - Result[i*2-1] := ApplyNormal(path[i], norms[i-1], delta); - Result[i*2] := ApplyNormal(path[i], norms[i], delta); - end; - Result[highI*2+1] := ApplyNormal(path[0], norms[highI], delta); -end; -//------------------------------------------------------------------------------ - -type - TGrowRec = record - StepsPerRad : double; - StepSin : double; - StepCos : double; - Radius : double; - aSin : double; - aCos : double; - pt : TPointD; - norm1 : TPointD; - norm2 : TPointD; - end; - -function DoRound(const growRec: TGrowRec): TPathD; -var - i, steps: Integer; - a: Double; - pt2: TPointD; -begin - with growRec do - begin - a := ArcTan2(aSin, aCos); - steps := Round(StepsPerRad * Abs(a)); - SetLength(Result, steps + 2); - pt2 := PointD(norm1.x * Radius, norm1.y * Radius); - Result[0] := PointD(pt.x + pt2.x, pt.y + pt2.y); - for i := 1 to steps do - begin - pt2 := PointD(pt2.X * StepCos - StepSin * pt2.Y, - pt2.X * StepSin + pt2.Y * StepCos); - Result[i] := PointD(pt.X + pt2.X, pt.Y + pt2.Y); - end; - pt2 := PointD(norm2.x * Radius, norm2.y * Radius); - Result[steps+1] := PointD(pt.x + pt2.x, pt.y + pt2.y); - end; -end; -//------------------------------------------------------------------------------ - -function CalcRoundingSteps(radius: double): double; -begin - //the results of this function have been derived empirically - //and may need further adjustment - if radius < 0.55 then result := 4 - else result := Pi * Sqrt(radius); -end; -//------------------------------------------------------------------------------ - -function Grow(const path, normals: TPathD; delta: double; - joinStyle: TJoinStyle; miterLim: double; isOpen: Boolean): TPathD; -var - resCnt, resCap: integer; - norms : TPathD; - parallelOffsets : TPathD; - - procedure AddPoint(const pt: TPointD); - begin - if resCnt >= resCap then - begin - inc(resCap, 64); - setLength(result, resCap); - end; - result[resCnt] := pt; - inc(resCnt); - end; - - procedure DoMiter(const growRec: TGrowRec); - var - a: double; - begin - with growRec do - begin - a := delta / (1 + aCos); //see offset_triginometry4.svg - AddPoint(PointD(pt.X + (norm2.X + norm1.X) * a, - pt.Y + (norm2.Y + norm1.Y) * a)); - end; - end; - - procedure DoSquare(const growRec: TGrowRec; const po1, po2: TPointD); - var - pt1, pt2: TPointD; - ip, ptQ : TPointD; - vec : TPointD; - begin - with growRec do - begin - // using the reciprocal of unit normals (as unit vectors) - // get the average unit vector ... - //vec := GetAvgUnitVector(PointD(-norm1.Y, norm1.X),PointD(norm2.Y,-norm2.X)); - vec := NormalizeVector(PointD(norm2.Y - norm1.Y, norm1.X - norm2.X)); - // now offset the original vertex delta units along unit vector - ptQ := OffsetPoint(pt, delta * vec.X, delta * vec.Y); - - // get perpendicular vertices - pt1 := OffsetPoint(ptQ, delta * vec.Y, delta * -vec.X); - pt2 := OffsetPoint(ptQ, delta * -vec.Y, delta * vec.X); - // using 2 vertices along one edge offset (po1 & po2) - IntersectPoint(pt1,pt2,po1,po2, ip); - AddPoint(ip); - //get the second intersect point through reflecion - ip := ReflectPoint(ip, ptQ); - AddPoint(ip); - end; - end; - - procedure AppendPath(const path: TPathD); - var - len: integer; - begin - len := Length(path); - if resCnt + len > resCap then - begin - inc(resCap, len); - setLength(result, resCap); - end; - Move(path[0], result[resCnt], len * SizeOf(TPointD)); - inc(resCnt, len); - end; - -var - i : cardinal; - prevI : cardinal; - len : cardinal; - highI : cardinal; - iLo,iHi : cardinal; - growRec : TGrowRec; - absDelta : double; -begin - Result := nil; - if not Assigned(path) then exit; - len := Length(path); - if not isOpen then - while (len > 2) and - PointsNearEqual(path[len -1], path[0], 0.001) do - dec(len); - if len < 2 then Exit; - - absDelta := Abs(delta); - if absDelta < MinStrokeWidth/2 then - begin - if delta < 0 then - delta := -MinStrokeWidth/2 else - delta := MinStrokeWidth/2; - end; - if absDelta < 1 then - joinStyle := jsSquare - else if joinStyle = jsAuto then - begin - if delta < AutoWidthThreshold / 2 then - joinStyle := jsSquare else - joinStyle := jsRound; - end; - - if assigned(normals) then - norms := normals else - norms := GetNormals(path); - - highI := len -1; - parallelOffsets := GetParallelOffests(path, norms, delta); - - if joinStyle = jsRound then - begin - growRec.Radius := delta; - growRec.StepsPerRad := CalcRoundingSteps(growRec.Radius)/(Pi *2); - if delta < 0 then - GetSinCos(-1/growRec.StepsPerRad, growRec.StepSin, growRec.StepCos) else - GetSinCos(1/growRec.StepsPerRad, growRec.StepSin, growRec.StepCos); - end else - begin - if miterLim <= 0 then miterLim := DefaultMiterLimit - else if miterLim < 2 then miterLim := 2; - miterLim := 2 /(sqr(miterLim)); - growRec.StepsPerRad := 0; //stop compiler warning. - end; - - resCnt := 0; resCap := 0; - - if isOpen then - begin - iLo := 1; iHi := highI -1; - prevI := 0; - AddPoint(parallelOffsets[0]); - end else - begin - iLo := 0; iHi := highI; - prevI := highI; - end; - - for i := iLo to iHi do - begin - - if PointsNearEqual(path[i], path[prevI], 0.01) then - begin - prevI := i; - Continue; - end; - - growRec.aSin := CrossProduct(norms[prevI], norms[i]); - growRec.aCos := DotProduct(norms[prevI], norms[i]); - if (growRec.aSin > 1.0) then growRec.aSin := 1.0 - else if (growRec.aSin < -1.0) then growRec.aSin := -1.0; - - growRec.pt := path[i]; - growRec.norm1 := norms[prevI]; - growRec.norm2 := norms[i]; - - if (growRec.aCos > 0.99) then // almost straight - less than 8 degrees - begin - AddPoint(parallelOffsets[prevI*2+1]); - if (growRec.aCos < 0.9998) then // greater than 1 degree - AddPoint(parallelOffsets[i*2]); - end - else if (growRec.aCos > -0.99) and (growRec.aSin * delta < 0) then - begin //ie is concave - AddPoint(parallelOffsets[prevI*2+1]); - AddPoint(path[i]); - AddPoint(parallelOffsets[i*2]); - end - else if (joinStyle = jsRound) then - begin - AppendPath(DoRound(growRec)); - end - else if (joinStyle = jsMiter) then // nb: miterLim <= 2 - begin - if (1 + growRec.aCos > miterLim) then //within miter range - DoMiter(growRec) else - DoSquare(growRec, - parallelOffsets[prevI*2], parallelOffsets[prevI*2 +1]); - end - // don't bother squaring angles that deviate < ~20 deg. because squaring - // will be indistinguishable from mitering and just be a lot slower - else if (growRec.aCos > 0.9) then - DoMiter(growRec) - else - DoSquare(growRec, parallelOffsets[prevI*2], parallelOffsets[prevI*2 +1]); - - prevI := i; - end; - if isOpen then AddPoint(parallelOffsets[highI*2-1]); - SetLength(Result, resCnt); -end; -//------------------------------------------------------------------------------ - -procedure AppendPath(var path: TPathD; const pt: TPointD); +procedure AppendToPath(var path: TPathD; const pt: TPointD); var len: integer; begin @@ -2353,190 +2136,582 @@ function SegmentsIntersect(const ln1a, ln1b, ln2a, ln2b: TPointD; end; //------------------------------------------------------------------------------ -function ReverseNormals(const norms: TPathD): TPathD; +function CalcRoundingSteps(radius: double): double; +begin + //the results of this function have been derived empirically + //and may need further adjustment + if radius < 0.55 then result := 4 + else result := Pi * Sqrt(radius *2); +end; +//------------------------------------------------------------------------------ + +function Grow(const path, normals: TPathD; delta: double; + joinStyle: TJoinStyle; miterLim: double; isOpen: Boolean): TPathD; var - i, highI: integer; + resCnt, resCap : integer; + norms : TPathD; + stepsPerRadian : double; + stepSin, stepCos : double; + asin, acos : double; + + procedure AddPoint(const pt: TPointD); + begin + if resCnt >= resCap then + begin + inc(resCap, 64); + setLength(result, resCap); + end; + result[resCnt] := pt; + inc(resCnt); + end; + + procedure DoMiter(j, k: Integer; cosA: Double); + var + q: Double; + begin + q := delta / (cosA +1); + AddPoint(PointD( + path[j].X + (norms[k].X + norms[j].X) *q, + path[j].Y + (norms[k].Y + norms[j].Y) *q)); + end; + + procedure DoBevel(j, k: Integer); + var + absDelta: double; + begin + if k = j then + begin + absDelta := Abs(delta); + AddPoint(PointD( + path[j].x - absDelta * norms[j].x, + path[j].y - absDelta * norms[j].y)); + AddPoint(PointD( + path[j].x + absDelta * norms[j].x, + path[j].y + absDelta * norms[j].y)); + end else + begin + AddPoint(PointD( + path[j].x + delta * norms[k].x, + path[j].y + delta * norms[k].y)); + AddPoint(PointD( + path[j].x + delta * norms[j].x, + path[j].y + delta * norms[j].y)); + end; + end; + + procedure DoSquare(j, k: Integer); + var + vec, ptQ, ptR, ptS, ptT, ptU, ip: TPointD; + absDelta: double; + begin + if k = j then + begin + vec.X := norms[j].Y; //squaring a line end + vec.Y := -norms[j].X; + end else + begin + // using the reciprocal of unit normals (as unit vectors) + // get the average unit vector ... + vec := GetAvgUnitVector( + PointD(-norms[k].Y, norms[k].X), + PointD(norms[j].Y, -norms[j].X)); + end; + + absDelta := Abs(delta); + ptQ := PointD(path[j].X + absDelta * vec.X, path[j].Y + absDelta * vec.Y); + + ptR := PointD(ptQ.X + delta * vec.Y, ptQ.Y + delta * -vec.X); + ptS := ReflectPoint(ptR, ptQ); + + // get 2 vertices along one edge offset + ptT := PointD( + path[k].X + norms[k].X * delta, + path[k].Y + norms[k].Y * delta); + + if (j = k) then + begin + ptU.X := ptT.X + vec.X * delta; + ptU.Y := ptT.Y + vec.Y * delta; + ip := IntersectPoint(ptR, ptS, ptT, ptU); + AddPoint(ReflectPoint(ip, ptQ)); + AddPoint(ip); + end else + begin + ptU := PointD( + path[j].X + norms[k].X * delta, + path[j].Y + norms[k].Y * delta); + ip := IntersectPoint(ptR, ptS, ptT, ptU); + AddPoint(ip); + AddPoint(ReflectPoint(ip, ptQ)); + end; + end; + + procedure DoRound(j, k: Integer); + var + i, steps: Integer; + pt: TPointD; + dx, dy, oldDx: double; + angle: double; + begin + // nb: angles may be negative but this will always be a convex join + pt := path[j]; + if j = k then + begin + dx := -norms[k].X * delta; + dy := -norms[k].Y * delta; + end else + begin + dx := norms[k].X * delta; + dy := norms[k].Y * delta; + end; + AddPoint(PointD(pt.X + dx, pt.Y + dy)); + + angle := ArcTan2(asin, acos); + steps := Ceil(stepsPerRadian * abs(angle)); + + for i := 2 to steps do + begin + oldDx := dx; + dx := oldDx * stepCos - stepSin * dy; + dy := oldDx * stepSin + stepCos * dy; + AddPoint(PointD(pt.X + dx, pt.Y + dy)); + end; + AddPoint(PointD( + pt.X + norms[j].X * delta, + pt.Y + norms[j].Y * delta)); + end; + +var + j, k : cardinal; + len : cardinal; + steps : double; + highI : cardinal; + iLo,iHi : cardinal; + absDelta : double; begin - highI := high(norms); - setLength(result, highI +1); - for i := 1 to highI do + Result := nil; + if not Assigned(path) then exit; + len := Length(path); + if not isOpen then + while (len > 2) and + PointsNearEqual(path[len -1], path[0], 0.001) do + dec(len); + if len < 2 then Exit; + + absDelta := Abs(delta); + if absDelta < MinStrokeWidth/2 then + begin + if delta < 0 then + delta := -MinStrokeWidth/2 else + delta := MinStrokeWidth/2; + end; + if absDelta < 1 then + joinStyle := jsButt + else if joinStyle = jsAuto then + begin + if delta < AutoWidthThreshold / 2 then + joinStyle := jsSquare else + joinStyle := jsRound; + end; + + if assigned(normals) then + norms := normals else + norms := GetNormals(path); + + highI := len -1; + + stepsPerRadian := 0; + if joinStyle = jsRound then begin - result[i -1].X := -norms[highI -i].X; - result[i -1].Y := -norms[highI -i].Y; + steps := CalcRoundingSteps(delta); +// // avoid excessive precision // todo - recheck if needed +// if (steps > absDelta * Pi) then +// steps := absDelta * Pi; + stepSin := sin(TwoPi/steps); + stepCos := cos(TwoPi/steps); + if (delta < 0) then stepSin := -stepSin; + stepsPerRadian := steps / TwoPi; end; - result[highI].X := -norms[highI].X; - result[highI].Y := -norms[highI].Y; + + if miterLim <= 0 then miterLim := DefaultMiterLimit + else if miterLim < 2 then miterLim := 2; + miterLim := 2 /(sqr(miterLim)); + + resCnt := 0; + resCap := 0; + + if isOpen then + begin + iLo := 1; iHi := highI -1; + k := 0; + AddPoint(PointD( + path[0].X + norms[0].X * delta, + path[0].Y + norms[0].Y * delta)); + end else + begin + iLo := 0; iHi := highI; + k := highI; + end; + + for j := iLo to iHi do + begin + + if PointsNearEqual(path[j], path[k], 0.01) then + begin + k := j; // todo - check if needed + Continue; + end; + + asin := CrossProduct(norms[k], norms[j]); + if (asin > 1.0) then asin := 1.0 + else if (asin < -1.0) then asin := -1.0; + acos := DotProduct(norms[k], norms[j]); + + if (acos > -0.999) and (asin * delta < 0) then + begin + // is concave + AddPoint(PointD( + path[j].X + norms[k].X * delta, path[j].Y + norms[k].Y * delta)); + AddPoint(path[j]); + AddPoint(PointD( + path[j].X + norms[j].X * delta, path[j].Y + norms[j].Y * delta)); + end + else if (acos > 0.999) and (joinStyle <> jsRound) then + begin + // almost straight - less than 2.5 degree, so miter + DoMiter(j, k, acos); + end + else if (joinStyle = jsMiter) then + begin + if (1 + acos > miterLim) then + DoMiter(j, k, acos) else + DoSquare(j, k); + end + else if (joinStyle = jsRound) then + DoRound(j, k) + else if (joinStyle = jsSquare) then + DoSquare(j, k) + else + DoBevel(j, k); + k := j; + end; + + if isOpen then + AddPoint(PointD( + path[highI].X + norms[highI].X * delta, //todo - check this !!! + path[highI].Y + norms[highI].Y * delta)); + + SetLength(Result, resCnt); end; //------------------------------------------------------------------------------ -function GrowOpenLine(const line: TPathD; width: double; +function GrowOpenLine(const line: TPathD; delta: double; joinStyle: TJoinStyle; endStyle: TEndStyle; - miterLimOrRndScale: double): TPathD; + miterLim: double): TPathD; var - len, x,y: integer; - segLen, halfWidth: double; - normals, line2, lineL, lineR, arc: TPathD; - invNorm: TPointD; - growRec: TGrowRec; + len : integer; + resCnt, resCap : integer; + asin, acos : double; + stepSin, stepCos : double; + stepsPerRadian : double; + path, norms : TPathD; + + procedure AddPoint(const pt: TPointD); + begin + if resCnt >= resCap then + begin + inc(resCap, 64); + setLength(result, resCap); + end; + result[resCnt] := pt; + inc(resCnt); + end; + + procedure DoMiter(j, k: Integer; cosA: Double); + var + q: Double; + begin + q := delta / (cosA +1); + AddPoint(PointD( + path[j].X + (norms[k].X + norms[j].X) *q, + path[j].Y + (norms[k].Y + norms[j].Y) *q)); + end; + + procedure DoBevel(j, k: Integer); + var + absDelta: double; + begin + if k = j then + begin + absDelta := Abs(delta); + AddPoint(PointD( + path[j].x - absDelta * norms[j].x, + path[j].y - absDelta * norms[j].y)); + AddPoint(PointD( + path[j].x + absDelta * norms[j].x, + path[j].y + absDelta * norms[j].y)); + end else + begin + AddPoint(PointD( + path[j].x + delta * norms[k].x, + path[j].y + delta * norms[k].y)); + AddPoint(PointD( + path[j].x + delta * norms[j].x, + path[j].y + delta * norms[j].y)); + end; + end; + + procedure DoSquare(j, k: Integer); + var + vec, ptQ, ptR, ptS, ptT, ptU, ip: TPointD; + absDelta: double; + begin + if k = j then + begin + vec.X := norms[j].Y; //squaring a line end + vec.Y := -norms[j].X; + end else + begin + // using the reciprocal of unit normals (as unit vectors) + // get the average unit vector ... + vec := GetAvgUnitVector( + PointD(-norms[k].Y, norms[k].X), + PointD(norms[j].Y, -norms[j].X)); + end; + + absDelta := Abs(delta); + ptQ := PointD(path[j].X + absDelta * vec.X, path[j].Y + absDelta * vec.Y); + + ptR := PointD(ptQ.X + delta * vec.Y, ptQ.Y + delta * -vec.X); + ptS := ReflectPoint(ptR, ptQ); + + // get 2 vertices along one edge offset + ptT := PointD( + path[k].X + norms[k].X * delta, + path[k].Y + norms[k].Y * delta); + + if (j = k) then + begin + ptU.X := ptT.X + vec.X * delta; + ptU.Y := ptT.Y + vec.Y * delta; + ip := IntersectPoint(ptR, ptS, ptT, ptU); + AddPoint(ReflectPoint(ip, ptQ)); + AddPoint(ip); + end else + begin + ptU := PointD( + path[j].X + norms[k].X * delta, + path[j].Y + norms[k].Y * delta); + ip := IntersectPoint(ptR, ptS, ptT, ptU); + AddPoint(ip); + AddPoint(ReflectPoint(ip, ptQ)); + end; + end; + + procedure DoRound(j, k: Integer); + var + i, steps: Integer; + pt: TPointD; + dx, dy, oldDx: double; + angle: double; + begin + // nb: angles may be negative but this will always be a convex join + pt := path[j]; + if j = k then + begin + dx := -norms[k].X * delta; + dy := -norms[k].Y * delta; + angle := PI; + end else + begin + dx := norms[k].X * delta; + dy := norms[k].Y * delta; + angle := ArcTan2(asin, acos); + end; + AddPoint(PointD(pt.X + dx, pt.Y + dy)); + + steps := Ceil(stepsPerRadian * abs(angle)); + for i := 2 to steps do + begin + oldDx := dx; + dx := oldDx * stepCos - stepSin * dy; + dy := oldDx * stepSin + stepCos * dy; + AddPoint(PointD(pt.X + dx, pt.Y + dy)); + end; + AddPoint(PointD( + pt.X + norms[j].X * delta, + pt.Y + norms[j].Y * delta)); + end; + + procedure DoPoint(j: Cardinal; var k: Cardinal); + begin + asin := CrossProduct(norms[k], norms[j]); + if (asin > 1.0) then asin := 1.0 + else if (asin < -1.0) then asin := -1.0; + acos := DotProduct(norms[k], norms[j]); + + if (acos > -0.999) and (asin * delta < 0) then + begin + // is concave + AddPoint(PointD( + path[j].X + norms[k].X * delta, path[j].Y + norms[k].Y * delta)); + AddPoint(path[j]); + AddPoint(PointD( + path[j].X + norms[j].X * delta, path[j].Y + norms[j].Y * delta)); + end + else if (acos > 0.999) and (joinStyle <> jsRound) then + // almost straight - less than 2.5 degree, so miter + DoMiter(j, k, acos) + else if (joinStyle = jsMiter) then + begin + if (1 + acos > miterLim) then + DoMiter(j, k, acos) else + DoSquare(j, k); + end + else if (joinStyle = jsRound) then + DoRound(j, k) + else if (joinStyle = jsSquare) then + DoSquare(j, k) + else + DoBevel(j, k); + k := j; + end; + +var + highJ : cardinal; + j, k : cardinal; + steps : double; begin Result := nil; - line2 := StripNearDuplicates(line, 0.5, false); - len := length(line2); + path := StripNearDuplicates(line, 0.5, false); + len := length(path); if len = 0 then Exit; - if width < MinStrokeWidth then - width := MinStrokeWidth; - halfWidth := width * 0.5; + if delta < MinStrokeWidth then + delta := MinStrokeWidth; + delta := delta * 0.5; + if len = 1 then begin - x := Round(line2[0].X); - y := Round(line2[0].Y); - SetLength(result, 1); - result := Ellipse(RectD(x -halfWidth, y -halfWidth, - x +halfWidth, y +halfWidth)); + with path[0] do + result := Ellipse(RectD(x-delta, y-delta, x+delta, y+delta)); Exit; end; - if endStyle = esPolygon then - begin - case joinStyle of - jsSquare, jsMiter : endStyle := esSquare; - else endStyle := esRound; - end; - end; + //Assert(endStyle <> esClosed); //with very narrow lines, don't get fancy with joins and line ends - if (width <= 2) then + if (delta <= 1) then begin - joinStyle := jsSquare; + joinStyle := jsButt; if endStyle = esRound then endStyle := esSquare; end else if joinStyle = jsAuto then begin if (endStyle = esRound) and - (width >= AutoWidthThreshold) then + (delta >= AutoWidthThreshold) then joinStyle := jsRound else joinStyle := jsSquare; end; - normals := GetNormals(line2); - if endStyle = esRound then - begin - //grow the line's left side of the line => line1 - lineL := Grow(line2, normals, - halfWidth, joinStyle, miterLimOrRndScale, true); - //build the rounding at the start => result - invNorm.X := -normals[0].X; - invNorm.Y := -normals[0].Y; - //get the rounding parameters - growRec.StepsPerRad := - CalcRoundingSteps(halfWidth * miterLimOrRndScale)/(Pi*2); - GetSinCos(1/growRec.StepsPerRad, growRec.StepSin, growRec.StepCos); - growRec.aSin := invNorm.X * normals[0].Y - invNorm.Y * normals[0].X; - growRec.aCos := invNorm.X * normals[0].X + invNorm.Y * normals[0].Y; - growRec.Radius := halfWidth; - growRec.pt := line2[0]; - growRec.norm1 := invNorm; - growRec.norm2 := normals[0]; - Result := DoRound(growRec); - //join line1 into result - AppendPath(Result, lineL); - //reverse the normals and build the end arc => arc - normals := ReverseNormals(normals); - invNorm.X := -normals[0].X; invNorm.Y := -normals[0].Y; - growRec.aSin := invNorm.X * normals[0].Y - invNorm.Y * normals[0].X; - growRec.aCos := invNorm.X * normals[0].X + invNorm.Y * normals[0].Y; - growRec.pt := line2[High(line2)]; - growRec.norm1 := invNorm; - growRec.norm2 := normals[0]; - arc := DoRound(growRec); - //grow the line's right side of the line - lineR := Grow(ReversePath(line2), normals, - halfWidth, joinStyle, miterLimOrRndScale, true); - //join arc and line2 into result - AppendPath(Result, arc); - AppendPath(Result, lineR); - end else + stepsPerRadian := 0; + if (joinStyle = jsRound) or (endStyle = esRound) then begin - lineL := Copy(line2, 0, len); - if endStyle = esSquare then - begin - // esSquare => extends both line ends by 1/2 lineWidth - AdjustPoint(lineL[0], lineL[1], width * 0.5); - AdjustPoint(lineL[len-1], lineL[len-2], width * 0.5); - end else - begin - //esButt -> extend only very short end segments - segLen := Distance(lineL[0], lineL[1]); - if segLen < width * 0.5 then - AdjustPoint(lineL[0], lineL[1], width * 0.5 - segLen); - segLen := Distance(lineL[len-1], lineL[len-2]); - if segLen < width * 0.5 then - AdjustPoint(lineL[len-1], lineL[len-2], width * 0.5 - segLen); - end; - //first grow the left side of the line => Result - Result := Grow(lineL, normals, - halfWidth, joinStyle, miterLimOrRndScale, true); - //reverse normals and path and grow the right side => lineR - normals := ReverseNormals(normals); - lineR := Grow(ReversePath(lineL), normals, - halfWidth, joinStyle, miterLimOrRndScale, true); - //join both sides - AppendPath(Result, lineR); + steps := CalcRoundingSteps(delta); +// if (steps > absDelta * Pi) then // todo - recheck if needed +// steps := absDelta * Pi; + stepSin := sin(TwoPi/steps); + stepCos := cos(TwoPi/steps); + if (delta < 0) then stepSin := -stepSin; + stepsPerRadian := steps / TwoPi; + end; + + if miterLim <= 0 then miterLim := DefaultMiterLimit + else if miterLim < 2 then miterLim := 2; + miterLim := 2 /(sqr(miterLim)); + + norms := GetNormals(path); + resCnt := 0; resCap := 0; + + case endStyle of + esButt: DoBevel(0,0); + esRound: DoRound(0,0); + else DoSquare(0, 0); end; + + // offset the left side going **forward** + k := 0; + highJ := len -1; + for j := 1 to highJ -1 do DoPoint(j,k); + + // reverse the normals ... + for j := highJ downto 1 do + begin + norms[j].X := -norms[j-1].X; + norms[j].Y := -norms[j-1].Y; + end; + norms[0] := norms[len -1]; + + case endStyle of + esButt: DoBevel(highJ,highJ); + esRound: DoRound(highJ,highJ); + else DoSquare(highJ,highJ); + end; + + // offset the left side going **backward** + k := highJ; + for j := highJ -1 downto 1 do + DoPoint(j, k); + + SetLength(Result, resCnt); end; //------------------------------------------------------------------------------ function GrowClosedLine(const line: TPathD; width: double; joinStyle: TJoinStyle; miterLimOrRndScale: double): TPathsD; var - line2, norms: TPathD; + norms: TPathD; rec: TRectD; skipHole: Boolean; begin - line2 := StripNearDuplicates(line, 0.5, true); - rec := GetBoundsD(line2); + rec := GetBoundsD(line); skipHole := (rec.Width <= width) or (rec.Height <= width); if skipHole then begin SetLength(Result, 1); - norms := GetNormals(line2); - Result[0] := Grow(line2, norms, width/2, joinStyle, miterLimOrRndScale); + norms := GetNormals(line); + Result[0] := Grow(line, norms, width/2, joinStyle, miterLimOrRndScale, false); end else begin SetLength(Result, 2); - norms := GetNormals(line2); - Result[0] := Grow(line2, norms, width/2, joinStyle, miterLimOrRndScale); - line2 := ReversePath(line2); - norms := ReverseNormals(norms); - Result[1] := Grow(line2, norms, width/2, joinStyle, miterLimOrRndScale); + norms := GetNormals(line); + Result[0] := Grow(line, norms, width/2, joinStyle, miterLimOrRndScale, false); + Result[1] := ReversePath( + Grow(line, norms, -width/2, joinStyle, miterLimOrRndScale, false)); end; end; //------------------------------------------------------------------------------ -function Outline(const line: TPathD; lineWidth: double; +function RoughOutline(const line: TPathD; lineWidth: double; joinStyle: TJoinStyle; endStyle: TEndStyle; miterLimOrRndScale: double): TPathsD; +var + lines: TPathsD; begin - if not assigned(line) then - Result := nil - else if endStyle = esClosed then - result := GrowClosedLine(line, - lineWidth, joinStyle, miterLimOrRndScale) - else - begin - SetLength(Result,1); - result[0] := GrowOpenLine(line, lineWidth, - joinStyle, endStyle, miterLimOrRndScale); - end; + SetLength(lines,1); + lines[0] := line; + Result := RoughOutline(lines, lineWidth, + joinStyle, endStyle, miterLimOrRndScale); end; //------------------------------------------------------------------------------ -function Outline(const lines: TPathsD; lineWidth: double; +function RoughOutline(const lines: TPathsD; lineWidth: double; joinStyle: TJoinStyle; endStyle: TEndStyle; miterLimOrRndScale: double): TPathsD; var i: integer; + lwDiv2: double; + p: TPathD; begin result := nil; if not assigned(lines) then exit; @@ -2549,12 +2724,21 @@ function Outline(const lines: TPathsD; lineWidth: double; if endStyle = esPolygon then begin for i := 0 to high(lines) do - if Length(lines[i]) > 2 then - AppendPath(Result, GrowClosedLine(lines[i], - lineWidth, joinStyle, miterLimOrRndScale)) - else - AppendPath(Result, GrowOpenLine(lines[i], lineWidth, - joinStyle, endStyle, miterLimOrRndScale)); + begin + if Length(lines[i]) = 1 then + begin + lwDiv2 := lineWidth/2; + with lines[i][0] do + AppendPath(Result, + Ellipse(RectD(x-lwDiv2, y-lwDiv2, x+lwDiv2, y+lwDiv2))); + end else + begin + p := StripNearDuplicates(lines[i], 0.25, true); + if Length(p) = 2 then AppendToPath(p, p[0]); + AppendPath(Result, + GrowClosedLine(p, lineWidth, joinStyle, miterLimOrRndScale)); + end; + end; end else for i := 0 to high(lines) do @@ -2955,7 +3139,7 @@ function Arc(const rec: TRectD; angle := endAngle - startAngle + angle360 else angle := endAngle - startAngle; //steps = (No. steps for a whole ellipse) * angle/(2*Pi) - steps := Round(CalcRoundingSteps((rec.width + rec.height) * scale)); + steps := Round(CalcRoundingSteps((rec.width + rec.height)/2 * scale)); steps := steps div 2; ///////////////////////////////// if steps < 2 then steps := 2; SetLength(Result, Steps +1); @@ -3006,46 +3190,46 @@ function ArrowHead(const arrowTip, ctrlPt: TPointD; size: double; asSimple: begin setLength(result, 3); - basePt := OffsetPoint(arrowTip, -unitVec.X * size, -unitVec.Y * size); + basePt := TranslatePoint(arrowTip, -unitVec.X * size, -unitVec.Y * size); result[0] := arrowTip; - result[1] := OffsetPoint(basePt, -unitVec.Y * sDiv50, unitVec.X * sDiv50); - result[2] := OffsetPoint(basePt, unitVec.Y * sDiv50, -unitVec.X * sDiv50); + result[1] := TranslatePoint(basePt, -unitVec.Y * sDiv50, unitVec.X * sDiv50); + result[2] := TranslatePoint(basePt, unitVec.Y * sDiv50, -unitVec.X * sDiv50); end; asFancy: begin setLength(result, 4); - basePt := OffsetPoint(arrowTip, + basePt := TranslatePoint(arrowTip, -unitVec.X * sDiv120, -unitVec.Y * sDiv120); - result[0] := OffsetPoint(basePt, -unitVec.Y *sDiv50, unitVec.X *sDiv50); - result[1] := OffsetPoint(arrowTip, -unitVec.X *size, -unitVec.Y *size); - result[2] := OffsetPoint(basePt, unitVec.Y *sDiv50, -unitVec.X *sDiv50); + result[0] := TranslatePoint(basePt, -unitVec.Y *sDiv50, unitVec.X *sDiv50); + result[1] := TranslatePoint(arrowTip, -unitVec.X *size, -unitVec.Y *size); + result[2] := TranslatePoint(basePt, unitVec.Y *sDiv50, -unitVec.X *sDiv50); result[3] := arrowTip; end; asDiamond: begin setLength(result, 4); - basePt := OffsetPoint(arrowTip, -unitVec.X * sDiv60, -unitVec.Y * sDiv60); + basePt := TranslatePoint(arrowTip, -unitVec.X * sDiv60, -unitVec.Y * sDiv60); result[0] := arrowTip; - result[1] := OffsetPoint(basePt, -unitVec.Y * sDiv50, unitVec.X * sDiv50); - result[2] := OffsetPoint(arrowTip, -unitVec.X * sDiv120, -unitVec.Y * sDiv120); - result[3] := OffsetPoint(basePt, unitVec.Y * sDiv50, -unitVec.X * sDiv50); + result[1] := TranslatePoint(basePt, -unitVec.Y * sDiv50, unitVec.X * sDiv50); + result[2] := TranslatePoint(arrowTip, -unitVec.X * sDiv120, -unitVec.Y * sDiv120); + result[3] := TranslatePoint(basePt, unitVec.Y * sDiv50, -unitVec.X * sDiv50); end; asCircle: begin - basePt := OffsetPoint(arrowTip, -unitVec.X * sDiv50, -unitVec.Y * sDiv50); + basePt := TranslatePoint(arrowTip, -unitVec.X * sDiv50, -unitVec.Y * sDiv50); with Point(basePt) do result := Ellipse(RectD(x - sDiv50, y - sDiv50, x + sDiv50, y + sDiv50)); end; asTail: begin setLength(result, 6); - basePt := OffsetPoint(arrowTip, -unitVec.X * sDiv60, -unitVec.Y * sDiv60); - result[0] := OffsetPoint(arrowTip, -unitVec.X * sDiv50, -unitVec.Y * sDiv50); - result[1] := OffsetPoint(arrowTip, -unitVec.Y * sDiv40, unitVec.X * sDiv40); - result[2] := OffsetPoint(basePt, -unitVec.Y * sDiv40, unitVec.X * sDiv40); - result[3] := OffsetPoint(arrowTip, -unitVec.X * sDiv120, -unitVec.Y * sDiv120); - result[4] := OffsetPoint(basePt, unitVec.Y * sDiv40, -unitVec.X * sDiv40); - result[5] := OffsetPoint(arrowTip, unitVec.Y * sDiv40, -unitVec.X * sDiv40); + basePt := TranslatePoint(arrowTip, -unitVec.X * sDiv60, -unitVec.Y * sDiv60); + result[0] := TranslatePoint(arrowTip, -unitVec.X * sDiv50, -unitVec.Y * sDiv50); + result[1] := TranslatePoint(arrowTip, -unitVec.Y * sDiv40, unitVec.X * sDiv40); + result[2] := TranslatePoint(basePt, -unitVec.Y * sDiv40, unitVec.X * sDiv40); + result[3] := TranslatePoint(arrowTip, -unitVec.X * sDiv120, -unitVec.Y * sDiv120); + result[4] := TranslatePoint(basePt, unitVec.Y * sDiv40, -unitVec.X * sDiv40); + result[5] := TranslatePoint(arrowTip, unitVec.Y * sDiv40, -unitVec.X * sDiv40); end; end; end; @@ -3255,8 +3439,9 @@ function GetDashedOutLine(const path: TPathD; if pattern[i] <= 0 then pattern[i] := 1; tmp := GetDashedPath(path, closed, pattern, patternOffset); for i := 0 to high(tmp) do - AppendPath(Result, GrowOpenLine(tmp[i], - lineWidth, joinStyle, endStyle, 2)); +// AppendPath(Result, GrowOpenLine(tmp[i], +// lineWidth, joinStyle, endStyle, 2)); + AppendPath(Result, GrowClosedLine(tmp[i], lineWidth, joinStyle, 2)); end; //------------------------------------------------------------------------------ diff --git a/Ext/SVGIconImageList/Image32/source/Img32.inc b/Ext/SVGIconImageList/Image32/source/Img32.inc index 8690d94..1ea8a27 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.inc +++ b/Ext/SVGIconImageList/Image32/source/Img32.inc @@ -1,20 +1,34 @@ -//NO_STORAGE is experimental -//Allows file system storage of layered objects etc -//Must be disabled to compile the experimental 'CtrlDemo' in Examples +// While "storage" is still technically experimental, +// it does allow file system storage of layered objects etc +// Comment out the following preprocessor define if you do wish to +// use storage (eg to compile the experimental 'CtrlDemo' in Examples). {$DEFINE NO_STORAGE} +// Image downsampling occurs when images are reduced in size, and the default downsampling +// function is 'BoxDownSampling'. When downsampling, this function generally produces much +// clearer images than general purpose resamplers (which are much better at upsampling, +// and doing other affine transformations). However, if for some reason you do wish to use +// a general purpose resampler while downsampling, then disable this define. +{$DEFINE USE_DOWNSAMPLER_AUTOMATICALLY} + +// The SimplifyPath and SimplifyPaths functions have changed. Specifically the last +// parameter has changed from IsOpenPath to IsClosedPath, though the default has also +// changed from false to true which should minimise any inconvenience. This change was +// made to remove an inconsistency with other functions that all contain an IsClosedPath +// parameter. However, if this change is going to create havoc for some reason, then +// the following (somewhat temporary) define can be enabled. +{.$DEFINE USE_OLD_SIMPLIFYPATHS} + //USING_VCL_LCL - using either Delphi Visual Component Library or Lazarus Component Library //is required if using the TImage32Panel component //and adds a few extra library features (eg copying to and from TBitmap objects) {$IF DEFINED(FPC)} {$DEFINE USING_LCL} -{$ELSEIF declared(FireMonkeyVersion)} + {$DEFINE USING_VCL_LCL} +{$ELSEIF declared(FireMonkeyVersion) OR DEFINED(FRAMEWORK_FMX)} {$DEFINE USING_FMX} {$ELSE} {$DEFINE USING_VCL} -{$IFEND} - -{$IF DEFINED(USING_VCL) or DEFINED(USING_LCL)} {$DEFINE USING_VCL_LCL} {$IFEND} @@ -63,14 +77,11 @@ {$IF COMPILERVERSION >= 21} //Delphi 2010 {$DEFINE GESTURES} //added screen gesture support {$IF COMPILERVERSION >= 23} //DelphiXE2 - {$IF declared(FireMonkeyVersion)} //defined in FMX.Types - {$DEFINE FMX} - {$IFEND} {$DEFINE USES_NAMESPACES} {$DEFINE FORMATSETTINGS} {$DEFINE TROUNDINGMODE} {$DEFINE UITYPES} //added UITypes unit - {$DEFINE XPLAT_GENERICS} //reasonable cross-platform & generics support + {$DEFINE XPLAT_GENERICS} //cross-platform generics support {$DEFINE STYLESERVICES} //added StyleServices unit {$IF COMPILERVERSION >= 24} //DelphiXE3 {$LEGACYIFEND ON} diff --git a/Ext/SVGIconImageList/Image32/source/Img32.pas b/Ext/SVGIconImageList/Image32/source/Img32.pas index d431269..023f8b1 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.pas @@ -3,9 +3,9 @@ (******************************************************************************* * Author : Angus Johnson * * Version : 4.4 * -* Date : 17 December 2023 * +* Date : 25 April 2024 * * Website : http://www.angusj.com * -* Copyright : Angus Johnson 2019-2023 * +* Copyright : Angus Johnson 2019-2024 * * Purpose : The core module of the Image32 library * * License : http://www.boost.org/LICENSE_1_0.txt * *******************************************************************************) @@ -164,7 +164,7 @@ TImageFormat = class TTileFillStyle = (tfsRepeat, tfsMirrorHorz, tfsMirrorVert, tfsRotate180); - TResamplerFunction = function(img: TImage32; x256, y256: integer): TColor32; + TResamplerFunction = function(img: TImage32; x, y: double): TColor32; TImage32 = class(TObject) private @@ -195,6 +195,7 @@ TImage32 = class(TObject) function GetBounds: TRect; function GetMidPoint: TPointD; protected + procedure ResetColorCount; function RectHasTransparency(rec: TRect): Boolean; function CopyPixels(rec: TRect): TArrayOfColor32; //CopyInternal: Internal routine (has no scaling or bounds checking) @@ -478,7 +479,9 @@ TImageList32 = class function ClampByte(val: Integer): byte; overload; {$IFDEF INLINE} inline; {$ENDIF} function ClampByte(val: double): byte; overload; {$IFDEF INLINE} inline; {$ENDIF} function ClampRange(val, min, max: Integer): Integer; overload; + {$IFDEF INLINE} inline; {$ENDIF} function ClampRange(val, min, max: double): double; overload; + {$IFDEF INLINE} inline; {$ENDIF} function IncPColor32(pc: Pointer; cnt: Integer): PColor32; procedure NormalizeAngle(var angle: double; tolerance: double = Pi/360); @@ -546,7 +549,7 @@ TImageList32 = class rNearestResampler : integer; rBilinearResampler: integer; rBicubicResampler : integer; - + rWeightedBilinear : integer; DefaultResampler: Integer = 0; //Both MulTable and DivTable are used in blend functions @@ -1667,7 +1670,7 @@ procedure TImage32.AssignTo(dst: TImage32); dst.fResampler := fResampler; dst.fIsPremultiplied := fIsPremultiplied; dst.fAntiAliased := fAntiAliased; - dst.fColorCount := 0; + dst.ResetColorCount; try dst.SetSize(Width, Height); if (Width > 0) and (Height > 0) then @@ -1684,7 +1687,7 @@ procedure TImage32.AssignTo(dst: TImage32); procedure TImage32.Changed; begin if fUpdateCnt <> 0 then Exit; - fColorCount := 0; + ResetColorCount; if Assigned(fOnChange) then fOnChange(Self); end; //------------------------------------------------------------------------------ @@ -1801,6 +1804,12 @@ procedure TImage32.FillRect(rec: TRect; color: TColor32); end; //------------------------------------------------------------------------------ +procedure TImage32.ResetColorCount; +begin + fColorCount := 0; +end; +//------------------------------------------------------------------------------ + function TImage32.RectHasTransparency(rec: TRect): Boolean; var i,j, rw: Integer; @@ -1973,7 +1982,7 @@ procedure TImage32.Resize(newWidth, newHeight: Integer); BlockNotify; try - if fResampler = 0 then + if fResampler <= rNearestResampler then NearestNeighborResize(newWidth, newHeight) else ResamplerResize(newWidth, newHeight); @@ -2000,16 +2009,15 @@ procedure TImage32.NearestNeighborResize(newWidth, newHeight: Integer); //get scaled X & Y values once only (storing them in lookup arrays) ... SetLength(scaledXi, newWidth); for x := 0 to newWidth -1 do - scaledXi[x] := Floor(x * fWidth / newWidth); + scaledXi[x] := Trunc(x * fWidth / newWidth); SetLength(scaledYi, newHeight); for y := 0 to newHeight -1 do - scaledYi[y] := Floor(y * fHeight / newHeight); + scaledYi[y] := Trunc(y * fHeight / newHeight); pc := @tmp[0]; for y := 0 to newHeight - 1 do begin srcY := scaledYi[y]; - if (srcY < 0) or (srcY >= fHeight) then Continue; for x := 0 to newWidth - 1 do begin pc^ := fPixels[scaledXi[x] + srcY * fWidth]; @@ -2083,7 +2091,7 @@ procedure TImage32.ScaleToFitCentered(width, height: integer); Scale(sx); if height = self.Height then Exit; rec2 := Bounds; - Types.OffsetRect(rec2, 0, (height - self.Height) div 2); + TranslateRect(rec2, 0, (height - self.Height) div 2); tmp := TImage32.Create(self); try SetSize(width, height); @@ -2096,7 +2104,7 @@ procedure TImage32.ScaleToFitCentered(width, height: integer); Scale(sy); if width = self.Width then Exit; rec2 := Bounds; - Types.OffsetRect(rec2, (width - self.Width) div 2, 0); + TranslateRect(rec2, (width - self.Width) div 2, 0); tmp := TImage32.Create(self); try SetSize(width, height); @@ -2450,7 +2458,7 @@ function TImage32.CopyBlend(src: TImage32; srcRec, dstRec: TRect; RectWidthHeight(srcRecClipped, w, h); RectWidthHeight(srcRec, srcW, srcH); ScaleRect(dstRec, w / srcW, h / srcH); - Types.OffsetRect(dstRec, + TranslateRect(dstRec, srcRecClipped.Left - srcRec.Left, srcRecClipped.Top - srcRec.Top); end; @@ -2480,7 +2488,7 @@ function TImage32.CopyBlend(src: TImage32; srcRec, dstRec: TRect; RectWidthHeight(dstRecClipped, w, h); RectWidthHeight(dstRec, dstW, dstH); ScaleRect(srcRecClipped, w / dstW, h / dstH); - Types.OffsetRect(srcRecClipped, + TranslateRect(srcRecClipped, dstRecClipped.Left - dstRec.Left, dstRecClipped.Top - dstRec.Top); end; @@ -3156,7 +3164,6 @@ function TImage32.CropTransparentPixels: TRect; procedure TImage32.Rotate(angleRads: double); var - rec: TRectD; mat: TMatrixD; begin if not ClockwiseRotationIsAnglePositive then @@ -3182,11 +3189,10 @@ procedure TImage32.Rotate(angleRads: double); end else begin mat := IdentityMatrix; - MatrixTranslate(mat, Width/2, Height/2); - rec := RectD(Bounds); - rec := GetRotatedRectBounds(rec, angleRads); + // the rotation point isn't important + // because AffineTransformImage() will + // will resize and recenter the image MatrixRotate(mat, NullPointD, angleRads); - MatrixTranslate(mat, rec.Width/2, rec.Height/2); AffineTransformImage(self, mat); end; end; diff --git a/Ext/SVGIconImageList/Source/FMX.SVGIconImageList.pas b/Ext/SVGIconImageList/Source/FMX.SVGIconImageList.pas index 5063866..84b06be 100644 --- a/Ext/SVGIconImageList/Source/FMX.SVGIconImageList.pas +++ b/Ext/SVGIconImageList/Source/FMX.SVGIconImageList.pas @@ -47,7 +47,7 @@ interface ; const - SVGIconImageListVersion = '4.1.2'; + SVGIconImageListVersion = '4.1.3'; DEFAULT_SIZE = 32; ZOOM_DEFAULT = 100; SVG_INHERIT_COLOR = TAlphaColors.Null; diff --git a/Ext/SVGIconImageList/Source/Image32SVGFactory.pas b/Ext/SVGIconImageList/Source/Image32SVGFactory.pas index bf24c5f..a0fe84d 100644 --- a/Ext/SVGIconImageList/Source/Image32SVGFactory.pas +++ b/Ext/SVGIconImageList/Source/Image32SVGFactory.pas @@ -166,7 +166,7 @@ procedure TImage32SVG.UpdateSizeInfo(defaultWidth, defaultHeight: integer); //nb: default widths should be the target image's dimensions //since these values will be used for SVG images that simply //specify their widths and heights as percentages - vbox := fSvgReader.GetViewbox(defaultWidth, defaultHeight); + vbox := fSvgReader.RootElement.GetViewbox; FWidth := vbox.Width; FHeight := vbox.Height; end; diff --git a/Ext/SVGIconImageList/Source/SVGIconImageListBase.pas b/Ext/SVGIconImageList/Source/SVGIconImageListBase.pas index 2b8a68d..d9ef217 100644 --- a/Ext/SVGIconImageList/Source/SVGIconImageListBase.pas +++ b/Ext/SVGIconImageList/Source/SVGIconImageListBase.pas @@ -48,7 +48,7 @@ interface SvgInterfaces; const - SVGIconImageListVersion = '4.1.2'; + SVGIconImageListVersion = '4.1.3'; DEFAULT_SIZE = 16; type diff --git a/Ext/StyledComponents/source/Animations.RES b/Ext/StyledComponents/source/Animations.RES index 5368b52..e5c255b 100644 Binary files a/Ext/StyledComponents/source/Animations.RES and b/Ext/StyledComponents/source/Animations.RES differ diff --git a/Ext/StyledComponents/source/Animations.rc b/Ext/StyledComponents/source/Animations.rc index 765d150..5ffc582 100644 --- a/Ext/StyledComponents/source/Animations.rc +++ b/Ext/StyledComponents/source/Animations.rc @@ -2,4 +2,6 @@ LOTTIE_INFORMATION RCDATA "..\Animations\information.json" LOTTIE_CUSTOM RCDATA "..\Animations\custom.json" LOTTIE_ERROR RCDATA "..\Animations\error.json" LOTTIE_WARNING RCDATA "..\Animations\warning.json" -LOTTIE_SHIELD RCDATA "..\Animations\shield.json" \ No newline at end of file +LOTTIE_SHIELD RCDATA "..\Animations\shield.json" +LOTTIE_NOTIFY RCDATA "..\Animations\notify.json" +LOTTIE_QUESTION RCDATA "..\Animations\question.json" \ No newline at end of file diff --git a/Ext/StyledComponents/source/CommandLinkBMP.RES b/Ext/StyledComponents/source/CommandLinkBMP.RES new file mode 100644 index 0000000..5f05e70 Binary files /dev/null and b/Ext/StyledComponents/source/CommandLinkBMP.RES differ diff --git a/Ext/StyledComponents/source/CommandLinkPNG.RES b/Ext/StyledComponents/source/CommandLinkPNG.RES new file mode 100644 index 0000000..27fd5f3 Binary files /dev/null and b/Ext/StyledComponents/source/CommandLinkPNG.RES differ diff --git a/Ext/StyledComponents/source/Skia.Vcl.StyledTaskDialogAnimatedUnit.dfm b/Ext/StyledComponents/source/Skia.Vcl.StyledTaskDialogAnimatedUnit.dfm index 5fd55c5..878e28c 100644 --- a/Ext/StyledComponents/source/Skia.Vcl.StyledTaskDialogAnimatedUnit.dfm +++ b/Ext/StyledComponents/source/Skia.Vcl.StyledTaskDialogAnimatedUnit.dfm @@ -1,5 +1,5 @@ -inherited StyledTaskDialogAnimated: TStyledTaskDialogAnimated - Caption = 'StyledTaskDialogAnimated' +inherited StyledTaskDialogAnimatedForm: TStyledTaskDialogAnimatedForm + Caption = 'StyledTaskDialogAnimatedForm' TextHeight = 15 inherited CenterPanel: TPanel inherited ImagePanel: TPanel diff --git a/Ext/StyledComponents/source/Skia.Vcl.StyledTaskDialogAnimatedUnit.pas b/Ext/StyledComponents/source/Skia.Vcl.StyledTaskDialogAnimatedUnit.pas index 48a6c6a..de68eb1 100644 --- a/Ext/StyledComponents/source/Skia.Vcl.StyledTaskDialogAnimatedUnit.pas +++ b/Ext/StyledComponents/source/Skia.Vcl.StyledTaskDialogAnimatedUnit.pas @@ -1,13 +1,13 @@ {******************************************************************************} { } -{ StyledTaskDialogAnimated: an example of Task Dialog Form } -{ using a TSkAnimatedImage with Lottie Animations } +{ StyledTaskDialogAnimated: an example of Task Dialog Form } +{ using a TSkAnimatedImage with Lottie Animations } { } -{ Copyright (c) 2022-2024 (Ethea S.r.l.) } -{ Author: Carlo Barazzetta } -{ Contributors: } +{ Copyright (c) 2022-2024 (Ethea S.r.l.) } +{ Author: Carlo Barazzetta } +{ Contributors: } { } -{ https://github.com/EtheaDev/StyledComponents } +{ https://github.com/EtheaDev/StyledComponents } { } {******************************************************************************} { } @@ -47,6 +47,7 @@ interface , Vcl.ButtonStylesAttributes , Vcl.AngularButtonStyles , Vcl.ColorButtonStyles + , Vcl.StyledTaskDialog , Vcl.StyledTaskDialogFormUnit , Vcl.ExtCtrls , Vcl.StdCtrls @@ -56,10 +57,11 @@ interface ; type - TStyledTaskDialogAnimated = class(TStyledTaskDialogForm) + TStyledTaskDialogAnimatedForm = class(TStyledTaskDialogForm) SkAnimatedImage: TSkAnimatedImage; private protected + class function CanUseAnimations: Boolean; override; procedure LoadImage(const AImageIndex: TImageIndex; AImageName: string); override; public end; @@ -71,14 +73,19 @@ implementation uses Vcl.Themes; -procedure TStyledTaskDialogAnimated.LoadImage( +class function TStyledTaskDialogAnimatedForm.CanUseAnimations: Boolean; +begin + Result := True; +end; + +procedure TStyledTaskDialogAnimatedForm.LoadImage( const AImageIndex: TImageIndex; AImageName: string); var LStream: TResourceStream; LImageName: string; begin //Using ..\Animations\Animations.rc file compiled into Animations.RES file - LImageName := UpperCase(Format('LOTTIE_%s',[AImageName])); + LImageName := UpperCase('LOTTIE_'+AImageName); LStream := TResourceStream.Create(HInstance, LImageName, RT_RCDATA); try SkAnimatedImage.LoadFromStream(LStream); @@ -90,6 +97,6 @@ procedure TStyledTaskDialogAnimated.LoadImage( end; initialization - RegisterTaskDialogFormClass(TStyledTaskDialogAnimated); + RegisterTaskDialogFormClass(TStyledTaskDialogAnimatedForm); end. diff --git a/Ext/StyledComponents/source/StyledComponents.inc b/Ext/StyledComponents/source/StyledComponents.inc index 6d2c56a..cf49523 100644 --- a/Ext/StyledComponents/source/StyledComponents.inc +++ b/Ext/StyledComponents/source/StyledComponents.inc @@ -170,6 +170,8 @@ {$IFDEF DXE6+} {$Define GDIPlusSupport} + {.$Define DrawTextWithGDIPlus} + {.$Define DrawRectWithGDIPlus} {$ENDIF} {$IFDEF D10_3+} diff --git a/Ext/StyledComponents/source/StyledNavButtonsPNG.RES b/Ext/StyledComponents/source/StyledNavButtonsPNG.RES index 3aa9bb0..9a70201 100644 Binary files a/Ext/StyledComponents/source/StyledNavButtonsPNG.RES and b/Ext/StyledComponents/source/StyledNavButtonsPNG.RES differ diff --git a/Ext/StyledComponents/source/Vcl.AngularButtonStyles.pas b/Ext/StyledComponents/source/Vcl.AngularButtonStyles.pas index f8a14cb..116ccd6 100644 --- a/Ext/StyledComponents/source/Vcl.AngularButtonStyles.pas +++ b/Ext/StyledComponents/source/Vcl.AngularButtonStyles.pas @@ -1,13 +1,13 @@ {******************************************************************************} { } -{ AngulaButtonStyles: Button Styles inspired to Material/angular } -{ https://material.angular.io/components/button/overview } +{ AngulaButtonStyles: Button Styles inspired to Material/angular } +{ https://material.angular.io/components/button/overview } { } -{ Copyright (c) 2022-2024 (Ethea S.r.l.) } -{ Author: Carlo Barazzetta } -{ Contributors: } +{ Copyright (c) 2022-2024 (Ethea S.r.l.) } +{ Author: Carlo Barazzetta } +{ Contributors: } { } -{ https://github.com/EtheaDev/StyledComponents } +{ https://github.com/EtheaDev/StyledComponents } { } {******************************************************************************} { } @@ -221,7 +221,7 @@ procedure TAngularButtonStyleLight.UpdateAttributes( //Default Style Attributes for Angular Buttons: Flat //using Flat Style as base style - ANormalStyle.DrawType := btRounded; + ANormalStyle.DrawType := btRoundRect; ANormalStyle.BorderWidth := 0; ANormalStyle.BorderDrawStyle := brdClear; ANormalStyle.FontStyle := [fsBold]; @@ -409,7 +409,7 @@ procedure TAngularButtonStyleDark.UpdateAttributes( //Default Style Attributes for Angular Buttons: Flat //using Flat Style as base style - ANormalStyle.DrawType := btRounded; + ANormalStyle.DrawType := btRoundRect; ANormalStyle.BorderWidth := 0; ANormalStyle.BorderDrawStyle := brdClear; ANormalStyle.ButtonDrawStyle := btnSolid; diff --git a/Ext/StyledComponents/source/Vcl.BootstrapButtonStyles.pas b/Ext/StyledComponents/source/Vcl.BootstrapButtonStyles.pas index a7a7799..b87cb7b 100644 --- a/Ext/StyledComponents/source/Vcl.BootstrapButtonStyles.pas +++ b/Ext/StyledComponents/source/Vcl.BootstrapButtonStyles.pas @@ -1,13 +1,13 @@ {******************************************************************************} { } -{ BootstrapButtonStyles: Button Styles inspired to Bootstrap } -{ https://getbootstrap.com/docs/4.0/components/buttons/ } +{ BootstrapButtonStyles: Button Styles inspired to Bootstrap } +{ https://getbootstrap.com/docs/4.0/components/buttons/ } { } -{ Copyright (c) 2022-2024 (Ethea S.r.l.) } -{ Author: Carlo Barazzetta } -{ Contributors: } +{ Copyright (c) 2022-2024 (Ethea S.r.l.) } +{ Author: Carlo Barazzetta } +{ Contributors: } { } -{ https://github.com/EtheaDev/StyledComponents } +{ https://github.com/EtheaDev/StyledComponents } { } {******************************************************************************} { } @@ -212,7 +212,7 @@ procedure TBoostrapButtonStyles.UpdateAttributes( BootstrapClassToColors(AClass, AAppearance, LFontColor, LButtonColor, LOutLine); //Default Style Attributes for Bootstrap Buttons - ANormalStyle.DrawType := btRounded; + ANormalStyle.DrawType := btRoundRect; ANormalStyle.FontStyle := [fsBold]; ANormalStyle.BorderWidth := BOOTSTRAP_BORDER_WIDTH; diff --git a/Ext/StyledComponents/source/Vcl.ButtonStylesAttributes.pas b/Ext/StyledComponents/source/Vcl.ButtonStylesAttributes.pas index 3b4f560..1b320fb 100644 --- a/Ext/StyledComponents/source/Vcl.ButtonStylesAttributes.pas +++ b/Ext/StyledComponents/source/Vcl.ButtonStylesAttributes.pas @@ -1,12 +1,14 @@ {******************************************************************************} { } -{ StyledButton: a Button Component based on TGraphicControl } +{ TStyledButtonAttributes: a collection of Rendering attributes } +{ for Styled Components } +{ TNotificationBadgeAttributes: a set of Rendering attributes for Badge } { } -{ Copyright (c) 2022-2024 (Ethea S.r.l.) } -{ Author: Carlo Barazzetta } -{ Contributors: } +{ Copyright (c) 2022-2024 (Ethea S.r.l.) } +{ Author: Carlo Barazzetta } +{ Contributors: } { } -{ https://github.com/EtheaDev/StyledComponents } +{ https://github.com/EtheaDev/StyledComponents } { } {******************************************************************************} { } @@ -28,37 +30,57 @@ interface {$INCLUDE StyledComponents.inc} +{$IFDEF D10_4+} + {$R CommandLinkPNG.RES} +{$ELSE} + {$R CommandLinkBMP.RES} +{$ENDIF} uses Winapi.Windows - , Vcl.Graphics , System.Classes , System.Contnrs , System.UITypes , System.Types + , Vcl.Graphics , Vcl.Controls , Vcl.Buttons + , Vcl.StdCtrls + , Vcl.ImgList + , Vcl.Themes , Winapi.CommCtrl ; const DEFAULT_RADIUS = 6; + RESOURCE_SHIELD_ICON = 'BUTTON_SHIELD_ADMIN'; + DEFAULT_MAX_BADGE_VALUE = 99; resourcestring ERROR_FAMILY_NOT_FOUND = 'Styled Button Family "%s" not found'; + ERROR_NEGATIVE_VALUE = 'Error: Notification Count cannot be negative!'; Type //Windows Version TWindowsVersion = (wvUndefined, wvWindowsXP, wvWindowsVista, wvWindows7, wvWindows8, wvWindows8_1, wvWindows10, wvWindows11); + TNotificationBadgePosition = (nbpTopRight, nbpTopLeft, nbpBottomRight, nbpBottomLeft); + TNotificationBadgeSize = (nbsNormal, nbsSmallDot); + //string typed attributes TStyledButtonFamily = string; TStyledButtonClass = string; TStyledButtonAppearance = string; //Type of border - TStyledButtonDrawType = (btRounded, btRect, btEllipse); + TStyledButtonDrawType = (btRoundRect, btRounded, btRect, btEllipse); + TRoundedCorner = (rcTopLeft, rcTopRight, rcBottomRight, rcBottomLeft); + TRoundedCorners = set of TRoundedCorner; +const + ALL_ROUNDED_CORNERS = [rcTopLeft, rcTopRight, rcBottomLeft, rcBottomRight]; + +Type //Type of Draw for Border TBorderDrawStyle = (brdClear, brdSolid); //similar to Pen.psClear and Pen.psSolid TButtonDrawStyle = (btnClear, btnSolid); //similar to Brush.bsClear and Brush.bsSolid @@ -68,8 +90,61 @@ interface TButtonClasses = Array of TStyledButtonClass; TButtonAppearances = Array of TStyledButtonAppearance; + TNotificationBadgeAttributes = class(TComponent) + private + FNotificationCount: Integer; + FCustomText: string; + FMaxNotifications: Word; + FPosition: TNotificationBadgePosition; + FSize: TNotificationBadgeSize; + FColor: TColor; + FFontColor: TColor; + + FOwnerControl: TControl; + FOnContentChange: TNotifyEvent; + procedure InvalidateControl; + procedure SetMaxNotifications(const AValue: Word); + procedure SetPosition(const AValue: TNotificationBadgePosition); + procedure SetNotificationCount(const AValue: Integer); + procedure SetColor(const AValue: TColor); + procedure SetFontColor(const AValue: TColor); + function GetBadgeContent: string; + procedure SetCustomText(const AValue: string); + procedure SetSize(const Value: TNotificationBadgeSize); + function GetIsVisible: Boolean; + public + procedure Assign(ASource: TPersistent); override; + constructor Create(AOwner: TComponent); override; + function HasCustomAttributes: Boolean; + property BadgeContent: string read GetBadgeContent; + property IsVisible: Boolean read GetIsVisible; + published + property Color: TColor read FColor write SetColor default clRed; + property CustomText: string read FCustomText write SetCustomText; + property FontColor: TColor read FFontColor write SetFontColor default clWhite; + property NotificationCount: Integer read FNotificationCount write SetNotificationCount default 0; + property MaxNotifications: Word read FMaxNotifications write SetMaxNotifications default DEFAULT_MAX_BADGE_VALUE; + property Position: TNotificationBadgePosition read FPosition write SetPosition default nbpTopRight; + property Size: TNotificationBadgeSize read FSize write SetSize default nbsNormal; + + property OnContentChange: TNotifyEvent read FOnContentChange write FOnContentChange; + end; + TStyledButtonAttributes = class(TComponent) private + //Custom values + FCustomDrawType: TStyledButtonDrawType; + FCustomBorderWidth: Integer; + FCustomBorderDrawStyle: TBorderDrawStyle; + FCustomButtonDrawStyle: TButtonDrawStyle; + FCustomBorderColor: TColor; + FCustomFontColor: TColor; + FCustomFontStyle: TFontStyles; + FCustomButtonColor: TColor; + FCustomRadius: Integer; + FCustomRoundedCorners: TRoundedCorners; + + //Default Values retrieved by Family/Class/Appearance FDrawType: TStyledButtonDrawType; FBorderWidth: Integer; FBorderDrawStyle: TBorderDrawStyle; @@ -79,36 +154,73 @@ TStyledButtonAttributes = class(TComponent) FFontStyle: TFontStyles; FFontName: TFontName; FButtonColor: TColor; - FOwnerControl: TGraphicControl; - FIsChanged: Boolean; FRadius: Integer; + FRoundedCorners: TRoundedCorners; + + FOwnerControl: TControl; + FHasCustomDrawType: Boolean; + FHasCustomBorderWidth: Boolean; + FHasCustomBorderDrawStyle: Boolean; + FHasCustomButtonDrawStyle: Boolean; + FHasCustomBorderColor: Boolean; + FHasCustomFontColor: Boolean; + FHasCustomFontStyle: Boolean; + FHasCustomButtonColor: Boolean; + FHasCustomRadius: Boolean; + FHasCustomRoundedCorners: Boolean; + procedure InvalidateControl; - procedure SetBorderColor(const Value: TColor); - procedure SetBorderDrawStyle(const Value: TBorderDrawStyle); - procedure SetButtonDrawStyle(const Value: TButtonDrawStyle); - procedure SetDrawType(const Value: TStyledButtonDrawType); - procedure SetBorderWidth(const Value: Integer); - procedure SetButtonColor(const Value: TColor); - procedure SetFontColor(const Value: TColor); - procedure SetFontStyle(const Value: TFontStyles); - procedure SetRadius(const Value: Integer); + procedure SetBorderColor(const AValue: TColor); + procedure SetBorderDrawStyle(const AValue: TBorderDrawStyle); + procedure SetButtonDrawStyle(const AValue: TButtonDrawStyle); + procedure SetDrawType(const AValue: TStyledButtonDrawType); + procedure SetBorderWidth(const AValue: Integer); + procedure SetButtonColor(const AValue: TColor); + procedure SetFontColor(const AValue: TColor); + procedure SetFontStyle(const AValue: TFontStyles); + procedure SetRadius(const AValue: Integer); + procedure SetRoundedCorners(const AValue: TRoundedCorners); + function GetBorderColor: TColor; + function GetBorderDrawStyle: TBorderDrawStyle; + function GetBorderWidth: Integer; + function GetButtonColor: TColor; + function GetButtonDrawStyle: TButtonDrawStyle; + function GetDrawType: TStyledButtonDrawType; + function GetFontColor: TColor; + function GetFontStyle: TFontStyles; + function GetRadius: Integer; + function GetRoundedCorners: TRoundedCorners; + procedure SetCustomAttributes(const Value: Boolean); public constructor Create(AOwner: TComponent); override; - procedure ResetChanged; - function IsChanged: Boolean; + function HasCustomAttributes: Boolean; procedure Assign(ASource: TPersistent); override; function PenStyle: TPenStyle; function BrushStyle: TBrushStyle; + function AssignStyledAttributes(const ASource: TStyledButtonAttributes): Boolean; + procedure ResetCustomAttributes; + property HasCustomDrawType: Boolean read FHasCustomDrawType; + property HasCustomBorderWidth: Boolean read FHasCustomBorderWidth; + property HasCustomBorderDrawStyle: Boolean read FHasCustomBorderDrawStyle; + property HasCustomButtonDrawStyle: Boolean read FHasCustomButtonDrawStyle; + property HasCustomBorderColor: Boolean read FHasCustomBorderColor; + property HasCustomFontColor: Boolean read FHasCustomFontColor; + property HasCustomFontStyle: Boolean read FHasCustomFontStyle; + property HasCustomButtonColor: Boolean read FHasCustomButtonColor; + property HasCustomRadius: Boolean read FHasCustomRadius; + property HasCustomRoundedCorners: Boolean read FHasCustomRoundedCorners; published - property DrawType: TStyledButtonDrawType read FDrawType write SetDrawType; - property BorderWidth: Integer read FBorderWidth write SetBorderWidth; - property BorderDrawStyle: TBorderDrawStyle read FBorderDrawStyle write SetBorderDrawStyle default brdSolid; - property ButtonDrawStyle: TButtonDrawStyle read FButtonDrawStyle write SetButtonDrawStyle default btnSolid; - property BorderColor: TColor read FBorderColor write SetBorderColor; - property FontColor: TColor read FFontColor write SetFontColor; - property FontStyle: TFontStyles read FFontStyle write SetFontStyle; - property ButtonColor: TColor read FButtonColor write SetButtonColor; - property Radius: Integer read FRadius write SetRadius; + property DrawType: TStyledButtonDrawType read GetDrawType write SetDrawType stored FHasCustomDrawType; + property BorderWidth: Integer read GetBorderWidth write SetBorderWidth stored FHasCustomBorderWidth; + property BorderDrawStyle: TBorderDrawStyle read GetBorderDrawStyle write SetBorderDrawStyle stored FHasCustomBorderDrawStyle; + property ButtonDrawStyle: TButtonDrawStyle read GetButtonDrawStyle write SetButtonDrawStyle stored FHasCustomButtonDrawStyle; + property BorderColor: TColor read GetBorderColor write SetBorderColor stored FHasCustomBorderColor; + property FontColor: TColor read GetFontColor write SetFontColor stored FHasCustomFontColor; + property FontStyle: TFontStyles read GetFontStyle write SetFontStyle stored FHasCustomFontStyle; + property ButtonColor: TColor read GetButtonColor write SetButtonColor stored FHasCustomButtonColor; + property Radius: Integer read GetRadius write SetRadius stored FHasCustomRadius; + property RoundedCorners: TRoundedCorners read GetRoundedCorners write SetRoundedCorners stored FHasCustomRoundedCorners; + property UseCustomAttributes: Boolean read HasCustomAttributes write SetCustomAttributes stored False; end; // Abstraction of Graphic Button Attributes @@ -132,9 +244,9 @@ TStyledButtonAttributes = class(TComponent) TButtonFamily = class(TObject) private FStyleFamily: TStyledButtonFamily; - FStyledAttributes: IStyledButtonAttributes; + FCustomAttributes: IStyledButtonAttributes; public - property StyledAttributes: IStyledButtonAttributes read FStyledAttributes; + property StyledAttributes: IStyledButtonAttributes read FCustomAttributes; end; //utilities @@ -144,21 +256,67 @@ function HtmlToColor(Color: string): TColor; function ColortoGrayscale(AColor : TColor): TColor; function ColorIsLight(Color: TColor): Boolean; function SameStyledButtonStyle(Style1, Style2: TStyledButtonAttributes): Boolean; +function SameNotificationBadgeAttributes(Attr1, Attr2: TNotificationBadgeAttributes): Boolean; procedure CloneButtonStyle(const ASource: TStyledButtonAttributes; var ADest: TStyledButtonAttributes); +function GetActiveStyleName(const AControl: TControl): string; function GetWindowsVersion: TWindowsVersion; -//drawing "old-style" with masked bitmap -procedure DrawBitBtnGlyph(ACanvas: TCanvas; ARect: TRect; Kind: Vcl.Buttons.TBitBtnKind; +//Calculate Image and Text Rect for Drawing using ImageAlignment and ImageMargins +//for StyledButton and StyledGraphicButton +procedure CalcImageAndTextRect(const ASurfaceRect: TRect; + const ACaption: string; + out ATextRect: TRect; out AImageRect: TRect; + const AImageWidth, AImageHeight: Integer; + const AImageAlignment: TImageAlignment; + const AImageMargins: TImageMargins; + const AScale: Single); overload; + +//Calculate Image and Text Rect for Drawing using ButtonLayout, Margin and Spacing +//For StyledSpeedButton and StyledBitBtn +procedure CalcImageAndTextRect(const ACanvas: TCanvas; + const ACaption: string; const AClient: TRect; + const AOffset: TPoint; + var AGlyphPos: TPoint; var ATextBounds: TRect; + const AImageWidth, AImageHeight: Integer; + const ALayout: TButtonLayout; + const AMargin, ASpacing: Integer; + const ABiDiFlags: Cardinal); overload; + +//draw of Glyph +procedure DrawBitBtnGlyph(ACanvas: TCanvas; ARect: TRect; + Kind: Vcl.Buttons.TBitBtnKind; AState: TButtonState; AEnabled: Boolean; AOriginal: TBitmap; ANumGlyphs: Integer; const ATransparentColor: TColor); -//drawing Button +//drawing "old-style" with masked bitmap +procedure DrawBitmapTransparent(ACanvas: TCanvas; ARect: TRect; + const AWidth, AHeight: Integer; AOriginal: TBitmap; + AState: TButtonState; ANumGlyphs: Integer; const ATransparentColor: TColor); + +//drawing Command-Link Arrow (white or Black) +procedure DrawIconFromCommandLinkRes(ACanvas: TCanvas; ARect: TRect; + AVCLStyleName: string; AState: TButtonState; AEnabled: Boolean); + +//Draw rectangle and border into Canvas +procedure DrawRect(ACanvas: TCanvas; var ARect: TRect); +//draw Button into Canvas procedure CanvasDrawShape(const ACanvas: TCanvas; ARect: TRect; - const ADrawType: TStyledButtonDrawType; const ACornerRadius: Single); -//drawing bar and triangle for SplitButton + const ADrawType: TStyledButtonDrawType; const ACornerRadius: Single; + const ARoundedCorners: TRoundedCorners; + const APreserveBorderSpace: Boolean = True); +//draw Text into Canvas +procedure CanvasDrawText(const ACanvas: TCanvas; ARect: TRect; + const AText: string; ABiDiModeFlags: LongInt); +//draw bar and triangle for SplitButton into Canvas procedure CanvasDrawBarAndTriangle(const ACanvas: TCanvas; const ARect: TRect; const AScaleFactor: Single; ABarColor, ATriangleColor: TColor); +//draw Vertical bar into Canvas +procedure CanvasDrawBar(const ACanvas: TCanvas; const ARect: TRect; + const AScaleFactor: Single; ABarColor: TColor); +//draw a triangle into Canvas +procedure CanvasDrawTriangle(const ACanvas: TCanvas; const ARect: TRect; + const AScaleFactor: Single; ATriangleColor: TColor); //ButtonFamily Factory procedure RegisterButtonFamily( @@ -200,6 +358,7 @@ implementation {$endif} , System.SysUtils , System.Math + , Vcl.StandardButtonStyles ; var @@ -208,15 +367,25 @@ implementation function SameStyledButtonStyle(Style1, Style2: TStyledButtonAttributes): Boolean; begin Result := - (Style1.DrawType = Style2.DrawType) and - (Style1.BorderWidth = Style2.BorderWidth) and - (Style1.BorderDrawStyle = Style2.BorderDrawStyle) and - (Style1.ButtonDrawStyle = Style2.ButtonDrawStyle) and - (Style1.BorderColor = Style2.BorderColor) and - (Style1.FontColor = Style2.FontColor) and - (Style1.FontStyle = Style2.FontStyle) and - (Style1.ButtonColor = Style2.ButtonColor) and - (Style1.Radius = Style2.Radius); + (Style1.FDrawType = Style2.FDrawType) and + (Style1.FBorderWidth = Style2.FBorderWidth) and + (Style1.FBorderDrawStyle = Style2.FBorderDrawStyle) and + (Style1.FButtonDrawStyle = Style2.FButtonDrawStyle) and + (Style1.FBorderColor = Style2.FBorderColor) and + (Style1.FFontColor = Style2.FFontColor) and + (Style1.FFontStyle = Style2.FFontStyle) and + (Style1.FFontName = Style2.FFontName) and + (Style1.FButtonColor = Style2.FButtonColor) and + (Style1.FRadius = Style2.FRadius) and + (Style1.FRoundedCorners = Style2.FRoundedCorners); +end; + +function SameNotificationBadgeAttributes(Attr1, Attr2: TNotificationBadgeAttributes): Boolean; +begin + Result := + (Attr1.FNotificationCount = Attr2.FNotificationCount) and + (Attr1.FMaxNotifications = Attr2.FMaxNotifications) and + (Attr1.FPosition = Attr2.FPosition); end; function ColortoGrayscale(AColor : TColor): TColor; @@ -275,15 +444,66 @@ procedure CloneButtonStyle( const ASource: TStyledButtonAttributes; var ADest: TStyledButtonAttributes); begin - ADest.DrawType := ASource.DrawType; - ADest.BorderWidth := ASource.BorderWidth; - ADest.BorderDrawStyle := ASource.BorderDrawStyle; - ADest.ButtonDrawStyle := ASource.ButtonDrawStyle; - ADest.BorderColor := ASource.BorderColor; - ADest.FontStyle := ASource.FontStyle; - ADest.FontColor := ASource.FontColor; - ADest.ButtonColor := ASource.ButtonColor; - ADest.Radius := ASource.Radius; + ADest.FDrawType := ASource.FDrawType; + ADest.FBorderWidth := ASource.FBorderWidth; + ADest.FBorderDrawStyle := ASource.FBorderDrawStyle; + ADest.FButtonDrawStyle := ASource.FButtonDrawStyle; + ADest.FBorderColor := ASource.FBorderColor; + ADest.FFontStyle := ASource.FFontStyle; + ADest.FFontColor := ASource.FFontColor; + ADest.FButtonColor := ASource.FButtonColor; + ADest.FRadius := ASource.FRadius; + ADest.FRoundedCorners := ASource.FRoundedCorners; + + ADest.FCustomDrawType := ASource.FCustomDrawType; + ADest.FCustomBorderWidth := ASource.FCustomBorderWidth; + ADest.FCustomBorderDrawStyle := ASource.FCustomBorderDrawStyle; + ADest.FCustomButtonDrawStyle := ASource.FCustomButtonDrawStyle; + ADest.FCustomBorderColor := ASource.FCustomBorderColor; + ADest.FCustomFontStyle := ASource.FCustomFontStyle; + ADest.FCustomFontColor := ASource.FCustomFontColor; + ADest.FCustomButtonColor := ASource.FCustomButtonColor; + ADest.FCustomRadius := ASource.FCustomRadius; + ADest.FCustomRoundedCorners := ASource.FCustomRoundedCorners; + + ADest.FHasCustomDrawType := ASource.FHasCustomDrawType; + ADest.FHasCustomBorderWidth := ASource.FHasCustomBorderWidth; + ADest.FHasCustomBorderDrawStyle := ASource.FHasCustomBorderDrawStyle; + ADest.FHasCustomButtonDrawStyle := ASource.FHasCustomButtonDrawStyle; + ADest.FHasCustomBorderColor := ASource.FHasCustomBorderColor; + ADest.FHasCustomFontStyle := ASource.FHasCustomFontStyle; + ADest.FHasCustomFontColor := ASource.FHasCustomFontColor; + ADest.FHasCustomButtonColor := ASource.FHasCustomButtonColor; + ADest.FHasCustomRadius := ASource.FHasCustomRadius; + ADest.FHasCustomRoundedCorners := ASource.FHasCustomRoundedCorners; +end; + +function GetActiveStyleName(const AControl: TControl): string; +begin + {$IFDEF D10_4+} + Result := AControl.GetStyleName; + if Result = '' then + begin + {$IFDEF D11+} + if (csDesigning in AControl.ComponentState) then + Result := TStyleManager.ActiveDesigningStyle.Name + else + Result := TStyleManager.ActiveStyle.Name; + {$ELSE} + Result := TStyleManager.ActiveStyle.Name; + {$ENDIF} + end; + {$ELSE} + Result := TStyleManager.ActiveStyle.Name; + {$ENDIF} + if (csDesigning in AControl.ComponentState) then + begin + if (Result = 'Windows Designer Dark') or + (Result = 'Win10IDE_Dark') or + (Result = 'Win10IDE_Light') or + (Result = 'Mountain_Mist' ) then + Result := 'Windows'; + end; end; function GetWindowsVersion: TWindowsVersion; @@ -366,11 +586,11 @@ function StyleFamilyCheckAttributes( Result := True; if GetButtonFamily(AFamily, AButtonFamily) then begin - AButtonFamily.FStyledAttributes.GetStyleByModalResult(mrNone, + AButtonFamily.FCustomAttributes.GetStyleByModalResult(mrNone, LDefaultClass, LDefaultAppearance); //Check AClass LClassFound := False; - LClasses := AButtonFamily.FStyledAttributes.GetButtonClasses; + LClasses := AButtonFamily.FCustomAttributes.GetButtonClasses; for I := 0 to Length(LClasses)-1 do begin if SameText(LClasses[I], AClass) then @@ -388,7 +608,7 @@ function StyleFamilyCheckAttributes( //Check AAppearance LAppearanceFound := False; - LAppearances := AButtonFamily.FStyledAttributes.GetButtonAppearances; + LAppearances := AButtonFamily.FCustomAttributes.GetButtonAppearances; for I := 0 to Length(LAppearances)-1 do begin if SameText(LAppearances[I], AAppearance) then @@ -414,20 +634,41 @@ procedure StyleFamilyUpdateAttributes( ASelectedStyle, AHotStyle, ADisabledStyle: TStyledButtonAttributes); var LButtonFamily: TButtonFamily; + LNormalStyle, LPressedStyle, LSelectedStyle, LHotStyle, LDisabledStyle: TStyledButtonAttributes; begin if GetButtonFamily(AFamily, LButtonFamily) then begin - LButtonFamily.FStyledAttributes.UpdateAttributes( - AFamily, AClass, AAppearance, - ANormalStyle, APressedStyle, ASelectedStyle, - AHotStyle, ADisabledStyle); - + LNormalStyle := TStyledButtonAttributes.Create(nil); + LPressedStyle := TStyledButtonAttributes.Create(nil); + LSelectedStyle := TStyledButtonAttributes.Create(nil); + LHotStyle := TStyledButtonAttributes.Create(nil); + LDisabledStyle := TStyledButtonAttributes.Create(nil); + try + LButtonFamily.FCustomAttributes.UpdateAttributes( + AFamily, AClass, AAppearance, + LNormalStyle, LPressedStyle, LSelectedStyle, + LHotStyle, LDisabledStyle); + + ANormalStyle.AssignStyledAttributes(LNormalStyle); + APressedStyle.AssignStyledAttributes(LPressedStyle); + ASelectedStyle.AssignStyledAttributes(LSelectedStyle); + AHotStyle.AssignStyledAttributes(LHotStyle); + ADisabledStyle.AssignStyledAttributes(LDisabledStyle); + finally + LNormalStyle.Free; + LPressedStyle.Free; + LSelectedStyle.Free; + LHotStyle.Free; + LDisabledStyle.Free; + end; //Attributes defined with Family/Class/Appearance reset any changes +(* ANormalStyle.ResetChanged; APressedStyle.ResetChanged; ASelectedStyle.ResetChanged; AHotStyle.ResetChanged; ADisabledStyle.ResetChanged; +*) end; end; @@ -441,7 +682,7 @@ procedure StyleFamilyUpdateAttributesByModalResult( begin if GetButtonFamily(AFamily, LButtonFamily) then begin - LButtonFamily.FStyledAttributes.GetStyleByModalResult( + LButtonFamily.FCustomAttributes.GetStyleByModalResult( AModalResult, AClass, AAppearance); end; @@ -454,7 +695,9 @@ procedure RegisterButtonFamily( begin LFamily := TButtonFamily.Create; LFamily.FStyleFamily := AStyledButtonAttributes.ButtonFamilyName; - LFamily.FStyledAttributes := AStyledButtonAttributes; + LFamily.FCustomAttributes := AStyledButtonAttributes; + if not Assigned(FFamilies) then + FFamilies := TObjectList.Create(True); FFamilies.Add(LFamily); end; @@ -471,12 +714,12 @@ function GetButtonFamilyClass(const AFamilyName: TStyledButtonFamily): TButtonFa function GetButtonClasses(const AFamily: TButtonFamily): TButtonClasses; begin - Result := AFamily.FStyledAttributes.GetButtonClasses; + Result := AFamily.FCustomAttributes.GetButtonClasses; end; function GetButtonAppearances(const AFamily: TButtonFamily): TButtonAppearances; begin - Result := AFamily.FStyledAttributes.GetButtonAppearances; + Result := AFamily.FCustomAttributes.GetButtonAppearances; end; function GetButtonFamilyName(const Index: Integer): TStyledButtonFamily; @@ -489,7 +732,7 @@ function GetButtonFamilyClasses(const AFamily: TStyledButtonFamily): TButtonClas LButtonFamily: TButtonFamily; begin if GetButtonFamily(AFamily, LButtonFamily) then - Result := LButtonFamily.FStyledAttributes.GetButtonClasses + Result := LButtonFamily.FCustomAttributes.GetButtonClasses else raise Exception.CreateFmt(ERROR_FAMILY_NOT_FOUND,[AFamily]); end; @@ -499,16 +742,181 @@ function GetButtonFamilyAppearances(const AFamily: TStyledButtonFamily): TButton LButtonFamily: TButtonFamily; begin if GetButtonFamily(AFamily, LButtonFamily) then - Result := LButtonFamily.FStyledAttributes.GetButtonAppearances + Result := LButtonFamily.FCustomAttributes.GetButtonAppearances else raise Exception.CreateFmt(ERROR_FAMILY_NOT_FOUND,[AFamily]); end; +{ TNotificationBadgeAttributes } + +procedure TNotificationBadgeAttributes.Assign(ASource: TPersistent); +var + LSource: TNotificationBadgeAttributes; +begin + if ASource is TNotificationBadgeAttributes then + begin + LSource := TNotificationBadgeAttributes(ASource); + NotificationCount := LSource.FNotificationCount; + MaxNotifications := LSource.FMaxNotifications; + Position := LSource.FPosition; + Color := LSource.FColor; + FontColor := LSource.FFontColor; + Size := LSource.FSize; + end + else + inherited Assign(ASource); +end; + +constructor TNotificationBadgeAttributes.Create(AOwner: TComponent); +begin + inherited; + FNotificationCount := 0; + FMaxNotifications := DEFAULT_MAX_BADGE_VALUE; + FPosition := nbpTopRight; + FColor := clRed; + FFontColor := clWhite; + FSize := nbsNormal; + if AOwner is TControl then + begin + FOwnerControl := TControl(AOwner); + SetSubComponent(True); + end; +end; + +function TNotificationBadgeAttributes.GetBadgeContent: string; +begin + if (FCustomText <> '') then + Result := FCustomText + else + begin + if FNotificationCount > MaxNotifications then + Result := IntToStr(MaxNotifications)+'+' + else if FNotificationCount > 0 then + Result := IntToStr(FNotificationCount) + else + Result := ''; + end; +end; + +function TNotificationBadgeAttributes.GetIsVisible: Boolean; +begin + Result := (FCustomText <> '') or (FNotificationCount > 0); +end; + +function TNotificationBadgeAttributes.HasCustomAttributes: Boolean; +begin + Result := (FNotificationCount <> 0) or + (FMaxNotifications <> DEFAULT_MAX_BADGE_VALUE) or + (FPosition <> nbpTopRight) or + (FColor <> clRed) or + (FFontColor <> clWhite) or + (FSize <> nbsNormal) or + (FCustomText <> ''); +end; + +procedure TNotificationBadgeAttributes.InvalidateControl; +begin + if Assigned(FOwnerControl) then + FOwnerControl.Invalidate; +end; + +procedure TNotificationBadgeAttributes.SetMaxNotifications(const AValue: Word); +begin + if FMaxNotifications <> AValue then + begin + FMaxNotifications := AValue; + if IsVisible then + InvalidateControl; + end; +end; + +procedure TNotificationBadgeAttributes.SetPosition(const AValue: TNotificationBadgePosition); +begin + if FPosition <> AValue then + begin + FPosition := AValue; + if IsVisible then + InvalidateControl; + end; +end; + +procedure TNotificationBadgeAttributes.SetSize( + const Value: TNotificationBadgeSize); +begin + if FSize <> Value then + begin + FSize := Value; + InvalidateControl; + end; +end; + +procedure TNotificationBadgeAttributes.SetCustomText(const AValue: string); +begin + if FCustomText <> AValue then + begin + FCustomText := AValue; + if Assigned(FOnContentChange) then + FOnContentChange(Self); + InvalidateControl; + end; +end; + +procedure TNotificationBadgeAttributes.SetColor(const AValue: TColor); +begin + if FColor <> AValue then + begin + FColor := AValue; + if IsVisible then + InvalidateControl; + end; +end; + +procedure TNotificationBadgeAttributes.SetNotificationCount(const AValue: Integer); +begin + if AValue < 0 then + raise Exception.Create(ERROR_NEGATIVE_VALUE); + if FNotificationCount <> AValue then + begin + FNotificationCount := AValue; + if Assigned(FOnContentChange) then + FOnContentChange(Self); + InvalidateControl; + end; +end; + +procedure TNotificationBadgeAttributes.SetFontColor(const AValue: TColor); +begin + if FFontColor <> AValue then + begin + FFontColor := AValue; + if IsVisible then + InvalidateControl; + end; +end; + { TStyledButtonAttributes } -function TStyledButtonAttributes.IsChanged: Boolean; +procedure TStyledButtonAttributes.SetCustomAttributes(const Value: Boolean); +begin + if not Value then + begin + ResetCustomAttributes; + InvalidateControl; + end; +end; + +function TStyledButtonAttributes.HasCustomAttributes: Boolean; begin - Result := FIsChanged; + Result := FHasCustomDrawType or + FHasCustomBorderWidth or + FHasCustomBorderDrawStyle or + FHasCustomButtonDrawStyle or + FHasCustomBorderColor or + FHasCustomFontColor or + FHasCustomFontStyle or + FHasCustomButtonColor or + FHasCustomRadius or + FHasCustomRoundedCorners; end; function TStyledButtonAttributes.PenStyle: TPenStyle; @@ -520,9 +928,18 @@ function TStyledButtonAttributes.PenStyle: TPenStyle; end; end; -procedure TStyledButtonAttributes.ResetChanged; +procedure TStyledButtonAttributes.ResetCustomAttributes; begin - FIsChanged := False; + FHasCustomDrawType := False; + FHasCustomBorderWidth := False; + FHasCustomBorderDrawStyle := False; + FHasCustomButtonDrawStyle := False; + FHasCustomBorderColor := False; + FHasCustomFontColor := False; + FHasCustomFontStyle := False; + FHasCustomButtonColor := False; + FHasCustomRadius := False; + FHasCustomRoundedCorners := False; end; procedure TStyledButtonAttributes.Assign(ASource: TPersistent); @@ -532,21 +949,42 @@ procedure TStyledButtonAttributes.Assign(ASource: TPersistent); if ASource is TStyledButtonAttributes then begin LSource := TStyledButtonAttributes(ASource); - FDrawType := LSource.FDrawType; - FBorderWidth := LSource.FBorderWidth; - FBorderDrawStyle := LSource.FBorderDrawStyle; - FButtonDrawStyle := LSource.FButtonDrawStyle; - FBorderColor := LSource.FBorderColor; - FFontColor := LSource.FFontColor; - FFontStyle := LSource.FFontStyle; - FFontName := LSource.FFontName; - FButtonColor := LSource.FButtonColor; - FRadius := LSource.FRadius; + CloneButtonStyle(LSource, Self); end else inherited Assign(ASource); end; +function TStyledButtonAttributes.AssignStyledAttributes( + const ASource: TStyledButtonAttributes): Boolean; +begin + //Assign internal "custom" variable +(* + FCustomDrawType := ASource.FCustomDrawType; + FCustomBorderWidth := ASource.FCustomBorderWidth; + FCustomBorderDrawStyle := ASource.FCustomBorderDrawStyle; + FCustomButtonDrawStyle := ASource.FCustomButtonDrawStyle; + FCustomBorderColor := ASource.FCustomBorderColor; + FCustomFontColor := ASource.FCustomFontColor; + FCustomFontStyle := ASource.FCustomFontStyle; + FCustomButtonColor := ASource.FCustomButtonColor; + FCustomRadius := ASource.FCustomRadius; + FCustomRoundedCorners := ASource.FCustomRoundedCorners; +*) + //Assign internal variable + FDrawType := ASource.FDrawType; + FBorderWidth := ASource.FBorderWidth; + FBorderDrawStyle := ASource.FBorderDrawStyle; + FButtonDrawStyle := ASource.FButtonDrawStyle; + FBorderColor := ASource.FBorderColor; + FFontColor := ASource.FFontColor; + FFontStyle := ASource.FFontStyle; + FButtonColor := ASource.FButtonColor; + FRadius := ASource.FRadius; + FRoundedCorners := ASource.FRoundedCorners; + Result := True; +end; + function TStyledButtonAttributes.BrushStyle: TBrushStyle; begin case FButtonDrawStyle of @@ -560,104 +998,330 @@ constructor TStyledButtonAttributes.Create(AOwner: TComponent); begin inherited; FRadius := DEFAULT_RADIUS; + FRoundedCorners := ALL_ROUNDED_CORNERS; FBorderDrawStyle := brdSolid; FButtonDrawStyle := btnSolid; - if AOwner is TGraphicControl then + if AOwner is TControl then begin - FOwnerControl := TGraphicControl(AOwner); + FOwnerControl := TControl(AOwner); SetSubComponent(True); - FIsChanged := False; end; end; +function TStyledButtonAttributes.GetBorderColor: TColor; +begin + if not HasCustomBorderColor then + Result := FBorderColor + else + Result := FCustomBorderColor; +end; + +function TStyledButtonAttributes.GetBorderDrawStyle: TBorderDrawStyle; +begin + if not HasCustomBorderDrawStyle then + Result := FBorderDrawStyle + else + Result := FCustomBorderDrawStyle; +end; + +function TStyledButtonAttributes.GetBorderWidth: Integer; +begin + if not HasCustomBorderWidth then + Result := FBorderWidth + else + Result := FCustomBorderWidth; +end; + +function TStyledButtonAttributes.GetButtonColor: TColor; +begin + if not HasCustomButtonColor then + Result := FButtonColor + else + Result := FCustomButtonColor; +end; + +function TStyledButtonAttributes.GetButtonDrawStyle: TButtonDrawStyle; +begin + if not HasCustomButtonDrawStyle then + Result := FButtonDrawStyle + else + Result := FCustomButtonDrawStyle; +end; + +function TStyledButtonAttributes.GetDrawType: TStyledButtonDrawType; +begin + if not HasCustomDrawType then + Result := FDrawType + else + Result := FCustomDrawType; +end; + +function TStyledButtonAttributes.GetFontColor: TColor; +begin + if not HasCustomFontColor then + Result := FFontColor + else + Result := FCustomFontColor; +end; + +function TStyledButtonAttributes.GetFontStyle: TFontStyles; +begin + if not HasCustomFontStyle then + Result := FFontStyle + else + Result := FCustomFontStyle; +end; + +function TStyledButtonAttributes.GetRadius: Integer; +begin + if not HasCustomRadius then + Result := FRadius + else + Result := FCustomRadius; +end; + +function TStyledButtonAttributes.GetRoundedCorners: TRoundedCorners; +begin + if not HasCustomRoundedCorners then + Result := FRoundedCorners + else + Result := FCustomRoundedCorners; +end; + procedure TStyledButtonAttributes.InvalidateControl; begin if Assigned(FOwnerControl) then - begin - FIsChanged := True; FOwnerControl.Invalidate; +end; + +procedure TStyledButtonAttributes.SetBorderColor(const AValue: TColor); +begin + if Assigned(FOwnerControl) then + begin + //Setting a Custom property value + if FCustomBorderColor <> AValue then + begin + FCustomBorderColor := AValue; + FHasCustomBorderColor := FCustomBorderColor <> FBorderColor; + InvalidateControl; + end + end + else + begin + //Setting a property using StyleFamily, StyleClass and StyleAppearance + if FBorderColor <> AValue then + begin + FBorderColor := AValue; + InvalidateControl; + end; end; end; -procedure TStyledButtonAttributes.SetBorderColor(const Value: TColor); +procedure TStyledButtonAttributes.SetBorderDrawStyle(const AValue: TBorderDrawStyle); begin - if FBorderColor <> Value then + if Assigned(FOwnerControl) then begin - FBorderColor := Value; - InvalidateControl; + //Setting a Custom property value + if FCustomBorderDrawStyle <> AValue then + begin + FCustomBorderDrawStyle := AValue; + FHasCustomBorderDrawStyle := FCustomBorderDrawStyle <> FBorderDrawStyle; + InvalidateControl; + end + end + else + begin + //Setting a property using StyleFamily, StyleClass and StyleAppearance + if FBorderDrawStyle <> AValue then + begin + FBorderDrawStyle := AValue; + InvalidateControl; + end; end; end; -procedure TStyledButtonAttributes.SetBorderDrawStyle(const Value: TBorderDrawStyle); +procedure TStyledButtonAttributes.SetButtonDrawStyle(const AValue: TButtonDrawStyle); begin - if FBorderDrawStyle <> Value then + if Assigned(FOwnerControl) then begin - FBorderDrawStyle := Value; - InvalidateControl; + //Setting a Custom property value + if FCustomButtonDrawStyle <> AValue then + begin + FCustomButtonDrawStyle := AValue; + FHasCustomButtonDrawStyle := FCustomButtonDrawStyle <> FButtonDrawStyle; + InvalidateControl; + end + end + else + begin + //Setting a property using StyleFamily, StyleClass and StyleAppearance + if FButtonDrawStyle <> AValue then + begin + FButtonDrawStyle := AValue; + InvalidateControl; + end; end; end; -procedure TStyledButtonAttributes.SetButtonDrawStyle(const Value: TButtonDrawStyle); +procedure TStyledButtonAttributes.SetDrawType(const AValue: TStyledButtonDrawType); begin - if FButtonDrawStyle <> Value then + if Assigned(FOwnerControl) then begin - FButtonDrawStyle := Value; - InvalidateControl; + //Setting a Custom property value + if FCustomDrawType <> AValue then + begin + FCustomDrawType := AValue; + FHasCustomDrawType := FCustomDrawType <> FDrawType; + InvalidateControl; + end + end + else + begin + //Setting a property using StyleFamily, StyleClass and StyleAppearance + if FDrawType <> AValue then + begin + FDrawType := AValue; + InvalidateControl; + end; end; end; -procedure TStyledButtonAttributes.SetDrawType(const Value: TStyledButtonDrawType); +procedure TStyledButtonAttributes.SetBorderWidth(const AValue: Integer); begin - if FDrawType <> Value then + if Assigned(FOwnerControl) then begin - FDrawType := Value; - InvalidateControl; + //Setting a Custom property value + if FCustomBorderWidth <> AValue then + begin + FCustomBorderWidth := AValue; + FHasCustomBorderWidth := FCustomBorderWidth <> FBorderWidth; + InvalidateControl; + end + end + else + begin + //Setting a property using StyleFamily, StyleClass and StyleAppearance + if FBorderWidth <> AValue then + begin + FBorderWidth := AValue; + InvalidateControl; + end; end; end; -procedure TStyledButtonAttributes.SetBorderWidth(const Value: Integer); +procedure TStyledButtonAttributes.SetButtonColor(const AValue: TColor); begin - if FBorderWidth <> Value then + if Assigned(FOwnerControl) then begin - FBorderWidth := Value; - InvalidateControl; + //Setting a Custom property value + if FCustomButtonColor <> AValue then + begin + FCustomButtonColor := AValue; + FHasCustomButtonColor := FCustomButtonColor <> FButtonColor; + InvalidateControl; + end + end + else + begin + //Setting a property using StyleFamily, StyleClass and StyleAppearance + if FButtonColor <> AValue then + begin + FButtonColor := AValue; + InvalidateControl; + end; end; end; -procedure TStyledButtonAttributes.SetButtonColor(const Value: TColor); +procedure TStyledButtonAttributes.SetFontColor(const AValue: TColor); begin - if FButtonColor <> Value then + if Assigned(FOwnerControl) then begin - FButtonColor := Value; - InvalidateControl; + //Setting a Custom property value + if FCustomFontColor <> AValue then + begin + FCustomFontColor := AValue; + FHasCustomFontColor := FCustomFontColor <> FFontColor; + InvalidateControl; + end + end + else + begin + //Setting a property using StyleFamily, StyleClass and StyleAppearance + if FFontColor <> AValue then + begin + FFontColor := AValue; + InvalidateControl; + end; end; end; -procedure TStyledButtonAttributes.SetFontColor(const Value: TColor); +procedure TStyledButtonAttributes.SetFontStyle(const AValue: TFontStyles); begin - if FFontColor <> Value then + if Assigned(FOwnerControl) then begin - FFontColor := Value; - InvalidateControl; + //Setting a Custom property value + if FCustomFontStyle <> AValue then + begin + FCustomFontStyle := AValue; + FHasCustomFontStyle := FCustomFontStyle <> FFontStyle; + InvalidateControl; + end + end + else + begin + //Setting a property using StyleFamily, StyleClass and StyleAppearance + if FFontStyle <> AValue then + begin + FFontStyle := AValue; + InvalidateControl; + end; end; end; -procedure TStyledButtonAttributes.SetFontStyle(const Value: TFontStyles); +procedure TStyledButtonAttributes.SetRadius(const AValue: Integer); begin - if FFontStyle <> Value then + if Assigned(FOwnerControl) then begin - FFontStyle := Value; - InvalidateControl; + //Setting a Custom property value + if FCustomRadius <> AValue then + begin + FCustomRadius := AValue; + FHasCustomRadius := FCustomRadius <> FRadius; + InvalidateControl; + end + end + else + begin + //Setting a property using StyleFamily, StyleClass and StyleAppearance + if FRadius <> AValue then + begin + FRadius := AValue; + InvalidateControl; + end; end; end; -procedure TStyledButtonAttributes.SetRadius(const Value: Integer); +procedure TStyledButtonAttributes.SetRoundedCorners(const AValue: TRoundedCorners); begin - if FRadius <> Value then + if Assigned(FOwnerControl) then begin - FRadius := Value; - InvalidateControl; + //Setting a Custom property value + if FCustomRoundedCorners <> AValue then + begin + FCustomRoundedCorners := AValue; + FHasCustomRoundedCorners := FCustomRoundedCorners <> FRoundedCorners; + InvalidateControl; + end + end + else + begin + //Setting a property using StyleFamily, StyleClass and StyleAppearance + if FRoundedCorners <> AValue then + begin + FRoundedCorners := AValue; + InvalidateControl; + end; end; end; @@ -698,16 +1362,8 @@ procedure AdjustCanvasRect(const ACanvas: TCanvas; end; {$ifdef GDIPlusSupport} -procedure GPInflateRectF(var ARect: TGPRectF; - const AValue: Single); -begin - ARect.X := ARect.X + (AValue / 2); - ARect.Y := ARect.Y + (AValue / 2); - ARect.Width := ARect.width - AValue -1; - ARect.Height := ARect.Height - AValue -1; -end; - -function GetRoundRectangle(ARectangle: TGPRectF; +(* +function GetRoundedPath(ARectangle: TGPRectF; ARadius: Single): TGPGraphicsPath; var LPath : TGPGraphicsPath; @@ -725,6 +1381,50 @@ function GetRoundRectangle(ARectangle: TGPRectF; LPath.AddArc(l + w - d, t, d, d, 270, 90); // topright LPath.AddArc(l + w - d, t + h - d, d, d, 0, 90); // bottomright LPath.AddArc(l, t + h - d, d, d, 90, 90); // bottomleft + + LPath.CloseFigure(); + result := LPath; +end; +*) +function GetRoundedCornersPath(ARectangle: TGPRectF; + ARadius: Single; ARoundedCorners: TRoundedCorners): TGPGraphicsPath; +const + d0 = 0.0001; +var + LPath : TGPGraphicsPath; + l, t, w, h, d : Single; +begin + LPath := TGPGraphicsPath.Create; + l := ARectangle.X; + t := ARectangle.Y; + w := ARectangle.Width; + h := ARectangle.Height; + d := ARadius / 2; + + // topleft + if rcTopLeft in ARoundedCorners then + LPath.AddArc(l, t, d, d, 180, 90) + else + LPath.AddArc(l, t, d0, d0, 180, 90); + + // topright + if rcTopRight in ARoundedCorners then + LPath.AddArc(l + w - d, t, d, d, 270, 90) + else + LPath.AddArc(l + w - d0, t, d0, d0, 270, 90); + + // bottomright + if rcBottomRight in ARoundedCorners then + LPath.AddArc(l + w - d, t + h - d, d, d, 0, 90) + else + LPath.AddArc(l + w - d0, t + h - d0, d0, d0, 0, 90); + + // bottomleft + if rcBottomLeft in ARoundedCorners then + LPath.AddArc(l, t + h - d, d, d, 90, 90) + else + LPath.AddArc(l, t + h - d0, d0, d0, 90, 90); + LPath.CloseFigure(); result := LPath; end; @@ -744,80 +1444,313 @@ function GPColor(AColor: TColor): TGPColor; nil, 'BBOK', 'BBCANCEL', 'BBHELP', 'BBYES', 'BBNO', 'BBCLOSE', 'BBABORT', 'BBRETRY', 'BBIGNORE', 'BBALL'); -procedure DrawBitBtnGlyph(ACanvas: TCanvas; ARect: TRect; Kind: Vcl.Buttons.TBitBtnKind; - AState: TButtonState; AEnabled: Boolean; - AOriginal: TBitmap; ANumGlyphs: Integer; const ATransparentColor: TColor); +procedure CalcImageAndTextRect(const ASurfaceRect: TRect; + const ACaption: string; + out ATextRect: TRect; out AImageRect: TRect; + const AImageWidth, AImageHeight: Integer; + const AImageAlignment: TImageAlignment; + const AImageMargins: TImageMargins; + const AScale: Single); +var + IW, IH, IX, IY: Integer; + LImageAlignment: TImageAlignment; +begin + if ACaption = '' then + LImageAlignment := iaCenter + else + LImageAlignment := AImageAlignment; + //Text Rect as whole surface Rect (if there is no Image) + ATextRect := ASurfaceRect; + + //Calc Image Rect and Change ATextRect + IH := AImageHeight; + IW := AImageWidth; + if (IH > 0) and (IW > 0) then + begin + IX := Round(ATextRect.Left + (2*AScale)); + IY := ATextRect.Top + (ATextRect.Height - IH) div 2; + case LImageAlignment of + iaCenter: + begin + IX := ATextRect.CenterPoint.X - IW div 2; + end; + iaLeft: + begin + IX := Round(ATextRect.Left + (2*AScale)); + Inc(IX, AImageMargins.Left); + Inc(IY, AImageMargins.Top); + Dec(IY, AImageMargins.Bottom); + ATextRect.Left := IX + IW + AImageMargins.Right; + end; + iaRight: + begin + IX := Round(ATextRect.Right - IW - (2*AScale)); + Dec(IX, AImageMargins.Right); + Dec(IX, AImageMargins.Left); + Inc(IY, AImageMargins.Top); + Dec(IY, AImageMargins.Bottom); + ATextRect.Right := IX; + end; + iaTop: + begin + IX := ATextRect.Left + (ATextRect.Width - IW) div 2; + Inc(IX, AImageMargins.Left); + Dec(IX, AImageMargins.Right); + IY := Round(ATextRect.Top + (2*AScale)); + Inc(IY, AImageMargins.Top); + ATextRect.Top := IY + IH + AImageMargins.Bottom; + end; + iaBottom: + begin + IX := ATextRect.Left + (ATextRect.Width - IW) div 2; + Inc(IX, AImageMargins.Left); + Dec(IX, AImageMargins.Right); + IY := Round(ATextRect.Bottom - IH - (2*AScale)); + Dec(IY, AImageMargins.Bottom); + Dec(IY, AImageMargins.Top); + ATextRect.Bottom := IY; + end; + end; + end + else + begin + IX := 0; + IY := 0; + end; + AImageRect.Left := IX; + AImageRect.Top := IY; + AImageRect.Width := IW; + AImageRect.Height := IH; + + if ATextRect.IsEmpty then + ATextRect := ASurfaceRect; +end; + +procedure CalcImageAndTextRect(const ACanvas: TCanvas; + const ACaption: string; const AClient: TRect; + const AOffset: TPoint; + var AGlyphPos: TPoint; var ATextBounds: TRect; + const AImageWidth, AImageHeight: Integer; + const ALayout: TButtonLayout; + const AMargin, ASpacing: Integer; + const ABiDiFlags: Cardinal); +var + LTextPos: TPoint; + LClientSize, LGlyphSize, LTextSize: TPoint; + LTotalSize: TPoint; + LLayout: TButtonLayout; + LMargin, LSpacing: Integer; +begin + LLayout := ALayout; + if (ABiDiFlags and DT_RIGHT) = DT_RIGHT then + begin + if LLayout = blGlyphLeft then LLayout := blGlyphRight + else if LLayout = blGlyphRight then LLayout := blGlyphLeft; + end; + + { calculate the item sizes } + LClientSize := Point( + AClient.Right - AClient.Left, + AClient.Bottom - AClient.Top); + + LGlyphSize := Point(AImageWidth, AImageHeight); + + if Length(ACaption) > 0 then + begin + ATextBounds := Rect(0, 0, AClient.Right - AClient.Left, 0); + DrawText(ACanvas.Handle, ACaption, Length(ACaption), ATextBounds, + DT_CALCRECT or ABiDiFlags); + LTextSize := Point( + ATextBounds.Right - ATextBounds.Left, + ATextBounds.Bottom - ATextBounds.Top); + end + else + begin + ATextBounds := Rect(0, 0, 0, 0); + LTextSize := Point(0,0); + end; + + { If the layout has the glyph on the right or the left, then both the + text and the glyph are centered vertically. If the glyph is on the top + or the bottom, then both the text and the glyph are centered horizontally.} + if LLayout in [blGlyphLeft, blGlyphRight] then + begin + AGlyphPos.Y := (LClientSize.Y - LGlyphSize.Y + 1) div 2; + LTextPos.Y := (LClientSize.Y - LTextSize.Y + 1) div 2; + end + else + begin + AGlyphPos.X := (LClientSize.X - LGlyphSize.X + 1) div 2; + LTextPos.X := (LClientSize.X - LTextSize.X + 1) div 2; + end; + + { if there is no text or no bitmap, then Spacing is irrelevant } + if (LTextSize.X = 0) or (LGlyphSize.X = 0) then + LSpacing := 0 + else + LSpacing := ASpacing; + + { adjust Margin and Spacing } + LMargin := AMargin; + if LMargin = -1 then + begin + if LSpacing < 0 then + begin + LTotalSize := Point(LGlyphSize.X + LTextSize.X, LGlyphSize.Y + LTextSize.Y); + if ALayout in [blGlyphLeft, blGlyphRight] then + LMargin := (LClientSize.X - LTotalSize.X) div 3 + else + LMargin := (LClientSize.Y - LTotalSize.Y) div 3; + LSpacing := LMargin; + end + else + begin + LTotalSize := Point(LGlyphSize.X + LSpacing + LTextSize.X, LGlyphSize.Y + + LSpacing + LTextSize.Y); + if LLayout in [blGlyphLeft, blGlyphRight] then + LMargin := (LClientSize.X - LTotalSize.X + 1) div 2 + else + LMargin := (LClientSize.Y - LTotalSize.Y + 1) div 2; + end; + end + else + begin + if LSpacing < 0 then + begin + LTotalSize := Point( + LClientSize.X - (LMargin + LGlyphSize.X), + LClientSize.Y - (LMargin + LGlyphSize.Y)); + if LLayout in [blGlyphLeft, blGlyphRight] then + LSpacing := (LTotalSize.X - LTextSize.X) div 2 + else + LSpacing := (LTotalSize.Y - LTextSize.Y) div 2; + end; + end; + + case LLayout of + blGlyphLeft: + begin + AGlyphPos.X := LMargin; + LTextPos.X := AGlyphPos.X + LGlyphSize.X + LSpacing; + end; + blGlyphRight: + begin + AGlyphPos.X := LClientSize.X - LMargin - LGlyphSize.X; + LTextPos.X := AGlyphPos.X - LSpacing - LTextSize.X; + end; + blGlyphTop: + begin + AGlyphPos.Y := LMargin; + LTextPos.Y := AGlyphPos.Y + LGlyphSize.Y + LSpacing; + end; + blGlyphBottom: + begin + AGlyphPos.Y := LClientSize.Y - LMargin - LGlyphSize.Y; + LTextPos.Y := AGlyphPos.Y - LSpacing - LTextSize.Y; + end; + end; + + { fixup the result variables } + Inc(AGlyphPos.X, AClient.Left + AOffset.X); + Inc(AGlyphPos.Y, AClient.Top + AOffset.Y); + + OffsetRect(ATextBounds, LTextPos.X + AClient.Left + AOffset.X, LTextPos.Y + AClient.Top + AOffset.Y); +end; + +procedure DrawIconFromCommandLinkRes(ACanvas: TCanvas; ARect: TRect; + AVCLStyleName: string; AState: TButtonState; AEnabled: Boolean); +var + LResName: String; + LThemeAttribute: TThemeAttribute; + {$IFDEF D10_4+} + LImage: TWicImage; + {$ELSE} + LBitmap: TBitmap; + {$ENDIF} +begin + if AVCLStyleName = RESOURCE_SHIELD_ICON then + begin + LResName := RESOURCE_SHIELD_ICON; + end + else if (AVCLStyleName = 'Windows') then + begin + //Load image from resources by Kind + LResName := 'CMD_LINK_ARROW_BLUE'; + end + else + begin + if ACanvas.Font.Color = clWhite then + LResName := 'CMD_LINK_ARROW_WHITE' + else if ACanvas.Font.Color = clBlack then + LResName := 'CMD_LINK_ARROW_BLACK' + else + begin + GetStyleAttributes(AVCLStyleName, LThemeAttribute); + if LThemeAttribute.ThemeType = ttLight then + LResName := 'CMD_LINK_ARROW_BLACK' + else + LResName := 'CMD_LINK_ARROW_WHITE'; + end; + end; + {$IFDEF D10_4+} + LImage := TWicImage.Create; + try + LImage.InterpolationMode := wipmHighQualityCubic; + LImage.LoadFromResourceName(HInstance, LResName); + ACanvas.StretchDraw(ARect, LImage); + Exit; + finally + LImage.Free; + end; + {$ELSE} + LBitmap := TBitmap.Create; + try + LBitmap.PixelFormat := pf32bit; + //LBitmap.TransparentMode := tmFixed; + LBitmap.LoadFromResourceName(HInstance, LResName); + //ACanvas.StretchDraw(ARect, LBitmap); + //LBitmapRect := TRect.Create(ARect.Top, ARect.Left, LBitmap.Width, LBitmap.Height); + DrawBitmapTransparent(ACanvas, ARect, ARect.Width, ARect.Height, LBitmap, bsUp, 1, clBlack); + Exit; + finally + LBitmap.Free; + end; + {$ENDIF} +end; + +procedure DrawBitmapTransparent(ACanvas: TCanvas; ARect: TRect; + const AWidth, AHeight: Integer; AOriginal: TBitmap; + AState: TButtonState; ANumGlyphs: Integer; const ATransparentColor: TColor); const ROP_DSPDxax = $00E20746; var IL: TImageList; - LResName: String; - LOriginal, TmpImage, MonoBmp, DDB: TBitmap; - LNumGlyphs: Integer; - IWidth, IHeight: Integer; + TmpImage, MonoBmp, DDB: TBitmap; IRect, ORect: TRect; I: TButtonState; DestDC: HDC; LIndex: Integer; - {$IFDEF D10_4+} - LImage: TWicImage; - {$ENDIF} begin - if not AEnabled then - AState := bsDisabled; LIndex := -1; - IL := nil; TmpImage := nil; - LOriginal := nil; + IL := nil; try - if Kind = bkCustom then - begin - if ANumGlyphs = 0 then - Exit; - LOriginal := AOriginal; - LNumGlyphs := ANumGlyphs; - end - else - begin - //Load image from resources by Kind - LResName := BitBtnResNames[Kind]; - {$IFDEF D10_4+} - LImage := TWicImage.Create; - try - LImage.InterpolationMode := wipmHighQualityCubic; - LImage.LoadFromResourceName(HInstance, LResName); - ACanvas.StretchDraw(ARect, LImage); - Exit; - finally - LImage.Free; - end; - {$ELSE} - LOriginal := TBitmap.Create; - LNumGlyphs := 2; - LOriginal.PixelFormat := pf32bit; - LOriginal.LoadFromResourceName(HInstance, LResName); - {$ENDIF} - end; - if (LOriginal.Width = 0) or (LOriginal.Height = 0) then - Exit; - IWidth := LOriginal.Width div LNumGlyphs; - IHeight := LOriginal.Height; TmpImage := TBitmap.Create; - TmpImage.Width := IWidth; - TmpImage.Height := IHeight; + TmpImage.Width := AWidth; + TmpImage.Height := AHeight; IL := TImageList.CreateSize(TmpImage.Width, TmpImage.Height); - IRect := Rect(0, 0, IWidth, IHeight); + IRect := Rect(0, 0, AWidth, AHeight); TmpImage.Canvas.Brush.Color := clBtnFace; - TmpImage.Palette := CopyPalette(LOriginal.Palette); + TmpImage.Palette := CopyPalette(AOriginal.Palette); I := AState; - if Ord(I) >= LNumGlyphs then I := bsUp; - ORect := Rect(Ord(I) * IWidth, 0, (Ord(I) + 1) * IWidth, IHeight); + if Ord(I) >= ANumGlyphs then I := bsUp; + ORect := Rect(Ord(I) * AWidth, 0, (Ord(I) + 1) * AWidth, AHeight); case AState of bsUp, bsDown, bsExclusive: begin - TmpImage.Canvas.CopyRect(IRect, LOriginal.Canvas, ORect); - if LOriginal.TransparentMode = tmFixed then + TmpImage.Canvas.CopyRect(IRect, AOriginal.Canvas, ORect); + if AOriginal.TransparentMode = tmFixed then LIndex := IL.AddMasked(TmpImage, ATransparentColor) else LIndex := IL.AddMasked(TmpImage, clDefault); @@ -830,15 +1763,15 @@ procedure DrawBitBtnGlyph(ACanvas: TCanvas; ARect: TRect; Kind: Vcl.Buttons.TBit try MonoBmp := TBitmap.Create; DDB := TBitmap.Create; - DDB.Assign(LOriginal); + DDB.Assign(AOriginal); DDB.HandleType := bmDDB; if ANumGlyphs > 1 then with TmpImage.Canvas do begin { Change white & gray to clBtnHighlight and clBtnShadow } CopyRect(IRect, DDB.Canvas, ORect); MonoBmp.Monochrome := True; - MonoBmp.Width := IWidth; - MonoBmp.Height := IHeight; + MonoBmp.Width := AWidth; + MonoBmp.Height := AHeight; { Convert white to clBtnHighlight } DDB.Canvas.Brush.Color := clWhite; @@ -847,7 +1780,7 @@ procedure DrawBitBtnGlyph(ACanvas: TCanvas; ARect: TRect; Kind: Vcl.Buttons.TBit DestDC := Handle; SetTextColor(DestDC, clBlack); SetBkColor(DestDC, clWhite); - BitBlt(DestDC, 0, 0, IWidth, IHeight, + BitBlt(DestDC, 0, 0, AWidth, AHeight, MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax); { Convert gray to clBtnShadow } @@ -857,7 +1790,7 @@ procedure DrawBitBtnGlyph(ACanvas: TCanvas; ARect: TRect; Kind: Vcl.Buttons.TBit DestDC := Handle; SetTextColor(DestDC, clBlack); SetBkColor(DestDC, clWhite); - BitBlt(DestDC, 0, 0, IWidth, IHeight, + BitBlt(DestDC, 0, 0, AWidth, AHeight, MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax); { Convert transparent color to clBtnFace } @@ -867,7 +1800,7 @@ procedure DrawBitBtnGlyph(ACanvas: TCanvas; ARect: TRect; Kind: Vcl.Buttons.TBit DestDC := Handle; SetTextColor(DestDC, clBlack); SetBkColor(DestDC, clWhite); - BitBlt(DestDC, 0, 0, IWidth, IHeight, + BitBlt(DestDC, 0, 0, AWidth, AHeight, MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax); end else @@ -875,10 +1808,10 @@ procedure DrawBitBtnGlyph(ACanvas: TCanvas; ARect: TRect; Kind: Vcl.Buttons.TBit { Create a disabled version } with MonoBmp do begin - Assign(LOriginal); + Assign(AOriginal); HandleType := bmDDB; Canvas.Brush.Color := clBlack; - Width := IWidth; + Width := AWidth; if Monochrome then begin Canvas.Font.Color := clWhite; @@ -894,12 +1827,12 @@ procedure DrawBitBtnGlyph(ACanvas: TCanvas; ARect: TRect; Kind: Vcl.Buttons.TBit Brush.Color := clBtnHighlight; SetTextColor(Handle, clBlack); SetBkColor(Handle, clWhite); - BitBlt(Handle, 1, 1, IWidth, IHeight, + BitBlt(Handle, 1, 1, AWidth, AHeight, MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax); Brush.Color := clBtnShadow; SetTextColor(Handle, clBlack); SetBkColor(Handle, clWhite); - BitBlt(Handle, 0, 0, IWidth, IHeight, + BitBlt(Handle, 0, 0, AWidth, AHeight, MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax); end; end; @@ -910,37 +1843,94 @@ procedure DrawBitBtnGlyph(ACanvas: TCanvas; ARect: TRect; Kind: Vcl.Buttons.TBit LIndex := IL.AddMasked(TmpImage, clDefault); end; end; - ImageList_DrawEx(IL.Handle, LIndex, ACanvas.Handle, ARect.Left, ARect.Top, 0, 0, + ImageList_DrawEx(IL.Handle, LIndex, ACanvas.Handle, ARect.Left, ARect.Top, AWidth, AHeight, clNone, clNone, ILD_Transparent); finally + IL.Free; TmpImage.Free; + end; +end; + +procedure DrawBitBtnGlyph(ACanvas: TCanvas; ARect: TRect; + Kind: Vcl.Buttons.TBitBtnKind; + AState: TButtonState; AEnabled: Boolean; + AOriginal: TBitmap; ANumGlyphs: Integer; const ATransparentColor: TColor); +var + LResName: String; + LOriginal: TBitmap; + LNumGlyphs: Integer; + {$IFDEF D10_4+} + LImage: TWicImage; + {$ENDIF} +begin + if not AEnabled then + AState := bsDisabled; + LOriginal := nil; + try + if Kind = bkCustom then + begin + if ANumGlyphs = 0 then + Exit; + LOriginal := AOriginal; + LNumGlyphs := ANumGlyphs; + end + else + begin + //Load image from resources by Kind + LResName := BitBtnResNames[Kind]; + {$IFDEF D10_4+} + LImage := TWicImage.Create; + try + LImage.InterpolationMode := wipmHighQualityCubic; + LImage.LoadFromResourceName(HInstance, LResName); + ACanvas.StretchDraw(ARect, LImage); + Exit; + finally + LImage.Free; + end; + {$ELSE} + LOriginal := TBitmap.Create; + LNumGlyphs := 2; + LOriginal.PixelFormat := pf32bit; + LOriginal.LoadFromResourceName(HInstance, LResName); + {$ENDIF} + end; + if not Assigned(LOriginal) or ((LOriginal.Width = 0) or (LOriginal.Height = 0)) then + Exit; + DrawBitmapTransparent(ACanvas, ARect, LOriginal.Width div LNumGlyphs, LOriginal.Height, LOriginal, + AState, LNumGlyphs, ATransparentColor); + finally if Kind <> bkCustom then LOriginal.Free; - IL.Free; end; end; -procedure CanvasDrawBarAndTriangle(const ACanvas: TCanvas; const ARect: TRect; - const AScaleFactor: Single; ABarColor, ATriangleColor: TColor); +procedure CanvasDrawBar(const ACanvas: TCanvas; const ARect: TRect; + const AScaleFactor: Single; ABarColor: TColor); var - LWidth: Integer; - LHeight: Integer; - LMargin: Integer; Points2: array [0..1] of TPoint; - Points3: array [0..2] of TPoint; LRect: TRect; begin - LHeight := Round(4 * AScaleFactor); - LMargin := (ARect.Height - LHeight) div 2; - //Draw vertical bar ACanvas.Pen.Color := ABarColor; LRect := Rect(ARect.Left-2,ARect.Top+2,ARect.Right-2,ARect.Bottom-2); Points2[0] := Point(ARect.Left -1, ARect.Top + ACanvas.Pen.Width); Points2[1] := Point(ARect.Left -1, ARect.Bottom - ACanvas.Pen.Width); ACanvas.Polyline(Points2); +end; +procedure CanvasDrawTriangle(const ACanvas: TCanvas; const ARect: TRect; + const AScaleFactor: Single; ATriangleColor: TColor); +var + LWidth: Integer; + LHeight: Integer; + LMargin: Integer; + Points3: array [0..2] of TPoint; + LRect: TRect; +begin //Draw triangle + LHeight := Round(4 * AScaleFactor); + LMargin := (ARect.Height - LHeight) div 2; ACanvas.Pen.Color := ATriangleColor; LRect := ARect; LWidth := LRect.Width - 8; @@ -956,9 +1946,21 @@ procedure CanvasDrawBarAndTriangle(const ACanvas: TCanvas; const ARect: TRect; ACanvas.Polygon(Points3); end; +procedure CanvasDrawBarAndTriangle(const ACanvas: TCanvas; const ARect: TRect; + const AScaleFactor: Single; ABarColor, ATriangleColor: TColor); +begin + //Draw vertical bar + CanvasDrawBar(ACanvas, ARect, AScaleFactor, ABarColor); + + //Draw triangle + CanvasDrawTriangle(ACanvas, ARect, AScaleFactor, ATriangleColor); +end; + {$ifdef GDIPlusSupport} procedure CanvasDrawShape(const ACanvas: TCanvas; ARect: TRect; - const ADrawType: TStyledButtonDrawType; const ACornerRadius: Single); + const ADrawType: TStyledButtonDrawType; const ACornerRadius: Single; + const ARoundedCorners: TRoundedCorners; + const APreserveBorderSpace: Boolean = True); var LGraphics: TGPGraphics; LPen: TGPPen; @@ -968,6 +1970,17 @@ procedure CanvasDrawShape(const ACanvas: TCanvas; ARect: TRect; LPath: TGPGraphicsPath; LBorderWidth: Single; X, Y, W, H: Single; + LCornerRadius: Single; + + procedure GPInflateRectF(var ARect: TGPRectF; + const AValue: Single); + begin + ARect.X := ARect.X + (AValue / 2); + ARect.Y := ARect.Y + (AValue / 2); + ARect.Width := ARect.width - AValue -1; + ARect.Height := ARect.Height - AValue -1; + end; + begin LGraphics := nil; LPen := nil; @@ -990,18 +2003,20 @@ procedure CanvasDrawShape(const ACanvas: TCanvas; ARect: TRect; if (ADrawType in [btRect]) then begin - //Drawing Rectangular button (no need to GDI+) - AdjustCanvasRect(ACanvas, ARect, True); - if ACanvas.Brush.Style = bsSolid then - ACanvas.FillRect(ARect); - ACanvas.Rectangle(ARect); + DrawRect(ACanvas, ARect); end - else if (ADrawType in [btRounded]) then + else if (ADrawType in [btRounded, btRoundRect]) then begin //Reduce canvas to draw a rounded rectangle of Pen Width - GPInflateRectF(LRect, LBorderWidth); - //Drawing a Rounded Rect - LPath := GetRoundRectangle(LRect, ACornerRadius*2); + if APreserveBorderSpace then + GPInflateRectF(LRect, LBorderWidth) + else + GPInflateRectF(LRect, 1); + if ADrawType = btRoundRect then + LCornerRadius := ACornerRadius //Drawing a Rounded Rect + else + LCornerRadius := LRect.Height - LBorderWidth; //Drawing a Rounded Button + LPath := GetRoundedCornersPath(LRect, LCornerRadius*2, ARoundedCorners); if ACanvas.Brush.Style = bsSolid then begin LBrush := TGPSolidBrush.Create(LButtonColor); @@ -1028,12 +2043,21 @@ procedure CanvasDrawShape(const ACanvas: TCanvas; ARect: TRect; end; {$else} procedure CanvasDrawShape(const ACanvas: TCanvas; ARect: TRect; - const ADrawType: TStyledButtonDrawType; const ACornerRadius: Integer); + const ADrawType: TStyledButtonDrawType; const ACornerRadius: Single; + const APreserveBorderSpace: Boolean = True); +var + LCornerRadius, LBorderWidth: Integer; begin - if ADrawType in [btRounded] then + LBorderWidth := ACanvas.Pen.Width; + if ADrawType in [btRounded, btRoundRect] then begin - AdjustCanvasRect(ACanvas, ARect, False); - ACanvas.RoundRect(ARect, ACornerRadius, ACornerRadius); + if APreserveBorderSpace then + AdjustCanvasRect(ACanvas, ARect, False); + if ADrawType = btRoundRect then + LCornerRadius := Round(ACornerRadius*2) //Drawing a Rounded Rect + else + LCornerRadius := ARect.Height - LBorderWidth; //Drawing a Rounded Button + ACanvas.RoundRect(ARect, Round(LCornerRadius), LCornerRadius); end else if ADrawType in [btRect] then begin @@ -1044,15 +2068,134 @@ procedure CanvasDrawShape(const ACanvas: TCanvas; ARect: TRect; end else begin + //Drawing Circle or Ellipsis ACanvas.Ellipse(ARect.Left, ARect.Top, ARect.Left + ARect.Width, ARect.Top + ARect.Height); end; end; {$endif} +{$ifdef DrawRectWithGDIPlus} +procedure DrawRect(ACanvas: TCanvas; var ARect: TRect); +var + LGraphics: TGPGraphics; + LBrush: TGPBrush; + LPen: TGPPen; + LButtonColor, LPenColor: TGPColor; + LBorderWidth: Integer; + LRect: TGPRectF; + X, Y, W, H: Single; + + procedure GPInflateRectF(var ARect: TGPRectF; + const AValue: Single); + begin + ARect.X := ARect.X + (AValue / 2); + ARect.Y := ARect.Y + (AValue / 2); + ARect.Width := ARect.width - AValue; + ARect.Height := ARect.Height - AValue; + end; + +begin + LGraphics := nil; + LBrush := nil; + LPen := nil; + try + X := ARect.Left; + Y := ARect.Top; + W := ARect.Width; + H := ARect.Height; + LGraphics := TGPGraphics.Create(ACanvas.Handle); + LPenColor := GPColor(ACanvas.Pen.Color); + LButtonColor := GPColor(ACanvas.Brush.Color); + LBrush := TGPSolidBrush.Create(LButtonColor); + LBorderWidth := ACanvas.Pen.Width; + if ACanvas.Pen.Style = psClear then + LPen := TGPPen.Create(TAlphaColorRec.Null, LBorderWidth) + else + LPen := TGPPen.Create(LPenColor, LBorderWidth); + //Reduce canvas to draw a rounded rectangle of Pen Width + LRect := Winapi.GDIPAPI.MakeRect(X, Y, W, H); + GPInflateRectF(LRect, LBorderWidth); + //GDI+ equivalent of FillRect and Rectangle + LGraphics.FillRectangle(LBrush, X, Y, W, H); + LGraphics.DrawRectangle(LPen, LRect); + finally + LBrush.Free; + LGraphics.Free; + LPen.Free; + end; +end; +{$else} +procedure DrawRect(ACanvas: TCanvas; var ARect: TRect); +begin + //Drawing Rectangular button (no need to GDI+) + AdjustCanvasRect(ACanvas, ARect, True); + if ACanvas.Brush.Style = bsSolid then + ACanvas.FillRect(ARect); + ACanvas.Rectangle(ARect); +end; +{$endif} + + +{$ifdef DrawTextWithGDIPlus} +function FontStyleToGDI(AFont: TFont): TFontStyle; +begin + Result := FontStyleRegular; + if fsBold in AFont.Style then + Result := Result + FontStyleBold; + if fsItalic in AFont.Style then + Result := Result + FontStyleItalic; + if fsUnderline in AFont.Style then + Result := Result + FontStyleUnderline; + if fsStrikeOut in AFont.Style then + Result := Result + FontStyleStrikeout; +end; + +procedure CanvasDrawText(const ACanvas: TCanvas; ARect: TRect; + const AText: string; ABiDiModeFlags: LongInt); +var + LGraphics: TGPGraphics; + LFontFamily: TGPFontFamily; + LFont: TGPFont; + LFontStyle: TFontStyle; + LSolidBrush: TGPSolidBrush; + LFontColor: TGPColor; + LPointF: TGPPointF; + X,Y: Single; + R: TRectF; +begin + LGraphics := nil; + LFontFamily := nil; + LFont := nil; + try + LGraphics := TGPGraphics.Create(ACanvas.Handle); + LFontFamily := TGPFontFamily.Create(ACanvas.Font.Name); + LFontStyle := FontStyleToGDI(ACanvas.Font); + LFont := TGPFont.Create(LFontFamily, -ACanvas.Font.Height, + LFontStyle, UnitPixel); + LFontColor := GPColor(ACanvas.Font.Color); + LSolidBrush := TGPSolidBrush.Create(LFontColor); + X := ARect.Left-1; + Y := ARect.Top-1; + LPointF := MakePoint(X, Y); + LGraphics.DrawString(AText, Length(AText), LFont, LPointF, LSolidBrush); + finally + LGraphics.Free; + LFontFamily.Free; + LFont.Free; + end; +end; +{$else} +procedure CanvasDrawText(const ACanvas: TCanvas; ARect: TRect; + const AText: string; ABiDiModeFlags: LongInt); +begin + Winapi.Windows.DrawText(ACanvas.Handle, PChar(AText), + Length(AText), ARect, ABiDiModeFlags); +end; +{$endif} + initialization _WindowsVersion := wvUndefined; - FFamilies := TObjectList.Create(True); finalization FFamilies.Free; diff --git a/Ext/StyledComponents/source/Vcl.ColorButtonStyles.pas b/Ext/StyledComponents/source/Vcl.ColorButtonStyles.pas index 5b20ccb..2ebe49f 100644 --- a/Ext/StyledComponents/source/Vcl.ColorButtonStyles.pas +++ b/Ext/StyledComponents/source/Vcl.ColorButtonStyles.pas @@ -1,13 +1,13 @@ {******************************************************************************} { } -{ ColorButtonStyles: Button Styles based on VCL color names } -{ Unit System.UIConsts } +{ ColorButtonStyles: Button Styles based on VCL color names } +{ Unit System.UIConsts } { } -{ Copyright (c) 2022-2024 (Ethea S.r.l.) } -{ Author: Carlo Barazzetta } -{ Contributors: } +{ Copyright (c) 2022-2024 (Ethea S.r.l.) } +{ Author: Carlo Barazzetta } +{ Contributors: } { } -{ https://github.com/EtheaDev/StyledComponents } +{ https://github.com/EtheaDev/StyledComponents } { } {******************************************************************************} { } @@ -188,7 +188,7 @@ procedure TBasicColorButtonStyles.UpdateAttributes( BasicClassToColors(AClass, AAppearance, LFontColor, LButtonColor, LBorderColor, LOutLine); //Default Style Attributes for Basic Color Buttons - ANormalStyle.DrawType := btRounded; + ANormalStyle.DrawType := btRoundRect; ANormalStyle.FontStyle := [fsBold]; ANormalStyle.BorderWidth := COLOR_BTN_WIDTH; @@ -354,7 +354,7 @@ procedure TSVGColorButtonStyles.UpdateAttributes( SVGClassToColors(AClass, AAppearance, LFontColor, LButtonColor, LBorderColor, LOutLine); //Default Style Attributes for Basic Color Buttons - ANormalStyle.DrawType := btRounded; + ANormalStyle.DrawType := btRoundRect; ANormalStyle.FontStyle := [fsBold]; ANormalStyle.BorderWidth := COLOR_BTN_WIDTH; diff --git a/Ext/StyledComponents/source/Vcl.SkAnimatedImageHelper.pas b/Ext/StyledComponents/source/Vcl.SkAnimatedImageHelper.pas index 09a54a9..8e7a3fe 100644 --- a/Ext/StyledComponents/source/Vcl.SkAnimatedImageHelper.pas +++ b/Ext/StyledComponents/source/Vcl.SkAnimatedImageHelper.pas @@ -1,12 +1,12 @@ {******************************************************************************} { } -{ SkAnimatedImageHelper: an helper class for TSkAnimatedImage } +{ SkAnimatedImageHelper: an helper class for TSkAnimatedImage } { } -{ Copyright (c) 2022-2024 (Ethea S.r.l.) } -{ Author: Carlo Barazzetta } -{ Contributors: } +{ Copyright (c) 2022-2024 (Ethea S.r.l.) } +{ Author: Carlo Barazzetta } +{ Contributors: } { } -{ https://github.com/EtheaDev/StyledComponents } +{ https://github.com/EtheaDev/StyledComponents } { } {******************************************************************************} { } diff --git a/Ext/StyledComponents/source/Vcl.StandardButtonStyles.pas b/Ext/StyledComponents/source/Vcl.StandardButtonStyles.pas index e108217..0572e2d 100644 --- a/Ext/StyledComponents/source/Vcl.StandardButtonStyles.pas +++ b/Ext/StyledComponents/source/Vcl.StandardButtonStyles.pas @@ -1,13 +1,13 @@ {******************************************************************************} { } -{ Standard Button Family: implementation of "standard" Family } -{ attributes for StyledButton similar to VCL Styled Buttons } +{ Standard Button Family: implementation of "standard" Family } +{ attributes for StyledButton similar to VCL Styled Buttons } { } -{ Copyright (c) 2022-2024 (Ethea S.r.l.) } -{ Author: Carlo Barazzetta } -{ Contributors: Ariel Montes } +{ Copyright (c) 2022-2024 (Ethea S.r.l.) } +{ Author: Carlo Barazzetta } +{ Contributors: Ariel Montes } { } -{ https://github.com/EtheaDev/StyledComponents } +{ https://github.com/EtheaDev/StyledComponents } { } {******************************************************************************} { } @@ -34,10 +34,12 @@ interface , Vcl.ButtonStylesAttributes; const + DEFAULT_STYLEDRAWTYPE = btRoundRect; DEFAULT_CLASSIC_FAMILY = 'Classic'; DEFAULT_WINDOWS_CLASS = 'Windows'; DEFAULT_APPEARANCE = 'Normal'; OUTLINE_APPEARANCE = 'Outline'; + DEFAULT_CURSOR = crHandPoint; STD_BORDER_WIDTH = 2; Type @@ -70,6 +72,7 @@ TThemeAttribute = class FontColor: TColor; FontHotColor: TColor; BorderType: TStyledButtonDrawType; + IDEStyle: Boolean; end; //To add new styles used from your application that are not managed by default @@ -81,7 +84,11 @@ procedure RegisterThemeAttributes(const AVCLStyleName: string; const AHotColor: TColor; const ABorderColor: TColor; const ABorderHotColor: TColor; - const ABorderType: TStyledButtonDrawType); + const ABorderType: TStyledButtonDrawType; + const AIDEStyle: Boolean = False); + +function GetStyleAttributes(const AStyleName: string; + out AThemeAttribute: TThemeAttribute): Boolean; implementation @@ -277,9 +284,9 @@ procedure TButtonStandardStyles.UpdateAttributes( //with lighter or darker button color CloneButtonStyle(AHotStyle, ASelectedStyle); if LDarkStyle then - ASelectedStyle.ButtonColor := LightenColor(LHotColor, 20) + ASelectedStyle.ButtonColor := LightenColor(LHotColor, 10) else - ASelectedStyle.ButtonColor := DarkenColor(LHotColor, 20); + ASelectedStyle.ButtonColor := DarkenColor(LHotColor, 10); //Pressed Button, , similar to Hot //with lighter or darker button and border color @@ -296,9 +303,18 @@ procedure TButtonStandardStyles.UpdateAttributes( end; //Disabled Button (lighten) - ADisabledStyle.BorderColor := LightenColor(ADisabledStyle.BorderColor, 50); - ADisabledStyle.ButtonColor := LightenColor(ADisabledStyle.ButtonColor, 50); - ADisabledStyle.FontColor := LightenColor(ADisabledStyle.FontColor, 50); + if LDarkStyle then + begin + ADisabledStyle.BorderColor := LightenColor(ADisabledStyle.BorderColor, 10); + ADisabledStyle.ButtonColor := LightenColor(ADisabledStyle.ButtonColor, 10); + ADisabledStyle.FontColor := DarkenColor(ADisabledStyle.FontColor, 50); + end + else + begin + ADisabledStyle.BorderColor := LightenColor(ADisabledStyle.BorderColor, 50); + ADisabledStyle.ButtonColor := LightenColor(ADisabledStyle.ButtonColor, 50); + ADisabledStyle.FontColor := LightenColor(ADisabledStyle.FontColor, 50); + end; end; procedure RegisterThemeAttributes( @@ -310,7 +326,8 @@ procedure RegisterThemeAttributes( const AHotColor: TColor; const ABorderColor: TColor; const ABorderHotColor: TColor; - const ABorderType: TStyledButtonDrawType); + const ABorderType: TStyledButtonDrawType; + const AIDEStyle: Boolean = False); var LThemeAttribute: TThemeAttribute; @@ -325,6 +342,7 @@ procedure RegisterThemeAttributes( LThemeAttribute.FontHotColor := AFontHotColor; LThemeAttribute.HotColor := AHotColor; LThemeAttribute.BorderType := ABorderType; + LThemeAttribute.IDEStyle := AIDEStyle; end; begin @@ -343,6 +361,8 @@ procedure RegisterThemeAttributes( end; procedure InitDefaultThemesAttributes; +var + LButtonBorder: TStyledButtonDrawType; function IsWindows11: Boolean; begin @@ -352,15 +372,15 @@ procedure InitDefaultThemesAttributes; begin ThemeAttributes := TList.Create; - //Non themed Windows Style if IsWindows11 then - RegisterThemeAttributes('Windows',ttLight,clBlack,clBlack, - htmlToColor('#fdfdfd'),htmlToColor('#e0eef9'), - htmlToColor('#d0d0d0'),htmlToColor('#0078d4'),btRounded) + LButtonBorder := btRoundRect else - RegisterThemeAttributes('Windows',ttLight,clBlack,clBlack, - htmlToColor('#fdfdfd'),htmlToColor('#fdfdfd'), - htmlToColor('#d0d0d0'),htmlToColor('#e0eef9'),btRect); + LButtonBorder := btRect; + + //Non themed Windows Style + RegisterThemeAttributes('Windows',ttLight,clBlack,clBlack, + htmlToColor('#fdfdfd'),htmlToColor('#e0eef9'), + htmlToColor('#d0d0d0'),htmlToColor('#0078d4'),LButtonBorder); if StyleServices.Enabled then begin @@ -369,164 +389,164 @@ procedure InitDefaultThemesAttributes; htmlToColor('#020202'),htmlToColor('#020202'),btRect); RegisterThemeAttributes('Amethyst Kamri',ttLight,clBlack,clBlack, htmlToColor('#cdd1e2'),htmlToColor('#F99369'), - htmlToColor('#868db0'),htmlToColor('#868db0'),btRounded); + htmlToColor('#868db0'),htmlToColor('#868db0'),btRoundRect); RegisterThemeAttributes('Aqua Graphite',ttDark,clWhite,clWhite, htmlToColor('#0070bb'),htmlToColor('#1585cc'), - htmlToColor('#043f5c'),htmlToColor('#043f5c'),btRounded); + htmlToColor('#043f5c'),htmlToColor('#043f5c'),btRoundRect); RegisterThemeAttributes('Aqua Light Slate',ttLight,clBlack,clBlack, htmlToColor('#f1f1f1'),htmlToColor('#a9d8f2'), - htmlToColor('#9c9c9c'),htmlToColor('#9c9c9c'),btRounded); + htmlToColor('#9c9c9c'),htmlToColor('#9c9c9c'),btRoundRect); RegisterThemeAttributes('Auric' ,ttDark,clWhite,clBlack, htmlToColor('#5e5e5f'),htmlToColor('#fad535'), - clBlack,clBlack,btRounded); + clBlack,clBlack,btRoundRect); RegisterThemeAttributes('Calypso',ttDark,clWhite,clBlack, htmlToColor('#44617c'),htmlToColor('#80ceb5'), - htmlToColor('#44617c'),htmlToColor('#80ceb5'),btRounded); + htmlToColor('#44617c'),htmlToColor('#80ceb5'),btRoundRect); RegisterThemeAttributes('Calypso LE',ttDark,clWhite,clBlack, htmlToColor('#44617c'),htmlToColor('#80ceb5'), - htmlToColor('#44617c'),htmlToColor('#80ceb5'),btRounded); + htmlToColor('#44617c'),htmlToColor('#80ceb5'),btRoundRect); RegisterThemeAttributes('Calypso SE',ttDark,clWhite,clBlack, htmlToColor('#44617c'),htmlToColor('#6bafe2'), - htmlToColor('#44617c'),htmlToColor('#6bafe2'),btRounded); + htmlToColor('#44617c'),htmlToColor('#6bafe2'),btRoundRect); RegisterThemeAttributes('Calypso SLE',ttDark,clWhite,clBlack, htmlToColor('#44617c'),htmlToColor('#6bafe2'), - htmlToColor('#44617c'),htmlToColor('#6bafe2'),btRounded); + htmlToColor('#44617c'),htmlToColor('#6bafe2'),btRoundRect); RegisterThemeAttributes('Carbon',ttDark,htmlToColor('#c0c0c0'),clWhite, htmlToColor('#3a3a3a'),htmlToColor('#3e3e3e'), htmlToColor('#191919'),htmlToColor('#191919'),btRect); RegisterThemeAttributes('Charcoal Dark Slate',ttDark,htmlToColor('#a3a3a3'),clWhite, htmlToColor('#3a3a3a'),htmlToColor('#1f1f1f'), - htmlToColor('#191919'),htmlToColor('#191919'),btRounded); + htmlToColor('#191919'),htmlToColor('#191919'),btRoundRect); RegisterThemeAttributes('Cobalt XEMedia',ttDark,htmlToColor('#c0c0c0'),clWhite, htmlToColor('#121e32'),htmlToColor('#0f2c54'), - htmlToColor('#a1a5ab'),htmlToColor('#a1a5ab'),btRounded); + htmlToColor('#a1a5ab'),htmlToColor('#a1a5ab'),btRoundRect); RegisterThemeAttributes('Copper',ttLight,clBlack,clWhite, clWhite,htmlToColor('#e46b60'), - clWhite,htmlToColor('#e46b60'),btRounded); + clWhite,htmlToColor('#e46b60'),btRoundRect); RegisterThemeAttributes('CopperDark',ttDark,clWhite,clWhite, htmlToColor('#2b2b2b'),htmlToColor('#e46b60'), - htmlToColor('#2b2b2b'),htmlToColor('#e46b60'),btRounded); + htmlToColor('#898989'),htmlToColor('#E46B60'),btRoundRect); RegisterThemeAttributes('Coral',ttDark,clWhite,clWhite, htmlToColor('#d86d00'),htmlToColor('#d86d00'), - htmlToColor('#d86d00'),htmlToColor('#d1d1d1'),btRounded); + htmlToColor('#d86d00'),htmlToColor('#d1d1d1'),btRoundRect); RegisterThemeAttributes('Cyan Dusk',ttLight,clBlack,clWhite, htmlToColor('#b4bac2'),htmlToColor('#324a65'), - htmlToColor('#687e97'),htmlToColor('#687e97'),btRounded); + htmlToColor('#687e97'),htmlToColor('#687e97'),btRoundRect); RegisterThemeAttributes('Cyan Night',ttLight,clBlack,clWhite, htmlToColor('#b0b4bf'),htmlToColor('#323c62'), - htmlToColor('#687297'),htmlToColor('#687297'),btRounded); + htmlToColor('#687297'),htmlToColor('#687297'),btRoundRect); RegisterThemeAttributes('Diamond',ttLight,clBlack,clBlack, htmlToColor('#efeff0'),htmlToColor('#f5f5f5'), - htmlToColor('#c4c3c3'),htmlToColor('#c4c3c3'),btRounded); + htmlToColor('#c4c3c3'),htmlToColor('#c4c3c3'),btRoundRect); RegisterThemeAttributes('Emerald',ttDark,clWhite,clWhite, htmlToColor('#00a57d'),htmlToColor('#00a57d'), - htmlToColor('#00a57d'),htmlToColor('#cbcbc7'),btRounded); + htmlToColor('#00a57d'),htmlToColor('#cbcbc7'),btRoundRect); RegisterThemeAttributes('Emerald Light Slate',ttLight,clBlack,clBlack, htmlToColor('#e0e0e0'),htmlToColor('#87e168'), - htmlToColor('#9c9c9c'),htmlToColor('#9c9c9c'),btRounded); + htmlToColor('#9c9c9c'),htmlToColor('#9c9c9c'),btRoundRect); RegisterThemeAttributes('Flat UI Light',ttLight,clBlack,clWhite, htmlToColor('#e4e6e7'),htmlToColor('#3498da'), - htmlToColor('#e4e6e7'),htmlToColor('#3498da'),btRounded); + htmlToColor('#e4e6e7'),htmlToColor('#3498da'),btRoundRect); RegisterThemeAttributes('Glossy',ttDark,clWhite,clWhite, htmlToColor('#3d3d3d'),htmlToColor('#2f65a7'), - clBlack,clBlack,btRounded); + clBlack,clBlack,btRoundRect); RegisterThemeAttributes('Glow',ttDark,clWhite,htmlToColor('#37bdbb'), htmlToColor('#2e343c'),htmlToColor('#2d333b'), - htmlToColor('#1a1c1f'),htmlToColor('#1a1c1f'),btRounded); + htmlToColor('#1a1c1f'),htmlToColor('#1a1c1f'),btRoundRect); RegisterThemeAttributes('Golden Graphite',ttDark,htmlToColor('#eaeaea'),clWhite, htmlToColor('#bb8900'),htmlToColor('#c6920f'), - htmlToColor('#5c3e04'),htmlToColor('#5c3e04'),btRounded); + htmlToColor('#5c3e04'),htmlToColor('#5c3e04'),btRoundRect); RegisterThemeAttributes('Iceberg Classico',ttLight,clBlack,clBlack, htmlToColor('#e4eaf1'),htmlToColor('#99c7ea'), - htmlToColor('#91a6c0'),htmlToColor('#91a6c0'),btRounded); + htmlToColor('#91a6c0'),htmlToColor('#91a6c0'),btRoundRect); RegisterThemeAttributes('Jet',ttDark,clWhite,htmlToColor('#cee9f8'), htmlToColor('#303030'),htmlToColor('#393939'), - htmlToColor('#585858'),htmlToColor('#585858'),btRounded); + htmlToColor('#585858'),htmlToColor('#585858'),btRoundRect); RegisterThemeAttributes('Lavender Classico',ttLight,clBlack,clBlack, htmlToColor('#eaeaee'),htmlToColor('#a9c4e6'), - htmlToColor('#a1a1b4'),htmlToColor('#a1a1b4'),btRounded); + htmlToColor('#a1a1b4'),htmlToColor('#a1a1b4'),btRoundRect); RegisterThemeAttributes('Light',ttLight,clBlack,clBlack, htmlToColor('#fdfdfd'),htmlToColor('#d4e6f3'), htmlToColor('#ababab'),htmlToColor('#a2c7e4'),btRect); RegisterThemeAttributes('Lucky Point',ttDark,clWhite,clBlack, htmlToColor('#3f4c6a'),htmlToColor('#74b9c9'), - htmlToColor('#3f4c6a'),htmlToColor('#74b9c9'),btRounded); + htmlToColor('#3f4c6a'),htmlToColor('#74b9c9'),btRoundRect); RegisterThemeAttributes('Luna',ttLight,clBlack,clBlack, htmlToColor('#bcd0e9'),htmlToColor('#ffd355'), - htmlToColor('#99b5de'),htmlToColor('#99b5de'),btRounded); + htmlToColor('#99b5de'),htmlToColor('#99b5de'),btRoundRect); RegisterThemeAttributes('Material Oxford Blue',ttDark,clWhite,clWhite, htmlToColor('#5f6a72'),htmlToColor('#00a1a1'), - htmlToColor('#5f6a72'),htmlToColor('#00a1a1'),btRounded); + htmlToColor('#5f6a72'),htmlToColor('#00a1a1'),btRoundRect); RegisterThemeAttributes('Material Oxford Blue SE',ttDark,clWhite,clWhite, htmlToColor('#5f6a72'),htmlToColor('#0a7fbf'), - htmlToColor('#5f6a72'),htmlToColor('#0a7fbf'),btRounded); + htmlToColor('#5f6a72'),htmlToColor('#0a7fbf'),btRoundRect); RegisterThemeAttributes('Material Patterns Blue',ttLight,clBlack,clBlack, htmlToColor('#e6ecf2'),htmlToColor('#e6ecf2'), - htmlToColor('#c4d3df'),htmlToColor('#18a1e9'),btRounded); + htmlToColor('#c4d3df'),htmlToColor('#18a1e9'),btRoundRect); { TODO: Old Delphi Styles RegisterThemeAttributes('Metropolis UI Black',ttDark,clWhite, - clWebLightYellow,clWebLightYellow,clDkGray,btRounded); + clWebLightYellow,clWebLightYellow,clDkGray,btRoundRect); RegisterThemeAttributes('Metropolis UI Blue',ttDark,clWhite, - clWebDarkSlategray,clWebDarkSlategray,clDkGray,btRounded); + clWebDarkSlategray,clWebDarkSlategray,clDkGray,btRoundRect); RegisterThemeAttributes('Metropolis UI Dark',ttDark,clWhite, - clWebLightYellow,clWebLightYellow,clDkGray,btRounded); + clWebLightYellow,clWebLightYellow,clDkGray,btRoundRect); RegisterThemeAttributes('Metropolis UI Green',ttDark,clWhite, - clWebLightGreen,clWebLightGreen,clWebLightgrey,btRounded); + clWebLightGreen,clWebLightGreen,clWebLightgrey,btRoundRect); } RegisterThemeAttributes('Obsidian',ttLight,clBlack,clBlack, htmlToColor('#cfd2d7'),htmlToColor('#ffd24e'), - htmlToColor('#2f2f2f'),htmlToColor('#2f2f2f'),btRounded); + htmlToColor('#2f2f2f'),htmlToColor('#2f2f2f'),btRoundRect); RegisterThemeAttributes('Onyx Blue',ttLight,clBlack,clWhite, htmlToColor('#adb0b4'),htmlToColor('#42729a'), - htmlToColor('#adb0b4'),htmlToColor('#42729a'),btRounded); + htmlToColor('#adb0b4'),htmlToColor('#42729a'),btRoundRect); RegisterThemeAttributes('Puerto Rico',ttDark,clWhite,clWhite, htmlToColor('#44beb0'),htmlToColor('#52cfc0'), - htmlToColor('#44beb0'),htmlToColor('#52cfc0'),btRounded); + htmlToColor('#44beb0'),htmlToColor('#52cfc0'),btRoundRect); RegisterThemeAttributes('Radiant',ttDark,clWhite,clWhite, htmlToColor('#00b8b0'),htmlToColor('#19bfb7'), - htmlToColor('#00b8b0'),htmlToColor('#19bfb7'),btRounded); + htmlToColor('#00b8b0'),htmlToColor('#19bfb7'),btRoundRect); RegisterThemeAttributes('Ruby Graphite',ttDark,clWhite,clWhite, htmlToColor('#bb0d00'),htmlToColor('#cc1e15'), - htmlToColor('#5c0404'),htmlToColor('#5c0404'),btRounded); + htmlToColor('#5c0404'),htmlToColor('#5c0404'),btRoundRect); RegisterThemeAttributes('Sapphire Kamri',ttLight,clBlack,clBlack, htmlToColor('#c1d9e7'),htmlToColor('#fa946b'), - htmlToColor('#6d9dbf'),htmlToColor('#a57b6c'),btRounded); + htmlToColor('#6d9dbf'),htmlToColor('#a57b6c'),btRoundRect); RegisterThemeAttributes('Silver',ttLight,clBlack,clBlack, htmlToColor('#dce0e6'),htmlToColor('#ffd24e'), - htmlToColor('#b9bec8'),htmlToColor('#b9bec8'),btRounded); + htmlToColor('#b9bec8'),htmlToColor('#b9bec8'),btRoundRect); RegisterThemeAttributes('Sky',ttLight,clBlack,clBlack, htmlToColor('#efefef'),htmlToColor('#acdbef'), - htmlToColor('#bebebe'),htmlToColor('#bebebe'),btRounded); + htmlToColor('#bebebe'),htmlToColor('#bebebe'),btRoundRect); RegisterThemeAttributes('Slate Classico',ttLight,clBlack,clBlack, htmlToColor('#ebebeb'),htmlToColor('#99c7ea'), - htmlToColor('#a8a8a8'),htmlToColor('#6692be'),btRounded); + htmlToColor('#a8a8a8'),htmlToColor('#6692be'),btRoundRect); RegisterThemeAttributes('Smokey Quartz Kamri',ttLight,clBlack,clBlack, htmlToColor('#dbdbdb'),htmlToColor('#f39772'), - htmlToColor('#9f9f9f'),htmlToColor('#9f9f9f'),btRounded); + htmlToColor('#9f9f9f'),htmlToColor('#9f9f9f'),btRoundRect); RegisterThemeAttributes('Stellar',ttLight,htmlToColor('#3e629a'),htmlToColor('#3e629a'), htmlToColor('#fcfcfc'),clWhite, - htmlToColor('#fcfcfc'),htmlToColor('#fcfcfc'),btRounded); + htmlToColor('#fcfcfc'),htmlToColor('#fcfcfc'),btRoundRect); RegisterThemeAttributes('Stellar Dark',ttLight,htmlToColor('#3e629a'),htmlToColor('#3e629a'), htmlToColor('#fcfcfc'),clWhite, - htmlToColor('#fcfcfc'),htmlToColor('#fcfcfc'),btRounded); + htmlToColor('#fcfcfc'),htmlToColor('#fcfcfc'),btRoundRect); RegisterThemeAttributes('Sterling',ttLight,clBlack,htmlToColor('#527593'), htmlToColor('#f9fafc'),htmlToColor('#eef6fb'), - htmlToColor('#dde1e4'),htmlToColor('#dde1e4'),btRounded); + htmlToColor('#dde1e4'),htmlToColor('#dde1e4'),btRoundRect); RegisterThemeAttributes('Tablet Dark',ttDark,clWhite,clBlack, htmlToColor('#3d4a79'),htmlToColor('#1abc9c'), - htmlToColor('#3d4a79'),htmlToColor('#1abc9c'),btRounded); + htmlToColor('#3d4a79'),htmlToColor('#1abc9c'),btRoundRect); RegisterThemeAttributes('Tablet Light',ttLight,clBlack,clWhite, clWhite,htmlToColor('#3d84dd'), - htmlToColor('#3d84dd'),htmlToColor('#3d84dd'),btRounded); + htmlToColor('#3d84dd'),htmlToColor('#3d84dd'),btRoundRect); RegisterThemeAttributes('Turquoise Gray',ttLight,clBlack,clWhite, htmlToColor('#ededed'),htmlToColor('#28c0e9'), - htmlToColor('#d3d3d3'),htmlToColor('#019ac4'),btRounded); + htmlToColor('#d3d3d3'),htmlToColor('#019ac4'),btRoundRect); RegisterThemeAttributes('Vapor',ttLight,clBlack,clBlack, htmlToColor('#89dcc8'),htmlToColor('#7cc6b4'), - htmlToColor('#89dcc8'),htmlToColor('#7cc6b4'),btRounded); + htmlToColor('#89dcc8'),htmlToColor('#7cc6b4'),btRoundRect); RegisterThemeAttributes('Wedgewood Light',ttLight,clBlack,clWhite, htmlToColor('#f5f5f6'),htmlToColor('#5a7390'), - htmlToColor('#dfdfe1'),htmlToColor('#dfdfe1'),btRounded); + htmlToColor('#dfdfe1'),htmlToColor('#dfdfe1'),btRoundRect); RegisterThemeAttributes('Windows10',ttLight,clBlack,clBlack, htmlToColor('#cccccc'),htmlToColor('#cccccc'), htmlToColor('#cccccc'),htmlToColor('#7a7a7a'),btRect); @@ -560,34 +580,58 @@ procedure InitDefaultThemesAttributes; RegisterThemeAttributes('Windows10 Purple',ttDark,clWhite,clWhite, htmlToColor('#672d63'),htmlToColor('#672d63'), htmlToColor('#672d63'),clWhite,btRect); - RegisterThemeAttributes('Windows10 SlateGray',ttDark,clWhite,htmlToColor('#7daca8'), + RegisterThemeAttributes('Windows10 SlateGray',ttDark,clWhite, + htmlToColor('#7daca8'),htmlToColor('#2a353b'), htmlToColor('#2a353b'),htmlToColor('#2a353b'), - htmlToColor('#2a353b'),htmlToColor('#7daca8'),btRect); + htmlToColor('#7daca8'),btRect); RegisterThemeAttributes('Windows11 MineShaft',ttDark,clWhite,clBlack, htmlToColor('#373737'),htmlToColor('#47b1e8'), - htmlToColor('#373737'),htmlToColor('#47b1e8'),btRounded); + htmlToColor('#373737'),htmlToColor('#47b1e8'),btRoundRect); RegisterThemeAttributes('Windows11 Modern Dark',ttDark,clWhite,clWhite, htmlToColor('#373737'),htmlToColor('#405560'), - htmlToColor('#434343'),htmlToColor('#4ab2e9'),btRounded); + htmlToColor('#434343'),htmlToColor('#4ab2e9'),btRoundRect); RegisterThemeAttributes('Windows11 Modern Light',ttLight,clBlack,clBlack, htmlToColor('#fdfdfd'),htmlToColor('#eef4f9'), - htmlToColor('#bbbbbb'),htmlToColor('#0067c0'),btRounded); + htmlToColor('#bbbbbb'),htmlToColor('#0067c0'),btRoundRect); RegisterThemeAttributes('Windows11 Polar Dark',ttDark,clWhite,clWhite, htmlToColor('#4b5167'),htmlToColor('#0781e0'), - htmlToColor('#4b5167'),htmlToColor('#0781e0'),btRounded); + htmlToColor('#4b5167'),htmlToColor('#0781e0'),btRoundRect); RegisterThemeAttributes('Windows11 Polar Light',ttLight,clBlack,clBlack, htmlToColor('#c7d4e1'),htmlToColor('#a2d0fe'), - htmlToColor('#c7d4e1'),htmlToColor('#a2d0fe'),btRounded); + htmlToColor('#c7d4e1'),htmlToColor('#a2d0fe'),btRoundRect); RegisterThemeAttributes('Windows11 White Smoke',ttLight,clBlack,clWhite, htmlToColor('#fdfdfd'),htmlToColor('#1975c5'), - htmlToColor('#e9e9e9'),htmlToColor('#1975c5'),btRounded); + htmlToColor('#e9e9e9'),htmlToColor('#1975c5'),btRoundRect); RegisterThemeAttributes('Zircon',ttLight,clBlack,clBlack, htmlToColor('#e5e8e9'),htmlToColor('#a0d4de'), - htmlToColor('#e5e8e9'),htmlToColor('#a0d4de'),btRounded); + htmlToColor('#e5e8e9'),htmlToColor('#a0d4de'),btRoundRect); RegisterThemeAttributes('Zircon SE',ttLight,clBlack,clBlack, htmlToColor('#e5e8e9'),htmlToColor('#a0d4de'), - htmlToColor('#e5e8e9'),htmlToColor('#a0d4de'),btRounded); + htmlToColor('#e5e8e9'),htmlToColor('#a0d4de'),btRoundRect); + RegisterThemeAttributes('Windows11 Impressive Dark',ttDark,clWhite,clWhite, + htmlToColor('#3F506D'),htmlToColor('#5172EF'), + htmlToColor('#3F506D'),htmlToColor('#5172EF'),btRoundRect); + RegisterThemeAttributes('Windows11 Impressive Dark SE',ttDark,clWhite,clWhite, + htmlToColor('#3F506D'),htmlToColor('#5172EF'), + htmlToColor('#3F506D'),htmlToColor('#5172EF'),btRoundRect); + RegisterThemeAttributes('Windows11 Impressive Light',ttLight,clBlack,clWhite, + htmlToColor('#CAD4E6'),htmlToColor('#5172EF'), + htmlToColor('#CAD4E6'),htmlToColor('#5172EF'),btRoundRect); + RegisterThemeAttributes('Windows11 Impressive Light SE',ttLight,clBlack,clWhite, + htmlToColor('#CAD4E6'),htmlToColor('#5172EF'), + htmlToColor('#CAD4E6'),htmlToColor('#5172EF'),btRoundRect); end; + + //IDE Styled + RegisterThemeAttributes('Win10IDE_Dark',ttDark,clWhite,clWhite, + htmlToColor('#373737'),htmlToColor('#405560'), + htmlToColor('#434343'),htmlToColor('#4ab2e9'),btRoundRect, True); + RegisterThemeAttributes('Win10IDE_Light',ttLight,clBlack,clBlack, + htmlToColor('#fdfdfd'),htmlToColor('#eef4f9'), + htmlToColor('#bbbbbb'),htmlToColor('#0067c0'),btRoundRect, True); + RegisterThemeAttributes('Mountain_Mist',ttLight,clBlack,clBlack, + htmlToColor('#fdfdfd'),htmlToColor('#eef4f9'), + htmlToColor('#bbbbbb'),htmlToColor('#0067c0'),btRoundRect, True); end; procedure FreeThemesAttributes; diff --git a/Ext/StyledComponents/source/Vcl.StyledAnimatedButton.pas b/Ext/StyledComponents/source/Vcl.StyledAnimatedButton.pas index 750b16b..9fdd5c2 100644 --- a/Ext/StyledComponents/source/Vcl.StyledAnimatedButton.pas +++ b/Ext/StyledComponents/source/Vcl.StyledAnimatedButton.pas @@ -1,12 +1,13 @@ {******************************************************************************} { } -{ TStyledAnimatedButton: a StyledButton with support for Skia Animations } +{ TStyledAnimatedButton: a StyledButton with "animated icon" } +{ using a Skia TSkAnimatedImage component } { } -{ Copyright (c) 2022-2024 (Ethea S.r.l.) } -{ Author: Carlo Barazzetta } -{ Contributors: } +{ Copyright (c) 2022-2024 (Ethea S.r.l.) } +{ Author: Carlo Barazzetta } +{ Contributors: } { } -{ https://github.com/EtheaDev/StyledComponents } +{ https://github.com/EtheaDev/StyledComponents } { } {******************************************************************************} { } @@ -50,24 +51,54 @@ interface DEFAULT_ANIM_MARGIN = 10; type - TAutoAnimationType = (AnimateOnMouseOver, AnimateOnClick, AnimateAlways, AnimateOnFocused); + TAutoAnimationType = (AnimateOnMouseOver, AnimateOnClick, AnimateAlways, AnimateOnFocus); TAutoAnimationTypes = set of TAutoAnimationType; + { TStyledAnimatedButtonRender } TStyledAnimatedButtonRender = class(TStyledButtonRender) + private + FAnimationHeight: Integer; + FAnimationWidth: Integer; + FAutoSizeAnimation: Boolean; + FAutoSizeAnimationMargin: Integer; + procedure SetAutoSizeAnimationMargin(const AValue: Integer); + procedure SetAnimationHeight(const AValue: Integer); + procedure SetAnimationWidth(const AValue: Integer); + procedure SetAutoSizeAnimation(const AValue: Boolean); public + {$IFDEF HiDPISupport} + procedure ChangeScale(M, D: Integer; isDpiChange: Boolean); override; + {$ENDIF} function GetImageSize(out AWidth: Integer; out AHeight: Integer; out AImageList: TCustomImageList; out AImageIndex: Integer): Boolean; override; + constructor CreateStyled(AOwner: TControl; + const AOnClick: TNotifyEvent; + const AControlFont: TControlFont; + const AGetCaption: TGetCaption; + const ASetCaption: TSetCaption; + const AGetParentFont: TGetParentFont; + const ASetParentFont: TSetParentFont; + const AFamily: TStyledButtonFamily; + const AClass: TStyledButtonClass; + const AAppearance: TStyledButtonAppearance; + const ADrawType: TStyledButtonDrawType; + const ACursor: TCursor; + const AUseCustomDrawType: Boolean); override; + property AnimationHeight: Integer read FAnimationHeight write SetAnimationHeight; + property AnimationWidth: Integer read FAnimationWidth write SetAnimationWidth; + property AutoSizeAnimation: Boolean read FAutoSizeAnimation write SetAutoSizeAnimation; + property AutoSizeAnimationMargin: Integer read FAutoSizeAnimationMargin write SetAutoSizeAnimationMargin; end; + { TStyledAnimatedButton } + [ComponentPlatforms(pidWin32 or pidWin64)] TStyledAnimatedButton = class(TStyledButton) strict private FSkAnimatedImage: TSkAnimatedImage; procedure AnimatedImageClick(Sender: TObject); procedure AnimatedImageDblClick(Sender: TObject); + procedure AnimatedImageMouseEnter(Sender: TObject); + procedure AnimatedImageMouseLeave(Sender: TObject); private - FAnimationHeight: Integer; - FAnimationWidth: Integer; - FAutoSizeAnimation: Boolean; - FAutoSizeAnimationMargin: Integer; FAutoAnimationTypes: TAutoAnimationTypes; function GetAnimatedImage: TSkAnimatedImage; function GetSource: TSkAnimatedImage.TSource; @@ -79,17 +110,23 @@ TStyledAnimatedButton = class(TStyledButton) procedure SetAutoAnimationTypes(const AValue: TAutoAnimationTypes); procedure WMSetFocus(var Message: TMessage); message WM_SETFOCUS; procedure WMKillFocus(var Message: TMessage); message WM_KILLFOCUS; - procedure CMMouseEnter(var Message: TNotifyEvent); message CM_MOUSEENTER; - procedure CMMouseLeave(var Message: TNotifyEvent); message CM_MOUSELEAVE; + procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER; + procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE; procedure ReadData(AStream: TStream); procedure WriteData(AStream: TStream); procedure SetAnimationInverse(const AValue: Boolean); procedure SetAnimationLoop(const AValue: Boolean); function GetAnimationInverse: Boolean; function GetAnimationLoop: Boolean; + function GetAnimationHeight: Integer; + function GetAnimationWidth: Integer; + function GetAutoSizeAnimation: Boolean; + function GetAutoSizeAnimationMargin: Integer; + function GetRender: TStyledAnimatedButtonRender; strict protected procedure DefineProperties(AFiler: TFiler); override; protected + procedure Loaded; override; procedure SetCursor(const AValue: TCursor); override; procedure Notification(AComponent: TComponent; Operation: TOperation); override; procedure Paint; override; @@ -102,8 +139,8 @@ TStyledAnimatedButton = class(TStyledButton) destructor Destroy; override; procedure LoadAnimationFromFile(const AFileName: TFileName); procedure LoadAnimationFromStream(const AStream: TStream); + procedure LoadAnimationFromResource(const AResourceName: string); procedure Click; override; - public //Animation procedures and functions function CanPlayAnimation: boolean; procedure StartAnimation(ALoop: Boolean = False; @@ -114,15 +151,16 @@ TStyledAnimatedButton = class(TStyledButton) function AnimationIsRunning: Boolean; procedure CreateAnimation; property AnimatedImage: TSkAnimatedImage read GetAnimatedImage; + property Render: TStyledAnimatedButtonRender read GetRender; published property AutoAnimationTypes: TAutoAnimationTypes read FAutoAnimationTypes write SetAutoAnimationTypes default [AnimateOnMouseOver]; - property AutoSizeAnimation: Boolean read FAutoSizeAnimation write SetAutoSizeAnimation default True; - property AutoSizeAnimationMargin: Integer read FAutoSizeAnimationMargin write SetAutoSizeAnimationMargin default DEFAULT_ANIM_MARGIN; + property AutoSizeAnimation: Boolean read GetAutoSizeAnimation write SetAutoSizeAnimation default True; + property AutoSizeAnimationMargin: Integer read GetAutoSizeAnimationMargin write SetAutoSizeAnimationMargin default DEFAULT_ANIM_MARGIN; property AnimationSource: TSkAnimatedImage.TSource read GetSource write SetSource; - property AnimationWidth: Integer read FAnimationWidth write SetAnimationWidth default DEFAULT_ANIM_SIZE; - property AnimationHeight: Integer read FAnimationHeight write SetAnimationHeight default DEFAULT_ANIM_SIZE; - property AnimationLoop: Boolean read GetAnimationLoop write SetAnimationLoop; - property AnimationInverse: Boolean read GetAnimationInverse write SetAnimationInverse; + property AnimationWidth: Integer read GetAnimationWidth write SetAnimationWidth default DEFAULT_ANIM_SIZE; + property AnimationHeight: Integer read GetAnimationHeight write SetAnimationHeight default DEFAULT_ANIM_SIZE; + property AnimationLoop: Boolean read GetAnimationLoop write SetAnimationLoop default False; + property AnimationInverse: Boolean read GetAnimationInverse write SetAnimationInverse default False; end; implementation @@ -135,6 +173,105 @@ implementation {$ENDIF} ; +{ TStyledAnimatedButtonRender } + +procedure TStyledAnimatedButtonRender.SetAutoSizeAnimationMargin( + const AValue: Integer); +begin + if FAutoSizeAnimationMargin <> AValue then + begin + FAutoSizeAnimationMargin := AValue; + Invalidate; + end; +end; + +constructor TStyledAnimatedButtonRender.CreateStyled(AOwner: TControl; + const AOnClick: TNotifyEvent; const AControlFont: TControlFont; + const AGetCaption: TGetCaption; const ASetCaption: TSetCaption; + const AGetParentFont: TGetParentFont; const ASetParentFont: TSetParentFont; + const AFamily: TStyledButtonFamily; const AClass: TStyledButtonClass; + const AAppearance: TStyledButtonAppearance; + const ADrawType: TStyledButtonDrawType; + const ACursor: TCursor; const AUseCustomDrawType: Boolean); +begin + inherited; + AnimationHeight := DEFAULT_ANIM_SIZE; + AnimationWidth := DEFAULT_ANIM_SIZE; + AutoSizeAnimationMargin := DEFAULT_ANIM_MARGIN; + AutoSizeAnimation := True; +end; + +function TStyledAnimatedButtonRender.GetImageSize(out AWidth, AHeight: Integer; + out AImageList: TCustomImageList; out AImageIndex: Integer): Boolean; +var + LStyledAnimatedButton: TStyledAnimatedButton; + LSize: Integer; +begin + Result := inherited GetImageSize(AWidth, AHeight, AImageList, AImageIndex); + if not Result then + begin + if OwnerControl is TStyledAnimatedButton then + begin + LStyledAnimatedButton := TStyledAnimatedButton(OwnerControl); + if LStyledAnimatedButton.AutoSizeAnimation then + begin + LSize := Min(OwnerControl.Width, OwnerControl.Height); + AWidth := LSize - (FAutoSizeAnimationMargin * 2); + AHeight := AWidth; + end + else + begin + AWidth := FAnimationWidth; + AHeight := FAnimationHeight; + end; + end; + end; +end; + +procedure TStyledAnimatedButtonRender.SetAnimationHeight(const AValue: Integer); +begin + if FAnimationHeight <> AValue then + begin + FAnimationHeight := AValue; + FAutoSizeAnimation := False; + Invalidate; + end; +end; + +procedure TStyledAnimatedButtonRender.SetAnimationWidth(const AValue: Integer); +begin + if FAnimationWidth <> AValue then + begin + FAnimationWidth := AValue; + FAutoSizeAnimation := False; + Invalidate; + end; +end; + +procedure TStyledAnimatedButtonRender.SetAutoSizeAnimation( + const AValue: Boolean); +begin + if FAutoSizeAnimation <> AValue then + begin + FAutoSizeAnimation := AValue; + Invalidate; + end; +end; + +{$IFDEF HiDPISupport} +procedure TStyledAnimatedButtonRender.ChangeScale(M, D: Integer; isDpiChange: Boolean); +begin + if isDpiChange then + begin + FAnimationHeight := MulDiv(FAnimationHeight, M, D); + FAnimationWidth := MulDiv(FAnimationWidth, M, D); + FAutoSizeAnimationMargin := MulDiv(FAutoSizeAnimationMargin, M, D); + end; +end; +{$ENDIF} + +{ TStyledAnimatedButton } + procedure TStyledAnimatedButton.CreateAnimation; begin FSkAnimatedImage := TSkAnimatedImage.Create(Self); @@ -146,6 +283,8 @@ procedure TStyledAnimatedButton.CreateAnimation; FSkAnimatedImage.Parent := Self; FSkAnimatedImage.OnClick := AnimatedImageClick; FSkAnimatedImage.OnDblClick := AnimatedImageDblClick; + FSkAnimatedImage.OnMouseEnter := AnimatedImageMouseEnter; + FSkAnimatedImage.OnMouseLeave := AnimatedImageMouseLeave; //FSkAnimatedImage.Visible := False; FSkAnimatedImage.Cursor := Cursor; end; @@ -157,24 +296,20 @@ constructor TStyledAnimatedButton.CreateStyled( const AAppearance: TStyledButtonAppearance); begin inherited CreateStyled(AOwner, AFamily, AClass, AAppearance); - FAnimationHeight := DEFAULT_ANIM_SIZE; - FAnimationWidth := DEFAULT_ANIM_SIZE; - FAutoSizeAnimationMargin := DEFAULT_ANIM_MARGIN; - FAutoSizeAnimation := True; FAutoAnimationTypes := [AnimateOnMouseOver]; end; procedure TStyledAnimatedButton.ReadData(AStream: TStream); begin - if AStream.Size = 0 then + if (AStream.Size = 0) and Assigned(FSkAnimatedImage) then FSkAnimatedImage.Source.Data := nil else - FSkAnimatedImage.LoadFromStream(AStream); + AnimatedImage.LoadFromStream(AStream); end; procedure TStyledAnimatedButton.WriteData(AStream: TStream); begin - if FSkAnimatedImage.Source.Data <> nil then + if Assigned(FSkAnimatedImage) and (FSkAnimatedImage.Source.Data <> nil) then AStream.WriteBuffer(FSkAnimatedImage.Source.Data, Length(FSkAnimatedImage.Source.Data)); end; @@ -185,7 +320,7 @@ procedure TStyledAnimatedButton.DefineProperties(AFiler: TFiler); begin if AFiler.Ancestor <> nil then Result := (not (AFiler.Ancestor is TStyledAnimatedButton)) or - not TStyledAnimatedButton(AFiler.Ancestor).AnimationSource.Equals(FSkAnimatedImage.Source) + not TStyledAnimatedButton(AFiler.Ancestor).AnimationSource.Equals(Self.AnimationSource) else Result := AnimatedImage.Source.Data <> nil; end; @@ -207,6 +342,11 @@ function TStyledAnimatedButton.GetAnimatedImage: TSkAnimatedImage; Result := FSkAnimatedImage; end; +function TStyledAnimatedButton.GetAnimationHeight: Integer; +begin + Result := Render.AnimationHeight; +end; + function TStyledAnimatedButton.GetAnimationInverse: Boolean; begin Result := AnimatedImage.GetInverse; @@ -217,6 +357,26 @@ function TStyledAnimatedButton.GetAnimationLoop: Boolean; Result := AnimatedImage.GetLoop; end; +function TStyledAnimatedButton.GetAnimationWidth: Integer; +begin + Result := Render.AnimationWidth; +end; + +function TStyledAnimatedButton.GetAutoSizeAnimation: Boolean; +begin + Result := Render.AutoSizeAnimation; +end; + +function TStyledAnimatedButton.GetAutoSizeAnimationMargin: Integer; +begin + Result := Render.AutoSizeAnimationMargin; +end; + +function TStyledAnimatedButton.GetRender: TStyledAnimatedButtonRender; +begin + Result := inherited Render as TStyledAnimatedButtonRender; +end; + function TStyledAnimatedButton.GetRenderClass: TStyledButtonRenderClass; begin Result := TStyledAnimatedButtonRender; @@ -237,7 +397,30 @@ procedure TStyledAnimatedButton.LoadAnimationFromStream(const AStream: TStream); AnimatedImage.LoadFromStream(AStream); end; -procedure TStyledAnimatedButton.Notification(AComponent: TComponent; Operation: TOperation); +procedure TStyledAnimatedButton.LoadAnimationFromResource( + const AResourceName: string); +var + LStream: TResourceStream; +begin + LStream := TResourceStream.Create(HInstance, AResourceName, + RT_RCDATA); + try + AnimatedImage.LoadFromStream(LStream); + finally + LStream.Free; + end; +end; + + +procedure TStyledAnimatedButton.Loaded; +begin + inherited; + if csDesigning in ComponentState then + AnimatedImage.StartAnimation; +end; + +procedure TStyledAnimatedButton.Notification(AComponent: TComponent; + Operation: TOperation); begin (* if (Operation = opInsert) and (AComponent = Images) then @@ -263,28 +446,29 @@ procedure TStyledAnimatedButton.Click; procedure TStyledAnimatedButton.WMKillFocus(var Message: TMessage); begin - if AnimateOnFocused in FAutoAnimationTypes then - AnimatedImage.StopAnimation; + inherited; + if AnimateOnFocus in FAutoAnimationTypes then + AnimatedImage.StopAnimation; end; procedure TStyledAnimatedButton.WMSetFocus(var Message: TMessage); begin - if AnimateOnFocused in FAutoAnimationTypes then + if AnimateOnFocus in FAutoAnimationTypes then AnimatedImage.StartAnimation; inherited; end; -procedure TStyledAnimatedButton.CMMouseEnter(var Message: TNotifyEvent); +procedure TStyledAnimatedButton.CMMouseEnter(var Message: TMessage); begin - if AnimateOnMouseOver in FAutoAnimationTypes then - AnimatedImage.StartAnimation; +// if AnimateOnMouseOver in FAutoAnimationTypes then +// AnimatedImage.StartAnimation; inherited; end; -procedure TStyledAnimatedButton.CMMouseLeave(var Message: TNotifyEvent); +procedure TStyledAnimatedButton.CMMouseLeave(var Message: TMessage); begin - if AnimateOnMouseOver in FAutoAnimationTypes then - AnimatedImage.StopAnimation; +// if AnimateOnMouseOver in FAutoAnimationTypes then +// AnimatedImage.StopAnimation; inherited; end; @@ -307,6 +491,18 @@ procedure TStyledAnimatedButton.AnimatedImageDblClick(Sender: TObject); Self.DblClick; end; +procedure TStyledAnimatedButton.AnimatedImageMouseEnter(Sender: TObject); +begin + if AnimateOnMouseOver in FAutoAnimationTypes then + AnimatedImage.StartAnimation; +end; + +procedure TStyledAnimatedButton.AnimatedImageMouseLeave(Sender: TObject); +begin + if AnimateOnMouseOver in FAutoAnimationTypes then + AnimatedImage.StopAnimation; +end; + function TStyledAnimatedButton.AnimationIsRunning: Boolean; begin Result := AnimatedImage.Animation.Running; @@ -331,20 +527,20 @@ procedure TStyledAnimatedButton.Paint; LImageList, LImageIndex); if (LImageWidth=0) or (LImageHeight=0) then begin - LImageWidth := FAnimationWidth; - LImageHeight := FAnimationHeight; + LImageWidth := Render.AnimationWidth; + LImageHeight := Render.AnimationHeight; end; LImageRect := ClientRect; LImageRect := CalcImageRect(LImageRect, LImageWidth, LImageHeight); if (LImageRect.Width <> 0) and (LImageRect.Height <> 0) then begin - FSkAnimatedImage.SetBounds(LImageRect.Left, LImageRect.Top, LImageRect.Width, LImageRect.Height); + FSkAnimatedImage.SetBounds(LImageRect.Left, LImageRect.Top, + LImageRect.Width, LImageRect.Height); if not FSkAnimatedImage.AnimationRunning then FSkAnimatedImage.Animation.Progress := 1; end; - end - else - inherited; + end; + inherited; end; procedure TStyledAnimatedButton.PauseAnimation; @@ -365,12 +561,7 @@ procedure TStyledAnimatedButton.SetSource( procedure TStyledAnimatedButton.SetAnimationHeight(const AValue: Integer); begin - if FAnimationHeight <> AValue then - begin - FAnimationHeight := AValue; - FAutoSizeAnimation := False; - Invalidate; - end; + Render.AnimationHeight := AValue; end; procedure TStyledAnimatedButton.SetAnimationInverse(const AValue: Boolean); @@ -385,12 +576,7 @@ procedure TStyledAnimatedButton.SetAnimationLoop(const AValue: Boolean); procedure TStyledAnimatedButton.SetAnimationWidth(const AValue: Integer); begin - if FAnimationWidth <> AValue then - begin - FAnimationWidth := AValue; - FAutoSizeAnimation := False; - Invalidate; - end; + Render.AnimationWidth := AValue; end; procedure TStyledAnimatedButton.SetAutoAnimationTypes( @@ -410,20 +596,12 @@ procedure TStyledAnimatedButton.SetAutoAnimationTypes( procedure TStyledAnimatedButton.SetAutoSizeAnimation(const AValue: Boolean); begin - if FAutoSizeAnimation <> AValue then - begin - FAutoSizeAnimation := AValue; - Invalidate; - end; + Render.AutoSizeAnimation := AValue; end; procedure TStyledAnimatedButton.SetAutoSizeAnimationMargin(const AValue: Integer); begin - if FAutoSizeAnimationMargin <> AValue then - begin - FAutoSizeAnimationMargin := AValue; - Invalidate; - end; + Render.AutoSizeAnimationMargin := AValue; end; procedure TStyledAnimatedButton.SetCursor(const AValue: TCursor); @@ -433,34 +611,4 @@ procedure TStyledAnimatedButton.SetCursor(const AValue: TCursor); AnimatedImage.Cursor := AValue; end; -{ TStyledAnimatedButtonRender } - -function TStyledAnimatedButtonRender.GetImageSize(out AWidth, AHeight: Integer; - out AImageList: TCustomImageList; out AImageIndex: Integer): Boolean; -var - LStyledAnimatedButton: TStyledAnimatedButton; - LSize: Integer; -begin - Result := inherited GetImageSize(AWidth, AHeight, AImageList, AImageIndex); - if not Result then - begin - if OwnerControl is TStyledAnimatedButton then - begin - LStyledAnimatedButton := TStyledAnimatedButton(OwnerControl); - if LStyledAnimatedButton.AutoSizeAnimation then - begin - LSize := Min(OwnerControl.Width, OwnerControl.Height); - AWidth := LSize - (LStyledAnimatedButton.FAutoSizeAnimationMargin * 2); - AHeight := AWidth; - end - else - begin - AWidth := LStyledAnimatedButton.FAnimationWidth; - AHeight := LStyledAnimatedButton.FAnimationHeight; - end; - Result := True; - end; - end; -end; - end. diff --git a/Ext/StyledComponents/source/Vcl.StyledAnimatedTaskDialog.pas b/Ext/StyledComponents/source/Vcl.StyledAnimatedTaskDialog.pas index 9c3906e..739e8f0 100644 --- a/Ext/StyledComponents/source/Vcl.StyledAnimatedTaskDialog.pas +++ b/Ext/StyledComponents/source/Vcl.StyledAnimatedTaskDialog.pas @@ -1,13 +1,13 @@ {******************************************************************************} { } -{ StyledAnimatedTaskDialog: a Task Dialog Component with StyleButtons } -{ and animations using Skia4Delphi } +{ StyledAnimatedTaskDialog: a Task Dialog Component with StyleButtons } +{ and animations using Skia4Delphi } { } -{ Copyright (c) 2022-2024 (Ethea S.r.l.) } -{ Author: Carlo Barazzetta } -{ Contributors: } +{ Copyright (c) 2022-2024 (Ethea S.r.l.) } +{ Author: Carlo Barazzetta } +{ Contributors: } { } -{ https://github.com/EtheaDev/StyledComponents } +{ https://github.com/EtheaDev/StyledComponents } { } {******************************************************************************} { } @@ -35,7 +35,6 @@ interface , System.Classes , WinApi.Windows , Vcl.StyledTaskDialog - , Skia.Vcl.StyledTaskDialogAnimatedUnit //to register StyledTaskDialogAnimatedUnit ; //{$WARN SYMBOL_PLATFORM OFF} @@ -48,6 +47,10 @@ TStyledAnimatedTaskDialog = class(TStyledTaskDialog) implementation +uses + Skia.Vcl.StyledTaskDialogAnimatedUnit //to register StyledTaskDialogAnimatedUnit + ; + initialization finalization diff --git a/Ext/StyledComponents/source/Vcl.StyledAnimatedToolbar.pas b/Ext/StyledComponents/source/Vcl.StyledAnimatedToolbar.pas index 55ef781..b2f7148 100644 --- a/Ext/StyledComponents/source/Vcl.StyledAnimatedToolbar.pas +++ b/Ext/StyledComponents/source/Vcl.StyledAnimatedToolbar.pas @@ -1,13 +1,13 @@ {******************************************************************************} { } -{ StyledToolbar: a Toolbar with TStyledAnimatedToolButtons inside } -{ Based on TStyledToolbar and animations using Skia4Delphi } +{ StyledToolbar: a Toolbar with TStyledAnimatedToolButtons inside } +{ Based on TStyledToolbar and animations using Skia4Delphi } { } -{ Copyright (c) 2022-2024 (Ethea S.r.l.) } -{ Author: Carlo Barazzetta } -{ Contributors: } +{ Copyright (c) 2022-2024 (Ethea S.r.l.) } +{ Author: Carlo Barazzetta } +{ Contributors: } { } -{ https://github.com/EtheaDev/StyledComponents } +{ https://github.com/EtheaDev/StyledComponents } { } {******************************************************************************} { } @@ -266,7 +266,7 @@ procedure TStyledAnimatedToolButton.Click; procedure TStyledAnimatedToolButton.WMSetFocus(var Message: TMessage); begin - if AnimateOnFocused in FAutoAnimationTypes then + if AnimateOnFocus in FAutoAnimationTypes then AnimatedImage.StartAnimation; inherited; end; @@ -316,11 +316,13 @@ procedure TStyledAnimatedToolButton.StopAnimation; end; procedure TStyledAnimatedToolButton.Paint; +(* var LImageRect: TRect; LImageList: TCustomImageList; LImageIndex: Integer; LImageWidth, LImageHeight: Integer; +*) begin (* if Assigned(FSkAnimatedImage) then diff --git a/Ext/StyledComponents/source/Vcl.StyledButton.pas b/Ext/StyledComponents/source/Vcl.StyledButton.pas index 38f90bf..5de365f 100644 --- a/Ext/StyledComponents/source/Vcl.StyledButton.pas +++ b/Ext/StyledComponents/source/Vcl.StyledButton.pas @@ -1,13 +1,15 @@ {******************************************************************************} { } -{ TStyledGraphicButton: a Button Component based on TGraphicControl } -{ TStyledButton: a Button Component based on TCustomControl } +{ TStyledGraphicButton: a "styled" Button based on TGraphicControl } +{ TStyledButton: a "styled" Button Component similar to TButton } +{ TStyledSpeedButton: a "styled" Button Component similar to TSpeedButton } +{ TStyledBitBtn: a "styled" Button Component similar to TBitBtn } { } -{ Copyright (c) 2022-2024 (Ethea S.r.l.) } -{ Author: Carlo Barazzetta } -{ Contributors: } +{ Copyright (c) 2022-2024 (Ethea S.r.l.) } +{ Author: Carlo Barazzetta } +{ Contributors: } { } -{ https://github.com/EtheaDev/StyledComponents } +{ https://github.com/EtheaDev/StyledComponents } { } {******************************************************************************} { } @@ -47,14 +49,11 @@ interface , Vcl.ActnList , Vcl.Menus , Vcl.ButtonStylesAttributes + , Vcl.StandardButtonStyles ; const - StyledButtonsVersion = '2.1.0'; - DEFAULT_BTN_WIDTH = 75; - DEFAULT_BTN_HEIGHT = 25; - DEFAULT_IMAGE_HMARGIN = 8; - DEFAULT_IMAGE_VMARGIN = 4; + StyledButtonsVersion = '3.5.1'; resourcestring ERROR_SETTING_BUTTON_STYLE = 'Error setting Button Style: %s/%s/%s not available'; @@ -64,13 +63,15 @@ interface EStyledButtonError = Exception; TStyledButtonState = (bsmNormal, bsmPressed, bsmSelected, bsmHot, bsmDisabled); - TStyledButtonStyle = (bsPushButton, bsSplitButton); TStyledButtonRender = class; TStyledButtonRenderClass = class of TStyledButtonRender; + { TGraphicButtonActionLink } TGraphicButtonActionLink = class(TControlActionLink) strict private + function ClientRender: TStyledButtonRender; + function AssignedClientRender: Boolean; strict protected FClient: TControl; function IsEnabledLinked: Boolean; override; @@ -81,6 +82,8 @@ TGraphicButtonActionLink = class(TControlActionLink) procedure SetEnabled(Value: Boolean); override; procedure SetImageIndex(Value: Integer); override; procedure AssignClient(AClient: TObject); override; + procedure SetGroupIndex(Value: Integer); override; + procedure SetChecked(Value: Boolean); override; public function IsCheckedLinked: Boolean; override; function IsGlyphLinked(Index: TImageIndex): Boolean; virtual; @@ -94,6 +97,7 @@ TGraphicButtonActionLink = class(TControlActionLink) TSetParentFont = procedure (const AParentFont: Boolean) of Object; TGetParentFont = function: Boolean of Object; + { TStyledButtonRender } TStyledButtonRender = class(TObject) strict private FOwnerControl: TControl; @@ -105,18 +109,19 @@ TStyledButtonRender = class(TObject) FButtonStyleSelected: TStyledButtonAttributes; FButtonStyleHot: TStyledButtonAttributes; FButtonStyleDisabled: TStyledButtonAttributes; + FNotificationBadge: TNotificationBadgeAttributes; FModalResult: TModalResult; FMouseInControl: Boolean; FState: TButtonState; FImageMargins: TImageMargins; FStyleRadius: Integer; + FStyleRoundedCorners: TRoundedCorners; FStyleDrawType: TStyledButtonDrawType; FStyleFamily: TStyledButtonFamily; FStyleClass: TStyledButtonClass; FStyleAppearance: TStyledButtonAppearance; - FCustomDrawType: Boolean; FStyleApplied: Boolean; FDisabledImages: TCustomImageList; @@ -125,27 +130,32 @@ TStyledButtonRender = class(TObject) FDisabledImageIndex: TImageIndex; FHotImageIndex: TImageIndex; + FStylusHotImageIndex: TImageIndex; FPressedImageIndex: TImageIndex; FSelectedImageIndex: TImageIndex; {$IFDEF D10_4+} FDisabledImageName: TImageName; FHotImageName: TImageName; + FStylusHotImageName: TImageName; FPressedImageName: TImageName; FSelectedImageName: TImageName; {$ENDIF} - + FSpacing: Integer; + FMargin: Integer; FImageAlignment: TImageAlignment; + FButtonLayout: TButtonLayout; FTag: Integer; FWordWrap: Boolean; FActive: Boolean; FDefault: Boolean; FCancel: Boolean; FKind: TBitBtnKind; - FStyle: TStyledButtonStyle; + FStyle: TCustomButton.TButtonStyle; FDropDownMenu: TPopupMenu; FDropDownRect: TRect; FOnDropDownClick: TNotifyEvent; FMouseOverDropDown: Boolean; + FElevationRequired: Boolean; FOnClick: TNotifyEvent; FControlFont: TControlFont; FSetCaption: TSetCaption; @@ -159,9 +169,19 @@ TStyledButtonRender = class(TObject) FGlyph: TBitmap; FNumGlyphs: TNumGlyphs; FTransparentColor: TColor; + FTransparent: Boolean; FFlat: Boolean; + FCaptionAlignment: TAlignment; + FCommandLinkHint: string; + + FAllowAllUp: Boolean; + FGroupIndex: Integer; + FDown: Boolean; + FShowCaption: Boolean; + procedure SetImageMargins(const AValue: TImageMargins); procedure SetStyleRadius(const AValue: Integer); + procedure SetStyleRoundedCorners(const AValue: TRoundedCorners); procedure SetStyleFamily(const AValue: TStyledButtonFamily); procedure SetStyleClass(const AValue: TStyledButtonClass); procedure SetStyleAppearance(const AValue: TStyledButtonAppearance); @@ -172,6 +192,7 @@ TStyledButtonRender = class(TObject) procedure SetDisabledImageIndex(const AValue: TImageIndex); procedure SetHotImageIndex(const AValue: TImageIndex); + procedure SetStylusHotImageIndex(const AValue: TImageIndex); function GetImageIndex: TImageIndex; procedure SetImageIndex(const AValue: TImageIndex); procedure SetPressedImageIndex(const AValue: TImageIndex); @@ -182,6 +203,7 @@ TStyledButtonRender = class(TObject) procedure UpdateImageName(Index: TImageIndex; var Name: TImageName); procedure SetDisabledImageName(const AValue: TImageName); procedure SetHotImageName(const AValue: TImageName); + procedure SetStylusHotImageName(const AValue: TImageName); function GetImageName: TImageName; procedure SetImageName(const AValue: TImageName); procedure SetPressedImageName(const AValue: TImageName); @@ -191,34 +213,37 @@ TStyledButtonRender = class(TObject) function GetAttributes(const AMode: TStyledButtonState): TStyledButtonAttributes; procedure ImageMarginsChange(Sender: TObject); procedure SetImageAlignment(const AValue: TImageAlignment); + procedure DrawNotificationBadge( + const ACanvas: TCanvas; const ASurfaceRect: TRect); procedure DrawBackgroundAndBorder(const ACanvas: TCanvas; const AStyleAttribute: TStyledButtonAttributes; const AEraseBackground: Boolean); procedure DrawText(const ACanvas: TCanvas; - const AText: string; var ARect: TRect; AFlags: Cardinal); + const AText: string; const AAlignment: TAlignment; + const ASpacing: Integer; + var ARect: TRect; AFlags: Cardinal); function GetDrawingStyle(const ACanvas: TCanvas): TStyledButtonAttributes; procedure SetStyleDrawType(const AValue: TStyledButtonDrawType); procedure ImageListChange(Sender: TObject); - procedure SetText(const AValue: TCaption); procedure SetButtonStylePressed(const AValue: TStyledButtonAttributes); procedure SetButtonStyleSelected(const AValue: TStyledButtonAttributes); procedure SetButtonStyleHot(const AValue: TStyledButtonAttributes); procedure SetButtonStyleNormal(const AValue: TStyledButtonAttributes); procedure SetButtonStyleDisabled(const AValue: TStyledButtonAttributes); + procedure SetNotificationBadge(const AValue: TNotificationBadgeAttributes); - procedure UpdateControlStyle; procedure SetWordWrap(const AValue: Boolean); procedure SetStyleApplied(const AValue: Boolean); function GetKind: TBitBtnKind; - procedure SetKind(const Value: TBitBtnKind); - function BitBtnCaptions(Kind: TBitBtnKind): string; + procedure SetKind(const AValue: TBitBtnKind); function UpdateStyleUsingModalResult: boolean; - procedure SetDropDownMenu(const Value: TPopupMenu); - procedure SetStyle(const Value: TStyledButtonStyle); + procedure SetDropDownMenu(const AValue: TPopupMenu); + procedure SetStyle(const AValue: TCustomButton.TButtonStyle); function GetActiveStyleName: string; function AsVCLStyle: Boolean; - + function GetAsVCLComponent: Boolean; + procedure SetAsVCLComponent(const AValue: Boolean); //Owner Control access function GetAction: TCustomAction; procedure SetAction(const AAction: TCustomAction); @@ -232,7 +257,6 @@ TStyledButtonRender = class(TObject) function GetComponentState: TComponentState; function GetComponentHeight: Integer; function GetComponentWidth: Integer; - procedure Invalidate; function GetHint: string; function GetButtonState: TStyledButtonState; function GetHandle: HWND; @@ -242,10 +266,30 @@ TStyledButtonRender = class(TObject) function GetNumGlyphs: TNumGlyphs; procedure SetNumGlyphs(const AValue: TNumGlyphs); procedure SetFlat(const AValue: Boolean); - private procedure SetState(const AValue: TButtonState); function GetMouseInControl: Boolean; + function GetHasCustomAttributes: Boolean; + procedure SetHasCustomAttributes(const AValue: Boolean); + procedure SetLayout(const AValue: TButtonLayout); + procedure SetMargin(const AValue: Integer); + procedure SetSpacing(const AValue: Integer); + procedure SetTransparent(const AValue: Boolean); + procedure SetCaptionAlignment(const AValue: TAlignment); + procedure SetCommandLinkHint(const AValue: string); + procedure SetElevationRequired(const AValue: Boolean); + procedure SetAllowAllUp(const AValue: Boolean); + procedure SetDown(const AValue: Boolean); + procedure SetGroupIndex(const AValue: Integer); + procedure SetShowCaption(const AValue: Boolean); + procedure UpAllButtons; protected + FCustomDrawType: Boolean; + FUseButtonLayout: Boolean; + function BitBtnCaptions(Kind: TBitBtnKind): string; + procedure Invalidate; virtual; + function GetOwnerScaleFactor: Single; + function HasTransparentParts: Boolean; + function IsCaptionAlignmentStored: Boolean; function GetBackGroundColor: TColor; function IsDefaultImageMargins: Boolean; function UpdateCount: Integer; @@ -258,9 +302,11 @@ TStyledButtonRender = class(TObject) procedure CheckImageIndexes; {$ENDIF} function GetName: TComponentName; - function CalcImageRect(var ATextRect: TRect; + function CalcImageRect(const ASurfaceRect: TRect; const AImageWidth, AImageHeight: Integer): TRect; procedure InternalCopyImage(Image: TBitmap; ImageList: TCustomImageList; Index: Integer); + function GetInternalImage(out AImageList: TCustomImageList; + out AImageIndex: Integer): Boolean; public function GetImageSize(out AWidth, AHeight: Integer; out AImageList: TCustomImageList; out AImageIndex: Integer): Boolean; virtual; @@ -277,12 +323,12 @@ TStyledButtonRender = class(TObject) X, Y: Integer); procedure Loaded; procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); - procedure UpdateStyleElements; procedure EraseBackground(const ACanvas: TCanvas); procedure DrawButton(const ACanvas: TCanvas; const AEraseBackground: Boolean); - procedure DrawImage(const ACanvas: TCanvas; - var ATextRect: TRect); + procedure DrawCaptionAndImage(const ACanvas: TCanvas; + const ASurfaceRect: TRect); + procedure SetText(const AValue: TCaption); function GetText: TCaption; function CanDropDownMenu: boolean; //Windows messages @@ -294,7 +340,7 @@ TStyledButtonRender = class(TObject) procedure CMMouseLeave(var Message: TNotifyEvent); procedure CMEnabledChanged(var Message: TMessage); {$IFDEF HiDPISupport} - procedure ChangeScale(M, D: Integer; isDpiChange: Boolean); + procedure ChangeScale(M, D: Integer; isDpiChange: Boolean); virtual; {$ENDIF} procedure BeginUpdate; procedure EndUpdate; @@ -309,6 +355,7 @@ TStyledButtonRender = class(TObject) function IsStyleNormalStored: Boolean; function IsStyleDisabledStored: Boolean; function IsStylePressedStored: Boolean; + function IsNotificationBadgeStored: Boolean; procedure SetButtonStyle(const AStyleFamily: TStyledButtonFamily; const AStyleClass: TStyledButtonClass; const AStyleAppearance: TStyledButtonAppearance); overload; @@ -325,7 +372,16 @@ TStyledButtonRender = class(TObject) const AImageAlignment: TImageAlignment = iaLeft; const AAction: TCustomAction = nil; const AOnClick: TNotifyEvent = nil; - const AName: string = ''): TControl; + const AName: string = ''): TControl; overload; + function AssignAttributes( + const AEnabled: Boolean = True; + const AImageList: TCustomImageList = nil; + {$IFDEF D10_4+}const AImageName: string = '';{$ENDIF} + const AImageIndex: Integer = -1; + const AButtonLayout: TButtonLayout = blGlyphLeft; + const AAction: TCustomAction = nil; + const AOnClick: TNotifyEvent = nil; + const AName: string = ''): TControl; overload; procedure Click(AKeyPressed: Boolean); procedure DoDropDownMenu; @@ -343,7 +399,10 @@ TStyledButtonRender = class(TObject) const ASetParentFont: TSetParentFont; const AFamily: TStyledButtonFamily; const AClass: TStyledButtonClass; - const AAppearance: TStyledButtonAppearance); + const AAppearance: TStyledButtonAppearance; + const ADrawType: TStyledButtonDrawType; + const ACursor: TCursor; + const AUseCustomDrawType: Boolean); virtual; constructor Create(AOwner: TControl; const AOnClick: TNotifyEvent; const AControlFont: TControlFont; @@ -353,12 +412,17 @@ TStyledButtonRender = class(TObject) const ASetParentFont: TSetParentFont); destructor Destroy; override; function IsDefaultAppearance: Boolean; + property AsVCLComponent: Boolean read GetAsVCLComponent write SetAsVCLComponent; property Active: Boolean read FActive write FActive; property Focused: Boolean read GetFocused; property ButtonState: TStyledButtonState read GetButtonState; property StyleApplied: Boolean read FStyleApplied write SetStyleApplied; property Caption: TCaption read GetText write SetText; + property CaptionAlignment: TAlignment read FCaptionAlignment write SetCaptionAlignment; + property ShowCaption: Boolean read FShowCaption write SetShowCaption default True; + property CommandLinkHint: string read FCommandLinkHint write SetCommandLinkHint; property Default: Boolean read FDefault write FDefault; + property ElevationRequired: Boolean read FElevationRequired write SetElevationRequired; property Cancel: Boolean read FCancel write FCancel; property ActiveStyleName: string read GetActiveStyleName; property ImageAlignment: TImageAlignment read FImageAlignment write SetImageAlignment; @@ -368,6 +432,7 @@ TStyledButtonRender = class(TObject) property Flat: Boolean read FFlat write SetFlat; property SplitButtonWidth: Integer read GetSplitButtonWidth; property HotImageIndex: TImageIndex read FHotImageIndex write SetHotImageIndex; + property StylusHotImageIndex: TImageIndex read FStylusHotImageIndex write SetStylusHotImageIndex; property Glyph: TBitmap read GetGlyph write SetGlyph; property NumGlyphs: TNumGlyphs read GetNumGlyphs write SetNumGlyphs; property Images: TCustomImageList read FImages write SetImages; @@ -376,10 +441,11 @@ TStyledButtonRender = class(TObject) property OwnerControl: TControl read FOwnerControl; property PressedImageIndex: TImageIndex read FPressedImageIndex write SetPressedImageIndex; property SelectedImageIndex: TImageIndex read FSelectedImageIndex write SetSelectedImageIndex; - + property Transparent: Boolean read FTransparent write SetTransparent; {$IFDEF D10_4+} property DisabledImageName: TImageName read FDisabledImageName write SetDisabledImageName; property HotImageName: TImageName read FHotImageName write SetHotImageName; + property StylusHotImageName: TImageName read FStylusHotImageName write SetStylusHotImageName; property ImageName: TImageName read GetImageName write SetImageName; property PressedImageName: TImageName read FPressedImageName write SetPressedImageName; property SelectedImageName: TImageName read FSelectedImageName write SetSelectedImageName; @@ -387,11 +453,23 @@ TStyledButtonRender = class(TObject) property ImageMargins: TImageMargins read FImageMargins write SetImageMargins; property ModalResult: TModalResult read FModalResult write SetModalResult; property RescalingButton: Boolean read GetRescalingButton write SetRescalingButton; + + //Properties used when UseButtonLayout is true + property Layout: TButtonLayout read FButtonLayout write SetLayout; + property Margin: Integer read FMargin write SetMargin default -1; + property Spacing: Integer read FSpacing write SetSpacing default 4; + + //Property used by TStyledButton, TStyledGraphicButton and TStyledSpeedButton + property AllowAllUp: Boolean read FAllowAllUp write SetAllowAllUp; + property GroupIndex: Integer read FGroupIndex write SetGroupIndex; + property Down: Boolean read FDown write SetDown; + //Style as TButton - property Style: TStyledButtonStyle read FStyle write SetStyle; + property Style: TCustomButton.TButtonStyle read FStyle write SetStyle; //StyledComponents Attributes property StyleRadius: Integer read FStyleRadius write SetStyleRadius; + property StyleRoundedCorners: TRoundedCorners read FStyleRoundedCorners write SetStyleRoundedCorners default ALL_ROUNDED_CORNERS; property StyleDrawType: TStyledButtonDrawType read FStyleDrawType write SetStyleDrawType; property StyleFamily: TStyledButtonFamily read FStyleFamily write SetStyleFamily; property StyleClass: TStyledButtonClass read FStyleClass write SetStyleClass; @@ -405,6 +483,7 @@ TStyledButtonRender = class(TObject) property ButtonStyleSelected: TStyledButtonAttributes read FButtonStyleSelected write SetButtonStyleSelected; property ButtonStyleHot: TStyledButtonAttributes read FButtonStyleHot write SetButtonStyleHot; property ButtonStyleDisabled: TStyledButtonAttributes read FButtonStyleDisabled write SetButtonStyleDisabled; + property NotificationBadge: TNotificationBadgeAttributes read FNotificationBadge write SetNotificationBadge; property OnDropDownClick: TNotifyEvent read FOnDropDownClick write FOnDropDownClick; @@ -424,23 +503,38 @@ TStyledButtonRender = class(TObject) property Height: Integer read GetComponentHeight; property Width: Integer read GetComponentWidth; property Hint: string read GetHint; + //Owner Control must assign those event-handlers property OnClick: TNotifyEvent read FOnClick write FOnClick; property ControlFont: TControlFont read FControlFont write FControlFont; public procedure SetCustomStyleDrawType(ACustomStyleDrawType: Boolean); + property HasCustomAttributes: Boolean read GetHasCustomAttributes write SetHasCustomAttributes default False; end; - TStyledGraphicButton = class; - TStyledButton = class; + TCustomStyledGraphicButton = class; + TCustomStyledButton = class; + TStyledSpeedButton = class; + TStyledBitBtn = class; - TStyledGraphicButton = class(TGraphicControl) + { TCustomStyledGraphicButton } + TCustomStyledGraphicButton = class(TGraphicControl) private FRender: TStyledButtonRender; FImageIndex: TImageIndex; {$IFDEF D10_4+} FImageName: TImageName; {$ENDIF} + + class var + _DefaultStyleDrawType: TStyledButtonDrawType; + _UseCustomDrawType: Boolean; + _DefaultFamily: TStyledButtonFamily; + _DefaultClass: TStyledButtonClass; + _DefaultAppearance: TStyledButtonAppearance; + _DefaultStyleRadius: Integer; + _DefaultCursor: TCursor; + //Event Handlers passed to Render procedure ControlFont(var AValue: TFont); procedure ControlClick(Sender: TObject); @@ -451,6 +545,8 @@ TStyledGraphicButton = class(TGraphicControl) function IsCustomRadius: Boolean; function GetStyleRadius: Integer; procedure SetStyleRadius(const AValue: Integer); + function GetStyleRoundedCorners: TRoundedCorners; + procedure SetStyleRoundedCorners(const AValue: TRoundedCorners); function ImageMarginsStored: Boolean; function IsStoredStyleFamily: Boolean; function IsStoredStyleAppearance: Boolean; @@ -511,6 +607,7 @@ TStyledGraphicButton = class(TGraphicControl) function IsStyleNormalStored: Boolean; function IsStyleDisabledStored: Boolean; function IsStylePressedStored: Boolean; + function IsNotificationBadgeStored: Boolean; function IsImageIndexStored: Boolean; {$IFDEF D10_4+} function IsImageNameStored: Boolean; @@ -523,9 +620,8 @@ TStyledGraphicButton = class(TGraphicControl) procedure SetKind(const AValue: TBitBtnKind); function GetDropDownMenu: TPopupMenu; procedure SetDropDownMenu(const AValue: TPopupMenu); - function GetStyle: TStyledButtonStyle; - procedure SetStyle(const AValue: TStyledButtonStyle); - //function GetActiveStyleName: string; + function GetStyle: TCustomButton.TButtonStyle; + procedure SetStyle(const AValue: TCustomButton.TButtonStyle); function GetFocused: Boolean; //Windows messages procedure CMStyleChanged(var Message: TMessage); message CM_STYLECHANGED; @@ -548,9 +644,37 @@ TStyledGraphicButton = class(TGraphicControl) procedure SetNumGlyphs(const AValue: TNumGlyphs); function GetMouseInControl: Boolean; function GetCursor: TCursor; + function GetTransparent: Boolean; + procedure SetTransparent(const AValue: Boolean); + function GetCaptionAlignment: TAlignment; + procedure SetCaptionAlignment(const AValue: TAlignment); + function GetCommandLinkHint: string; + procedure SetCommandLinkHint(const AValue: string); + function IsCaptionAlignmentStored: Boolean; + function GetSpacing: Integer; + procedure SetSpacing(const AValue: Integer); + function GetLayout: TButtonLayout; + procedure SetLayout(const AValue: TButtonLayout); + function GetMargin: Integer; + procedure SetMargin(const AValue: Integer); + function GetAllowAllUp: Boolean; + function GetDown: Boolean; + function GetGroupIndex: Integer; + procedure SetAllowAllUp(const AValue: Boolean); + procedure SetDown(const AValue: Boolean); + procedure SetGroupIndex(const AValue: Integer); + function IsCheckedStored: Boolean; + function GetAsVCLComponent: Boolean; + procedure SetAsVCLComponent(const AValue: Boolean); + function GetActiveStyleName: string; + function GetNotificationBadge: TNotificationBadgeAttributes; + procedure SetNotificationBadge(const AValue: TNotificationBadgeAttributes); + function GetShowCaption: Boolean; + procedure SetShowCaption(const AValue: Boolean); protected procedure SetCursor(const AValue: TCursor); virtual; - function GetCaption: TCaption; virtual; + function GetCaption: TCaption; + function GetCaptionToDraw: TCaption; virtual; procedure SetCaption(const AValue: TCaption); virtual; function GetButtonState: TStyledButtonState; virtual; function GetImage(out AImageList: TCustomImageList; @@ -573,9 +697,18 @@ TStyledGraphicButton = class(TGraphicControl) X, Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; - procedure UpdateStyleElements; override; + {$IFDEF D10_4+} + procedure SetStyleName(const AValue: string); override; + {$ENDIF} function GetRenderClass: TStyledButtonRenderClass; virtual; public + class procedure RegisterDefaultRenderingStyle( + const ADrawType: TStyledButtonDrawType; + const AFamily: TStyledButtonFamily = DEFAULT_CLASSIC_FAMILY; + const AClass: TStyledButtonClass = DEFAULT_WINDOWS_CLASS; + const AAppearance: TStyledButtonAppearance = DEFAULT_APPEARANCE; + const AStyleRadius: Integer = DEFAULT_RADIUS; + const ACursor: TCursor = DEFAULT_CURSOR); virtual; function GetRescalingButton: Boolean; procedure SetRescalingButton(const AValue: Boolean); function GetSplitButtonWidth: Integer; @@ -588,7 +721,7 @@ TStyledGraphicButton = class(TGraphicControl) procedure SetButtonStyle(const AStyleFamily: TStyledButtonFamily; const AModalResult: TModalResult); overload; procedure AssignStyleTo(ADestRender: TStyledButtonRender); overload; - procedure AssignStyleTo(ADest: TStyledGraphicButton); overload; + procedure AssignStyleTo(ADest: TCustomStyledGraphicButton); overload; procedure AssignTo(ADest: TPersistent); override; function AssignAttributes( const AEnabled: Boolean = True; @@ -598,59 +731,41 @@ TStyledGraphicButton = class(TGraphicControl) const AImageAlignment: TImageAlignment = iaLeft; const AAction: TCustomAction = nil; const AOnClick: TNotifyEvent = nil; - const AName: string = ''): TStyledGraphicButton; + const AName: string = ''): TCustomStyledGraphicButton; procedure Click; override; procedure DoDropDownMenu; constructor CreateStyled(AOwner: TComponent; const AFamily: TStyledButtonFamily; const AClass: TStyledButtonClass; - const AAppearance: TStyledButtonAppearance); virtual; + const AAppearance: TStyledButtonAppearance); overload; virtual; + constructor CreateStyled(AOwner: TComponent; + const AFamily: TStyledButtonFamily; + const AClass: TStyledButtonClass; + const AAppearance: TStyledButtonAppearance; + const ADrawType: TStyledButtonDrawType; + const ACursor: TCursor; + const AUseCustomDrawType: Boolean); overload; virtual; constructor Create(AOwner: TComponent); override; destructor Destroy; override; + property ActiveStyleName: string read GetActiveStyleName; + property AsVCLComponent: Boolean read GetAsVCLComponent write SetAsVCLComponent; property Focused: Boolean read GetFocused; property ButtonState: TStyledButtonState read GetButtonState; property MouseInControl: Boolean read GetMouseInControl; property Render: TStyledButtonRender read FRender; property StyleApplied: Boolean read GetStyleApplied write SetStyleApplied; property RescalingButton: Boolean read GetRescalingButton write SetRescalingButton; - published - //property ActiveStyleName: string read GetActiveStyleName write FActiveStyleName stored false; - property Action; - property Align; - property Anchors; - property Constraints; - property DragCursor; - property DragKind; - property DragMode; property Enabled stored IsEnabledStored; - property Font; - property OnContextPopup; - property OnDragDrop; - property OnDragOver; - property OnEndDock; - property OnEndDrag; - property OnMouseActivate; - property OnMouseDown; - property OnMouseEnter; - property OnMouseLeave; - property OnMouseMove; - property OnMouseUp; - property OnGesture; - property OnStartDock; - property OnStartDrag; - property OnClick; - property PopUpMenu; property ParentFont default true; - property ParentShowHint; - property ShowHint; - {$IFDEF D10_4+} - property StyleName; - {$ENDIF} + property Layout: TButtonLayout read GetLayout write SetLayout default blGlyphLeft; + property Margin: Integer read GetMargin write SetMargin default -1; + property Spacing: Integer read GetSpacing write SetSpacing default 4; property StyleElements stored IsStoredStyleElements; - property Touch; - property Visible; property Caption: TCaption read GetText write SetText stored IsCaptionStored; - property Cursor: TCursor read GetCursor write SetCursor default crHandPoint; + property CaptionAlignment: TAlignment read GetCaptionAlignment write SetCaptionAlignment Stored IsCaptionAlignmentStored; + property ShowCaption: Boolean read GetShowCaption write SetShowCaption default True; + property CommandLinkHint: string read GetCommandLinkHint write SetCommandLinkHint; + property Cursor: TCursor read GetCursor write SetCursor default DEFAULT_CURSOR; property ImageAlignment: TImageAlignment read GetImageAlignment write SetImageAlignment default iaLeft; property DisabledImageIndex: TImageIndex read GetDisabledImageIndex write SetDisabledImageIndex default -1; property DisabledImages: TCustomImageList read GetDisabledImages write SetDisabledImages; @@ -673,33 +788,218 @@ TStyledGraphicButton = class(TGraphicControl) {$ENDIF} property ImageMargins: TImageMargins read GetImageMargins write SetImageMargins stored ImageMarginsStored; property ModalResult: TModalResult read GetModalResult write SetModalResult default mrNone; - //Style as TButton - property Style: TStyledButtonStyle read GetStyle write SetStyle default bsPushButton; + //Style as TSpeedButton + property Style: TCustomButton.TButtonStyle read GetStyle write SetStyle default TCustomButton.TButtonStyle.bsPushButton; + //Property used by TStyledButton, TStyledGraphicButton and TStyledSpeedButton + property AllowAllUp: Boolean read GetAllowAllUp write SetAllowAllUp default False; + property GroupIndex: Integer read GetGroupIndex write SetGroupIndex default 0; + property Down: Boolean read GetDown write SetDown stored IsCheckedStored default False; //StyledComponents Attributes property StyleRadius: Integer read GetStyleRadius write SetStyleRadius stored IsCustomRadius default DEFAULT_RADIUS; + property StyleRoundedCorners: TRoundedCorners read GetStyleRoundedCorners write SetStyleRoundedCorners default ALL_ROUNDED_CORNERS; property StyleDrawType: TStyledButtonDrawType read GetStyleDrawType write SetStyleDrawType stored IsCustomDrawType; property StyleFamily: TStyledButtonFamily read GetStyleFamily write SetStyleFamily stored IsStoredStyleFamily; property StyleClass: TStyledButtonClass read GetStyleClass write SetStyleClass stored IsStoredStyleClass; property StyleAppearance: TStyledButtonAppearance read GetStyleAppearance write SetStyleAppearance stored IsStoredStyleAppearance; property Tag: Integer read GetTag write SetTag default 0; + property Transparent: Boolean read GetTransparent write SetTransparent default False; property WordWrap: Boolean read GetWordWrap write SetWordWrap default False; property ButtonStyleNormal: TStyledButtonAttributes read GetButtonStyleNormal write SetButtonStyleNormal stored IsStyleNormalStored; property ButtonStylePressed: TStyledButtonAttributes read GetButtonStylePressed write SetButtonStylePressed stored IsStylePressedStored; property ButtonStyleSelected: TStyledButtonAttributes read GetButtonStyleSelected write SetButtonStyleSelected stored IsStyleSelectedStored; property ButtonStyleHot: TStyledButtonAttributes read GetButtonStyleHot write SetButtonStyleHot stored IsStyleHotStored; property ButtonStyleDisabled: TStyledButtonAttributes read GetButtonStyleDisabled write SetButtonStyleDisabled stored IsStyleDisabledStored; + property NotificationBadge: TNotificationBadgeAttributes read GetNotificationBadge write SetNotificationBadge stored IsNotificationBadgeStored; property OnDropDownClick: TNotifyEvent read GetOnDropDownClick write SetOnDropDownClick; end; - TStyledButton = class(TCustomControl) + { TStyledGraphicButton } + [ComponentPlatforms(pidWin32 or pidWin64)] + TStyledGraphicButton = class(TCustomStyledGraphicButton) + published + property ActiveStyleName; + property Action; + property Align; + property AllowAllUp; + property Anchors; + property AsVCLComponent stored False; + property Constraints; + property Cursor default DEFAULT_CURSOR; + property GroupIndex; + property Down; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property Font; + property NotificationBadge; + property OnContextPopup; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnMouseActivate; + property OnMouseDown; + property OnMouseEnter; + property OnMouseLeave; + property OnMouseMove; + property OnMouseUp; + property OnGesture; + property OnStartDock; + property OnStartDrag; + property OnClick; + property PopUpMenu; + property ParentFont; + property ParentShowHint; + property ShowHint; + {$IFDEF D10_4+} + property StyleName; + {$ENDIF} + property StyleElements; + property Transparent; + property Visible; + property Caption; + property CaptionAlignment; + property ShowCaption; + property CommandLinkHint; + property ImageAlignment; + property DisabledImageIndex; + property DisabledImages; + property DropDownMenu; + property Flat; + property Glyph; + property NumGlyphs; + property HotImageIndex; + property Images; + property ImageIndex; + property Kind; + property PressedImageIndex; + property SelectedImageIndex; + {$IFDEF D10_4+} + property DisabledImageName; + property HotImageName; + property ImageName; + property PressedImageName; + property SelectedImageName; + {$ENDIF} + property ImageMargins; + property ModalResult; + property Style; + property Tag; + //StyledComponents Attributes + property StyleRadius; + property StyleRoundedCorners; + property StyleDrawType; + property StyleFamily; + property StyleClass; + property StyleAppearance; + property WordWrap; + property ButtonStyleNormal; + property ButtonStylePressed; + property ButtonStyleSelected; + property ButtonStyleHot; + property ButtonStyleDisabled; + property OnDropDownClick; + end; + + { TStyledSpeedButton } + [ComponentPlatforms(pidWin32 or pidWin64)] + TStyledSpeedButton = class(TCustomStyledGraphicButton) + public + constructor Create(AOwner: TComponent); override; + published + property Action; + property Align; + property AllowAllUp; + property Anchors; + property AsVCLComponent stored False; + property BiDiMode; + property Constraints; + property Cursor default DEFAULT_CURSOR; + property GroupIndex; + property Down; + property DisabledImageIndex; + {$IFDEF D10_4+} + property DisabledImageName; + {$ENDIF} + property Caption; + property ShowCaption; + property Enabled; + {$IFDEF D10_4+} + property HotImageIndex; + property HotImageName; + property ImageIndex; + property ImageName; + property Images; + {$ENDIF} + property Flat; + property Font; + property Glyph; + property Layout; + property Margin; + property NotificationBadge; + property NumGlyphs; + property ParentFont; + property ParentShowHint; + property ParentBiDiMode; + property PopupMenu; + property PressedImageIndex; + {$IFDEF D10_4+} + property PressedImageName; + {$ENDIF} + property ShowHint; + property SelectedImageIndex; + {$IFDEF D10_4+} + property SelectedImageName; + {$ENDIF} + property Spacing; + property Transparent default True; + property Visible; + property StyleElements; + {$IFDEF D10_4+} + property StyleName; + {$ENDIF} + property OnClick; + property OnDblClick; + property OnMouseActivate; + property OnMouseDown; + property OnMouseEnter; + property OnMouseLeave; + property OnMouseMove; + property OnMouseUp; + //StyledComponents Attributes + property StyleRadius; + property StyleRoundedCorners; + property StyleDrawType; + property StyleFamily; + property StyleClass; + property StyleAppearance; + property ButtonStyleNormal; + property ButtonStylePressed; + property ButtonStyleSelected; + property ButtonStyleHot; + property ButtonStyleDisabled; + end; + + { TCustomStyledButton } + TCustomStyledButton = class(TCustomControl) private + FPaintBuffer: TBitmap; + FPaintBufferUsers: Integer; FRender: TStyledButtonRender; FImageIndex: TImageIndex; - FHandled: Boolean; {$IFDEF D10_4+} FImageName: TImageName; {$ENDIF} - //function StyleServicesEnabled: Boolean; + class var + _DefaultStyleDrawType: TStyledButtonDrawType; + _UseCustomDrawType: Boolean; + _DefaultFamily: TStyledButtonFamily; + _DefaultClass: TStyledButtonClass; + _DefaultAppearance: TStyledButtonAppearance; + _DefaultStyleRadius: Integer; + _DefaultCursor: TCursor; + //Event Handlers passed to Render procedure ControlFont(var AValue: TFont); procedure ControlClick(Sender: TObject); @@ -710,6 +1010,8 @@ TStyledButton = class(TCustomControl) function IsCustomRadius: Boolean; function GetStyleRadius: Integer; procedure SetStyleRadius(const AValue: Integer); + function GetStyleRoundedCorners: TRoundedCorners; + procedure SetStyleRoundedCorners(const AValue: TRoundedCorners); function ImageMarginsStored: Boolean; function IsStoredStyleFamily: Boolean; function IsStoredStyleAppearance: Boolean; @@ -730,6 +1032,8 @@ TStyledButton = class(TCustomControl) procedure SetDisabledImageIndex(const AValue: TImageIndex); function GetHotImageIndex: TImageIndex; procedure SetHotImageIndex(const AValue: TImageIndex); + function GetStylusHotImageIndex: TImageIndex; + procedure SetStylusHotImageIndex(const AValue: TImageIndex); procedure SetImageIndex(const AValue: TImageIndex); function GetPressedImageIndex: TImageIndex; procedure SetPressedImageIndex(const AValue: TImageIndex); @@ -740,6 +1044,8 @@ TStyledButton = class(TCustomControl) procedure SetDisabledImageName(const AValue: TImageName); function GetHotImageName: TImageName; procedure SetHotImageName(const AValue: TImageName); + function GetStylusHotImageName: TImageName; + procedure SetStylusHotImageName(const AValue: TImageName); function GetImageName: TImageName; procedure SetImageName(const AValue: TImageName); function GetPressedImageName: TImageName; @@ -770,6 +1076,7 @@ TStyledButton = class(TCustomControl) function IsStyleNormalStored: Boolean; function IsStyleDisabledStored: Boolean; function IsStylePressedStored: Boolean; + function IsNotificationBadgeStored: Boolean; function IsImageIndexStored: Boolean; {$IFDEF D10_4+} function IsImageNameStored: Boolean; @@ -786,10 +1093,9 @@ TStyledButton = class(TCustomControl) procedure SetKind(const AValue: TBitBtnKind); function GetDropDownMenu: TPopupMenu; procedure SetDropDownMenu(const AValue: TPopupMenu); - function GetStyle: TStyledButtonStyle; - procedure SetStyle(const AValue: TStyledButtonStyle); + function GetStyle: TCustomButton.TButtonStyle; + procedure SetStyle(const AValue: TCustomButton.TButtonStyle); function CanDropDownMenu: boolean; - //function GetActiveStyleName: string; //Windows messages procedure CMStyleChanged(var Message: TMessage); message CM_STYLECHANGED; procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; @@ -822,11 +1128,39 @@ TStyledButton = class(TCustomControl) procedure SetNumGlyphs(const AValue: TNumGlyphs); function GetMouseInControl: Boolean; function GetCursor: TCursor; + function GetCaptionAlignment: TAlignment; + procedure SetCaptionAlignment(const AValue: TAlignment); + function GetCommandLinkHint: string; + procedure SetCommandLinkHint(const AValue: string); + function GetSpacing: Integer; + procedure SetSpacing(const AValue: Integer); + function GetLayout: TButtonLayout; + procedure SetLayout(const AValue: TButtonLayout); + function GetMargin: Integer; + procedure SetMargin(const AValue: Integer); + function IsCaptionAlignmentStored: Boolean; + function GetElevationRequired: Boolean; + procedure SetElevationRequired(const AValue: Boolean); + function GetAsVCLComponent: Boolean; + procedure SetAsVCLComponent(const AValue: Boolean); + function GetActiveStyleName: string; + function GetNotificationBadge: TNotificationBadgeAttributes; + procedure SetNotificationBadge(const AValue: TNotificationBadgeAttributes); + function GetShowCaption: Boolean; + procedure SetShowCaption(const AValue: Boolean); + function GetAllowAllUp: Boolean; + function GetDown: Boolean; + function GetGroupIndex: Integer; + function IsCheckedStored: Boolean; + procedure SetAllowAllUp(const AValue: Boolean); + procedure SetDown(const AValue: Boolean); + procedure SetGroupIndex(const AValue: Integer); protected procedure SetCursor(const AValue: TCursor); virtual; function CalcImageRect(var ATextRect: TRect; const AImageWidth, AImageHeight: Integer): TRect; virtual; - function GetCaption: TCaption; virtual; + function GetCaption: TCaption; + function GetCaptionToDraw: TCaption; virtual; procedure SetCaption(const AValue: TCaption); virtual; function GetButtonState: TStyledButtonState; virtual; function GetImage(out AImageList: TCustomImageList; @@ -839,7 +1173,6 @@ TStyledButton = class(TCustomControl) function GetActionLinkClass: TControlActionLinkClass; override; procedure SetName(const AValue: TComponentName); override; procedure Loaded; override; - //procedure Paint; overload; override; {$IFDEF HiDPISupport} procedure ChangeScale(M, D: Integer; isDpiChange: Boolean); override; {$ENDIF} @@ -849,11 +1182,20 @@ TStyledButton = class(TCustomControl) X, Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; - procedure UpdateStyleElements; override; + {$IFDEF D10_4+} + procedure SetStyleName(const AValue: string); override; + {$ENDIF} //for StyledButton procedure CreateWnd; override; function GetRenderClass: TStyledButtonRenderClass; virtual; public + class procedure RegisterDefaultRenderingStyle( + const ADrawType: TStyledButtonDrawType; + const AFamily: TStyledButtonFamily = DEFAULT_CLASSIC_FAMILY; + const AClass: TStyledButtonClass = DEFAULT_WINDOWS_CLASS; + const AAppearance: TStyledButtonAppearance = DEFAULT_APPEARANCE; + const AStyleRadius: Integer = DEFAULT_RADIUS; + const ACursor: TCursor = DEFAULT_CURSOR); virtual; function GetRescalingButton: Boolean; procedure SetRescalingButton(const AValue: Boolean); function GetSplitButtonWidth: Integer; @@ -866,7 +1208,7 @@ TStyledButton = class(TCustomControl) procedure SetButtonStyle(const AStyleFamily: TStyledButtonFamily; const AModalResult: TModalResult); overload; procedure AssignStyleTo(ADestRender: TStyledButtonRender); overload; - procedure AssignStyleTo(ADest: TStyledButton); overload; + procedure AssignStyleTo(ADest: TCustomStyledButton); overload; procedure AssignTo(ADest: TPersistent); override; function AssignAttributes( const AEnabled: Boolean = True; @@ -876,73 +1218,57 @@ TStyledButton = class(TCustomControl) const AImageAlignment: TImageAlignment = iaLeft; const AAction: TCustomAction = nil; const AOnClick: TNotifyEvent = nil; - const AName: string = ''): TStyledButton; + const AName: string = ''): TCustomStyledButton; procedure DoDropDownMenu; constructor CreateStyled(AOwner: TComponent; const AFamily: TStyledButtonFamily; const AClass: TStyledButtonClass; - const AAppearance: TStyledButtonAppearance); virtual; + const AAppearance: TStyledButtonAppearance); overload; virtual; + constructor CreateStyled(AOwner: TComponent; + const AFamily: TStyledButtonFamily; + const AClass: TStyledButtonClass; + const AAppearance: TStyledButtonAppearance; + const ADrawType: TStyledButtonDrawType; + const ACursor: TCursor; + const AUseCustomDrawType: Boolean); overload; virtual; constructor Create(AOwner: TComponent); override; destructor Destroy; override; + + property ActiveStyleName: string read GetActiveStyleName; + property AsVCLComponent: Boolean read GetAsVCLComponent write SetAsVCLComponent; property ButtonState: TStyledButtonState read GetButtonState; property MouseInControl: Boolean read GetMouseInControl; property StyleApplied: Boolean read GetStyleApplied write SetStyleApplied; //For StyledButton + procedure ReleasePaintBuffer; procedure Click; override; property Render: TStyledButtonRender read FRender; property RescalingButton: Boolean read GetRescalingButton write SetRescalingButton; - published - //property ActiveStyleName: string read GetActiveStyleName write FActiveStyleName stored false; - property Action; - property Align; - property Anchors; - property Constraints; property DoubleBuffered default True; - property DragCursor; - property DragKind; - property DragMode; property Enabled stored IsEnabledStored; - property Font; - property OnContextPopup; - property OnDragDrop; - property OnDragOver; - property OnEndDock; - property OnEndDrag; - property OnEnter; - property OnExit; - property OnMouseActivate; - property OnMouseDown; - property OnMouseEnter; - property OnMouseLeave; - property OnMouseMove; - property OnMouseUp; - property OnGesture; - property OnStartDock; - property OnStartDrag; - property OnClick; - property PopUpMenu; property ParentFont default true; - property ParentShowHint; - property ShowHint; - {$IFDEF D10_4+} - property StyleName; - {$ENDIF} + property Layout: TButtonLayout read GetLayout write SetLayout default blGlyphLeft; + property Margin: Integer read GetMargin write SetMargin default -1; + property Spacing: Integer read GetSpacing write SetSpacing default 4; property StyleElements stored IsStoredStyleElements; property TabStop default True; - property Touch; - property Visible; property Caption: TCaption read GetText write SetText stored IsCaptionStored; - property Cursor: TCursor read GetCursor write SetCursor default crHandPoint; + property CaptionAlignment: TAlignment read GetCaptionAlignment write SetCaptionAlignment Stored IsCaptionAlignmentStored; + property ShowCaption: Boolean read GetShowCaption write SetShowCaption default True; + property CommandLinkHint: string read GetCommandLinkHint write SetCommandLinkHint; + property Cursor: TCursor read GetCursor write SetCursor default DEFAULT_CURSOR; property Default: Boolean read GetDefault write SetDefault default False; property Cancel: Boolean read GetCancel write SetCancel default False; property ImageAlignment: TImageAlignment read GetImageAlignment write SetImageAlignment default iaLeft; property DisabledImageIndex: TImageIndex read GetDisabledImageIndex write SetDisabledImageIndex default -1; property DisabledImages: TCustomImageList read GetDisabledImages write SetDisabledImages; property DropDownMenu: TPopupMenu read GetDropDownMenu write SetDropDownMenu; + property ElevationRequired: Boolean read GetElevationRequired write SetElevationRequired default False; property Flat: Boolean read GetFlat write SetFlat default False; property Glyph: TBitmap read GetGlyph write SetGlyph stored HasCustomGlyph; property NumGlyphs: TNumGlyphs read GetNumGlyphs write SetNumGlyphs default 1; property HotImageIndex: TImageIndex read GetHotImageIndex write SetHotImageIndex default -1; + property StylusHotImageIndex: TImageIndex read GetStylusHotImageIndex write SetStylusHotImageIndex default -1; property Images: TCustomImageList read GetImages write SetImages; property ImageIndex: TImageIndex read FImageIndex write SetImageIndex stored IsImageIndexStored; property Kind: TBitBtnKind read GetKind write SetKind default bkCustom; @@ -951,6 +1277,7 @@ TStyledButton = class(TCustomControl) {$IFDEF D10_4+} property DisabledImageName: TImageName read GetDisabledImageName write SetDisabledImageName; property HotImageName: TImageName read GetHotImageName write SetHotImageName; + property StylusHotImageName: TImageName read GetStylusHotImageName write SetStylusHotImageName; property ImageName: TImageName read GetImageName write SetImageName stored IsImageNameStored; property PressedImageName: TImageName read GetPressedImageName write SetPressedImageName; property SelectedImageName: TImageName read GetSelectedImageName write SetSelectedImageName; @@ -958,9 +1285,14 @@ TStyledButton = class(TCustomControl) property ImageMargins: TImageMargins read GetImageMargins write SetImageMargins stored ImageMarginsStored; property ModalResult: TModalResult read GetModalResult write SetModalResult default mrNone; //Style as TButton - property Style: TStyledButtonStyle read GetStyle write SetStyle default bsPushButton; + property Style: TCustomButton.TButtonStyle read GetStyle write SetStyle default TCustomButton.TButtonStyle.bsPushButton; + //Property used by TStyledButton, TStyledGraphicButton and TStyledSpeedButton + property AllowAllUp: Boolean read GetAllowAllUp write SetAllowAllUp default False; + property GroupIndex: Integer read GetGroupIndex write SetGroupIndex default 0; + property Down: Boolean read GetDown write SetDown stored IsCheckedStored default False; //StyledComponents Attributes property StyleRadius: Integer read GetStyleRadius write SetStyleRadius stored IsCustomRadius default DEFAULT_RADIUS; + property StyleRoundedCorners: TRoundedCorners read GetStyleRoundedCorners write SetStyleRoundedCorners default ALL_ROUNDED_CORNERS; property StyleDrawType: TStyledButtonDrawType read GetStyleDrawType write SetStyleDrawType stored IsCustomDrawType; property StyleFamily: TStyledButtonFamily read GetStyleFamily write SetStyleFamily stored IsStoredStyleFamily; property StyleClass: TStyledButtonClass read GetStyleClass write SetStyleClass stored IsStoredStyleClass; @@ -972,6 +1304,7 @@ TStyledButton = class(TCustomControl) property ButtonStyleSelected: TStyledButtonAttributes read GetButtonStyleSelected write SetButtonStyleSelected stored IsStyleSelectedStored; property ButtonStyleHot: TStyledButtonAttributes read GetButtonStyleHot write SetButtonStyleHot stored IsStyleHotStored; property ButtonStyleDisabled: TStyledButtonAttributes read GetButtonStyleDisabled write SetButtonStyleDisabled stored IsStyleDisabledStored; + property NotificationBadge: TNotificationBadgeAttributes read GetNotificationBadge write SetNotificationBadge stored IsNotificationBadgeStored; property OnDropDownClick: TNotifyEvent read GetOnDropDownClick write SetOnDropDownClick; //Property for StyledButton @@ -980,6 +1313,207 @@ TStyledButton = class(TCustomControl) property OnKeyUp; end; + { TStyledButton } + [ComponentPlatforms(pidWin32 or pidWin64)] + TStyledButton = class(TCustomStyledButton) + published + property ActiveStyleName; + property Action; + property Align; + property AllowAllUp; + property GroupIndex; + property Down; + property Anchors; + property AsVCLComponent stored False; + property BiDiMode; + property Cancel; + property Caption; + property CaptionAlignment; + property ShowCaption; + property CommandLinkHint; + property Constraints; + property Cursor default DEFAULT_CURSOR; + property Default; + property DisabledImageIndex; + {$IFDEF D10_4+} + property DisabledImageName; + {$ENDIF} + property DisabledImages; + property DoubleBuffered; + property DragCursor; + property DragKind; + property DragMode; + property DropDownMenu; + property ElevationRequired; + property Enabled; + property Font; + property HotImageIndex; + {$IFDEF D10_4+} + property HotImageName; + {$ENDIF} + property ImageAlignment; + property ImageIndex; + {$IFDEF D10_4+} + property ImageName; + {$ENDIF} + property ImageMargins; + property Images; + property ModalResult; + property NotificationBadge; + property ParentBiDiMode; + property ParentDoubleBuffered default False; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property PressedImageIndex; + {$IFDEF D10_4+} + property PressedImageName; + {$ENDIF} + property SelectedImageIndex; + {$IFDEF D10_4+} + property SelectedImageName; + {$ENDIF} + property ShowHint; + property Spacing; + property Style; + property StylusHotImageIndex; + property TabOrder; + property TabStop; + property Visible; + property WordWrap; + property StyleElements; + {$IFDEF D10_4+} + property StyleName; + property StylusHotImageName; + {$ENDIF} + property OnClick; + property OnContextPopup; + property OnDragDrop; + property OnDragOver; + property OnDropDownClick; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseActivate; + property OnMouseDown; + property OnMouseEnter; + property OnMouseLeave; + property OnMouseMove; + property OnMouseUp; + property OnStartDock; + property OnStartDrag; + + property Flat; + property Glyph; + property NumGlyphs; + property Kind; + property Tag; + + //StyledComponents Attributes + property StyleRadius; + property StyleRoundedCorners; + property StyleDrawType; + property StyleFamily; + property StyleClass; + property StyleAppearance; + property ButtonStyleNormal; + property ButtonStylePressed; + property ButtonStyleSelected; + property ButtonStyleHot; + property ButtonStyleDisabled; + end; + + { TStyledBitBtn } + [ComponentPlatforms(pidWin32 or pidWin64)] + TStyledBitBtn = class(TCustomStyledButton) + private + FStyle: TButtonStyle; + protected + function IsCaptionStored: Boolean; override; + public + constructor Create(AOwner: TComponent); override; + published + property Action; + property Align; + property Anchors; + property AsVCLComponent stored False; + property BiDiMode; + property Cancel; + property Caption; + property ShowCaption; + property Constraints; + property Cursor default DEFAULT_CURSOR; + property Default; + {$IFDEF D10_4+} + property DisabledImageIndex; + property DisabledImageName; + {$ENDIF} + property DoubleBuffered default True; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property Font; + {$IFDEF D10_4+} + property HotImageIndex; + property HotImageName; + property ImageIndex; + property ImageName; + property Images; + {$ENDIF} + property Glyph; + property Kind; + property Layout; + property Margin; + property ModalResult; + property NotificationBadge; + property NumGlyphs; + property Style: TButtonStyle read FStyle write FStyle; + property Spacing; + property TabOrder; + property TabStop; + property Visible; + property WordWrap; + property StyleElements; + {$IFDEF D10_4+} + property StyleName; + {$ENDIF} + property OnClick; + property OnContextPopup; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnMouseActivate; + property OnMouseDown; + property OnMouseEnter; + property OnMouseLeave; + property OnMouseMove; + property OnMouseUp; + property OnStartDock; + property OnStartDrag; + + //StyledComponents Attributes + property StyleRadius; + property StyleRoundedCorners; + property StyleDrawType; + property StyleFamily; + property StyleClass; + property StyleAppearance; + property ButtonStyleNormal; + property ButtonStylePressed; + property ButtonStyleSelected; + property ButtonStyleHot; + property ButtonStyleDisabled; + end; + //Global function to create a StyledButton function CreateAndPosStyledButton(const AOwner: TComponent; const AParent: TWinControl; @@ -987,15 +1521,15 @@ function CreateAndPosStyledButton(const AOwner: TComponent; const AClass: TStyledButtonClass; const AAppearance: TStyledButtonAppearance; const ACaption: TCaption; - const ARectPosition: TRect): TStyledButton; + const ARectPosition: TRect): TCustomStyledButton; implementation uses System.Types , System.RTLConsts + , System.StrUtils , Vcl.Forms - , Vcl.StandardButtonStyles {$IFDEF INCLUDE_BootstrapButtonStyles} , Vcl.BootstrapButtonStyles {$ENDIF} @@ -1009,11 +1543,11 @@ implementation ; const - {$IFDEF D10_4+} - DefaultBitBtnGlyphSize = 15; - {$ELSE} - DefaultBitBtnGlyphSize = 14; - {$ENDIF} + DEFAULT_BTN_WIDTH = 75; + DEFAULT_BTN_HEIGHT = 25; + DEFAULT_IMAGE_HMARGIN = 8; + DEFAULT_IMAGE_VMARGIN = 4; + DefaultBitBtnGlyphSize = 18; BitBtnModalResults: array[TBitBtnKind] of TModalResult = ( 0, mrOk, mrCancel, 0, mrYes, mrNo, 0, mrAbort, mrRetry, mrIgnore, mrAll); @@ -1024,9 +1558,9 @@ function CreateAndPosStyledButton(const AOwner: TComponent; const AClass: TStyledButtonClass; const AAppearance: TStyledButtonAppearance; const ACaption: TCaption; - const ARectPosition: TRect): TStyledButton; + const ARectPosition: TRect): TCustomStyledButton; begin - Result := TStyledButton.CreateStyled(AOwner, AFamily, AClass, AAppearance); + Result := TCustomStyledButton.CreateStyled(AOwner, AFamily, AClass, AAppearance); Result.Parent := AParent; Result.Caption := ACaption; Result.SetBounds(ARectPosition.Left, ARectPosition.Top, ARectPosition.Right, ARectPosition.Bottom); @@ -1036,40 +1570,52 @@ function CreateAndPosStyledButton(const AOwner: TComponent; procedure TStyledButtonRender.AssignStyleTo(ADest: TStyledButtonRender); begin + ADest.AsVCLComponent := Self.AsVCLComponent; if not ParentFont then ADest.Font.Assign(Self.Font); - ADest.FFlat := FFlat; + ADest.FFlat := Self.FFlat; + ADest.FStyle := Self.FStyle; ADest.FStyleRadius := Self.FStyleRadius; + ADest.FStyleRoundedCorners := Self.FStyleRoundedCorners; ADest.FButtonStyleNormal.Assign(Self.FButtonStyleNormal); ADest.FButtonStylePressed.Assign(Self.FButtonStylePressed); ADest.FButtonStyleSelected.Assign(Self.FButtonStyleSelected); ADest.FButtonStyleHot.Assign(Self.FButtonStyleHot); ADest.FButtonStyleDisabled.Assign(Self.FButtonStyleDisabled); + ADest.FNotificationBadge.Assign(Self.FNotificationBadge); ADest.SetButtonStyles(Self.FStyleFamily, Self.FStyleClass, Self.FStyleAppearance); ADest.FStyleDrawType := Self.FStyleDrawType; ADest.FCustomDrawType := Self.FCustomDrawType; + ADest.FUseButtonLayout := Self.FUseButtonLayout; + ADest.FButtonLayout := Self.FButtonLayout; + ADest.Transparent := Self.FTransparent; + ADest.FFlat := Self.FFlat; + ADest.FCaptionAlignment := Self.FCaptionAlignment; + ADest.FCommandLinkHint := Self.FCommandLinkHint; + ADest.FNotificationBadge.Assign(Self.FNotificationBadge); + if Assigned(FImages) then begin ADest.FImageMargins.Assign(FImageMargins); ADest.FImageAlignment := Self.FImageAlignment; ADest.Images := Images; - ADest.DisabledImageIndex := Self.DisabledImageIndex; ADest.ImageIndex := Self.ImageIndex; ADest.HotImageIndex := Self.HotImageIndex; + ADest.StylusHotImageIndex := Self.StylusHotImageIndex; ADest.SelectedImageIndex := Self.SelectedImageIndex; ADest.PressedImageIndex := Self.PressedImageIndex; {$IFDEF D10_4+} - ADest.DisabledImageName := Self.DisabledImageName; ADest.ImageName := Self.ImageName; ADest.HotImageName := Self.HotImageName; + ADest.StylusHotImageName := Self.StylusHotImageName; ADest.SelectedImageName := Self.SelectedImageName; ADest.PressedImageName := Self.PressedImageName; {$ENDIF} end; if Assigned(FDisabledImages) then begin - ADest.DisabledImages := DisabledImages; + ADest.DisabledImages := Self.DisabledImages; ADest.DisabledImageIndex := Self.DisabledImageIndex; {$IFDEF D10_4+} ADest.DisabledImageName := Self.DisabledImageName; @@ -1081,6 +1627,7 @@ procedure TStyledButtonRender.AssignStyleTo(ADest: TStyledButtonRender); ADest.NumGlyphs := FNumGlyphs; ADest.Glyph := FGlyph; end; + ADest.FCustomDrawType := Self.FCustomDrawType; end; function TStyledButtonRender.AssignAttributes( @@ -1106,6 +1653,41 @@ function TStyledButtonRender.AssignAttributes( ImageIndex := AImageIndex; {$ENDIF} ImageAlignment := AImageAlignment; + FUseButtonLayout := False; + end; + if Assigned(AAction) then + Action := AAction + else if Assigned(AOnClick) then + FOnClick := AOnClick; + if AName <> '' then + FOwnerControl.Name := AName; + Result := FOwnerControl; +end; + +function TStyledButtonRender.AssignAttributes( + const AEnabled: Boolean = True; + const AImageList: TCustomImageList = nil; + {$IFDEF D10_4+}const AImageName: string = '';{$ENDIF} + const AImageIndex: Integer = -1; + const AButtonLayout: TButtonLayout = blGlyphLeft; + const AAction: TCustomAction = nil; + const AOnClick: TNotifyEvent = nil; + const AName: string = ''): TControl; +begin + Enabled := AEnabled; + if Assigned(AImageList) then + begin + Images := AImageList; + {$IFDEF D10_4+} + if AImageName <> '' then + ImageName := AImageName + else + ImageIndex := AImageIndex; + {$ELSE} + ImageIndex := AImageIndex; + {$ENDIF} + Layout := AButtonLayout; + FUseButtonLayout := True; end; if Assigned(AAction) then Action := AAction @@ -1160,9 +1742,9 @@ procedure TStyledButtonRender.ChangeScale(M, D: Integer; isDpiChange: Boolean); procedure TStyledButtonRender.CMEnabledChanged(var Message: TMessage); begin if (not Enabled) then - FState := bsDisabled + State := bsDisabled else - FState := bsUp; + State := bsUp; if FMouseInControl then FMouseInControl := False; Invalidate; @@ -1192,11 +1774,6 @@ procedure TStyledButtonRender.CMMouseLeave(var Message: TNotifyEvent); Invalidate; end; -procedure TStyledButtonRender.UpdateControlStyle; -begin - UpdateStyleElements; -end; - function TStyledButtonRender.UpdateCount: Integer; begin Result := FUpdateCount; @@ -1205,8 +1782,7 @@ function TStyledButtonRender.UpdateCount: Integer; procedure TStyledButtonRender.CMStyleChanged(var Message: TMessage); begin inherited; - UpdateControlStyle; - Invalidate; + ApplyButtonStyle; end; procedure TStyledButtonRender.Click(AKeyPressed: Boolean); @@ -1251,19 +1827,26 @@ constructor TStyledButtonRender.CreateStyled(AOwner: TControl; const ASetParentFont: TSetParentFont; const AFamily: TStyledButtonFamily; const AClass: TStyledButtonClass; - const AAppearance: TStyledButtonAppearance); + const AAppearance: TStyledButtonAppearance; + const ADrawType: TStyledButtonDrawType; + const ACursor: TCursor; + const AUseCustomDrawType: Boolean); begin Assert(Assigned(AOwner)); inherited Create; FTransparentColor := clOlive; + FTransparent := False; + FImageIndex := -1; FNumGlyphs := 1; + FCaptionAlignment := TAlignment.taCenter; FFlat := False; + FShowCaption := True; //Owner Control "link" FOwnerControl := AOwner; - if (FOwnerControl is TStyledButton) then - TStyledButton(FOwnerControl).FRender := Self - else if (FOwnerControl is TStyledGraphicButton) then - TStyledGraphicButton(FOwnerControl).FRender := Self + if (FOwnerControl is TCustomStyledButton) then + TCustomStyledButton(FOwnerControl).FRender := Self + else if (FOwnerControl is TCustomStyledGraphicButton) then + TCustomStyledGraphicButton(FOwnerControl).FRender := Self else raise EStyledButtonError.Create(ERROR_CANNOT_USE_RENDER); @@ -1276,12 +1859,15 @@ constructor TStyledButtonRender.CreateStyled(AOwner: TControl; FDisabledImageIndex := -1; FHotImageIndex := -1; + FStylusHotImageIndex := -1; FImageAlignment := iaLeft; ImageIndex := -1; FPressedImageIndex := -1; FSelectedImageIndex := -1; + FSpacing := 4; + FMargin := -1; - FStyle := bsPushButton; + FStyle := TCustomButton.TButtonStyle.bsPushButton; FButtonStyleNormal := TStyledButtonAttributes.Create(AOwner); FButtonStyleNormal.Name := 'Normal'; FButtonStylePressed := TStyledButtonAttributes.Create(AOwner); @@ -1292,7 +1878,9 @@ constructor TStyledButtonRender.CreateStyled(AOwner: TControl; FButtonStyleHot.Name := 'Hot'; FButtonStyleDisabled := TStyledButtonAttributes.Create(AOwner); FButtonStyleDisabled.Name := 'Disabled'; - FOwnerControl.ControlStyle := [csCaptureMouse, csClickEvents, + FNotificationBadge := TNotificationBadgeAttributes.Create(AOwner); + FNotificationBadge.Name := 'NotificationBadge'; + FOwnerControl.ControlStyle := [csOpaque, csCaptureMouse, csClickEvents, csSetCaption, csDoubleClicks]; FImageChangeLink := TChangeLink.Create; FImageChangeLink.OnChange := ImageListChange; @@ -1301,15 +1889,18 @@ constructor TStyledButtonRender.CreateStyled(AOwner: TControl; FImageMargins.OnChange := ImageMarginsChange; FImageAlignment := iaLeft; FCustomDrawType := False; - FOwnerControl.Cursor := crHandPoint; + FOwnerControl.Cursor := ACursor; ParentFont := true; FOwnerControl.Width := DEFAULT_BTN_WIDTH; FOwnerControl.Height := DEFAULT_BTN_HEIGHT; FMouseInControl := false; - FStyleDrawType := btRounded; + FStyleDrawType := ADrawType; + FCustomDrawType := AUseCustomDrawType; FStyleRadius := DEFAULT_RADIUS; + FStyleRoundedCorners := ALL_ROUNDED_CORNERS; FStyleFamily := AFamily; FStyleAppearance := AAppearance; + //Call the Setter of StyleClass! StyleClass := AClass; end; @@ -1330,7 +1921,10 @@ constructor TStyledButtonRender.Create(AOwner: TControl; ASetParentFont, DEFAULT_CLASSIC_FAMILY, DEFAULT_WINDOWS_CLASS, - DEFAULT_APPEARANCE); + DEFAULT_APPEARANCE, + DEFAULT_STYLEDRAWTYPE, + DEFAULT_CURSOR, + False); end; procedure TStyledButtonRender.ActionChange(Sender: TObject; CheckDefaults: Boolean); @@ -1349,15 +1943,30 @@ procedure TStyledButtonRender.ActionChange(Sender: TObject; CheckDefaults: Boole function TStyledButtonRender.ApplyButtonStyle: Boolean; var LButtonFamily: TButtonFamily; + LStyleClass: TStyledButtonClass; + LStyleAppearance: TStyledButtonAppearance; begin + if AsVCLStyle then + begin + //if StyleElements contains seClient then use + //VCL Style assigned to Button or Global VCL Style + if seBorder in FOwnerControl.StyleElements then + LStyleAppearance := DEFAULT_APPEARANCE; + LStyleClass := GetActiveStyleName; + end + else + begin + LStyleClass := FStyleClass; + LStyleAppearance := FStyleAppearance; + end; Result := StyleFamilyCheckAttributes(FStyleFamily, - FStyleClass, FStyleAppearance, LButtonFamily); - if Result or (csDesigning in ComponentState) then + LStyleClass, LStyleAppearance, LButtonFamily); + if Result (*or (csDesigning in ComponentState)*) then begin StyleFamilyUpdateAttributes( FStyleFamily, - FStyleClass, - FstyleAppearance, + LStyleClass, + LStyleAppearance, FButtonStyleNormal, FButtonStylePressed, FButtonStyleSelected, @@ -1366,15 +1975,27 @@ function TStyledButtonRender.ApplyButtonStyle: Boolean; if not FCustomDrawType then FStyleDrawType := FButtonStyleNormal.DrawType; + end + else + begin + FStyleClass := LStyleClass; + FStyleAppearance := LStyleAppearance; end; if Result then Invalidate; end; +function TStyledButtonRender.IsCaptionAlignmentStored: Boolean; +begin + if (Style = TCustomButton.TButtonStyle.bsCommandLink) then + Result := CaptionAlignment <> taLeftJustify + else + Result := CaptionAlignment <> taCenter; +end; + destructor TStyledButtonRender.Destroy; begin Images := nil; - FreeAndNil(FGlyph); FreeAndNil(FImageChangeLink); FreeAndNil(FImageMargins); FreeAndNil(FButtonStyleNormal); @@ -1382,12 +2003,14 @@ destructor TStyledButtonRender.Destroy; FreeAndNil(FButtonStyleSelected); FreeAndNil(FButtonStyleHot); FreeAndNil(FButtonStyleDisabled); + FreeAndNil(FNotificationBadge); + FreeAndNil(FGlyph); inherited Destroy; end; function TStyledButtonRender.CanDropDownMenu: boolean; begin - Result := (FStyle = bsSplitButton) and + Result := (FStyle = TCustomButton.TButtonStyle.bsSplitButton) and (Assigned(DropDownMenu) or Assigned(FOnDropDownClick)); end; @@ -1425,10 +2048,10 @@ procedure TStyledButtonRender.WMKeyDown(var Message: TMessage); function TStyledButtonRender.GetHandle: HWND; begin - if (FOwnerControl is TStyledButton) then + if (FOwnerControl is TCustomStyledButton) then begin - if TStyledButton(FOwnerControl).HandleAllocated then - Result := TStyledButton(FOwnerControl).Handle + if TCustomStyledButton(FOwnerControl).HandleAllocated then + Result := TCustomStyledButton(FOwnerControl).Handle else Result := 0; end @@ -1456,8 +2079,28 @@ function TStyledButtonRender.GetText: TCaption; Result := FGetCaption; end; +function TStyledButtonRender.HasTransparentParts: Boolean; +begin + Result := (FStyleDrawType <> btRect) or FTransparent; +end; + function TStyledButtonRender.GetImage(out AImageList: TCustomImageList; out AImageIndex: Integer): Boolean; +begin + if (FOwnerControl is TCustomStyledButton) then + Result := TCustomStyledButton(FOwnerControl).GetImage(AImageList, AImageIndex) + else if (FOwnerControl is TCustomStyledGraphicButton) then + Result := TCustomStyledGraphicButton(FOwnerControl).GetImage(AImageList, AImageIndex) + else + begin + AImageList := nil; + AImageIndex := -1; + Result := False; + end; +end; + +function TStyledButtonRender.GetInternalImage(out AImageList: TCustomImageList; + out AImageIndex: Integer): Boolean; begin case ButtonState of bsmNormal: @@ -1476,8 +2119,10 @@ function TStyledButtonRender.GetImage(out AImageList: TCustomImageList; bsmHot: begin AImageList := FImages; - if FHotImageIndex <> -1 then + if (FHotImageIndex <> -1) then AImageIndex := FHotImageIndex + else if (FStylusHotImageIndex <> -1) then + AImageIndex := FStylusHotImageIndex else AImageIndex := ImageIndex; end; @@ -1526,7 +2171,7 @@ function TStyledButtonRender.IsCustomDrawType: Boolean; function TStyledButtonRender.IsDefaultAppearance: Boolean; begin - Result := (FStyleFamily = DEFAULT_CLASSIC_FAMILY) and + Result := (FStyleFamily = DEFAULT_APPEARANCE) and (FStyleClass = DEFAULT_WINDOWS_CLASS) and (FStyleAppearance = DEFAULT_APPEARANCE); end; @@ -1552,31 +2197,41 @@ function TStyledButtonRender.AsVCLStyle: Boolean; (seClient in FOwnerControl.StyleElements); end; +function TStyledButtonRender.GetAsVCLComponent: Boolean; +begin + Result := (FStyleFamily = DEFAULT_CLASSIC_FAMILY) and + (seClient in FOwnerControl.StyleElements); +end; + +procedure TStyledButtonRender.SetAsVCLComponent(const AValue: Boolean); +begin + if AValue <> GetAsVCLComponent then + begin + if AValue then + begin + FStyleFamily := DEFAULT_CLASSIC_FAMILY; + FStyleClass := DEFAULT_WINDOWS_CLASS; + FStyleAppearance := DEFAULT_APPEARANCE; + FOwnerControl.StyleElements := FOwnerControl.StyleElements + [seClient]; + end + else if FStyleFamily = DEFAULT_CLASSIC_FAMILY then + begin + FOwnerControl.StyleElements := FOwnerControl.StyleElements - [seClient]; + end; + ApplyButtonStyle; + end; +end; + function TStyledButtonRender.IsStoredStyleClass: Boolean; var LClass: TStyledButtonClass; LAppearance: TStyledButtonAppearance; LButtonFamily: TButtonFamily; - LModalResultClass: TStyledButtonClass; begin StyleFamilyCheckAttributes(FStyleFamily, LClass, LAppearance, LButtonFamily); - - if AsVCLStyle then - begin - Result := (FStyleClass <> GetActiveStyleName) - and not SameText(FStyleClass, 'Windows'); - end - else - begin - if FModalResult <> mrNone then - begin - LButtonFamily.StyledAttributes.GetStyleByModalResult(FModalResult, - LModalResultClass, LAppearance); - Result := FStyleClass <> LModalResultClass; - end - else - Result := FStyleClass <> LClass; - end; + if FModalResult <> mrNone then + LButtonFamily.StyledAttributes.GetStyleByModalResult(FModalResult, LClass, LAppearance); + Result := FStyleClass <> LClass; end; function TStyledButtonRender.IsStoredStyleAppearance: Boolean; @@ -1605,29 +2260,34 @@ function TStyledButtonRender.IsStoredStyleElements: Boolean; Result := False; end; +function TStyledButtonRender.IsNotificationBadgeStored: Boolean; +begin + Result := FNotificationBadge.HasCustomAttributes; +end; + function TStyledButtonRender.IsStyleDisabledStored: Boolean; begin - Result := FButtonStyleDisabled.IsChanged; + Result := FButtonStyleDisabled.HasCustomAttributes; end; function TStyledButtonRender.IsStylePressedStored: Boolean; begin - Result := FButtonStylePressed.IsChanged; + Result := FButtonStylePressed.HasCustomAttributes; end; function TStyledButtonRender.IsStyleSelectedStored: Boolean; begin - Result := FButtonStyleSelected.IsChanged; + Result := FButtonStyleSelected.HasCustomAttributes; end; function TStyledButtonRender.IsStyleHotStored: Boolean; begin - Result := FButtonStyleHot.IsChanged; + Result := FButtonStyleHot.HasCustomAttributes; end; function TStyledButtonRender.IsStyleNormalStored: Boolean; begin - Result := FButtonStyleNormal.IsChanged; + Result := FButtonStyleNormal.HasCustomAttributes; end; function TStyledButtonRender.GetAttributes(const AMode: TStyledButtonState): TStyledButtonAttributes; @@ -1643,25 +2303,101 @@ function TStyledButtonRender.GetAttributes(const AMode: TStyledButtonState): TSt end; procedure TStyledButtonRender.DrawText(const ACanvas: TCanvas; - const AText: string; var ARect: TRect; AFlags: Cardinal); + const AText: string; const AAlignment: TAlignment; + const ASpacing: Integer; + var ARect: TRect; AFlags: Cardinal); var - TextFormat: TTextFormatFlags; R: TRect; + OldBKMode: Integer; +begin + //Drawing Caption + R := ARect; + Winapi.Windows.DrawText(ACanvas.Handle, PChar(AText), Length(AText), + R, AFlags or DT_CALCRECT); + case AAlignment of + taLeftJustify: OffsetRect(R, ASpacing, (ARect.Height - R.Height) div 2); + taRightJustify: OffsetRect(R, ARect.Width - R.Width - ASpacing, (ARect.Height - R.Height) div 2); + else + OffsetRect(R, (ARect.Width - R.Width) div 2, (ARect.Height - R.Height) div 2); + end; + OldBKMode := SetBkMode(ACanvas.Handle, Winapi.Windows.TRANSPARENT); + CanvasDrawText(ACanvas, R, AText, AFlags); + SetBkMode(ACanvas.Handle, OldBKMode); +end; + +procedure TStyledButtonRender.DrawNotificationBadge( + const ACanvas: TCanvas; const ASurfaceRect: TRect); +var + LRect: TRect; + W, H, LBadgeChars, LBadgeBorderSize: Integer; + LBadgeValue: string; + LScaleFactor: Single; + LFlags: Cardinal; +begin + if not FNotificationBadge.IsVisible then + Exit; - function CanvasDrawText(ACanvas: TCanvas; const AText: string; var Bounds: TRect; Flag: Cardinal): Integer; + LScaleFactor := GetOwnerScaleFactor; + ACanvas.Pen.Style := psClear; + ACanvas.Brush.Color := FNotificationBadge.Color; + ACanvas.Font.Color := FNotificationBadge.FontColor; + ACanvas.Font.Style := [TFontStyle.fsBold]; + + //Calculate Badge Size + LFlags := DT_NOCLIP or DT_CENTER or DT_VCENTER or DT_CALCRECT; + LRect := ASurfaceRect; + LBadgeChars := Length(FNotificationBadge.BadgeContent); + if FNotificationBadge.CustomText = '' then + LBadgeValue := StringOfChar('9', LBadgeChars) + else + LBadgeValue := FNotificationBadge.CustomText; + Winapi.Windows.DrawText(ACanvas.Handle, + PChar(LBadgeValue), LBadgeChars, LRect, LFlags); + LBadgeValue := FNotificationBadge.BadgeContent; + + //Add Border + LBadgeBorderSize := Round(3 * LScaleFactor); + InflateRect(LRect, Round(LBadgeBorderSize*2.2), LBadgeBorderSize); + if FNotificationBadge.Size = nbsSmallDot then + begin + //Reduce size of dot based on Font Size + H := Round(LRect.Height / 2); + W := H; + end + else begin - SetBkMode(ACanvas.Handle, TRANSPARENT); - Result := Winapi.Windows.DrawText(ACanvas.Handle, PChar(AText), - Length(AText), Bounds, Flag) + H := LRect.Height; + W := Max(LRect.Width, H); end; -begin - TextFormat := TTextFormatFlags(AFlags); - //Drawing Caption - R := ARect; - CanvasDrawText(ACanvas, AText, R, AFlags or DT_CALCRECT); - OffsetRect(R, (ARect.Width - R.Width) div 2, (ARect.Height - R.Height) div 2); - CanvasDrawText(ACanvas, AText, R, AFlags); + //Calculate Badge Position + if FNotificationBadge.Position in [nbpTopLeft, nbpTopRight] then + begin + LRect.Top := ASurfaceRect.Top; + LRect.Bottom := LRect.Top + H; + end + else + begin + LRect.Bottom := ASurfaceRect.Bottom; + LRect.Top := LRect.Bottom - H; + end; + if FNotificationBadge.Position in [nbpTopRight, nbpBottomRight] then + begin + LRect.Right := ASurfaceRect.Right; + LRect.Left := ASurfaceRect.Right - W; + end + else + begin + LRect.Left := ASurfaceRect.Left; + LRect.Right := ASurfaceRect.Left + W; + end; + //Draw Badge + CanvasDrawshape(ACanvas, LRect, btRounded, 0, ALL_ROUNDED_CORNERS, False); + + //Draw Badge Content + if FNotificationBadge.Size <> nbsSmallDot then + DrawText(ACanvas, LBadgeValue, taCenter, 0, LRect, + DT_NOCLIP or DT_CENTER or DT_VCENTER); end; procedure TStyledButtonRender.DrawBackgroundAndBorder( @@ -1669,99 +2405,60 @@ procedure TStyledButtonRender.DrawBackgroundAndBorder( const AStyleAttribute: TStyledButtonAttributes; const AEraseBackground: Boolean); var - DrawRect, SplitButtonRect: TRect; + LDrawRect: TRect; + LButtonOffset: Integer; begin //Erase Background if AEraseBackground then EraseBackground(ACanvas); - //Don't draw button face for Flat Buttons - if not (FFlat and (FState in [bsUp, bsDisabled]) and not (FMouseInControl)) or - Focused then - begin - DrawRect := FOwnerControl.ClientRect; + LDrawRect := FOwnerControl.ClientRect; - //Draw Button Shape - CanvasDrawshape(ACanvas, DrawRect, FStyleDrawType, - FStyleRadius{$IFDEF D10_3+}*FOwnerControl.ScaleFactor{$ENDIF}); - end; + //Don't draw button border for Flat Buttons + if FFlat and not FMouseInControl and not Focused then + ACanvas.Pen.Style := psClear; + + //Don't draw button face for Transparent Buttons + if FTransparent and not FDown and not FMouseInControl and not Focused then + ACanvas.Brush.Style := bsClear; + + //Draw Button Shape + CanvasDrawshape(ACanvas, LDrawRect, FStyleDrawType, + FStyleRadius*GetOwnerScaleFactor, FStyleRoundedCorners); //Draw Bar and Triangle if FDropDownRect.Width > 0 then begin - SplitButtonRect.Left := DrawRect.Width - FDropDownRect.Width; if FFlat then ACanvas.Pen.Style := psClear; - CanvasDrawBarAndTriangle(ACanvas, FDropDownRect, - {$IFDEF D10_3+}FOwnerControl.ScaleFactor{$ELSE}1{$ENDIF}, - ACanvas.Pen.Color, AStyleAttribute.FontColor); + if not (StyleDrawType in [btRounded, btEllipse]) then + begin + CanvasDrawBar(ACanvas, FDropDownRect, + GetOwnerScaleFactor, + ACanvas.Pen.Color); + CanvasDrawTriangle(ACanvas, FDropDownRect, + GetOwnerScaleFactor, + AStyleAttribute.FontColor); + end + else + begin + LButtonOffset := FDropDownRect.Height div 8; + FDropDownRect.Left := FDropDownRect.Left - LButtonOffset; + FDropDownRect.Right := FDropDownRect.Right - LButtonOffset; + CanvasDrawTriangle(ACanvas, FDropDownRect, + GetOwnerScaleFactor, + AStyleAttribute.FontColor); + end; end; end; -function TStyledButtonRender.CalcImageRect(var ATextRect: TRect; +function TStyledButtonRender.CalcImageRect(const ASurfaceRect: TRect; const AImageWidth, AImageHeight: Integer): TRect; var - IW, IH, IX, IY: Integer; + LTextRect: TRect; begin - //Calc Image Rect - IH := AImageHeight; - IW := AImageWidth; - if (IH > 0) and (IW > 0) then - begin - IX := ATextRect.Left + 2; - IY := ATextRect.Top + (ATextRect.Height - IH) div 2; - case FImageAlignment of - iaCenter: - begin - IX := ATextRect.CenterPoint.X - IW div 2; - end; - iaLeft: - begin - IX := ATextRect.Left + 2; - Inc(IX, ImageMargins.Left); - Inc(IY, ImageMargins.Top); - Dec(IY, ImageMargins.Bottom); - Inc(ATextRect.Left, IX + IW + ImageMargins.Right); - end; - iaRight: - begin - IX := ATextRect.Right - IW - 2; - Dec(IX, ImageMargins.Right); - Dec(IX, ImageMargins.Left); - Inc(IY, ImageMargins.Top); - Dec(IY, ImageMargins.Bottom); - ATextRect.Right := IX; - end; - iaTop: - begin - IX := ATextRect.Left + (ATextRect.Width - IW) div 2; - Inc(IX, ImageMargins.Left); - Dec(IX, ImageMargins.Right); - IY := ATextRect.Top + 2; - Inc(IY, ImageMargins.Top); - Inc(ATextRect.Top, IY + IH + ImageMargins.Bottom); - end; - iaBottom: - begin - IX := ATextRect.Left + (ATextRect.Width - IW) div 2; - Inc(IX, ImageMargins.Left); - Dec(IX, ImageMargins.Right); - IY := ATextRect.Bottom - IH - 2; - Dec(IY, ImageMargins.Bottom); - Dec(IY, ImageMargins.Top); - ATextRect.Bottom := IY; - end; - end; - end - else - begin - IX := 0; - IY := 0; - end; - Result.Left := IX; - Result.Top := IY; - Result.Width := IW; - Result.Height := IH; + CalcImageAndTextRect(ASurfaceRect, Caption, LTextRect, Result, + AImageWidth, AImageHeight, FImageAlignment, FImageMargins, GetOwnerScaleFactor); end; procedure TStyledButtonRender.SetButtonStyles( @@ -1797,7 +2494,7 @@ procedure TStyledButtonRender.CheckImageIndexes; Images.CheckIndexAndName(FHotImageIndex, FHotImageName); Images.CheckIndexAndName(FPressedImageIndex, FPressedImageName); Images.CheckIndexAndName(FSelectedImageIndex, FSelectedImageName); - //Images.CheckIndexAndName(FStylusHotImageIndex, FStylusHotImageName); + Images.CheckIndexAndName(FStylusHotImageIndex, FStylusHotImageName); if FDisabledImages <> nil then FDisabledImages.CheckIndexAndName(FDisabledImageIndex, FDisabledImageName) else @@ -1807,17 +2504,31 @@ procedure TStyledButtonRender.CheckImageIndexes; procedure TStyledButtonRender.EraseBackground(const ACanvas: TCanvas); var - LOwnerControl: TWinControl; + LStyle: TCustomStyleServices; + LHandle: HWND; begin - if FOwnerControl is TWinControl then - LOwnerControl := TWinControl(FOwnerControl) - else - Exit; - - if (LOwnerControl.Parent <> nil) and LOwnerControl.Parent.DoubleBuffered then - PerformEraseBackground(LOwnerControl.Parent, ACanvas.Handle) - else - StyleServices.DrawParentBackground(LOwnerControl.Handle, ACanvas.Handle, nil, False); + LStyle := StyleServices; + if HasTransparentParts then + begin + if FOwnerControl is TWinControl then + LHandle := TWinControl(FOwnerControl).Handle + else + LHandle := 0; + if OwnerControl is TCustomStyledGraphicButton then + begin + if LStyle.Available and Transparent then + LStyle.DrawParentBackground(LHandle, ACanvas.Handle, nil, False) + else + PerformEraseBackground(FOwnerControl, ACanvas.Handle); + end + else + begin + if LStyle.Available then + LStyle.DrawParentBackground(LHandle, ACanvas.Handle, nil, False) + else + PerformEraseBackground(FOwnerControl, ACanvas.Handle); + end; + end; end; function TStyledButtonRender.GetImageSize(out AWidth, AHeight: Integer; @@ -1851,38 +2562,149 @@ function TStyledButtonRender.GetImageSize(out AWidth, AHeight: Integer; end; end; -procedure TStyledButtonRender.DrawImage(const ACanvas: TCanvas; - var ATextRect: TRect); +procedure TStyledButtonRender.DrawCaptionAndImage(const ACanvas: TCanvas; + const ASurfaceRect: TRect); var - LImageRect: TRect; + LTextFlags: Cardinal; + LImageRect, LTextRect: TRect; LImageList: TCustomImageList; LImageIndex: Integer; LImageWidth, LImageHeight: Integer; + LUseImageList: Boolean; + LGlyphPos: TPoint; + LCaption: TCaption; begin - if GetImageSize(LImageWidth, LImageHeight, LImageList, LImageIndex) then + if FShowCaption then + LCaption := Caption + else + LCaption := ''; + case FCaptionAlignment of + taLeftJustify: LTextFlags := DT_NOCLIP or DT_LEFT or DT_VCENTER; + taRightJustify: LTextFlags := DT_NOCLIP or DT_RIGHT or DT_VCENTER; + else + LTextFlags := DT_NOCLIP or DT_CENTER or DT_VCENTER; + end; + if FWordWrap then + LTextFlags := LTextFlags or DT_WORDBREAK; + LTextFlags := FOwnerControl.DrawTextBiDiModeFlags(LTextFlags); + LUseImageList := GetImageSize(LImageWidth, LImageHeight, + LImageList, LImageIndex); + + //FUseButtonLayout is used by TStyledBitBtn and TStyledSpeedButton + //to use Layout for Icon position + if FUseButtonLayout then begin - LImageRect := CalcImageRect(ATextRect, LImageWidth, LImageHeight); - if Assigned(LImageList) then - LImageList.Draw(ACanvas, LImageRect.Left, LImageRect.Top, LImageIndex, Enabled); + //Calculate LTextRect and LImageRect using Margin, Spacing and ButtonLayout + CalcImageAndTextRect(ACanvas, LCaption, ASurfaceRect, + TPoint.Create(0,0), LGlyphPos, LTextRect, + LImageWidth, LImageHeight, FButtonLayout, FMargin, FSpacing, LTextFlags); + LImageRect.Left := LGlyphPos.X; + LImageRect.Top := LGlyphPos.Y; + LImageRect.Width := LImageWidth; + LImageRect.Height := LImageHeight; end else begin - if ((FKind = bkCustom) and Assigned(FGlyph)) or (FKind <> bkCustom) then + if Style = bsCommandLink then begin - if (LImageWidth > 0) and (LImageHeight > 0) then + CalcImageAndTextRect(ASurfaceRect, LCaption, LTextRect, LImageRect, + LImageWidth, LImageHeight, FImageAlignment, FImageMargins, GetOwnerScaleFactor); + if Assigned(Images) then begin - LImageRect := CalcImageRect(ATextRect, LImageWidth, LImageHeight); - DrawBitBtnGlyph(ACanvas, LImageRect, FKind, FState, Enabled, FGlyph, FNumGlyphs, FTransparentColor); + //A CommandLink Buttons Ignores ImageAlignment and ImagePosition + //Fixed Left and Right of ImageRect + LImageRect.Right := LImageRect.Right - Round(8*GetOwnerScaleFactor); + LImageRect.Left := Round(8*GetOwnerScaleFactor); + LTextRect.Left := LImageWidth + FImageMargins.Left + FImageMargins.Right + + Round(8*GetOwnerScaleFactor); + end + else + begin + //Fixed Size of ImageRect + LImageRect.top := Round(16*GetOwnerScaleFactor); + LImageRect.Left := Round(10*GetOwnerScaleFactor); + LImageRect.Height := Round(20*GetOwnerScaleFactor); + LImageRect.Width := LImageRect.Height; + if AsVCLComponent then + DrawIconFromCommandLinkRes(ACanvas, LImageRect, + Self.ActiveStyleName, FState, Enabled) + else + DrawIconFromCommandLinkRes(ACanvas, LImageRect, + Self.FStyleClass, FState, Enabled); end; + end + else + begin + //Calculate LTextRect and LImageRect using ImageMargins and ImageAlignment + CalcImageAndTextRect(ASurfaceRect, LCaption, LTextRect, LImageRect, + LImageWidth, LImageHeight, FImageAlignment, FImageMargins, GetOwnerScaleFactor); + end; + end; + if ElevationRequired then + begin + //Load the Shield Icon from Resource + DrawIconFromCommandLinkRes(ACanvas, LImageRect, + RESOURCE_SHIELD_ICON, FState, Enabled) + end + else if LUseImageList then + begin + //Uses an ImageList to draw the Icon + LImageList.Draw(ACanvas, LImageRect.Left, LImageRect.Top, + LImageIndex, Enabled); + end + else + begin + if ((FKind = bkCustom) and Assigned(FGlyph)) or (FKind <> bkCustom) then + begin + //Uses the Glyph to draw the Icon + DrawBitBtnGlyph(ACanvas, LImageRect, FKind, FState, Enabled, + FGlyph, FNumGlyphs, FTransparentColor); end; end; + if (Style = bsCommandLink) then + begin + //Load the Arrow Icon from Resource + if Assigned(Images) then + LTextRect.Left := LImageRect.Right+Round(10*GetOwnerScaleFactor) + else + LTextRect.Left := Round(38*GetOwnerScaleFactor); + LTextRect.Right := ASurfaceRect.Right; + ACanvas.Font.Height := Round(-16*GetOwnerScaleFactor); + if AsVCLComponent and (ActiveStyleName = 'Windows') then + ACanvas.Font.Color := HtmlToColor('#0279D7'); //Windows Blue color + //Calculate TextRect: WordWrap, centered + LTextFlags := DT_NOCLIP or DT_VCENTER or DT_WORDBREAK; + Winapi.Windows.DrawText(ACanvas.Handle, PChar(LCaption), + Length(LCaption), LTextRect, LTextFlags or DT_CALCRECT); + //WordWrap but not vertical centerer: fixed top + LTextFlags := DT_NOCLIP or DT_WORDBREAK; + LTextRect.Top := Round(28*GetOwnerScaleFactor); + DrawText(ACanvas, LCaption, taLeftJustify, 0, LTextRect, LTextFlags); + if FCommandLinkHint <> '' then + begin + ACanvas.Font.Height := Round(-11*GetOwnerScaleFactor); + //Draw Command Link Hint Under Caption + LTextRect.Top := LTextRect.Top + LTextRect.Height; + LTextRect.Bottom := ASurfaceRect.Bottom; + LTextRect.Right := ASurfaceRect.Right - Round(4*GetOwnerScaleFactor); + //Calculate TextRect: WordWrap, centered + LTextFlags := DT_NOCLIP or DT_VCENTER or DT_WORDBREAK; + Winapi.Windows.DrawText(ACanvas.Handle, PChar(FCommandLinkHint), + Length(FCommandLinkHint), LTextRect, LTextFlags or DT_CALCRECT); + //WordWrap but not vertical centerer: fixed top + LTextFlags := DT_NOCLIP or DT_WORDBREAK; + OffsetRect(LTextRect, 0, Round(15*GetOwnerScaleFactor)); + DrawText(ACanvas, FCommandLinkHint, taLeftJustify, 0, LTextRect, LTextFlags); + end; + end + else + DrawText(ACanvas, LCaption, FCaptionAlignment, FSpacing, LTextRect, LTextFlags); end; procedure TStyledButtonRender.DrawButton(const ACanvas: TCanvas; const AEraseBackground: Boolean); var - LTextFlags: Cardinal; - LTextRect: TRect; + LSurfaceRect: TRect; LOldFontName: TFontName; LOldFontColor: TColor; LOldFontStyle: TFontStyles; @@ -1900,23 +2722,17 @@ procedure TStyledButtonRender.DrawButton(const ACanvas: TCanvas; try LStyleAttribute := GetDrawingStyle(ACanvas); - LTextFlags := 0; - if FWordWrap then - LTextFlags := LTextFlags or DT_WORDBREAK or DT_CENTER; DrawBackgroundAndBorder(ACanvas, LStyleAttribute, AEraseBackground); - LTextRect := FOwnerControl.ClientRect; - Dec(LTextRect.Right, FDropDownRect.Width); + LSurfaceRect := FOwnerControl.ClientRect; + if FDropDownRect.Width <> 0 then + Dec(LSurfaceRect.Right, FDropDownRect.Width); - DrawImage(ACanvas, LTextRect); + DrawCaptionAndImage(ACanvas, LSurfaceRect); - if LTextRect.IsEmpty then - LTextRect := FOwnerControl.ClientRect; - if FOwnerControl.AlignWithMargins then - InflateRect(LTextRect, -FOwnerControl.Margins.Left-FOwnerControl.Margins.Right, - -FOwnerControl.Margins.Top-FOwnerControl.Margins.Bottom); - DrawText(ACanvas, Caption, LTextRect, FOwnerControl.DrawTextBiDiModeFlags(LTextFlags)); + LSurfaceRect := FOwnerControl.ClientRect; + DrawNotificationBadge(ACanvas, LSurfaceRect); finally if LOldParentFont then ParentFont := LOldParentFont @@ -1936,10 +2752,10 @@ function TStyledButtonRender.GetBackGroundColor: TColor; function TStyledButtonRender.GetButtonState: TStyledButtonState; begin - if FOwnerControl is TStyledGraphicButton then - Result := TStyledGraphicButton(FOwnerControl).ButtonState - else if FOwnerControl is TStyledButton then - Result := TStyledButton(FOwnerControl).ButtonState + if FOwnerControl is TCustomStyledGraphicButton then + Result := TCustomStyledGraphicButton(FOwnerControl).ButtonState + else if FOwnerControl is TCustomStyledButton then + Result := TCustomStyledButton(FOwnerControl).ButtonState else Result := bsmNormal; end; @@ -1952,14 +2768,14 @@ function TStyledButtonRender.GetDrawingStyle(const ACanvas: TCanvas): TStyledBut ACanvas.Pen.Width := Round(Result.BorderWidth{$IFDEF D10_3+}*FOwnerControl.ScaleFactor{$ENDIF}); ACanvas.Pen.Color := Result.BorderColor; ACanvas.Brush.Style := Result.BrushStyle; - if ACanvas.Brush.Style <> bsClear then + if Result.ButtonDrawStyle <> btnClear then ACanvas.Brush.Color := Result.ButtonColor; ACanvas.Font := Font; ACanvas.Font.Color := Result.FontColor; if ParentFont then ACanvas.Font.Style := Result.FontStyle; - if FStyle = bsSplitButton then + if FStyle = TCustomButton.TButtonStyle.bsSplitButton then begin FDropDownRect := FOwnerControl.ClientRect; FDropDownRect.Left := FDropDownRect.Right - GetSplitButtonWidth - ACanvas.Pen.Width -2; @@ -1988,16 +2804,19 @@ procedure TStyledButtonRender.SetRescalingButton(const AValue: Boolean); procedure TStyledButtonRender.SetStyleDrawType(const AValue: TStyledButtonDrawType); begin - FStyleDrawType := AValue; - FCustomDrawType := True; -(* do not assign DrawType to any Style - FButtonStyleNormal.DrawType := FDrawType; - FButtonStylePressed.DrawType := FDrawType; - FButtonStyleSelected.DrawType := FDrawType; - FButtonStyleHot.DrawType := FDrawType; - FButtonStyleDisabled.DrawType := FDrawType; -*) - Invalidate; + if FStyleDrawType <> AValue then + begin + FStyleDrawType := AValue; + FCustomDrawType := True; + (* do not assign DrawType to any Style + FButtonStyleNormal.DrawType := FDrawType; + FButtonStylePressed.DrawType := FDrawType; + FButtonStyleSelected.DrawType := FDrawType; + FButtonStyleHot.DrawType := FDrawType; + FButtonStyleDisabled.DrawType := FDrawType; + *) + Invalidate; + end; end; function TStyledButtonRender.IsDefaultImageMargins: Boolean; @@ -2024,7 +2843,7 @@ procedure TStyledButtonRender.CalcDefaultImageMargins(const AValue: TImageAlignm function AdJustMargin(const AMargin, AOffset: Integer): Integer; begin - Result := AMargin + Round(AOffset*{$IFDEF D10_3+}FOwnerControl.ScaleFactor{$ELSE}1{$ENDIF}); + Result := AMargin + Round(AOffset*GetOwnerScaleFactor); end; begin @@ -2043,6 +2862,15 @@ procedure TStyledButtonRender.CalcDefaultImageMargins(const AValue: TImageAlignm end; end; +procedure TStyledButtonRender.SetLayout(const AValue: TButtonLayout); +begin + if AValue <> FButtonLayout then + begin + FButtonLayout := AValue; + Invalidate; + end; +end; + procedure TStyledButtonRender.SetImageAlignment(const AValue: TImageAlignment); begin if AValue <> FImageAlignment then @@ -2071,10 +2899,10 @@ procedure TStyledButtonRender.SetDisabledImageIndex(const AValue: TImageIndex); function TStyledButtonRender.GetImageIndex: TImageIndex; begin - if (FOwnerControl is TStyledButton) then - Result := TStyledButton(FOwnerControl).ImageIndex - else if (FOwnerControl is TStyledGraphicButton) then - Result := TStyledGraphicButton(FOwnerControl).ImageIndex + if (FOwnerControl is TCustomStyledButton) then + Result := TCustomStyledButton(FOwnerControl).ImageIndex + else if (FOwnerControl is TCustomStyledGraphicButton) then + Result := TCustomStyledGraphicButton(FOwnerControl).ImageIndex else raise EStyledButtonError.Create(ERROR_CANNOT_USE_RENDER); end; @@ -2084,10 +2912,10 @@ procedure TStyledButtonRender.SetImageIndex(const AValue: TImageIndex); if AValue <> FImageIndex then begin FImageIndex := AValue; - if (FOwnerControl is TStyledButton) then - TStyledButton(FOwnerControl).ImageIndex := AValue - else if (FOwnerControl is TStyledGraphicButton) then - TStyledGraphicButton(FOwnerControl).ImageIndex := AValue; + if (FOwnerControl is TCustomStyledButton) then + TCustomStyledButton(FOwnerControl).ImageIndex := AValue + else if (FOwnerControl is TCustomStyledGraphicButton) then + TCustomStyledGraphicButton(FOwnerControl).ImageIndex := AValue; {$IFDEF D10_4+} if (FImages <> nil) and FImages.IsImageNameAvailable then @@ -2115,10 +2943,10 @@ procedure TStyledButtonRender.SetDisabledImageName(const AValue: TImageName); function TStyledButtonRender.GetImageName: TImageName; begin - if (FOwnerControl is TStyledButton) then - Result := TStyledButton(FOwnerControl).FImageName - else if (FOwnerControl is TStyledGraphicButton) then - Result := TStyledGraphicButton(FOwnerControl).FImageName + if (FOwnerControl is TCustomStyledButton) then + Result := TCustomStyledButton(FOwnerControl).FImageName + else if (FOwnerControl is TCustomStyledGraphicButton) then + Result := TCustomStyledGraphicButton(FOwnerControl).FImageName else raise EStyledButtonError.Create(ERROR_CANNOT_USE_RENDER); end; @@ -2128,10 +2956,10 @@ procedure TStyledButtonRender.SetImageName(const AValue: TImageName); if AValue <> FImageName then begin FImageName := AValue; - if (FOwnerControl is TStyledButton) then - TStyledButton(FOwnerControl).ImageName := AValue - else if (FOwnerControl is TStyledGraphicButton) then - TStyledGraphicButton(FOwnerControl).ImageName := AValue; + if (FOwnerControl is TCustomStyledButton) then + TCustomStyledButton(FOwnerControl).ImageName := AValue + else if (FOwnerControl is TCustomStyledGraphicButton) then + TCustomStyledGraphicButton(FOwnerControl).ImageName := AValue; UpdateImageIndexAndName; Invalidate; end; @@ -2170,6 +2998,15 @@ procedure TStyledButtonRender.SetHotImageName(const AValue: TImageName); end; end; +procedure TStyledButtonRender.SetStylusHotImageName(const AValue: TImageName); +begin + if AValue <> FStylusHotImageName then + begin + FStylusHotImageName := AValue; + UpdateImageIndex(AValue, FStylusHotImageIndex); + end; +end; + procedure TStyledButtonRender.SetPressedImageName(const AValue: TImageName); begin if AValue <> FPressedImageName then @@ -2205,42 +3042,7 @@ procedure TStyledButtonRender.UpdateImageIndexAndName; function TStyledButtonRender.GetActiveStyleName: string; begin - {$IFDEF D10_4+} - Result := FOwnerControl.GetStyleName; - if Result = '' then - begin - {$IFDEF D11+} - if (csDesigning in ComponentState) then - Result := TStyleManager.ActiveDesigningStyle.Name - else - Result := TStyleManager.ActiveStyle.Name; - {$ELSE} - Result := TStyleManager.ActiveStyle.Name; - {$ENDIF} - end; - {$ELSE} - Result := TStyleManager.ActiveStyle.Name; - {$ENDIF} -end; - -procedure TStyledButtonRender.UpdateStyleElements; -var - LStyleClass: TStyledButtonClass; -begin - if AsVCLStyle then - begin - //if StyleElements contains seClient then Update style - //as VCL Style assigned to Button or Global VCL Style - if seBorder in FOwnerControl.StyleElements then - StyleAppearance := DEFAULT_APPEARANCE; - LStyleClass := GetActiveStyleName; - if LStyleClass <> FStyleClass then - begin - FStyleClass := LStyleClass; - StyleApplied := ApplyButtonStyle; - end; - end; - inherited; + Result := Vcl.ButtonStylesAttributes.GetActiveStyleName(FOwnerControl); end; procedure TStyledButtonRender.SetDisabledImages(const AValue: TCustomImageList); @@ -2263,18 +3065,78 @@ procedure TStyledButtonRender.SetDisabledImages(const AValue: TCustomImageList); end; end; -procedure TStyledButtonRender.SetDropDownMenu(const Value: TPopupMenu); +procedure TStyledButtonRender.UpAllButtons; +var + LParent: TWinControl; + LControl: TControl; + I: Integer; + LGraphicButton: TCustomStyledGraphicButton; + LButton: TCustomStyledButton; +begin + LParent := FOwnerControl.Parent; + for I := 0 to LParent.ControlCount -1 do + begin + LControl := LParent.Controls[I]; + if LControl is TCustomStyledGraphicButton then + begin + LGraphicButton := TCustomStyledGraphicButton(LControl); + if LGraphicButton.Down and (LGraphicButton <> FOwnerControl) and + (LGraphicButton.GroupIndex = GroupIndex) then + begin + LGraphicButton.Down := False; + Break; + end; + end; + if LControl is TCustomStyledButton then + begin + LButton := TCustomStyledButton(LControl); + if LButton.Down and (LButton <> FOwnerControl) and + (LButton.GroupIndex = GroupIndex) then + begin + LButton.Down := False; + Break; + end; + end; + end; +end; + +procedure TStyledButtonRender.SetDown(const AValue: Boolean); +begin + if AValue <> FDown then + begin + FDown := AValue; + if AValue then + begin + FState := bsDown; + UpAllButtons; + end + else + FState := bsUp; + Invalidate; + end; +end; + +procedure TStyledButtonRender.SetDropDownMenu(const AValue: TPopupMenu); begin - if Value <> FDropDownMenu then + if AValue <> FDropDownMenu then begin if DropDownMenu <> nil then DropDownMenu.RemoveFreeNotification(FOwnerControl); - FDropDownMenu := Value; + FDropDownMenu := AValue; if DropDownMenu <> nil then DropDownMenu.FreeNotification(FOwnerControl); end; end; +procedure TStyledButtonRender.SetElevationRequired(const AValue: Boolean); +begin + if FElevationRequired <> AValue then + begin + FElevationRequired := AValue; + Invalidate; + end; +end; + procedure TStyledButtonRender.SetFlat(const AValue: Boolean); begin if FFlat <> AValue then @@ -2287,7 +3149,8 @@ procedure TStyledButtonRender.SetFlat(const AValue: Boolean); procedure TStyledButtonRender.SetFocus; begin if FOwnerControl is TCustomControl and - TCustomControl(FOwnerControl).CanFocus then + TCustomControl(FOwnerControl).CanFocus and + TCustomControl(FOwnerControl).TabStop then TCustomControl(FOwnerControl).SetFocus; end; @@ -2299,6 +3162,15 @@ procedure TStyledButtonRender.SetGlyph(const AValue: TBitmap); Invalidate; end; +procedure TStyledButtonRender.SetGroupIndex(const AValue: Integer); +begin + if FGroupIndex <> AValue then + begin + FGroupIndex := AValue; + Invalidate; + end; +end; + procedure TStyledButtonRender.SetHotImageIndex(const AValue: TImageIndex); begin if AValue <> FHotImageIndex then @@ -2310,6 +3182,18 @@ procedure TStyledButtonRender.SetHotImageIndex(const AValue: TImageIndex); end; end; +procedure TStyledButtonRender.SetStylusHotImageIndex(const AValue: TImageIndex); +begin + if FStylusHotImageIndex <> AValue then + begin + FStylusHotImageIndex := AValue; + {$IFDEF D10_4+} + UpdateImageName(AValue, FHotImageName); + {$ENDIF} + end; +end; + + procedure TStyledButtonRender.SetImages(const AValue: TCustomImageList); begin if AValue <> FImages then @@ -2330,25 +3214,25 @@ procedure TStyledButtonRender.SetImages(const AValue: TCustomImageList); end; end; -procedure TStyledButtonRender.SetKind(const Value: TBitBtnKind); +procedure TStyledButtonRender.SetKind(const AValue: TBitBtnKind); begin - if Value <> FKind then + if AValue <> FKind then begin - if Value <> bkCustom then + if AValue <> bkCustom then begin - Default := Value in [bkOK, bkYes]; - Cancel := Value in [bkCancel, bkNo]; + Default := AValue in [bkOK, bkYes]; + Cancel := AValue in [bkCancel, bkNo]; if ((csLoading in ComponentState) and (Caption = '')) or (not (csLoading in ComponentState)) then begin - if Value <> bkCustom then - Caption := BitBtnCaptions(Value); + if AValue <> bkCustom then + Caption := BitBtnCaptions(AValue); end; - ModalResult := BitBtnModalResults[Value]; + ModalResult := BitBtnModalResults[AValue]; end; - FKind := Value; + FKind := AValue; Invalidate; end; end; @@ -2361,13 +3245,21 @@ function TStyledButtonRender.UpdateStyleUsingModalResult: boolean; //Force style of the button as defined into Family StyleFamilyUpdateAttributesByModalResult(FModalResult, FStyleFamily, FStyleClass, FStyleAppearance); - UpdateStyleElements; StyleApplied := ApplyButtonStyle; end else Result := False; end; +procedure TStyledButtonRender.SetMargin(const AValue: Integer); +begin + if FMargin <> AValue then + begin + FMargin := AValue; + Invalidate; + end; +end; + procedure TStyledButtonRender.SetModalResult(const AValue: TModalResult); begin if FModalResult <> AValue then @@ -2468,6 +3360,15 @@ procedure TStyledButtonRender.SetButtonStyleHot(const AValue: TStyledButtonAttri end; end; +procedure TStyledButtonRender.SetNotificationBadge( + const AValue: TNotificationBadgeAttributes); +begin + if not SameNotificationBadgeAttributes(FNotificationBadge, AValue) then + begin + FNotificationBadge := AValue; + end; +end; + procedure TStyledButtonRender.SetImageMargins(const AValue: TImageMargins); begin FImageMargins.Assign(AValue); @@ -2484,6 +3385,36 @@ procedure TStyledButtonRender.SetStyleRadius(const AValue: Integer); end; end; +procedure TStyledButtonRender.SetStyleRoundedCorners(const AValue: TRoundedCorners); +begin + if FStyleRoundedCorners <> AValue then + begin + FStyleRoundedCorners := AValue; + Invalidate; + end; +end; + +function TStyledButtonRender.GetHasCustomAttributes: Boolean; +begin + Result := FButtonStyleNormal.HasCustomAttributes or + FButtonStylePressed.HasCustomAttributes or + FButtonStyleSelected.HasCustomAttributes or + FButtonStyleHot.HasCustomAttributes or + FButtonStyleDisabled.HasCustomAttributes; +end; + +procedure TStyledButtonRender.SetHasCustomAttributes(const AValue: Boolean); +begin + if not AValue then + begin + FButtonStyleNormal.ResetCustomAttributes; + FButtonStylePressed.ResetCustomAttributes; + FButtonStyleSelected.ResetCustomAttributes; + FButtonStyleHot.ResetCustomAttributes; + FButtonStyleDisabled.ResetCustomAttributes; + end; +end; + procedure TStyledButtonRender.SetSelectedImageIndex(const AValue: TImageIndex); begin if AValue <> FSelectedImageIndex then @@ -2495,16 +3426,64 @@ procedure TStyledButtonRender.SetSelectedImageIndex(const AValue: TImageIndex); end; end; +procedure TStyledButtonRender.SetShowCaption(const AValue: Boolean); +begin + if FShowCaption <> AValue then + begin + FShowCaption := AValue; + Invalidate; + end; +end; + +procedure TStyledButtonRender.SetSpacing(const AValue: Integer); +begin + if FSpacing <> AValue then + begin + FSpacing := AValue; + Invalidate; + end; +end; + procedure TStyledButtonRender.SetState(const AValue: TButtonState); begin - FState := AValue; + if FState <> AValue then + begin + if (AValue <> bsDown) and FDown and not FAllowAllUp then + Exit; + FState := AValue; + end; end; -procedure TStyledButtonRender.SetStyle(const Value: TStyledButtonStyle); +procedure TStyledButtonRender.SetStyle(const AValue: TCustomButton.TButtonStyle); +const + DefCmdLinkWidth = 175; + DefCmdLinkHeights: array[Boolean] of Integer = (57, 41); begin - if Value <> FStyle then + if AValue <> FStyle then begin - FStyle := Value; + FStyle := AValue; + if not (csLoading in ComponentState) then + begin + case AValue of + bsPushButton, + bsSplitButton: + begin + if FStyle = bsCommandLink then + FOwnerControl.SetBounds(FOwnerControl.Left, FOwnerControl.Top, + FOwnerControl.ExplicitWidth, FOwnerControl.ExplicitHeight); + end; + bsCommandLink: + begin + if Height < DefCmdLinkHeights[FCommandLinkHint = ''] then + FOwnerControl.Height := DefCmdLinkHeights[FCommandLinkHint = '']; + if Width < DefCmdLinkWidth then + FOwnerControl.Width := DefCmdLinkWidth; + FStyle := AValue; + end; + end; + end; + if (FStyle = TCustomButton.TButtonStyle.bsCommandLink) then + CaptionAlignment := TAlignment.taLeftJustify; FMouseOverDropDown := False; if not (csLoading in ComponentState) then Invalidate; @@ -2542,12 +3521,12 @@ procedure TStyledButtonRender.SetStyleClass( if (FStyleFamily = DEFAULT_CLASSIC_FAMILY) then begin if (LValue <> DEFAULT_WINDOWS_CLASS) then - FOwnerControl.StyleElements := FOwnerControl.StyleElements - [seClient] - else - LValue := GetActiveStyleName; + FOwnerControl.StyleElements := FOwnerControl.StyleElements - [seClient]; +// else +// LValue := GetActiveStyleName; + if LValue = '' then + LValue := DEFAULT_WINDOWS_CLASS; end; - if LValue = '' then - LValue := DEFAULT_WINDOWS_CLASS; if (LValue <> Self.FStyleClass) or not FStyleApplied then begin Self.FStyleClass := LValue; @@ -2582,6 +3561,27 @@ procedure TStyledButtonRender.SetText(const AValue: TCaption); end; end; +procedure TStyledButtonRender.SetCaptionAlignment(const AValue: TAlignment); +begin + if FCaptionAlignment <> AValue then + begin + FCaptionAlignment := AValue; + Invalidate; + end; +end; + +procedure TStyledButtonRender.SetTransparent(const AValue: Boolean); +begin + if FTransparent <> AValue then + begin + FTransparent := AValue; + if AValue then + FOwnerControl.ControlStyle := FOwnerControl.ControlStyle - [csOpaque] else + FOwnerControl.ControlStyle := FOwnerControl.ControlStyle + [csOpaque]; + Invalidate; + end; +end; + procedure TStyledButtonRender.SetWordWrap(const AValue: Boolean); begin if FWordWrap <> AValue then @@ -2595,7 +3595,7 @@ procedure TStyledButtonRender.Loaded; begin inherited; SetImageIndex(ImageIndex); - if not FStyleApplied then + if not FStyleApplied (*and not HasCustomAttributes*) then begin StyleFamilyUpdateAttributesByModalResult(FModalResult, FStyleFamily, FStyleClass, FStyleAppearance); @@ -2623,7 +3623,8 @@ function TStyledButtonRender.GetSplitButtonWidth: Integer; procedure TStyledButtonRender.MouseMove(Shift: TShiftState; X, Y: Integer); begin inherited; - FMouseOverDropDown := (FStyle = bsSplitButton) and (X >= FDropDownRect.Left); + FMouseOverDropDown := (FStyle = TCustomButton.TButtonStyle.bsSplitButton) + and (X >= FDropDownRect.Left); end; procedure TStyledButtonRender.MouseUp(Button: TMouseButton; @@ -2631,9 +3632,16 @@ procedure TStyledButtonRender.MouseUp(Button: TMouseButton; begin if Enabled then begin - State := bsUp; + if GroupIndex <> 0 then + begin + if AllowAllUp and Down then + Down := False + else + Down := True; + end + else + State := bsUp; Invalidate; - inherited; end; end; @@ -2650,6 +3658,15 @@ procedure TStyledButtonRender.SetAction(const AAction: TCustomAction); FOwnerControl.Action := AAction; end; +procedure TStyledButtonRender.SetAllowAllUp(const AValue: Boolean); +begin + if FAllowAllUp <> AValue then + begin + FAllowAllUp := AValue; + Invalidate; + end; +end; + function TStyledButtonRender.GetName: TComponentName; begin Result := FOwnerControl.Name; @@ -2660,7 +3677,12 @@ function TStyledButtonRender.GetNumGlyphs: TNumGlyphs; Result := FNumGlyphs; end; -procedure TStyledGraphicButton.SetNumGlyphs(const AValue: TNumGlyphs); +function TStyledButtonRender.GetOwnerScaleFactor: Single; +begin + Result := {$IFDEF D10_3+}FOwnerControl.ScaleFactor{$ELSE}1{$ENDIF}; +end; + +procedure TCustomStyledGraphicButton.SetNumGlyphs(const AValue: TNumGlyphs); begin FRender.NumGlyphs := AValue; end; @@ -2680,6 +3702,15 @@ function TStyledButtonRender.GetControlEnabled: Boolean; Result := FOwnerControl.Enabled; end; +procedure TStyledButtonRender.SetCommandLinkHint(const AValue: string); +begin + if FCommandLinkHint <> AValue then + begin + FCommandLinkHint := AValue; + Invalidate; + end; +end; + procedure TStyledButtonRender.SetControlEnabled(const AValue: Boolean); begin FOwnerControl.Enabled := AValue; @@ -2759,19 +3790,19 @@ procedure TStyledButtonRender.Invalidate; FOwnerControl.Invalidate; end; -{ TStyledGraphicButton } +{ TCustomStyledGraphicButton } -procedure TStyledGraphicButton.AssignStyleTo(ADestRender: TStyledButtonRender); +procedure TCustomStyledGraphicButton.AssignStyleTo(ADestRender: TStyledButtonRender); begin FRender.AssignStyleTo(ADestRender); end; -procedure TStyledGraphicButton.AssignStyleTo(ADest: TStyledGraphicButton); +procedure TCustomStyledGraphicButton.AssignStyleTo(ADest: TCustomStyledGraphicButton); begin FRender.AssignStyleTo(ADest.Render); end; -function TStyledGraphicButton.AssignAttributes( +function TCustomStyledGraphicButton.AssignAttributes( const AEnabled: Boolean = True; const AImageList: TCustomImageList = nil; {$IFDEF D10_4+}const AImageName: string = '';{$ENDIF} @@ -2779,7 +3810,7 @@ function TStyledGraphicButton.AssignAttributes( const AImageAlignment: TImageAlignment = iaLeft; const AAction: TCustomAction = nil; const AOnClick: TNotifyEvent = nil; - const AName: string = ''): TStyledGraphicButton; + const AName: string = ''): TCustomStyledGraphicButton; begin Result := FRender.AssignAttributes(AEnabled, AImageList, @@ -2788,41 +3819,42 @@ function TStyledGraphicButton.AssignAttributes( AImageAlignment, AAction, AOnClick, - AName) as TStyledGraphicButton; + AName) as TCustomStyledGraphicButton; end; -procedure TStyledGraphicButton.AssignTo(ADest: TPersistent); +procedure TCustomStyledGraphicButton.AssignTo(ADest: TPersistent); var - LDest: TStyledGraphicButton; + LDest: TCustomStyledGraphicButton; begin inherited AssignTo(ADest); - if ADest is TStyledGraphicButton then + if ADest is TCustomStyledGraphicButton then begin - LDest := TStyledGraphicButton(ADest); + LDest := TCustomStyledGraphicButton(ADest); FRender.AssignStyleTo(LDest.Render); + LDest.Cursor := Self.Cursor; LDest.Hint := Self.Hint; LDest.Visible := Self.Visible; LDest.Caption := Self.Caption; LDest.ModalResult := Self.ModalResult; LDest.Tag := Self.Tag; LDest.Enabled := Self.Enabled; - LDest.Hint := Self.Hint; - LDest.Visible := Self.Visible; + LDest.Down := Self.Down; + LDest.AllowAllUp := Self.AllowAllUp; end; end; -procedure TStyledGraphicButton.BeginUpdate; +procedure TCustomStyledGraphicButton.BeginUpdate; begin FRender.BeginUpdate; end; -procedure TStyledGraphicButton.EndUpdate; +procedure TCustomStyledGraphicButton.EndUpdate; begin FRender.EndUpdate; end; {$IFDEF HiDPISupport} -procedure TStyledGraphicButton.ChangeScale(M, D: Integer; isDpiChange: Boolean); +procedure TCustomStyledGraphicButton.ChangeScale(M, D: Integer; isDpiChange: Boolean); begin if isDpiChange then begin @@ -2840,7 +3872,7 @@ procedure TStyledGraphicButton.ChangeScale(M, D: Integer; isDpiChange: Boolean); end; {$ENDIF} -procedure TStyledGraphicButton.CMDialogChar(var Message: TCMDialogChar); +procedure TCustomStyledGraphicButton.CMDialogChar(var Message: TCMDialogChar); begin with Message do if IsAccel(CharCode, Caption) and Visible then @@ -2851,98 +3883,127 @@ procedure TStyledGraphicButton.CMDialogChar(var Message: TCMDialogChar); inherited; end; -procedure TStyledGraphicButton.CMEnabledChanged(var Message: TMessage); +procedure TCustomStyledGraphicButton.CMEnabledChanged(var Message: TMessage); begin inherited; FRender.CMEnabledChanged(Message); end; -procedure TStyledGraphicButton.CMEnter(var Message: TCMEnter); +procedure TCustomStyledGraphicButton.CMEnter(var Message: TCMEnter); begin inherited; FRender.CMEnter(Message); end; -procedure TStyledGraphicButton.CMMouseEnter(var Message: TNotifyEvent); +procedure TCustomStyledGraphicButton.CMMouseEnter(var Message: TNotifyEvent); begin inherited; FRender.CMMouseEnter(Message); end; -procedure TStyledGraphicButton.CMMouseLeave(var Message: TNotifyEvent); +procedure TCustomStyledGraphicButton.CMMouseLeave(var Message: TNotifyEvent); begin inherited; FRender.CMMouseLeave(Message); end; -procedure TStyledGraphicButton.CMStyleChanged(var Message: TMessage); +procedure TCustomStyledGraphicButton.CMStyleChanged(var Message: TMessage); begin inherited; FRender.CMStyleChanged(Message); end; -procedure TStyledGraphicButton.Click; +procedure TCustomStyledGraphicButton.Click; begin FRender.Click(False); end; -constructor TStyledGraphicButton.CreateStyled(AOwner: TComponent; +constructor TCustomStyledGraphicButton.CreateStyled(AOwner: TComponent; const AFamily: TStyledButtonFamily; const AClass: TStyledButtonClass; const AAppearance: TStyledButtonAppearance); begin inherited Create(AOwner); FImageIndex := -1; - {$IFDEF D10_4+} - FImageName := ''; - {$ENDIF} FRender := GetRenderClass.CreateStyled(Self, - ControlClick, ControlFont, GetCaption, SetCaption, + ControlClick, ControlFont, GetCaptionToDraw, SetCaption, GetParentFont, SetParentFont, - AFamily, AClass, AAppearance); + AFamily, AClass, AAppearance, + _DefaultStyleDrawType, _DefaultCursor, _UseCustomDrawType); end; -constructor TStyledGraphicButton.Create(AOwner: TComponent); +constructor TCustomStyledGraphicButton.Create(AOwner: TComponent); begin CreateStyled(AOwner, - DEFAULT_CLASSIC_FAMILY, - DEFAULT_WINDOWS_CLASS, - DEFAULT_APPEARANCE); + _DefaultFamily, + _DefaultClass, + _DefaultAppearance); +end; + +constructor TCustomStyledGraphicButton.CreateStyled(AOwner: TComponent; + const AFamily: TStyledButtonFamily; const AClass: TStyledButtonClass; + const AAppearance: TStyledButtonAppearance; + const ADrawType: TStyledButtonDrawType; + const ACursor: TCursor; + const AUseCustomDrawType: Boolean); +begin + inherited Create(AOwner); + FImageIndex := -1; + FRender := GetRenderClass.CreateStyled(Self, + ControlClick, ControlFont, GetCaptionToDraw, SetCaption, + GetParentFont, SetParentFont, + AFamily, AClass, AAppearance, + ADrawType, ACursor, AUseCustomDrawType); end; -procedure TStyledGraphicButton.ActionChange(Sender: TObject; CheckDefaults: Boolean); +procedure TCustomStyledGraphicButton.ActionChange(Sender: TObject; CheckDefaults: Boolean); begin inherited; FRender.ActionChange(Sender, CheckDefaults); end; -destructor TStyledGraphicButton.Destroy; +function TCustomStyledGraphicButton.IsCaptionAlignmentStored: Boolean; +begin + Result := FRender.IsCaptionAlignmentStored; +end; + +destructor TCustomStyledGraphicButton.Destroy; begin FreeAndNil(FRender); inherited Destroy; end; -procedure TStyledGraphicButton.DoDropDownMenu; +procedure TCustomStyledGraphicButton.DoDropDownMenu; begin FRender.DoDropDownMenu; end; -function TStyledGraphicButton.GetText: TCaption; +function TCustomStyledGraphicButton.GetText: TCaption; begin Result := FRender.GetText; end; -function TStyledGraphicButton.GetKind: TBitBtnKind; +function TCustomStyledGraphicButton.GetTransparent: Boolean; +begin + Result := FRender.Transparent; +end; + +function TCustomStyledGraphicButton.GetKind: TBitBtnKind; begin Result := FRender.Kind; end; -function TStyledGraphicButton.ImageMarginsStored: Boolean; +function TCustomStyledGraphicButton.GetLayout: TButtonLayout; +begin + Result := FRender.Layout; +end; + +function TCustomStyledGraphicButton.ImageMarginsStored: Boolean; begin Result := not FRender.IsDefaultImageMargins; end; -function TStyledGraphicButton.IsCaptionStored: Boolean; +function TCustomStyledGraphicButton.IsCaptionStored: Boolean; begin if (ActionLink = nil) then Result := Caption <> '' @@ -2950,7 +4011,16 @@ function TStyledGraphicButton.IsCaptionStored: Boolean; Result := not TGraphicButtonActionLink(ActionLink).IsCaptionLinked; end; -function TStyledGraphicButton.IsEnabledStored: Boolean; +function TCustomStyledGraphicButton.IsCheckedStored: Boolean; +begin + if (ActionLink = nil) then + Result := FRender.Down + else + Result := not TGraphicButtonActionLink(ActionLink).IsCheckedLinked and + (FRender.Down); +end; + +function TCustomStyledGraphicButton.IsEnabledStored: Boolean; begin if (ActionLink = nil) then Result := not Enabled @@ -2958,75 +4028,81 @@ function TStyledGraphicButton.IsEnabledStored: Boolean; Result := not TGraphicButtonActionLink(ActionLink).IsEnabledLinked; end; -function TStyledGraphicButton.IsImageIndexStored: Boolean; +function TCustomStyledGraphicButton.IsImageIndexStored: Boolean; begin if (ActionLink = nil) then Result := FImageIndex <> -1 else - Result := not TGraphicButtonActionLink(ActionLink).IsImageIndexLinked; + Result := not TGraphicButtonActionLink(ActionLink).IsImageIndexLinked and + (FImageIndex <> -1); +end; + +function TCustomStyledGraphicButton.IsNotificationBadgeStored: Boolean; +begin + Result := FRender.IsNotificationBadgeStored; end; -function TStyledGraphicButton.IsCustomDrawType: Boolean; +function TCustomStyledGraphicButton.IsCustomDrawType: Boolean; begin Result := FRender.IsCustomDrawType; end; -function TStyledGraphicButton.IsCustomRadius: Boolean; +function TCustomStyledGraphicButton.IsCustomRadius: Boolean; begin Result := FRender.IsCustomRadius; end; -function TStyledGraphicButton.IsStoredStyleFamily: Boolean; +function TCustomStyledGraphicButton.IsStoredStyleFamily: Boolean; begin Result := FRender.IsStoredStyleFamily; end; -function TStyledGraphicButton.IsStoredStyleClass: Boolean; +function TCustomStyledGraphicButton.IsStoredStyleClass: Boolean; begin Result := FRender.IsStoredStyleClass; end; -function TStyledGraphicButton.IsStoredStyleAppearance: Boolean; +function TCustomStyledGraphicButton.IsStoredStyleAppearance: Boolean; begin Result := FRender.IsStoredStyleAppearance; end; -function TStyledGraphicButton.IsStoredStyleElements: Boolean; +function TCustomStyledGraphicButton.IsStoredStyleElements: Boolean; begin Result := FRender.IsStoredStyleElements; end; -function TStyledGraphicButton.IsStyleDisabledStored: Boolean; +function TCustomStyledGraphicButton.IsStyleDisabledStored: Boolean; begin Result := FRender.IsStyleDisabledStored; end; -function TStyledGraphicButton.IsStylePressedStored: Boolean; +function TCustomStyledGraphicButton.IsStylePressedStored: Boolean; begin Result := FRender.IsStylePressedStored; end; -function TStyledGraphicButton.IsStyleSelectedStored: Boolean; +function TCustomStyledGraphicButton.IsStyleSelectedStored: Boolean; begin Result := FRender.IsStyleSelectedStored; end; -function TStyledGraphicButton.IsStyleHotStored: Boolean; +function TCustomStyledGraphicButton.IsStyleHotStored: Boolean; begin Result := FRender.IsStyleHotStored; end; -function TStyledGraphicButton.IsStyleNormalStored: Boolean; +function TCustomStyledGraphicButton.IsStyleNormalStored: Boolean; begin Result := FRender.IsStyleNormalStored; end; -function TStyledGraphicButton.GetButtonState: TStyledButtonState; +function TCustomStyledGraphicButton.GetButtonState: TStyledButtonState; begin //Getting button state if not Enabled then Result := bsmDisabled - else if FRender.State = bsDown then + else if (FRender.State = bsDown) or (FRender.Down) then Result := bsmPressed else if Focused then Result := bsmSelected @@ -3036,84 +4112,108 @@ function TStyledGraphicButton.GetButtonState: TStyledButtonState; Result := bsmNormal; end; -function TStyledGraphicButton.GetFlat: Boolean; +function TCustomStyledGraphicButton.GetFlat: Boolean; begin Result := FRender.Flat; end; -function TStyledGraphicButton.GetFocused: Boolean; +function TCustomStyledGraphicButton.GetFocused: Boolean; begin Result := False; end; -function TStyledGraphicButton.GetGlyph: TBitmap; +function TCustomStyledGraphicButton.GetGlyph: TBitmap; begin Result := FRender.Glyph; end; -procedure TStyledGraphicButton.SetGlyph(const AValue: TBitmap); +function TCustomStyledGraphicButton.GetGroupIndex: Integer; +begin + Result := FRender.GroupIndex; +end; + +procedure TCustomStyledGraphicButton.SetGlyph(const AValue: TBitmap); begin FRender.Glyph := AValue; end; -procedure TStyledGraphicButton.Paint; +procedure TCustomStyledGraphicButton.SetGroupIndex(const AValue: Integer); +begin + FRender.GroupIndex := AValue; +end; + +procedure TCustomStyledGraphicButton.Paint; +begin + FRender.DrawButton(Canvas, not Transparent); +end; + +class procedure TCustomStyledGraphicButton.RegisterDefaultRenderingStyle( + const ADrawType: TStyledButtonDrawType; const AFamily: TStyledButtonFamily; + const AClass: TStyledButtonClass; const AAppearance: TStyledButtonAppearance; + const AStyleRadius: Integer; const ACursor: TCursor); begin - FRender.DrawButton(Canvas, False); + _DefaultStyleDrawType := ADrawType; + _UseCustomDrawType := True; + _DefaultFamily := AFamily; + _DefaultClass := AClass; + _DefaultAppearance := AAppearance; + _DefaultStyleRadius := AStyleRadius; + _DefaultCursor := ACursor; end; -function TStyledGraphicButton.GetRenderClass: TStyledButtonRenderClass; +function TCustomStyledGraphicButton.GetRenderClass: TStyledButtonRenderClass; begin Result := TStyledButtonRender; end; -function TStyledGraphicButton.GetRescalingButton: Boolean; +function TCustomStyledGraphicButton.GetRescalingButton: Boolean; begin Result := Assigned(FRender) and FRender.RescalingButton; end; -procedure TStyledGraphicButton.SetRescalingButton(const AValue: Boolean); +procedure TCustomStyledGraphicButton.SetRescalingButton(const AValue: Boolean); begin if Assigned(FRender) then FRender.RescalingButton := AValue; end; -function TStyledGraphicButton.GetStyleDrawType: TStyledButtonDrawType; +function TCustomStyledGraphicButton.GetStyleDrawType: TStyledButtonDrawType; begin Result := FRender.StyleDrawType; end; -procedure TStyledGraphicButton.SetStyleDrawType(const AValue: TStyledButtonDrawType); +procedure TCustomStyledGraphicButton.SetStyleDrawType(const AValue: TStyledButtonDrawType); begin FRender.StyleDrawType := AValue; end; -function TStyledGraphicButton.GetImage(out AImageList: TCustomImageList; +function TCustomStyledGraphicButton.GetImage(out AImageList: TCustomImageList; out AImageIndex: Integer): Boolean; begin - Result := FRender.GetImage(AImageList, AImageIndex); + Result := FRender.GetInternalImage(AImageList, AImageIndex); end; -function TStyledGraphicButton.GetImageAlignment: TImageAlignment; +function TCustomStyledGraphicButton.GetImageAlignment: TImageAlignment; begin Result := FRender.ImageAlignment; end; -procedure TStyledGraphicButton.SetImageAlignment(const AValue: TImageAlignment); +procedure TCustomStyledGraphicButton.SetImageAlignment(const AValue: TImageAlignment); begin FRender.ImageAlignment := AValue; end; -function TStyledGraphicButton.GetDisabledImageIndex: TImageIndex; +function TCustomStyledGraphicButton.GetDisabledImageIndex: TImageIndex; begin Result := FRender.DisabledImageIndex; end; -procedure TStyledGraphicButton.SetDisabledImageIndex(const AValue: TImageIndex); +procedure TCustomStyledGraphicButton.SetDisabledImageIndex(const AValue: TImageIndex); begin FRender.DisabledImageIndex := AValue; end; -procedure TStyledGraphicButton.SetImageIndex(const AValue: TImageIndex); +procedure TCustomStyledGraphicButton.SetImageIndex(const AValue: TImageIndex); begin if AValue <> FImageIndex then begin @@ -3123,28 +4223,28 @@ procedure TStyledGraphicButton.SetImageIndex(const AValue: TImageIndex); end; {$IFDEF D10_4+} -function TStyledGraphicButton.GetDisabledImageName: TImageName; +function TCustomStyledGraphicButton.GetDisabledImageName: TImageName; begin Result := FRender.DisabledImageName; end; -procedure TStyledGraphicButton.SetDisabledImageName(const AValue: TImageName); +procedure TCustomStyledGraphicButton.SetDisabledImageName(const AValue: TImageName); begin FRender.DisabledImageName := AValue; end; -function TStyledGraphicButton.IsImageNameStored: Boolean; +function TCustomStyledGraphicButton.IsImageNameStored: Boolean; begin Result := (ActionLink = nil) or not TGraphicButtonActionLink(ActionLink).IsImageNameLinked; end; -function TStyledGraphicButton.GetImageName: TImageName; +function TCustomStyledGraphicButton.GetImageName: TImageName; begin Result := FImageName; end; -procedure TStyledGraphicButton.SetImageName(const AValue: TImageName); +procedure TCustomStyledGraphicButton.SetImageName(const AValue: TImageName); begin if AValue <> FImageName then begin @@ -3153,124 +4253,158 @@ procedure TStyledGraphicButton.SetImageName(const AValue: TImageName); end; end; -function TStyledGraphicButton.GetHotImageName: TImageName; +function TCustomStyledGraphicButton.GetHotImageName: TImageName; begin Result := FRender.HotImageName; end; -procedure TStyledGraphicButton.SetHotImageName(const AValue: TImageName); +procedure TCustomStyledGraphicButton.SetHotImageName(const AValue: TImageName); begin FRender.HotImageName := AValue; end; -function TStyledGraphicButton.GetPressedImageName: TImageName; +function TCustomStyledGraphicButton.GetPressedImageName: TImageName; begin Result := FRender.PressedImageName; end; -procedure TStyledGraphicButton.SetPressedImageName(const AValue: TImageName); +procedure TCustomStyledGraphicButton.SetPressedImageName(const AValue: TImageName); begin FRender.PressedImageName := AValue; end; -function TStyledGraphicButton.GetSelectedImageName: TImageName; +function TCustomStyledGraphicButton.GetSelectedImageName: TImageName; begin Result := FRender.SelectedImageName; end; -procedure TStyledGraphicButton.SetSelectedImageName(const AValue: TImageName); +procedure TCustomStyledGraphicButton.SetSelectedImageName(const AValue: TImageName); begin FRender.SelectedImageName := AValue; end; {$ENDIF} -function TStyledGraphicButton.GetActionLinkClass: TControlActionLinkClass; +function TCustomStyledGraphicButton.GetActionLinkClass: TControlActionLinkClass; begin Result := TGraphicButtonActionLink; end; -(* -function TStyledGraphicButton.GetActiveStyleName: string; + +function TCustomStyledGraphicButton.GetActiveStyleName: string; begin Result := FRender.ActiveStyleName; end; -*) -procedure TStyledGraphicButton.UpdateStyleElements; + +function TCustomStyledGraphicButton.GetAllowAllUp: Boolean; begin - FRender.UpdateStyleElements; - inherited; + Result := FRender.AllowAllUp; +end; + +function TCustomStyledGraphicButton.GetAsVCLComponent: Boolean; +begin + Result := FRender.AsVCLComponent; end; -function TStyledGraphicButton.GetDisabledImages: TCustomImageList; +function TCustomStyledGraphicButton.GetDisabledImages: TCustomImageList; begin Result := FRender.DisabledImages; end; -procedure TStyledGraphicButton.SetDisabledImages(const AValue: TCustomImageList); +function TCustomStyledGraphicButton.GetDown: Boolean; +begin + Result := FRender.Down; +end; + +procedure TCustomStyledGraphicButton.SetDisabledImages(const AValue: TCustomImageList); begin FRender.DisabledImages := AValue; end; -function TStyledGraphicButton.GetDropDownMenu: TPopupMenu; +procedure TCustomStyledGraphicButton.SetDown(const AValue: Boolean); +begin + FRender.Down := AValue; +end; + +function TCustomStyledGraphicButton.GetDropDownMenu: TPopupMenu; begin Result := FRender.DropDownMenu; end; -procedure TStyledGraphicButton.SetDropDownMenu(const AValue: TPopupMenu); +procedure TCustomStyledGraphicButton.SetDropDownMenu(const AValue: TPopupMenu); begin FRender.DropDownMenu := AValue; end; -procedure TStyledGraphicButton.SetFlat(const AValue: Boolean); +procedure TCustomStyledGraphicButton.SetFlat(const AValue: Boolean); begin FRender.Flat := AValue; end; -function TStyledGraphicButton.GetHotImageIndex: TImageIndex; +function TCustomStyledGraphicButton.GetHotImageIndex: TImageIndex; begin Result := FRender.HotImageIndex; end; -procedure TStyledGraphicButton.SetHotImageIndex(const AValue: TImageIndex); +procedure TCustomStyledGraphicButton.SetHotImageIndex(const AValue: TImageIndex); begin FRender.HotImageIndex := AValue; end; -function TStyledGraphicButton.GetImages: TCustomImageList; +function TCustomStyledGraphicButton.GetImages: TCustomImageList; begin Result := FRender.Images; end; -procedure TStyledGraphicButton.SetImages(const AValue: TCustomImageList); +procedure TCustomStyledGraphicButton.SetImages(const AValue: TCustomImageList); begin FRender.Images := AValue; end; -procedure TStyledGraphicButton.SetKind(const AValue: TBitBtnKind); +procedure TCustomStyledGraphicButton.SetKind(const AValue: TBitBtnKind); begin FRender.Kind := AValue; end; -function TStyledGraphicButton.GetModalResult: TModalResult; +function TCustomStyledGraphicButton.GetMargin: Integer; +begin + Result := FRender.Margin; +end; + +procedure TCustomStyledGraphicButton.SetLayout(const AValue: TButtonLayout); +begin + FRender.Layout := AValue; +end; + +function TCustomStyledGraphicButton.GetModalResult: TModalResult; begin Result := FRender.ModalResult; end; -function TStyledGraphicButton.GetMouseInControl: Boolean; +function TCustomStyledGraphicButton.GetMouseInControl: Boolean; begin Result := FRender.MouseInControl; end; -function TStyledGraphicButton.GetNumGlyphs: TNumGlyphs; +function TCustomStyledGraphicButton.GetNotificationBadge: TNotificationBadgeAttributes; +begin + Result := FRender.NotificationBadge; +end; + +function TCustomStyledGraphicButton.GetNumGlyphs: TNumGlyphs; begin Result := FRender.NumGlyphs; end; -procedure TStyledGraphicButton.SetModalResult(const AValue: TModalResult); +procedure TCustomStyledGraphicButton.SetMargin(const AValue: Integer); +begin + FRender.Margin := AValue; +end; + +procedure TCustomStyledGraphicButton.SetModalResult(const AValue: TModalResult); begin FRender.ModalResult := AValue; end; -procedure TStyledGraphicButton.SetName(const AValue: TComponentName); +procedure TCustomStyledGraphicButton.SetName(const AValue: TComponentName); var LOldValue: string; begin @@ -3280,37 +4414,43 @@ procedure TStyledGraphicButton.SetName(const AValue: TComponentName); Invalidate; end; -function TStyledGraphicButton.GetOnDropDownClick: TNotifyEvent; +procedure TCustomStyledGraphicButton.SetNotificationBadge( + const AValue: TNotificationBadgeAttributes); +begin + FRender.NotificationBadge := AValue; +end; + +function TCustomStyledGraphicButton.GetOnDropDownClick: TNotifyEvent; begin Result := FRender.OnDropDownClick; end; -procedure TStyledGraphicButton.SetOnDropDownClick(const AValue: TNotifyEvent); +procedure TCustomStyledGraphicButton.SetOnDropDownClick(const AValue: TNotifyEvent); begin FRender.OnDropDownClick := AValue; end; -function TStyledGraphicButton.GetPressedImageIndex: TImageIndex; +function TCustomStyledGraphicButton.GetPressedImageIndex: TImageIndex; begin Result := FRender.PressedImageIndex; end; -procedure TStyledGraphicButton.SetPressedImageIndex(const AValue: TImageIndex); +procedure TCustomStyledGraphicButton.SetPressedImageIndex(const AValue: TImageIndex); begin FRender.PressedImageIndex := AValue; end; -function TStyledGraphicButton.GetButtonStyleNormal: TStyledButtonAttributes; +function TCustomStyledGraphicButton.GetButtonStyleNormal: TStyledButtonAttributes; begin Result := FRender.ButtonStyleNormal; end; -procedure TStyledGraphicButton.SetButtonStyleNormal(const AValue: TStyledButtonAttributes); +procedure TCustomStyledGraphicButton.SetButtonStyleNormal(const AValue: TStyledButtonAttributes); begin FRender.ButtonStyleNormal := AValue; end; -procedure TStyledGraphicButton.SetButtonStyle( +procedure TCustomStyledGraphicButton.SetButtonStyle( const AStyleFamily: TStyledButtonFamily; const AStyleClass: TStyledButtonClass; const AStyleAppearance: TStyledButtonAppearance); @@ -3318,148 +4458,205 @@ procedure TStyledGraphicButton.SetButtonStyle( FRender.SetButtonStyle(AStyleFamily, AStyleClass, AStyleAppearance); end; -procedure TStyledGraphicButton.SetButtonStyle(const AStyleFamily: TStyledButtonFamily; +procedure TCustomStyledGraphicButton.SetAllowAllUp(const AValue: Boolean); +begin + FRender.AllowAllUp := AValue; +end; + +procedure TCustomStyledGraphicButton.SetAsVCLComponent(const AValue: Boolean); +begin + FRender.AsVCLComponent := AValue; +end; + +procedure TCustomStyledGraphicButton.SetButtonStyle(const AStyleFamily: TStyledButtonFamily; const AModalResult: TModalResult); begin FRender.SetButtonStyle(AStyleFamily, AModalResult); end; -function TStyledGraphicButton.GetButtonStyleDisabled: TStyledButtonAttributes; +function TCustomStyledGraphicButton.GetButtonStyleDisabled: TStyledButtonAttributes; begin Result := FRender.ButtonStyleDisabled; end; -procedure TStyledGraphicButton.SetButtonStyleDisabled(const AValue: TStyledButtonAttributes); +procedure TCustomStyledGraphicButton.SetButtonStyleDisabled(const AValue: TStyledButtonAttributes); begin FRender.ButtonStyleDisabled := AValue; end; -function TStyledGraphicButton.GetButtonStylePressed: TStyledButtonAttributes; +function TCustomStyledGraphicButton.GetButtonStylePressed: TStyledButtonAttributes; begin Result := FRender.ButtonStylePressed; end; -procedure TStyledGraphicButton.SetButtonStylePressed(const AValue: TStyledButtonAttributes); +procedure TCustomStyledGraphicButton.SetButtonStylePressed(const AValue: TStyledButtonAttributes); begin FRender.ButtonStylePressed := AValue; end; -function TStyledGraphicButton.GetButtonStyleSelected: TStyledButtonAttributes; +function TCustomStyledGraphicButton.GetButtonStyleSelected: TStyledButtonAttributes; begin Result := FRender.ButtonStyleSelected; end; -procedure TStyledGraphicButton.SetButtonStyleSelected(const AValue: TStyledButtonAttributes); +procedure TCustomStyledGraphicButton.SetButtonStyleSelected(const AValue: TStyledButtonAttributes); begin FRender.ButtonStyleSelected := AValue; end; -function TStyledGraphicButton.GetButtonStyleHot: TStyledButtonAttributes; +function TCustomStyledGraphicButton.GetButtonStyleHot: TStyledButtonAttributes; begin Result := FRender.ButtonStyleHot; end; -procedure TStyledGraphicButton.SetButtonStyleHot(const AValue: TStyledButtonAttributes); +procedure TCustomStyledGraphicButton.SetButtonStyleHot(const AValue: TStyledButtonAttributes); begin FRender.ButtonStyleHot := AValue; end; -function TStyledGraphicButton.GetImageMargins: TImageMargins; +function TCustomStyledGraphicButton.GetImageMargins: TImageMargins; begin Result := FRender.ImageMargins; end; -procedure TStyledGraphicButton.SetImageMargins(const AValue: TImageMargins); +procedure TCustomStyledGraphicButton.SetImageMargins(const AValue: TImageMargins); begin FRender.ImageMargins := AValue; end; -function TStyledGraphicButton.GetStyleRadius: Integer; +function TCustomStyledGraphicButton.GetStyleRadius: Integer; begin Result := FRender.StyleRadius; end; -procedure TStyledGraphicButton.SetStyleRadius(const AValue: Integer); +function TCustomStyledGraphicButton.GetStyleRoundedCorners: TRoundedCorners; +begin + Result := FRender.StyleRoundedCorners; +end; + +procedure TCustomStyledGraphicButton.SetStyleRadius(const AValue: Integer); begin FRender.StyleRadius := AValue; end; -function TStyledGraphicButton.GetSelectedImageIndex: TImageIndex; +procedure TCustomStyledGraphicButton.SetStyleRoundedCorners( + const AValue: TRoundedCorners); +begin + FRender.StyleRoundedCorners := AValue; +end; + +function TCustomStyledGraphicButton.GetSelectedImageIndex: TImageIndex; begin Result := FRender.SelectedImageIndex; end; -function TStyledGraphicButton.GetSplitButtonWidth: Integer; +function TCustomStyledGraphicButton.GetShowCaption: Boolean; +begin + Result := FRender.ShowCaption; +end; + +function TCustomStyledGraphicButton.GetSpacing: Integer; +begin + Result := FRender.Spacing; +end; + +function TCustomStyledGraphicButton.GetSplitButtonWidth: Integer; begin Result := FRender.GetSplitButtonWidth; end; -procedure TStyledGraphicButton.SetSelectedImageIndex(const AValue: TImageIndex); +procedure TCustomStyledGraphicButton.SetSelectedImageIndex(const AValue: TImageIndex); begin FRender.SelectedImageIndex := AValue; end; -function TStyledGraphicButton.GetStyle: TStyledButtonStyle; +procedure TCustomStyledGraphicButton.SetShowCaption(const AValue: Boolean); +begin + FRender.ShowCaption := AValue; +end; + +procedure TCustomStyledGraphicButton.SetSpacing(const AValue: Integer); +begin + FRender.Spacing := AValue; +end; + +function TCustomStyledGraphicButton.GetStyle: TCustomButton.TButtonStyle; begin Result := FRender.Style; end; -procedure TStyledGraphicButton.SetStyle(const AValue: TStyledButtonStyle); +procedure TCustomStyledGraphicButton.SetStyle(const AValue: TCustomButton.TButtonStyle); begin FRender.Style := AValue; end; -function TStyledGraphicButton.GetStyleAppearance: TStyledButtonAppearance; +function TCustomStyledGraphicButton.GetStyleAppearance: TStyledButtonAppearance; begin Result := FRender.StyleAppearance; end; -procedure TStyledGraphicButton.SetStyleAppearance(const AValue: TStyledButtonAppearance); +procedure TCustomStyledGraphicButton.SetStyleAppearance(const AValue: TStyledButtonAppearance); begin FRender.StyleAppearance := AValue; end; -function TStyledGraphicButton.GetStyleApplied: Boolean; +function TCustomStyledGraphicButton.GetStyleApplied: Boolean; begin Result := FRender.StyleApplied; end; -procedure TStyledGraphicButton.SetStyleApplied(const AValue: Boolean); +procedure TCustomStyledGraphicButton.SetStyleApplied(const AValue: Boolean); begin FRender.StyleApplied := AValue; end; -function TStyledGraphicButton.GetStyleClass: TStyledButtonClass; +function TCustomStyledGraphicButton.GetStyleClass: TStyledButtonClass; begin Result := FRender.StyleClass; end; -procedure TStyledGraphicButton.SetStyleClass(const AValue: TStyledButtonClass); +procedure TCustomStyledGraphicButton.SetStyleClass(const AValue: TStyledButtonClass); begin FRender.StyleClass := AValue; end; -function TStyledGraphicButton.GetStyleFamily: TStyledButtonFamily; +function TCustomStyledGraphicButton.GetStyleFamily: TStyledButtonFamily; begin Result := FRender.StyleFamily; end; -procedure TStyledGraphicButton.SetStyleFamily(const AValue: TStyledButtonFamily); +procedure TCustomStyledGraphicButton.SetStyleFamily(const AValue: TStyledButtonFamily); begin FRender.StyleFamily := AValue; end; -procedure TStyledGraphicButton.SetText(const AValue: TCaption); +{$IFDEF D10_4+} +procedure TCustomStyledGraphicButton.SetStyleName(const AValue: string); +begin + if (AValue <> '') and (StyleFamily <> DEFAULT_CLASSIC_FAMILY) then + StyleFamily := DEFAULT_CLASSIC_FAMILY; + inherited; + if (AValue <> '') then + StyleClass := AValue; +end; +{$ENDIF} + +procedure TCustomStyledGraphicButton.SetText(const AValue: TCaption); begin FRender.Caption := AValue; end; -function TStyledGraphicButton.GetWordWrap: Boolean; +procedure TCustomStyledGraphicButton.SetTransparent(const AValue: Boolean); +begin + FRender.Transparent := AValue; +end; + +function TCustomStyledGraphicButton.GetWordWrap: Boolean; begin Result := FRender.WordWrap; end; -function TStyledGraphicButton.HasCustomGlyph: Boolean; +function TCustomStyledGraphicButton.HasCustomGlyph: Boolean; var Link: TGraphicButtonActionLink; begin @@ -3468,23 +4665,23 @@ function TStyledGraphicButton.HasCustomGlyph: Boolean; Link.IsGlyphLinked(ImageIndex)); end; -procedure TStyledGraphicButton.SetWordWrap(const AValue: Boolean); +procedure TCustomStyledGraphicButton.SetWordWrap(const AValue: Boolean); begin FRender.WordWrap := AValue; end; -procedure TStyledGraphicButton.ShowDropDownMenu; +procedure TCustomStyledGraphicButton.ShowDropDownMenu; begin FRender.ShowDropDownMenu; end; -procedure TStyledGraphicButton.Loaded; +procedure TCustomStyledGraphicButton.Loaded; begin inherited; FRender.Loaded; end; -procedure TStyledGraphicButton.MouseDown(Button: TMouseButton; +procedure TCustomStyledGraphicButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin FRender.MouseDown(Button, Shift, X, Y); @@ -3492,13 +4689,13 @@ procedure TStyledGraphicButton.MouseDown(Button: TMouseButton; inherited; end; -procedure TStyledGraphicButton.MouseMove(Shift: TShiftState; X, Y: Integer); +procedure TCustomStyledGraphicButton.MouseMove(Shift: TShiftState; X, Y: Integer); begin inherited; FRender.MouseMove(Shift, X, Y); end; -procedure TStyledGraphicButton.MouseUp(Button: TMouseButton; +procedure TCustomStyledGraphicButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if Enabled then @@ -3508,42 +4705,68 @@ procedure TStyledGraphicButton.MouseUp(Button: TMouseButton; end; end; -procedure TStyledGraphicButton.ControlClick(Sender: TObject); +procedure TCustomStyledGraphicButton.ControlClick(Sender: TObject); begin inherited Click; end; -procedure TStyledGraphicButton.ControlFont(var AValue: TFont); +procedure TCustomStyledGraphicButton.ControlFont(var AValue: TFont); begin AValue := Self.Font; end; -procedure TStyledGraphicButton.SetParentFont(const AValue: Boolean); +procedure TCustomStyledGraphicButton.SetParentFont(const AValue: Boolean); begin Self.ParentFont := AValue; end; -function TStyledGraphicButton.GetParentFont: Boolean; +function TCustomStyledGraphicButton.GetParentFont: Boolean; begin Result := Self.ParentFont; end; -function TStyledGraphicButton.GetCaption: TCaption; +function TCustomStyledGraphicButton.GetCaption: TCaption; +begin + Result := inherited Caption; +end; + +function TCustomStyledGraphicButton.GetCaptionToDraw: TCaption; begin Result := inherited Caption; end; -function TStyledGraphicButton.GetCursor: TCursor; +function TCustomStyledGraphicButton.GetCaptionAlignment: TAlignment; +begin + Result := FRender.CaptionAlignment; +end; + +function TCustomStyledGraphicButton.GetCommandLinkHint: string; +begin + Result := FRender.CommandLinkHint; +end; + +function TCustomStyledGraphicButton.GetCursor: TCursor; begin Result := inherited Cursor; end; -procedure TStyledGraphicButton.SetCaption(const AValue: TCaption); +procedure TCustomStyledGraphicButton.SetCaption(const AValue: TCaption); begin inherited Caption := AValue; end; -procedure TStyledGraphicButton.SetCursor(const AValue: TCursor); +procedure TCustomStyledGraphicButton.SetCaptionAlignment( + const AValue: TAlignment); +begin + FRender.CaptionAlignment := AValue; +end; + +procedure TCustomStyledGraphicButton.SetCommandLinkHint(const AValue: string); +begin + FRender.CommandLinkHint := AValue; +end; + +procedure TCustomStyledGraphicButton.SetCursor(const AValue: TCursor); begin if AValue <> Cursor then begin @@ -3551,7 +4774,7 @@ procedure TStyledGraphicButton.SetCursor(const AValue: TCursor); end; end; -procedure TStyledGraphicButton.Notification(AComponent: TComponent; AOperation: TOperation); +procedure TCustomStyledGraphicButton.Notification(AComponent: TComponent; AOperation: TOperation); begin inherited Notification(AComponent, AOperation); if AOperation = opRemove then @@ -3568,12 +4791,12 @@ procedure TStyledGraphicButton.Notification(AComponent: TComponent; AOperation: end; end; -function TStyledGraphicButton.GetTag: Integer; +function TCustomStyledGraphicButton.GetTag: Integer; begin Result := FRender.Tag; end; -procedure TStyledGraphicButton.SetTag(const AValue: Integer); +procedure TCustomStyledGraphicButton.SetTag(const AValue: Integer); begin FRender.Tag := AValue; end; @@ -3586,10 +4809,30 @@ procedure TGraphicButtonActionLink.AssignClient(AClient: TObject); FClient := AClient as TControl; end; +function TGraphicButtonActionLink.AssignedClientRender: Boolean; +begin + Result := ClientRender <> nil; +end; + +function TGraphicButtonActionLink.ClientRender: TStyledButtonRender; +begin + if FClient is TCustomStyledGraphicButton then + Result := TCustomStyledGraphicButton(FClient).FRender + else if FClient is TCustomStyledButton then + Result := TCustomStyledButton(FClient).FRender + else + Result := nil; +end; + function TGraphicButtonActionLink.IsCheckedLinked: Boolean; begin - Result := inherited IsCheckedLinked; - (*and (FClient.Checked = TCustomAction(Action).Checked);*) + if ClientRender <> nil then + begin + Result := inherited IsCheckedLinked and AssignedClientRender and + (ClientRender.Down = TCustomAction(Action).Checked); + end + else + Result := inherited IsCheckedLinked; end; function TGraphicButtonActionLink.IsEnabledLinked: Boolean; @@ -3607,15 +4850,15 @@ function TGraphicButtonActionLink.IsGlyphLinked(Index: TImageIndex): Boolean; LRender: TStyledButtonRender; begin Result := False; - if FClient is TStyledGraphicButton then + if FClient is TCustomStyledGraphicButton then begin - LGlyph := TStyledGraphicButton(FClient).Glyph; - LRender := TStyledGraphicButton(FClient).Render; + LGlyph := TCustomStyledGraphicButton(FClient).Glyph; + LRender := TCustomStyledGraphicButton(FClient).Render; end - else if FClient is TStyledButton then + else if FClient is TCustomStyledButton then begin - LGlyph := TStyledButton(FClient).Glyph; - LRender := TStyledButton(FClient).Render; + LGlyph := TCustomStyledButton(FClient).Glyph; + LRender := TCustomStyledButton(FClient).Render; end else begin @@ -3643,13 +4886,13 @@ function TGraphicButtonActionLink.IsGlyphLinked(Index: TImageIndex): Boolean; function TGraphicButtonActionLink.IsImageIndexLinked: Boolean; begin Assert(Assigned(FClient)); - if FClient is TStyledButton then + if FClient is TCustomStyledButton then Result := inherited IsImageIndexLinked and - (TStyledButton(FClient).ImageIndex = + (TCustomStyledButton(FClient).ImageIndex = TCustomAction(Action).ImageIndex) - else if FClient is TStyledGraphicButton then + else if FClient is TCustomStyledGraphicButton then Result := inherited IsImageIndexLinked and - (TStyledGraphicButton(FClient).ImageIndex = + (TCustomStyledGraphicButton(FClient).ImageIndex = TCustomAction(Action).ImageIndex) else Result := False; @@ -3659,41 +4902,67 @@ function TGraphicButtonActionLink.IsImageIndexLinked: Boolean; function TGraphicButtonActionLink.IsImageNameLinked: Boolean; begin Result := inherited IsImageNameLinked and - (TStyledGraphicButton(FClient).ImageName = + (TCustomStyledGraphicButton(FClient).ImageName = TCustomAction(Action).ImageName); end; {$ENDIF} +procedure TGraphicButtonActionLink.SetChecked(Value: Boolean); +begin + inherited; + if IsCheckedLinked and AssignedClientRender then + ClientRender.Down := Value; +end; + procedure TGraphicButtonActionLink.SetEnabled(Value: Boolean); begin if IsEnabledLinked then FClient.Enabled := Value; end; +procedure TGraphicButtonActionLink.SetGroupIndex(Value: Integer); +begin + inherited; + if IsGroupIndexLinked and AssignedClientRender then + ClientRender.GroupIndex := Value; +end; + procedure TGraphicButtonActionLink.SetImageIndex(Value: Integer); begin if IsImageIndexLinked then begin - if (FClient is TStyledButton) then - TStyledButton(FClient).ImageIndex := Value - else if (FClient is TStyledGraphicButton) then - TStyledGraphicButton(FClient).ImageIndex := Value; + if (FClient is TCustomStyledButton) then + TCustomStyledButton(FClient).ImageIndex := Value + else if (FClient is TCustomStyledGraphicButton) then + TCustomStyledGraphicButton(FClient).ImageIndex := Value; end; end; -{ TStyledButton } +{ TStyledSpeedButton } + +constructor TStyledSpeedButton.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + SetBounds(0, 0, 23, 22); + ParentFont := True; + FRender.SetText(''); + FRender.FUseButtonLayout := True; + FRender.Transparent := True; +end; + +{ TCustomStyledButton } -procedure TStyledButton.AssignStyleTo(ADestRender: TStyledButtonRender); +procedure TCustomStyledButton.AssignStyleTo(ADestRender: TStyledButtonRender); begin FRender.AssignStyleTo(ADestRender); end; -procedure TStyledButton.AssignStyleTo(ADest: TStyledButton); +procedure TCustomStyledButton.AssignStyleTo(ADest: TCustomStyledButton); begin FRender.AssignStyleTo(ADest.Render); end; -function TStyledButton.AssignAttributes( +function TCustomStyledButton.AssignAttributes( const AEnabled: Boolean = True; const AImageList: TCustomImageList = nil; {$IFDEF D10_4+}const AImageName: string = '';{$ENDIF} @@ -3701,7 +4970,7 @@ function TStyledButton.AssignAttributes( const AImageAlignment: TImageAlignment = iaLeft; const AAction: TCustomAction = nil; const AOnClick: TNotifyEvent = nil; - const AName: string = ''): TStyledButton; + const AName: string = ''): TCustomStyledButton; begin Result := FRender.AssignAttributes(AEnabled, AImageList, @@ -3710,45 +4979,44 @@ function TStyledButton.AssignAttributes( AImageAlignment, AAction, AOnClick, - AName) as TStyledButton; + AName) as TCustomStyledButton; end; -procedure TStyledButton.AssignTo(ADest: TPersistent); +procedure TCustomStyledButton.AssignTo(ADest: TPersistent); var - LDest: TStyledButton; + LDest: TCustomStyledButton; begin inherited AssignTo(ADest); - if ADest is TStyledButton then + if ADest is TCustomStyledButton then begin - if ADest is TStyledButton then + if ADest is TCustomStyledButton then begin - LDest := TStyledButton(ADest); + LDest := TCustomStyledButton(ADest); FRender.AssignStyleTo(LDest.Render); + LDest.Cursor := Self.Cursor; LDest.Hint := Self.Hint; LDest.Visible := Self.Visible; LDest.Caption := Self.Caption; LDest.ModalResult := Self.ModalResult; LDest.Tag := Self.Tag; LDest.Enabled := Self.Enabled; - LDest.Hint := Self.Hint; - LDest.Visible := Self.Visible; LDest.TabStop := Self.TabStop; end; end; end; -procedure TStyledButton.BeginUpdate; +procedure TCustomStyledButton.BeginUpdate; begin FRender.BeginUpdate; end; -procedure TStyledButton.EndUpdate; +procedure TCustomStyledButton.EndUpdate; begin FRender.EndUpdate; end; {$IFDEF HiDPISupport} -procedure TStyledButton.ChangeScale(M, D: Integer; isDpiChange: Boolean); +procedure TCustomStyledButton.ChangeScale(M, D: Integer; isDpiChange: Boolean); begin if isDpiChange then begin @@ -3766,37 +5034,37 @@ procedure TStyledButton.ChangeScale(M, D: Integer; isDpiChange: Boolean); end; {$ENDIF} -procedure TStyledButton.CMEnabledChanged(var Message: TMessage); +procedure TCustomStyledButton.CMEnabledChanged(var Message: TMessage); begin inherited; FRender.CMEnabledChanged(Message); end; -procedure TStyledButton.CMEnter(var Message: TCMEnter); +procedure TCustomStyledButton.CMEnter(var Message: TCMEnter); begin inherited; FRender.CMEnter(Message); end; -procedure TStyledButton.CMMouseEnter(var Message: TNotifyEvent); +procedure TCustomStyledButton.CMMouseEnter(var Message: TNotifyEvent); begin inherited; FRender.CMMouseEnter(Message); end; -procedure TStyledButton.CMMouseLeave(var Message: TNotifyEvent); +procedure TCustomStyledButton.CMMouseLeave(var Message: TNotifyEvent); begin inherited; FRender.CMMouseLeave(Message); end; -procedure TStyledButton.CMStyleChanged(var Message: TMessage); +procedure TCustomStyledButton.CMStyleChanged(var Message: TMessage); begin inherited; FRender.CMStyleChanged(Message); end; -constructor TStyledButton.CreateStyled(AOwner: TComponent; +constructor TCustomStyledButton.CreateStyled(AOwner: TComponent; const AFamily: TStyledButtonFamily; const AClass: TStyledButtonClass; const AAppearance: TStyledButtonAppearance); @@ -3805,82 +5073,100 @@ constructor TStyledButton.CreateStyled(AOwner: TComponent; DoubleBuffered := True; ParentColor := False; FImageIndex := -1; - {$IFDEF D10_4+} - FImageName := ''; - {$ENDIF} - FRender := GetRenderClass.CreateStyled(Self, - ControlClick, ControlFont, GetCaption, SetCaption, - GetParentFont, SetParentFont, AFamily, AClass, AAppearance); + FRender := GetRenderClass.CreateStyled(Self, + ControlClick, ControlFont, GetCaptionToDraw, SetCaption, + GetParentFont, SetParentFont, + AFamily, AClass, AAppearance, + _DefaultStyleDrawType, _DefaultCursor, _UseCustomDrawType); + TabStop := True; +end; + +constructor TCustomStyledButton.CreateStyled(AOwner: TComponent; + const AFamily: TStyledButtonFamily; const AClass: TStyledButtonClass; + const AAppearance: TStyledButtonAppearance; const ADrawType: TStyledButtonDrawType; + const ACursor: TCursor; const AUseCustomDrawType: Boolean); +begin + inherited Create(AOwner); + DoubleBuffered := True; + ParentColor := False; + FImageIndex := -1; + FRender := GetRenderClass.CreateStyled(Self, + ControlClick, ControlFont, GetCaptionToDraw, SetCaption, + GetParentFont, SetParentFont, + AFamily, AClass, AAppearance, + ADrawType, ACursor, AUseCustomDrawType); TabStop := True; end; -procedure TStyledButton.CreateWnd; +procedure TCustomStyledButton.CreateWnd; begin inherited CreateWnd; FRender.Active := Default; -(* - if not (csLoading in ComponentState) then - begin - SetElevationRequiredState; - UpdateImageList; - if FStyle = bsCommandLink then - UpdateCommandLinkHint; - end; -*) end; -constructor TStyledButton.Create(AOwner: TComponent); +constructor TCustomStyledButton.Create(AOwner: TComponent); begin CreateStyled(AOwner, - DEFAULT_CLASSIC_FAMILY, - DEFAULT_WINDOWS_CLASS, - DEFAULT_APPEARANCE); + _DefaultFamily, + _DefaultClass, + _DefaultAppearance); end; -procedure TStyledButton.ActionChange(Sender: TObject; CheckDefaults: Boolean); +procedure TCustomStyledButton.ActionChange(Sender: TObject; CheckDefaults: Boolean); begin inherited; FRender.ActionChange(Sender, CheckDefaults); end; -destructor TStyledButton.Destroy; +destructor TCustomStyledButton.Destroy; begin FreeAndNil(FRender); + FreeAndNil(FPaintBuffer); inherited Destroy; end; -function TStyledButton.CalcImageRect(var ATextRect: TRect; const AImageWidth, +function TCustomStyledButton.CalcImageRect(var ATextRect: TRect; const AImageWidth, AImageHeight: Integer): TRect; begin Result := FRender.CalcImageRect(ATextRect, AImageWidth, AImageHeight); end; -function TStyledButton.CanDropDownMenu: boolean; +function TCustomStyledButton.CanDropDownMenu: boolean; begin Result := FRender.CanDropDownMenu; end; -procedure TStyledButton.DoDropDownMenu; +procedure TCustomStyledButton.DoDropDownMenu; begin FRender.DoDropDownMenu; end; -function TStyledButton.GetText: TCaption; +function TCustomStyledButton.GetText: TCaption; begin Result := FRender.GetText; end; -function TStyledButton.GetKind: TBitBtnKind; +function TCustomStyledButton.GetKind: TBitBtnKind; begin Result := FRender.Kind; end; -function TStyledButton.ImageMarginsStored: Boolean; +function TCustomStyledButton.GetLayout: TButtonLayout; +begin + Result := FRender.Layout; +end; + +function TCustomStyledButton.ImageMarginsStored: Boolean; begin Result := not FRender.IsDefaultImageMargins; end; -function TStyledButton.IsCaptionStored: Boolean; +function TCustomStyledButton.IsCaptionAlignmentStored: Boolean; +begin + Result := FRender.IsCaptionAlignmentStored; +end; + +function TCustomStyledButton.IsCaptionStored: Boolean; begin if (ActionLink = nil) then Result := Caption <> '' @@ -3888,7 +5174,16 @@ function TStyledButton.IsCaptionStored: Boolean; Result := not TGraphicButtonActionLink(ActionLink).IsCaptionLinked; end; -function TStyledButton.IsEnabledStored: Boolean; +function TCustomStyledButton.IsCheckedStored: Boolean; +begin + if (ActionLink = nil) then + Result := FRender.Down + else + Result := not TGraphicButtonActionLink(ActionLink).IsCheckedLinked and + (FRender.Down); +end; + +function TCustomStyledButton.IsEnabledStored: Boolean; begin if (ActionLink = nil) then Result := not Enabled @@ -3896,7 +5191,7 @@ function TStyledButton.IsEnabledStored: Boolean; Result := not TGraphicButtonActionLink(ActionLink).IsEnabledLinked; end; -function TStyledButton.IsImageIndexStored: Boolean; +function TCustomStyledButton.IsImageIndexStored: Boolean; begin if (ActionLink = nil) then Result := ImageIndex <> -1 @@ -3904,62 +5199,67 @@ function TStyledButton.IsImageIndexStored: Boolean; Result := not TGraphicButtonActionLink(ActionLink).IsImageIndexLinked; end; -function TStyledButton.IsCustomDrawType: Boolean; +function TCustomStyledButton.IsNotificationBadgeStored: Boolean; +begin + Result := FRender.IsNotificationBadgeStored; +end; + +function TCustomStyledButton.IsCustomDrawType: Boolean; begin Result := FRender.IsCustomDrawType; end; -function TStyledButton.IsCustomRadius: Boolean; +function TCustomStyledButton.IsCustomRadius: Boolean; begin Result := FRender.IsCustomRadius; end; -function TStyledButton.IsStoredStyleFamily: Boolean; +function TCustomStyledButton.IsStoredStyleFamily: Boolean; begin Result := FRender.IsStoredStyleFamily; end; -function TStyledButton.IsStoredStyleClass: Boolean; +function TCustomStyledButton.IsStoredStyleClass: Boolean; begin Result := FRender.IsStoredStyleClass; end; -function TStyledButton.IsStoredStyleAppearance: Boolean; +function TCustomStyledButton.IsStoredStyleAppearance: Boolean; begin Result := FRender.IsStoredStyleAppearance; end; -function TStyledButton.IsStoredStyleElements: Boolean; +function TCustomStyledButton.IsStoredStyleElements: Boolean; begin Result := FRender.IsStoredStyleElements; end; -function TStyledButton.IsStyleDisabledStored: Boolean; +function TCustomStyledButton.IsStyleDisabledStored: Boolean; begin Result := FRender.IsStyleDisabledStored; end; -function TStyledButton.IsStylePressedStored: Boolean; +function TCustomStyledButton.IsStylePressedStored: Boolean; begin Result := FRender.IsStylePressedStored; end; -function TStyledButton.IsStyleSelectedStored: Boolean; +function TCustomStyledButton.IsStyleSelectedStored: Boolean; begin Result := FRender.IsStyleSelectedStored; end; -function TStyledButton.IsStyleHotStored: Boolean; +function TCustomStyledButton.IsStyleHotStored: Boolean; begin Result := FRender.IsStyleHotStored; end; -function TStyledButton.IsStyleNormalStored: Boolean; +function TCustomStyledButton.IsStyleNormalStored: Boolean; begin Result := FRender.IsStyleNormalStored; end; -function TStyledButton.GetButtonState: TStyledButtonState; +function TCustomStyledButton.GetButtonState: TStyledButtonState; begin //Getting button state if not Enabled then @@ -3974,54 +5274,54 @@ function TStyledButton.GetButtonState: TStyledButtonState; Result := bsmNormal; end; -function TStyledButton.GetRenderClass: TStyledButtonRenderClass; +function TCustomStyledButton.GetRenderClass: TStyledButtonRenderClass; begin Result := TStyledButtonRender; end; -function TStyledButton.GetRescalingButton: Boolean; +function TCustomStyledButton.GetRescalingButton: Boolean; begin Result := Assigned(FRender) and FRender.RescalingButton; end; -procedure TStyledButton.SetRescalingButton(const AValue: Boolean); +procedure TCustomStyledButton.SetRescalingButton(const AValue: Boolean); begin if Assigned(FRender) then FRender.RescalingButton := AValue; end; -function TStyledButton.GetStyleDrawType: TStyledButtonDrawType; +function TCustomStyledButton.GetStyleDrawType: TStyledButtonDrawType; begin Result := FRender.StyleDrawType; end; -procedure TStyledButton.SetStyleDrawType(const AValue: TStyledButtonDrawType); +procedure TCustomStyledButton.SetStyleDrawType(const AValue: TStyledButtonDrawType); begin FRender.StyleDrawType := AValue; end; -function TStyledButton.GetImage(out AImageList: TCustomImageList; +function TCustomStyledButton.GetImage(out AImageList: TCustomImageList; out AImageIndex: Integer): Boolean; begin - Result := FRender.GetImage(AImageList, AImageIndex); + Result := FRender.GetInternalImage(AImageList, AImageIndex); end; -function TStyledButton.GetImageAlignment: TImageAlignment; +function TCustomStyledButton.GetImageAlignment: TImageAlignment; begin Result := FRender.ImageAlignment; end; -procedure TStyledButton.SetImageAlignment(const AValue: TImageAlignment); +procedure TCustomStyledButton.SetImageAlignment(const AValue: TImageAlignment); begin FRender.ImageAlignment := AValue; end; -function TStyledButton.GetDefault: Boolean; +function TCustomStyledButton.GetDefault: Boolean; begin Result := FRender.Default; end; -procedure TStyledButton.SetDefault(const AValue: Boolean); +procedure TCustomStyledButton.SetDefault(const AValue: Boolean); var Form: TCustomForm; begin @@ -4036,27 +5336,27 @@ procedure TStyledButton.SetDefault(const AValue: Boolean); FRender.Active := FRender.Default; end; -function TStyledButton.GetCancel: Boolean; +function TCustomStyledButton.GetCancel: Boolean; begin Result := FRender.Cancel; end; -procedure TStyledButton.SetCancel(const AValue: Boolean); +procedure TCustomStyledButton.SetCancel(const AValue: Boolean); begin FRender.Cancel := AValue; end; -function TStyledButton.GetDisabledImageIndex: TImageIndex; +function TCustomStyledButton.GetDisabledImageIndex: TImageIndex; begin Result := FRender.DisabledImageIndex; end; -procedure TStyledButton.SetDisabledImageIndex(const AValue: TImageIndex); +procedure TCustomStyledButton.SetDisabledImageIndex(const AValue: TImageIndex); begin FRender.DisabledImageIndex := AValue; end; -procedure TStyledButton.SetImageIndex(const AValue: TImageIndex); +procedure TCustomStyledButton.SetImageIndex(const AValue: TImageIndex); begin if AValue <> FImageIndex then begin @@ -4066,28 +5366,28 @@ procedure TStyledButton.SetImageIndex(const AValue: TImageIndex); end; {$IFDEF D10_4+} -function TStyledButton.GetDisabledImageName: TImageName; +function TCustomStyledButton.GetDisabledImageName: TImageName; begin Result := FRender.DisabledImageName; end; -procedure TStyledButton.SetDisabledImageName(const AValue: TImageName); +procedure TCustomStyledButton.SetDisabledImageName(const AValue: TImageName); begin FRender.DisabledImageName := AValue; end; -function TStyledButton.IsImageNameStored: Boolean; +function TCustomStyledButton.IsImageNameStored: Boolean; begin Result := (ActionLink = nil) or not TGraphicButtonActionLink(ActionLink).IsImageNameLinked; end; -function TStyledButton.GetImageName: TImageName; +function TCustomStyledButton.GetImageName: TImageName; begin Result := FRender.ImageName; end; -procedure TStyledButton.SetImageName(const AValue: TImageName); +procedure TCustomStyledButton.SetImageName(const AValue: TImageName); begin if AValue <> FImageName then begin @@ -4096,144 +5396,218 @@ procedure TStyledButton.SetImageName(const AValue: TImageName); end; end; -function TStyledButton.GetHotImageName: TImageName; +function TCustomStyledButton.GetHotImageName: TImageName; begin Result := FRender.HotImageName; end; -procedure TStyledButton.SetHotImageName(const AValue: TImageName); +procedure TCustomStyledButton.SetHotImageName(const AValue: TImageName); begin FRender.HotImageName := AValue; end; -function TStyledButton.GetPressedImageName: TImageName; +function TCustomStyledButton.GetStylusHotImageName: TImageName; +begin + Result := FRender.StylusHotImageName; +end; + +procedure TCustomStyledButton.SetStylusHotImageName(const AValue: TImageName); +begin + FRender.StylusHotImageName := AValue; +end; + +function TCustomStyledButton.GetPressedImageName: TImageName; begin Result := FRender.PressedImageName; end; -procedure TStyledButton.SetPressedImageName(const AValue: TImageName); +procedure TCustomStyledButton.SetPressedImageName(const AValue: TImageName); begin FRender.PressedImageName := AValue; end; -function TStyledButton.GetSelectedImageName: TImageName; +function TCustomStyledButton.GetSelectedImageName: TImageName; begin Result := FRender.SelectedImageName; end; -procedure TStyledButton.SetSelectedImageName(const AValue: TImageName); +procedure TCustomStyledButton.SetSelectedImageName(const AValue: TImageName); begin FRender.SelectedImageName := AValue; end; {$ENDIF} -function TStyledButton.GetActionLinkClass: TControlActionLinkClass; +function TCustomStyledButton.GetActionLinkClass: TControlActionLinkClass; begin Result := TGraphicButtonActionLink; end; -(* -function TStyledButton.GetActiveStyleName: string; + +function TCustomStyledButton.GetActiveStyleName: string; begin Result := FRender.ActiveStyleName; end; -*) -procedure TStyledButton.UpdateStyleElements; + +function TCustomStyledButton.GetAllowAllUp: Boolean; begin - FRender.UpdateStyleElements; - inherited; + Result := FRender.AllowAllUp; end; -function TStyledButton.GetDisabledImages: TCustomImageList; +function TCustomStyledButton.GetAsVCLComponent: Boolean; +begin + Result := FRender.AsVCLComponent; +end; + +function TCustomStyledButton.GetDisabledImages: TCustomImageList; begin Result := FRender.DisabledImages; end; -procedure TStyledButton.SetDisabledImages(const AValue: TCustomImageList); +function TCustomStyledButton.GetDown: Boolean; +begin + Result := FRender.Down; +end; + +procedure TCustomStyledButton.SetDisabledImages(const AValue: TCustomImageList); begin FRender.DisabledImages := AValue; end; -function TStyledButton.GetDropDownMenu: TPopupMenu; +procedure TCustomStyledButton.SetDown(const AValue: Boolean); +begin + FRender.Down := AValue; +end; + +function TCustomStyledButton.GetDropDownMenu: TPopupMenu; begin Result := FRender.DropDownMenu; end; -function TStyledButton.GetFlat: Boolean; +function TCustomStyledButton.GetElevationRequired: Boolean; +begin + Result := FRender.ElevationRequired; +end; + +function TCustomStyledButton.GetFlat: Boolean; begin Result := FRender.Flat; end; -function TStyledButton.GetGlyph: TBitmap; +function TCustomStyledButton.GetGlyph: TBitmap; begin Result := FRender.Glyph; end; -procedure TStyledButton.SetGlyph(const AValue: TBitmap); +function TCustomStyledButton.GetGroupIndex: Integer; +begin + Result := FRender.GroupIndex; +end; + +procedure TCustomStyledButton.SetGlyph(const AValue: TBitmap); begin FRender.Glyph := AValue; end; -procedure TStyledButton.SetDropDownMenu(const AValue: TPopupMenu); +procedure TCustomStyledButton.SetGroupIndex(const AValue: Integer); +begin + FRender.GroupIndex := AValue; +end; + +procedure TCustomStyledButton.SetDropDownMenu(const AValue: TPopupMenu); begin FRender.DropDownMenu := AValue; end; -procedure TStyledButton.SetFlat(const AValue: Boolean); +procedure TCustomStyledButton.SetElevationRequired(const AValue: Boolean); +begin + FRender.ElevationRequired := AValue; +end; + +procedure TCustomStyledButton.SetFlat(const AValue: Boolean); begin FRender.Flat := AValue; end; -function TStyledButton.GetHotImageIndex: TImageIndex; +function TCustomStyledButton.GetHotImageIndex: TImageIndex; begin Result := FRender.HotImageIndex; end; -procedure TStyledButton.SetHotImageIndex(const AValue: TImageIndex); +procedure TCustomStyledButton.SetHotImageIndex(const AValue: TImageIndex); begin FRender.HotImageIndex := AValue; end; -function TStyledButton.GetImages: TCustomImageList; +function TCustomStyledButton.GetStylusHotImageIndex: TImageIndex; +begin + Result := FRender.StylusHotImageIndex; +end; + +procedure TCustomStyledButton.SetStylusHotImageIndex(const AValue: TImageIndex); +begin + FRender.StylusHotImageIndex := AValue; +end; + +function TCustomStyledButton.GetImages: TCustomImageList; begin Result := FRender.Images; end; -procedure TStyledButton.SetImages(const AValue: TCustomImageList); +procedure TCustomStyledButton.SetImages(const AValue: TCustomImageList); begin FRender.Images := AValue; end; -procedure TStyledButton.SetKind(const AValue: TBitBtnKind); +procedure TCustomStyledButton.SetKind(const AValue: TBitBtnKind); begin FRender.Kind := AValue; end; -function TStyledButton.GetModalResult: TModalResult; +function TCustomStyledButton.GetMargin: Integer; +begin + Result := FRender.Margin; +end; + +procedure TCustomStyledButton.SetLayout(const AValue: TButtonLayout); +begin + FRender.Layout := AValue; +end; + +function TCustomStyledButton.GetModalResult: TModalResult; begin Result := FRender.ModalResult; end; -function TStyledButton.GetMouseInControl: Boolean; +function TCustomStyledButton.GetMouseInControl: Boolean; begin Result := FRender.MouseInControl; end; -function TStyledButton.GetNumGlyphs: TNumGlyphs; +function TCustomStyledButton.GetNotificationBadge: TNotificationBadgeAttributes; +begin + Result := FRender.NotificationBadge; +end; + +function TCustomStyledButton.GetNumGlyphs: TNumGlyphs; begin Result := FRender.NumGlyphs; end; -procedure TStyledButton.SetNumGlyphs(const AValue: TNumGlyphs); +procedure TCustomStyledButton.SetNumGlyphs(const AValue: TNumGlyphs); begin FRender.NumGlyphs := AValue; end; -procedure TStyledButton.SetModalResult(const AValue: TModalResult); +procedure TCustomStyledButton.SetMargin(const AValue: Integer); +begin + FRender.Margin := AValue; +end; + +procedure TCustomStyledButton.SetModalResult(const AValue: TModalResult); begin FRender.ModalResult := AValue; end; -procedure TStyledButton.SetName(const AValue: TComponentName); +procedure TCustomStyledButton.SetName(const AValue: TComponentName); var LOldValue: string; begin @@ -4243,37 +5617,43 @@ procedure TStyledButton.SetName(const AValue: TComponentName); Invalidate; end; -function TStyledButton.GetOnDropDownClick: TNotifyEvent; +procedure TCustomStyledButton.SetNotificationBadge( + const AValue: TNotificationBadgeAttributes); +begin + FRender.NotificationBadge := AValue; +end; + +function TCustomStyledButton.GetOnDropDownClick: TNotifyEvent; begin Result := FRender.OnDropDownClick; end; -procedure TStyledButton.SetOnDropDownClick(const AValue: TNotifyEvent); +procedure TCustomStyledButton.SetOnDropDownClick(const AValue: TNotifyEvent); begin FRender.OnDropDownClick := AValue; end; -function TStyledButton.GetPressedImageIndex: TImageIndex; +function TCustomStyledButton.GetPressedImageIndex: TImageIndex; begin Result := FRender.PressedImageIndex; end; -procedure TStyledButton.SetPressedImageIndex(const AValue: TImageIndex); +procedure TCustomStyledButton.SetPressedImageIndex(const AValue: TImageIndex); begin FRender.PressedImageIndex := AValue; end; -function TStyledButton.GetButtonStyleNormal: TStyledButtonAttributes; +function TCustomStyledButton.GetButtonStyleNormal: TStyledButtonAttributes; begin Result := FRender.ButtonStyleNormal; end; -procedure TStyledButton.SetButtonStyleNormal(const AValue: TStyledButtonAttributes); +procedure TCustomStyledButton.SetButtonStyleNormal(const AValue: TStyledButtonAttributes); begin FRender.ButtonStyleNormal := AValue; end; -procedure TStyledButton.SetButtonStyle( +procedure TCustomStyledButton.SetButtonStyle( const AStyleFamily: TStyledButtonFamily; const AStyleClass: TStyledButtonClass; const AStyleAppearance: TStyledButtonAppearance); @@ -4281,148 +5661,200 @@ procedure TStyledButton.SetButtonStyle( FRender.SetButtonStyle(AStyleFamily, AStyleClass, AStyleAppearance); end; -procedure TStyledButton.SetButtonStyle(const AStyleFamily: TStyledButtonFamily; +procedure TCustomStyledButton.SetAllowAllUp(const AValue: Boolean); +begin + FRender.AllowAllUp := AValue; +end; + +procedure TCustomStyledButton.SetAsVCLComponent(const AValue: Boolean); +begin + FRender.AsVCLComponent := AValue; +end; + +procedure TCustomStyledButton.SetButtonStyle(const AStyleFamily: TStyledButtonFamily; const AModalResult: TModalResult); begin FRender.SetButtonStyle(AStyleFamily, AModalResult); end; -function TStyledButton.GetButtonStyleDisabled: TStyledButtonAttributes; +function TCustomStyledButton.GetButtonStyleDisabled: TStyledButtonAttributes; begin Result := FRender.ButtonStyleDisabled; end; -procedure TStyledButton.SetButtonStyleDisabled(const AValue: TStyledButtonAttributes); +procedure TCustomStyledButton.SetButtonStyleDisabled(const AValue: TStyledButtonAttributes); begin FRender.ButtonStyleDisabled := AValue; end; -function TStyledButton.GetButtonStylePressed: TStyledButtonAttributes; +function TCustomStyledButton.GetButtonStylePressed: TStyledButtonAttributes; begin Result := FRender.ButtonStylePressed; end; -procedure TStyledButton.SetButtonStylePressed(const AValue: TStyledButtonAttributes); +procedure TCustomStyledButton.SetButtonStylePressed(const AValue: TStyledButtonAttributes); begin FRender.ButtonStylePressed := AValue; end; -function TStyledButton.GetButtonStyleSelected: TStyledButtonAttributes; +function TCustomStyledButton.GetButtonStyleSelected: TStyledButtonAttributes; begin Result := FRender.ButtonStyleSelected; end; -procedure TStyledButton.SetButtonStyleSelected(const AValue: TStyledButtonAttributes); +procedure TCustomStyledButton.SetButtonStyleSelected(const AValue: TStyledButtonAttributes); begin FRender.ButtonStyleSelected := AValue; end; -function TStyledButton.GetButtonStyleHot: TStyledButtonAttributes; +function TCustomStyledButton.GetButtonStyleHot: TStyledButtonAttributes; begin Result := FRender.ButtonStyleHot; end; -procedure TStyledButton.SetButtonStyleHot(const AValue: TStyledButtonAttributes); +procedure TCustomStyledButton.SetButtonStyleHot(const AValue: TStyledButtonAttributes); begin FRender.ButtonStyleHot := AValue; end; -function TStyledButton.GetImageMargins: TImageMargins; +function TCustomStyledButton.GetImageMargins: TImageMargins; begin Result := FRender.ImageMargins; end; -procedure TStyledButton.SetImageMargins(const AValue: TImageMargins); +procedure TCustomStyledButton.SetImageMargins(const AValue: TImageMargins); begin FRender.ImageMargins := AValue; end; -function TStyledButton.GetStyleRadius: Integer; +function TCustomStyledButton.GetStyleRadius: Integer; begin Result := FRender.StyleRadius; end; -procedure TStyledButton.SetStyleRadius(const AValue: Integer); +function TCustomStyledButton.GetStyleRoundedCorners: TRoundedCorners; +begin + Result := FRender.StyleRoundedCorners; +end; + +procedure TCustomStyledButton.SetStyleRadius(const AValue: Integer); begin FRender.StyleRadius := AValue; end; -function TStyledButton.GetSelectedImageIndex: TImageIndex; +procedure TCustomStyledButton.SetStyleRoundedCorners( + const AValue: TRoundedCorners); +begin + FRender.StyleRoundedCorners := AValue; +end; + +function TCustomStyledButton.GetSelectedImageIndex: TImageIndex; begin Result := FRender.SelectedImageIndex; end; -function TStyledButton.GetSplitButtonWidth: Integer; +function TCustomStyledButton.GetShowCaption: Boolean; +begin + Result := FRender.ShowCaption; +end; + +function TCustomStyledButton.GetSpacing: Integer; +begin + Result := FRender.Spacing; +end; + +function TCustomStyledButton.GetSplitButtonWidth: Integer; begin Result := FRender.GetSplitButtonWidth; end; -procedure TStyledButton.SetSelectedImageIndex(const AValue: TImageIndex); +procedure TCustomStyledButton.SetSelectedImageIndex(const AValue: TImageIndex); begin FRender.SelectedImageIndex := AValue; end; -function TStyledButton.GetStyle: TStyledButtonStyle; +procedure TCustomStyledButton.SetShowCaption(const AValue: Boolean); +begin + FRender.ShowCaption := AValue; +end; + +procedure TCustomStyledButton.SetSpacing(const AValue: Integer); +begin + FRender.Spacing := AValue; +end; + +function TCustomStyledButton.GetStyle: TCustomButton.TButtonStyle; begin Result := FRender.Style; end; -procedure TStyledButton.SetStyle(const AValue: TStyledButtonStyle); +procedure TCustomStyledButton.SetStyle(const AValue: TCustomButton.TButtonStyle); begin FRender.Style := AValue; end; -function TStyledButton.GetStyleAppearance: TStyledButtonAppearance; +function TCustomStyledButton.GetStyleAppearance: TStyledButtonAppearance; begin Result := FRender.StyleAppearance; end; -procedure TStyledButton.SetStyleAppearance(const AValue: TStyledButtonAppearance); +procedure TCustomStyledButton.SetStyleAppearance(const AValue: TStyledButtonAppearance); begin FRender.StyleAppearance := AValue; end; -function TStyledButton.GetStyleApplied: Boolean; +function TCustomStyledButton.GetStyleApplied: Boolean; begin Result := FRender.StyleApplied; end; -procedure TStyledButton.SetStyleApplied(const AValue: Boolean); +procedure TCustomStyledButton.SetStyleApplied(const AValue: Boolean); begin FRender.StyleApplied := AValue; end; -function TStyledButton.GetStyleClass: TStyledButtonClass; +function TCustomStyledButton.GetStyleClass: TStyledButtonClass; begin Result := FRender.StyleClass; end; -procedure TStyledButton.SetStyleClass(const AValue: TStyledButtonClass); +procedure TCustomStyledButton.SetStyleClass(const AValue: TStyledButtonClass); begin FRender.StyleClass := AValue; end; -function TStyledButton.GetStyleFamily: TStyledButtonFamily; +function TCustomStyledButton.GetStyleFamily: TStyledButtonFamily; begin Result := FRender.StyleFamily; end; -procedure TStyledButton.SetStyleFamily(const AValue: TStyledButtonFamily); +procedure TCustomStyledButton.SetStyleFamily(const AValue: TStyledButtonFamily); begin FRender.StyleFamily := AValue; end; -procedure TStyledButton.SetText(const AValue: TCaption); +{$IFDEF D10_4+} +procedure TCustomStyledButton.SetStyleName(const AValue: string); +begin + if (AValue <> '') and (StyleFamily <> DEFAULT_CLASSIC_FAMILY) then + StyleFamily := DEFAULT_CLASSIC_FAMILY; + inherited; + if (AValue <> '') then + StyleClass := AValue; +end; +{$ENDIF} + +procedure TCustomStyledButton.SetText(const AValue: TCaption); begin FRender.Caption := AValue; end; -function TStyledButton.GetWordWrap: Boolean; +function TCustomStyledButton.GetWordWrap: Boolean; begin Result := FRender.WordWrap; end; -function TStyledButton.HasCustomGlyph: Boolean; +function TCustomStyledButton.HasCustomGlyph: Boolean; var Link: TGraphicButtonActionLink; begin @@ -4431,23 +5863,23 @@ function TStyledButton.HasCustomGlyph: Boolean; Link.IsGlyphLinked(ImageIndex)); end; -procedure TStyledButton.SetWordWrap(const AValue: Boolean); +procedure TCustomStyledButton.SetWordWrap(const AValue: Boolean); begin FRender.WordWrap := AValue; end; -procedure TStyledButton.ShowDropDownMenu; +procedure TCustomStyledButton.ShowDropDownMenu; begin FRender.ShowDropDownMenu; end; -procedure TStyledButton.Loaded; +procedure TCustomStyledButton.Loaded; begin inherited; FRender.Loaded; end; -procedure TStyledButton.MouseDown(Button: TMouseButton; +procedure TCustomStyledButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin FRender.MouseDown(Button, Shift, X, Y); @@ -4455,13 +5887,13 @@ procedure TStyledButton.MouseDown(Button: TMouseButton; inherited; end; -procedure TStyledButton.MouseMove(Shift: TShiftState; X, Y: Integer); +procedure TCustomStyledButton.MouseMove(Shift: TShiftState; X, Y: Integer); begin inherited; FRender.MouseMove(Shift, X, Y); end; -procedure TStyledButton.MouseUp(Button: TMouseButton; +procedure TCustomStyledButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if Enabled then @@ -4471,42 +5903,67 @@ procedure TStyledButton.MouseUp(Button: TMouseButton; end; end; -procedure TStyledButton.ControlClick(Sender: TObject); +procedure TCustomStyledButton.ControlClick(Sender: TObject); begin inherited Click; end; -procedure TStyledButton.ControlFont(var AValue: TFont); +procedure TCustomStyledButton.ControlFont(var AValue: TFont); begin AValue := Self.Font; end; -procedure TStyledButton.SetParentFont(const AValue: Boolean); +procedure TCustomStyledButton.SetParentFont(const AValue: Boolean); begin Self.ParentFont := AValue; end; -function TStyledButton.GetParentFont: Boolean; +function TCustomStyledButton.GetParentFont: Boolean; begin Result := Self.ParentFont; end; -function TStyledButton.GetCaption: TCaption; +function TCustomStyledButton.GetCaption: TCaption; begin Result := inherited Caption; end; -function TStyledButton.GetCursor: TCursor; +function TCustomStyledButton.GetCaptionToDraw: TCaption; +begin + Result := inherited Caption; +end; + +function TCustomStyledButton.GetCaptionAlignment: TAlignment; +begin + Result := FRender.CaptionAlignment; +end; + +function TCustomStyledButton.GetCommandLinkHint: string; +begin + Result := FRender.CommandLinkHint; +end; + +function TCustomStyledButton.GetCursor: TCursor; begin Result := inherited Cursor; end; -procedure TStyledButton.SetCaption(const AValue: TCaption); +procedure TCustomStyledButton.SetCaption(const AValue: TCaption); begin inherited Caption := AValue; end; -procedure TStyledButton.SetCursor(const AValue: TCursor); +procedure TCustomStyledButton.SetCaptionAlignment(const AValue: TAlignment); +begin + FRender.CaptionAlignment := AValue; +end; + +procedure TCustomStyledButton.SetCommandLinkHint(const AValue: string); +begin + FRender.CommandLinkHint := AValue; +end; + +procedure TCustomStyledButton.SetCursor(const AValue: TCursor); begin if AValue <> Cursor then begin @@ -4514,7 +5971,7 @@ procedure TStyledButton.SetCursor(const AValue: TCursor); end; end; -procedure TStyledButton.Notification(AComponent: TComponent; AOperation: TOperation); +procedure TCustomStyledButton.Notification(AComponent: TComponent; AOperation: TOperation); begin inherited Notification(AComponent, AOperation); if AOperation = opRemove then @@ -4531,22 +5988,42 @@ procedure TStyledButton.Notification(AComponent: TComponent; AOperation: TOperat end; end; -function TStyledButton.GetTag: Integer; +class procedure TCustomStyledButton.RegisterDefaultRenderingStyle( + const ADrawType: TStyledButtonDrawType; const AFamily: TStyledButtonFamily; + const AClass: TStyledButtonClass; const AAppearance: TStyledButtonAppearance; + const AStyleRadius: Integer; const ACursor: TCursor); +begin + _DefaultStyleDrawType := ADrawType; + _UseCustomDrawType := True; + _DefaultFamily := AFamily; + _DefaultClass := AClass; + _DefaultAppearance := AAppearance; + _DefaultStyleRadius := AStyleRadius; + _DefaultCursor := ACursor; +end; + +procedure TCustomStyledButton.ReleasePaintBuffer; +begin + if FPaintBufferUsers = 0 then + FreeAndNil(FPaintBuffer); +end; + +function TCustomStyledButton.GetTag: Integer; begin Result := FRender.Tag; end; -procedure TStyledButton.SetTag(const AValue: Integer); +procedure TCustomStyledButton.SetTag(const AValue: Integer); begin FRender.Tag := AValue; end; -procedure TStyledButton.Click; +procedure TCustomStyledButton.Click; begin FRender.Click(False); end; -procedure TStyledButton.CMDialogChar(var Message: TCMDialogChar); +procedure TCustomStyledButton.CMDialogChar(var Message: TCMDialogChar); begin with Message do if IsAccel(CharCode, Caption) and CanFocus then @@ -4557,7 +6034,7 @@ procedure TStyledButton.CMDialogChar(var Message: TCMDialogChar); inherited; end; -procedure TStyledButton.CMDialogKey(var Message: TCMDialogKey); +procedure TCustomStyledButton.CMDialogKey(var Message: TCMDialogKey); begin with Message do if (((CharCode = VK_RETURN) and FRender.Active) or @@ -4571,48 +6048,21 @@ procedure TStyledButton.CMDialogKey(var Message: TCMDialogKey); inherited; end; -(* -function TStyledButton.StyleServicesEnabled: Boolean; -var - LStyle: TCustomStyleServices; -begin - LStyle := StyleServices; - Result := LStyle.Available and not LStyle.IsSystemStyle and - (FindControl(Handle) = nil); -end; -*) - -procedure TStyledButton.WMEraseBkGnd(var Message: TWmEraseBkgnd); - - function IsComponentStyleActive: Boolean; - begin - {$IFDEF D10_4+} - Result := IsCustomStyleActive; - {$ELSE} - Result := False; - {$ENDIF} - end; - +procedure TCustomStyledButton.WMEraseBkGnd(var Message: TWmEraseBkgnd); begin - if IsComponentStyleActive and (seClient in StyleElements) then - begin - Message.Result := 1 - end - else + inherited; + { Erase background if we're not doublebuffering or painting to memory. } + if not FDoubleBuffered or + (TMessage(Message).wParam = WPARAM(TMessage(Message).lParam)) then begin - { Erase background if we're not doublebuffering or painting to memory. } - if not FDoubleBuffered or - (TMessage(Message).wParam = WPARAM(TMessage(Message).lParam)) then - begin - Brush.Color := FRender.GetBackGroundColor; - Brush.Style := bsSolid; - FillRect(Message.DC, ClientRect, Brush.Handle); - end; - Message.Result := 1; + Brush.Color := FRender.GetBackGroundColor; + Brush.Style := bsSolid; + FillRect(Message.DC, ClientRect, Brush.Handle); end; + Message.Result := 1; end; -procedure TStyledButton.CNKeyDown(var Message: TWMKeyDown); +procedure TCustomStyledButton.CNKeyDown(var Message: TWMKeyDown); begin with Message do begin @@ -4628,79 +6078,117 @@ procedure TStyledButton.CNKeyDown(var Message: TWMKeyDown); end; end; -procedure TStyledButton.WMKeyDown(var Message: TMessage); +procedure TCustomStyledButton.WMKeyDown(var Message: TMessage); begin inherited; FRender.WMKeyDown(Message); end; -procedure TStyledButton.WMKeyUp(var Message: TMessage); +procedure TCustomStyledButton.WMKeyUp(var Message: TMessage); begin inherited; FRender.WMKeyUp(Message); end; -procedure TStyledButton.CMFocusChanged(var Message: TCMFocusChanged); +procedure TCustomStyledButton.CMFocusChanged(var Message: TCMFocusChanged); begin with Message do - if Sender is TStyledButton then + if Sender is TCustomStyledButton then FRender.Active := Sender = Self else FRender.Active := Default; inherited; end; -procedure TStyledButton.WMSetFocus(var Message: TMessage); +procedure TCustomStyledButton.WMSetFocus(var Message: TMessage); begin inherited; Invalidate; end; -procedure TStyledButton.WMKillFocus(var Message: TMessage); +procedure TCustomStyledButton.WMKillFocus(var Message: TMessage); begin Invalidate; inherited; end; -procedure TStyledButton.WMPaint(var Message: TMessage); +procedure TCustomStyledButton.WMPaint(var Message: TMessage); var DC: HDC; LCanvas: TCanvas; PS: TPaintStruct; - LControl: TWinControl; - FPaintBuffer: TBitmap; begin - LControl := Self; - DC := HDC(Message.WParam); - LCanvas := TCanvas.Create; - try - if DC <> 0 then - LCanvas.Handle := DC - else - LCanvas.Handle := BeginPaint(LControl.Handle, PS); - + //if FOverridePaint then + begin + DC := HDC(Message.WParam); + LCanvas := TCanvas.Create; + try + if DC <> 0 then + LCanvas.Handle := DC + else + LCanvas.Handle := BeginPaint(Self.Handle, PS); if FDoubleBuffered and (DC = 0) then begin - FPaintBuffer := TBitmap.Create; + if FPaintBuffer = nil then + FPaintBuffer := TBitmap.Create; + Inc(FPaintBufferUsers); try - FPaintBuffer.SetSize(LControl.Width, LControl.Height); - FRender.DrawButton(FPaintBuffer.Canvas, True); + FPaintBuffer.SetSize(Self.Width, Self.Height); + FRender.EraseBackground(FPaintBuffer.Canvas); + FRender.DrawButton(FPaintBuffer.Canvas, MouseInControl); + // paint other controls + PaintControls(FPaintBuffer.Canvas.Handle, nil); LCanvas.Draw(0, 0, FPaintBuffer); finally - FPaintBuffer.Free; + Dec(FPaintBufferUsers); + ReleasePaintBuffer; end; end - else - begin - FRender.DrawButton(LCanvas, True); - end; - if DC = 0 then - EndPaint(LControl.Handle, PS); - finally - LCanvas.Handle := 0; - LCanvas.Free; + else + begin + if not DoubleBuffered and (FPaintBuffer <> nil) then + ReleasePaintBuffer; + FRender.EraseBackground(LCanvas); + FRender.DrawButton(LCanvas, MouseInControl); + // paint other controls + PaintControls(LCanvas.Handle, nil); + end; + if DC = 0 then + EndPaint(Self.Handle, PS); + finally + LCanvas.Handle := 0; + LCanvas.Free; + end; end; - FHandled := True; + Message.Result := 1; +end; + +{ TStyledBitBtn } + +constructor TStyledBitBtn.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FRender.FUseButtonLayout := True; +end; + +function TStyledBitBtn.IsCaptionStored: Boolean; +begin + Result := AnsiCompareStr(Caption, FRender.BitBtnCaptions(FRender.Kind)) <> 0; end; +initialization + TCustomStyledGraphicButton._DefaultStyleDrawType := DEFAULT_STYLEDRAWTYPE; + TCustomStyledGraphicButton._DefaultFamily := DEFAULT_CLASSIC_FAMILY; + TCustomStyledGraphicButton._DefaultClass := DEFAULT_WINDOWS_CLASS; + TCustomStyledGraphicButton._DefaultAppearance := DEFAULT_APPEARANCE; + TCustomStyledGraphicButton._DefaultStyleRadius := DEFAULT_RADIUS; + TCustomStyledGraphicButton._DefaultCursor := DEFAULT_CURSOR; + + TCustomStyledButton._DefaultStyleDrawType := DEFAULT_STYLEDRAWTYPE; + TCustomStyledButton._DefaultFamily := DEFAULT_CLASSIC_FAMILY; + TCustomStyledButton._DefaultClass := DEFAULT_WINDOWS_CLASS; + TCustomStyledButton._DefaultAppearance := DEFAULT_APPEARANCE; + TCustomStyledButton._DefaultStyleRadius := DEFAULT_RADIUS; + TCustomStyledButton._DefaultCursor := DEFAULT_CURSOR; + end. diff --git a/Ext/StyledComponents/source/Vcl.StyledButtonGroup.pas b/Ext/StyledComponents/source/Vcl.StyledButtonGroup.pas new file mode 100644 index 0000000..c11ebca --- /dev/null +++ b/Ext/StyledComponents/source/Vcl.StyledButtonGroup.pas @@ -0,0 +1,1491 @@ +{******************************************************************************} +{ } +{ StyledButtonGroup: a Styled ButtonGroup with TStyledGrpButtonItem } +{ Based on TButtonGroup and TStyledButton } +{ } +{ Copyright (c) 2022-2024 (Ethea S.r.l.) } +{ Author: Carlo Barazzetta } +{ Contributors: } +{ } +{ https://github.com/EtheaDev/StyledComponents } +{ } +{******************************************************************************} +{ } +{ Licensed under the Apache License, Version 2.0 (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.apache.org/licenses/LICENSE-2.0 } +{ } +{ Unless required by applicable law or agreed to in writing, software } +{ distributed under the License is distributed on an "AS IS" BASIS, } +{ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. } +{ See the License for the specific language governing permissions and } +{ limitations under the License. } +{ } +{******************************************************************************} +unit Vcl.StyledButtonGroup; + +interface + +{$INCLUDE StyledComponents.inc} + +uses + Vcl.ImgList + , System.UITypes + , System.SysUtils + , System.Classes + , System.Math + , Vcl.ToolWin + , Vcl.ComCtrls + , Vcl.StdCtrls + , Vcl.ExtCtrls + , Vcl.Themes + , Vcl.Controls + , Vcl.ActnList + , Vcl.Menus + , Vcl.CategoryButtons + , Winapi.Messages + , Winapi.Windows + , Vcl.StyledButton + , Vcl.ButtonStylesAttributes + , Vcl.StandardButtonStyles + , Vcl.ButtonGroup + , Vcl.Graphics + ; + +resourcestring + ERROR_SETTING_BUTTONGROUP_STYLE = 'Error setting ButtonGroup Style: %s/%s/%s not available'; + +type + EStyledButtonGroupError = Exception; + + TStyledButtonGroup = class; + TStyledButtonGroupClass = class of TStyledButtonGroup; + TStyledGrpButtonItem = class; + TStyledGrpButtonItemClass = class of TGrpButtonItem; + TStyledGrpButtonItems = class; + TStyledGrpButtonItemsClass = class of TGrpButtonItems; + + TGrpButtonProc = reference to procedure (Button: TStyledGrpButtonItem); + + { TStyledGrpButtonItems } + TStyledGrpButtonItems = class(TGrpButtonItems) + private + function GetStyledButtonGroup: TStyledButtonGroup; + public + constructor Create(const ButtonGroup: TButtonGroup); override; + function Add: TStyledGrpButtonItem; + property ButtonGroup: TStyledButtonGroup read GetStyledButtonGroup; + end; + + { TStyledGrpButtonItem } + TStyledGrpButtonItem = class(TGrpButtonItem) + private + //Styled Attributes + FStyleRadius: Integer; + FStyleRoundedCorners: TRoundedCorners; + FStyleDrawType: TStyledButtonDrawType; + FStyleFamily: TStyledButtonFamily; + FStyleClass: TStyledButtonClass; + FStyleAppearance: TStyledButtonAppearance; + FStyleApplied: Boolean; + procedure InvalidateOwner; + function IsCustomDrawType: Boolean; + function IsCustomRoundedCorners: Boolean; + function IsCustomRadius: Boolean; + function IsStoredStyle: Boolean; + procedure SetStyleFamily(const AValue: TStyledButtonFamily); + procedure SetStyleClass(const AValue: TStyledButtonClass); + procedure SetStyleAppearance(const AValue: TStyledButtonAppearance); + procedure SetStyleDrawType(const AValue: TStyledButtonDrawType); + procedure SetStyleRadius(const AValue: Integer); + procedure SetStyleRoundedCorners(const AValue: TRoundedCorners); + function GetStyledButtonGroup: TStyledButtonGroup; + function ApplyButtonStyle: Boolean; + procedure LoadDefaultStyles; + public + constructor Create(Collection: TCollection); override; + procedure SetButtonStyle(const AStyleFamily: TStyledButtonFamily; + const AStyleClass: TStyledButtonClass; + const AStyleAppearance: TStyledButtonAppearance); + published + property ButtonGroup: TStyledButtonGroup read GetStyledButtonGroup; + + //StyledComponents Attributes + property StyleRadius: Integer read FStyleRadius write SetStyleRadius stored IsCustomRadius; + property StyleDrawType: TStyledButtonDrawType read FStyleDrawType write SetStyleDrawType stored IsCustomDrawType; + property StyleRoundedCorners: TRoundedCorners read FStyleRoundedCorners write SetStyleRoundedCorners stored IsCustomRoundedCorners; + property StyleFamily: TStyledButtonFamily read FStyleFamily write SetStyleFamily stored IsStoredStyle; + property StyleClass: TStyledButtonClass read FStyleClass write SetStyleClass stored IsStoredStyle; + property StyleAppearance: TStyledButtonAppearance read FStyleAppearance write SetStyleAppearance stored IsStoredStyle; + end; + + { TStyledButtonGroup } + [ComponentPlatforms(pidWin32 or pidWin64)] + TStyledButtonGroup = class(TButtonGroup) + private + //StyledButton Attributes + FButtonStyleNormal: TStyledButtonAttributes; + FButtonStylePressed: TStyledButtonAttributes; + FButtonStyleSelected: TStyledButtonAttributes; + FButtonStyleHot: TStyledButtonAttributes; + FButtonStyleDisabled: TStyledButtonAttributes; + + //Styled Attributes + FStyleRadius: Integer; + FStyleDrawType: TStyledButtonDrawType; + FStyleRoundedCorners: TRoundedCorners; + FStyleFamily: TStyledButtonFamily; + FStyleClass: TStyledButtonClass; + FStyleAppearance: TStyledButtonAppearance; + FCustomDrawType: Boolean; + FStyleApplied: Boolean; + + FCaptionAlignment: TAlignment; + FImageAlignment: TImageAlignment; + FImageMargins: TImageMargins; + FSpacing: Integer; + FFlat: Boolean; + FButtonsCursor: TCursor; + FCursor: TCursor; + + class var + _DefaultStyleDrawType: TStyledButtonDrawType; + _UseCustomDrawType: Boolean; + _DefaultFamily: TStyledButtonFamily; + _DefaultClass: TStyledButtonClass; + _DefaultAppearance: TStyledButtonAppearance; + _DefaultStyleRadius: Integer; + _DefaultButtonsCursor: TCursor; + + procedure ImageMarginsChange(Sender: TObject); + function IsCustomDrawType: Boolean; + function IsCustomRoundedCorners: Boolean; + function IsCustomRadius: Boolean; + function ImageMarginsStored: Boolean; + function IsStoredStyleAppearance: Boolean; + function IsStoredStyleClass: Boolean; + function IsStoredStyleFamily: Boolean; + procedure SetStyleAppearance(const AValue: TStyledButtonAppearance); + procedure SetStyleClass(const AValue: TStyledButtonClass); + procedure SetStyleDrawType(const AValue: TStyledButtonDrawType); + procedure SetStyleFamily(const AValue: TStyledButtonFamily); + procedure SetStyleRadius(const AValue: Integer); + procedure SetStyleRoundedCorners(const AValue: TRoundedCorners); + function ApplyButtonGroupStyle: Boolean; + procedure SetStyleApplied(const AValue: Boolean); + function ApplyButtonStyle: Boolean; + function GetActiveStyleName: string; + function AsVCLStyle: Boolean; + function GetAsVCLComponent: Boolean; + procedure SetAsVCLComponent(const AValue: Boolean); + procedure ProcessButtons(AButtonProc: TGrpButtonProc); + procedure SetButtonStyleDisabled(const AValue: TStyledButtonAttributes); + procedure SetButtonStyleHot(const AValue: TStyledButtonAttributes); + procedure SetButtonStyleNormal(const AValue: TStyledButtonAttributes); + procedure SetButtonStylePressed(const AValue: TStyledButtonAttributes); + procedure SetButtonStyleSelected(const AValue: TStyledButtonAttributes); + procedure GetDrawingStyle(const ACanvas: TCanvas; + const AButtonState: TStyledButtonState; + const AItem: TStyledGrpButtonItem); + function GetAttributes(const AMode: TStyledButtonState): TStyledButtonAttributes; + procedure DrawBackgroundAndBorder(const ACanvas: TCanvas; + const ADrawRect, ADropDownRect: TRect; + const AStyleDrawType: TStyledButtonDrawType; + const ARadius: Single; const ARoundedCorners: TRoundedCorners); + procedure DrawCaptionAndImage(const ACanvas: TCanvas; const ASurfaceRect: TRect; + const ACaption: TCaption; const AImageIndex: Integer); + procedure SetCaptionAlignment(const AValue: TAlignment); + function GetImageSize(out AWidth, AHeight: Integer; + out AImageList: TCustomImageList): boolean; + procedure DrawText(const ASurfaceRect: TRect; + const ACanvas: TCanvas; const AText: string; + const AAlignment: TAlignment; const ASpacing: Integer; var ARect: TRect; + AFlags: Cardinal); + procedure SetSpacing(const AValue: Integer); + procedure SetFlat(const AValue: Boolean); + function IsStyleEnabled: Boolean; + function IndexOfButtonAt(const X, Y: Integer): Integer; + procedure SetCursor(const AValue: TCursor); + procedure SetImageAlignment(const AValue: TImageAlignment); + function GetScaleFactor: Single; + function GetGrpButtonItems: TStyledGrpButtonItems; + procedure SetGrpButtonItems(const AValue: TStyledGrpButtonItems); + procedure SetImageMargins(const AValue: TImageMargins); + function IsDefaultImageMargins: Boolean; + procedure CalcDefaultImageMargins(const AValue: TImageAlignment); + {$IFNDEF D10_4+} + function IsCustomStyleActive: Boolean; + {$ENDIF} + //Windows messages + procedure CMStyleChanged(var Message: TMessage); message CM_STYLECHANGED; + protected + procedure Loaded; override; + function GetButtonClass: TGrpButtonItemClass; override; + function GetButtonsClass: TGrpButtonItemsClass; override; + procedure UpdateStyleElements; override; + procedure DrawButton(AIndex: Integer; ACanvas: TCanvas; + ARect: TRect; AState: TButtonDrawState); override; + procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override; + public + procedure Assign(Source: TPersistent); override; + function StyledButtonState(const AIndex: Integer; + const AState: TButtonDrawState): TStyledButtonState; + class procedure RegisterDefaultRenderingStyle( + const ADrawType: TStyledButtonDrawType; + const AFamily: TStyledButtonFamily = DEFAULT_CLASSIC_FAMILY; + const AClass: TStyledButtonClass = DEFAULT_WINDOWS_CLASS; + const AAppearance: TStyledButtonAppearance = DEFAULT_APPEARANCE; + const AStyleRadius: Integer = DEFAULT_RADIUS; + const AButtonsCursor: TCursor = DEFAULT_CURSOR); virtual; + procedure SetButtonGroupStyle(const AStyleFamily: TStyledButtonFamily; + const AStyleClass: TStyledButtonClass; + const AStyleAppearance: TStyledButtonAppearance); + procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override; + //Styled constructor + constructor CreateStyled(AOwner: TComponent; + const AFamily: TStyledButtonFamily; + const AClass: TStyledButtonClass; + const AAppearance: TStyledButtonAppearance); virtual; + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + property AsVCLComponent: Boolean read GetAsVCLComponent write SetAsVCLComponent stored False; + property StyleApplied: Boolean read FStyleApplied write SetStyleApplied; + published + property ButtonsCursor: TCursor read FButtonsCursor write FButtonsCursor default DEFAULT_CURSOR; + property Cursor: TCursor read FCursor write SetCursor default crDefault; + property CaptionAlignment: TAlignment read FCaptionAlignment write SetCaptionAlignment default taLeftJustify; + property Items: TStyledGrpButtonItems read GetGrpButtonItems write SetGrpButtonItems; + property ImageAlignment: TImageAlignment read FImageAlignment write SetImageAlignment default iaLeft; + property ImageMargins: TImageMargins read FImageMargins write SetImageMargins stored ImageMarginsStored; + property Flat: Boolean read FFlat write SetFlat default False; + property Spacing: Integer read FSpacing write SetSpacing default 4; + + //StyledButton Attributes + property ButtonStyleNormal: TStyledButtonAttributes read FButtonStyleNormal write SetButtonStyleNormal; + property ButtonStylePressed: TStyledButtonAttributes read FButtonStylePressed write SetButtonStylePressed; + property ButtonStyleSelected: TStyledButtonAttributes read FButtonStyleSelected write SetButtonStyleSelected; + property ButtonStyleHot: TStyledButtonAttributes read FButtonStyleHot write SetButtonStyleHot; + property ButtonStyleDisabled: TStyledButtonAttributes read FButtonStyleDisabled write SetButtonStyleDisabled; + + //StyledComponents Attributes + property StyleRadius: Integer read FStyleRadius write SetStyleRadius stored IsCustomRadius; + property StyleDrawType: TStyledButtonDrawType read FStyleDrawType write SetStyleDrawType stored IsCustomDrawType; + property StyleRoundedCorners: TRoundedCorners read FStyleRoundedCorners write SetStyleRoundedCorners stored IsCustomRoundedCorners; + property StyleFamily: TStyledButtonFamily read FStyleFamily write SetStyleFamily stored IsStoredStyleFamily; + property StyleClass: TStyledButtonClass read FStyleClass write SetStyleClass stored IsStoredStyleClass; + property StyleAppearance: TStyledButtonAppearance read FStyleAppearance write SetStyleAppearance stored IsStoredStyleAppearance; + end; + +implementation + +uses + Vcl.Consts + , Vcl.Forms + , System.Types + , System.RTLConsts + ; + +const + DEFAULT_IMAGE_HMARGIN = 2; + DEFAULT_IMAGE_VMARGIN = 2; + +{ TStyledButtonGroup } + +constructor TStyledButtonGroup.CreateStyled(AOwner: TComponent; + const AFamily: TStyledButtonFamily; const AClass: TStyledButtonClass; + const AAppearance: TStyledButtonAppearance); +begin + Assert(Assigned(AOwner)); + inherited Create(AOwner); + + //new properties for StyledButtonGroup + FCaptionAlignment := taLeftJustify; + FSpacing := 4; + FFlat := False; + FImageAlignment := iaLeft; + FButtonsCursor := _DefaultButtonsCursor; + FImageMargins := TImageMargins.Create; + FImageMargins.Left := 2; + FImageMargins.OnChange := ImageMarginsChange; + + FButtonStyleNormal := TStyledButtonAttributes.Create(Self); + FButtonStyleNormal.Name := 'Normal'; + FButtonStylePressed := TStyledButtonAttributes.Create(Self); + FButtonStylePressed.Name := 'Pressed'; + FButtonStyleSelected := TStyledButtonAttributes.Create(Self); + FButtonStyleSelected.Name := 'Selected'; + FButtonStyleHot := TStyledButtonAttributes.Create(Self); + FButtonStyleHot.Name := 'Hot'; + FButtonStyleDisabled := TStyledButtonAttributes.Create(Self); + FButtonStyleDisabled.Name := 'Disabled'; + + FStyleDrawType := _DefaultStyleDrawType; + FStyleRadius := _DefaultStyleRadius; + FStyleRoundedCorners := ALL_ROUNDED_CORNERS; + FStyleFamily := AFamily; + FStyleClass := AClass; + FStyleAppearance := AAppearance; +end; + +procedure TStyledButtonGroup.CMStyleChanged(var Message: TMessage); +begin + inherited; + ApplyButtonStyle; +end; + +constructor TStyledButtonGroup.Create(AOwner: TComponent); +begin + CreateStyled(AOwner, + _DefaultFamily, + _DefaultClass, + _DefaultAppearance); +end; + +destructor TStyledButtonGroup.Destroy; +begin + FreeAndNil(FImageMargins); + FreeAndNil(FButtonStyleNormal); + FreeAndNil(FButtonStylePressed); + FreeAndNil(FButtonStyleSelected); + FreeAndNil(FButtonStyleHot); + FreeAndNil(FButtonStyleDisabled); + inherited Destroy; +end; + +function TStyledButtonGroup.GetScaleFactor: Single; +begin + Result := {$IFDEF D10_3+}ScaleFactor{$ELSE}1{$ENDIF}; +end; + +procedure TStyledButtonGroup.DrawBackgroundAndBorder( + const ACanvas: TCanvas; const ADrawRect, ADropDownRect: TRect; + const AStyleDrawType: TStyledButtonDrawType; + const ARadius: Single; const ARoundedCorners: TRoundedCorners); +var + LButtonOffset: Integer; + LDropDownRect: TRect; + LScaleFactor: Single; +begin + LScaleFactor := GetScaleFactor; + LDropDownRect := ADropDownRect; + //Draw Button Shape + CanvasDrawshape(ACanvas, ADrawRect, AStyleDrawType, + ARadius*LScaleFactor, ARoundedCorners); + + //Draw Bar and Triangle + if LDropDownRect.Width > 0 then + begin + if not (AStyleDrawType in [btRounded, btEllipse]) then + begin + CanvasDrawBar(ACanvas, LDropDownRect, + LScaleFactor, + ACanvas.Pen.Color); + CanvasDrawTriangle(ACanvas, LDropDownRect, + LScaleFactor, + ACanvas.Font.Color); + end + else + begin + LButtonOffset := LDropDownRect.Height div 8; + LDropDownRect.Left := LDropDownRect.Left - LButtonOffset; + LDropDownRect.Right := LDropDownRect.Right - LButtonOffset; + CanvasDrawTriangle(ACanvas, LDropDownRect, + LScaleFactor, + ACanvas.Font.Color); + end; + end; +end; + +function TStyledButtonGroup.GetImageSize(out AWidth, AHeight: Integer; + out AImageList: TCustomImageList): boolean; +begin + AWidth := 0; + AHeight := 0; + //Return True if using ImageList + if Assigned(Images) then + begin + AWidth := Images.Width; + AHeight := Images.Height; + Result := True; + end + else + Result := False; +end; + +procedure TStyledButtonGroup.DrawText( + const ASurfaceRect: TRect; + const ACanvas: TCanvas; + const AText: string; const AAlignment: TAlignment; + const ASpacing: Integer; + var ARect: TRect; AFlags: Cardinal); +var + R: TRect; + LText: string; +begin + //Drawing Caption + R := ARect; + LText := AText; + Winapi.Windows.DrawText(ACanvas.Handle, PChar(AText), Length(AText), + R, AFlags or DT_CALCRECT); + case AAlignment of + taLeftJustify: + begin + OffsetRect(R, ASpacing, (ARect.Height - R.Height) div 2); + end; + taRightJustify: + begin + OffsetRect(R, ARect.Width - R.Width - ASpacing, (ARect.Height - R.Height) div 2); + end; + else + begin + OffsetRect(R, (ARect.Width - R.Width) div 2, (ARect.Height - R.Height) div 2); + end; + end; + if ASurfaceRect.Right < R.Right + ASpacing then + R.Right := ASurfaceRect.Right - ASpacing; + if ASurfaceRect.Left > R.Left - ASpacing then + R.Left := ASurfaceRect.Left + ASpacing; + ACanvas.TextRect(R, LText, [tfEndEllipsis]); +end; + +procedure TStyledButtonGroup.DrawCaptionAndImage( + const ACanvas: TCanvas; const ASurfaceRect: TRect; + const ACaption: TCaption; const AImageIndex: Integer); +var + LTextFlags: Cardinal; + LImageRect, LTextRect: TRect; + LImageList: TCustomImageList; + LImageWidth, LImageHeight: Integer; + LUseImageList: Boolean; +begin + if gboShowCaptions in ButtonOptions then + begin + case FCaptionAlignment of + taLeftJustify: LTextFlags := DT_NOCLIP or DT_LEFT or DT_VCENTER; + taRightJustify: LTextFlags := DT_NOCLIP or DT_RIGHT or DT_VCENTER; + else + LTextFlags := DT_NOCLIP or DT_CENTER or DT_VCENTER; + end; + LTextFlags := DrawTextBiDiModeFlags(LTextFlags); + (* + if FWordWrap then + LTextFlags := LTextFlags or DT_WORDBREAK; + *) + end + else + begin + LTextFlags := DT_NOCLIP or DT_CENTER or DT_VCENTER; + end; + LUseImageList := GetImageSize(LImageWidth, LImageHeight, LImageList); + + //Calculate LTextRect and LImageRect using ImageMargins and ImageAlignment + CalcImageAndTextRect(ASurfaceRect, ACaption, LTextRect, LImageRect, + LImageWidth, LImageHeight, FImageAlignment, FImageMargins, GetScaleFactor); + + if LUseImageList and not Assigned(OnDrawIcon) then + begin + //Uses an ImageList to draw the Icon + Images.Draw(ACanvas, LImageRect.Left, LImageRect.Top, + AImageIndex, Enabled); + end; + + if gboShowCaptions in ButtonOptions then + DrawText(ASurfaceRect, ACanvas, ACaption, FCaptionAlignment, FSpacing, + LTextRect, LTextFlags); +end; + +function TStyledButtonGroup.IndexOfButtonAt(const X, Y: Integer): Integer; +var + I: Integer; + LRect: TRect; + LPoint: TPoint; +begin + Result := -1; + LPoint := TPoint.Create(X,Y); + for I := 0 to Items.Count-1 do + begin + LRect := GetButtonRect(I); + if LRect.Contains(LPoint) then + begin + Result := I; + break; + end; + end; +end; + +{$IFNDEF D10_4+} +function TStyledButtonGroup.IsCustomStyleActive: Boolean; +begin + Result := False; +end; +{$ENDIF} + +function TStyledButtonGroup.StyledButtonState(const AIndex: Integer; + const AState: TButtonDrawState): TStyledButtonState; +var + LButtonItem: TStyledGrpButtonItem; +begin + LButtonItem := Items[AIndex] as TStyledGrpButtonItem; + Assert(Assigned(LButtonItem)); + //Calculate Styled State based on State + if (bdsHot in AState) and not (bdsDown in AState) then + Result := bsmHot + else if bdsDown in AState then + Result := bsmPressed + else if bdsFocused in AState then + Result := bsmSelected + else if not Enabled then + Result := bsmDisabled + else + Result := bsmNormal; +end; + +procedure TStyledButtonGroup.DrawButton(AIndex: Integer; ACanvas: TCanvas; + ARect: TRect; AState: TButtonDrawState); +var + LSurfaceRect: TRect; + LOldFontName: TFontName; + LOldFontColor: TColor; + LOldFontStyle: TFontStyles; + LOldParentFont: boolean; + LOldBrushStyle: TBrushStyle; + LOldPenWidth: Integer; + LStyle: TCustomStyleServices; + LState: TStyledButtonState; + LDetails: TThemedElementDetails; + LButtonItem: TStyledGrpButtonItem; + LDropDownRect: TRect; + LColor: TColor; +begin + //Do not call inherited + LButtonItem := Items[AIndex] as TStyledGrpButtonItem; + Assert(Assigned(LButtonItem)); + + if Assigned(OnDrawButton) and (not (csDesigning in ComponentState)) then + OnDrawButton(Self, AIndex, Canvas, ARect, AState) + else + begin + if Assigned(OnBeforeDrawButton) then + OnBeforeDrawButton(Self, AIndex, ACanvas, ARect, AState); + + LState := StyledButtonState(AIndex, AState); + + LOldParentFont := ParentFont; + LOldFontName := ACanvas.Font.Name; + LOldFontColor := ACanvas.Font.Color; + LOldFontStyle := ACanvas.Font.Style; + LOldBrushStyle := ACanvas.Brush.Style; + LOldPenWidth := ACanvas.Pen.Width; + try + GetDrawingStyle(ACanvas, LState, LButtonItem); + + //At the moment, no DropDown for Buttons + LDropDownRect := TRect.Create(0,0,0,0); + + if FFlat then + begin + LStyle := StyleServices{$IFDEF D10_4+}(Self){$ENDIF}; + if (LState in [bsmDisabled, bsmNormal]) and IsStyleEnabled then + begin + if (bdsSelected in AState) or (bdsDown in AState) then + LDetails := LStyle.GetElementDetails(tcbButtonSelected) + else if bdsHot in AState then + LDetails := LStyle.GetElementDetails(tcbButtonHot) + else + LDetails := LStyle.GetElementDetails(tcbButtonNormal); + + if not (IsCustomStyleActive and not (seFont in StyleElements)) and + LStyle.GetElementColor(LDetails, ecTextColor, LColor) and (LColor <> clNone) then + ACanvas.Font.Color := LColor; + end; + + //Don't draw button Face for Flat Normal/disabled Button + if LState in [bsmDisabled, bsmNormal] then + ACanvas.Brush.Style := bsClear; + end; + + DrawBackgroundAndBorder(ACanvas, ARect, LDropDownRect, + LButtonItem.StyleDrawType, LButtonItem.StyleRadius, LButtonItem.StyleRoundedCorners); + + LSurfaceRect := ARect; + if LDropDownRect.Width <> 0 then + Dec(LSurfaceRect.Right, LDropDownRect.Width); + + DrawCaptionAndImage(ACanvas, LSurfaceRect, LButtonItem.Caption, + LButtonItem.ImageIndex); + + { Draw the icon - prefer the event } + if Assigned(OnDrawIcon) then + OnDrawIcon(Self, AIndex, ACanvas, LSurfaceRect, AState, FSpacing); + + LSurfaceRect := ClientRect; + //DrawNotificationBadge(ACanvas, LSurfaceRect); + (* + { Show insert indications } + if [bdsInsertLeft, bdsInsertTop, bdsInsertRight, bdsInsertBottom] * State <> [] then + begin + ACanvas.Brush.Color := GetShadowColor(EdgeColor); + InsertIndication := Rect; + if bdsInsertLeft in State then + begin + Dec(InsertIndication.Left, 2); + InsertIndication.Right := InsertIndication.Left + 2; + end + else if bdsInsertTop in State then + begin + Dec(InsertIndication.Top); + InsertIndication.Bottom := InsertIndication.Top + 2; + end + else if bdsInsertRight in State then + begin + Inc(InsertIndication.Right, 2); + InsertIndication.Left := InsertIndication.Right - 2; + end + else if bdsInsertBottom in State then + begin + Inc(InsertIndication.Bottom); + InsertIndication.Top := InsertIndication.Bottom - 2; + end; + ACanvas.FillRect(InsertIndication); + ACanvas.Brush.Color := FillColor; + end; + *) + + if Assigned(OnAfterDrawButton) then + OnAfterDrawButton(Self, AIndex, Canvas, ARect, AState); + finally + //Restore original values + ACanvas.Font.Name := LOldFontName; + ACanvas.Font.Color := LOldFontColor; + ACanvas.Font.Style := LOldFontStyle; + ACanvas.Brush.Style := LOldBrushStyle; + ACanvas.Pen.Width := LOldPenWidth; + //ACanvas.Brush.Color := Color; + if LOldParentFont then + ParentFont := LOldParentFont; + end; + end; +end; + +procedure TStyledButtonGroup.SetBounds(ALeft, ATop, AWidth, AHeight: Integer); +begin + inherited; +end; + +procedure TStyledButtonGroup.ImageMarginsChange(Sender: TObject); +begin + Invalidate; +end; + +function TStyledButtonGroup.IsDefaultImageMargins: Boolean; +begin + //Default image margins: when all margins are zero except for + case FImageAlignment of + iaLeft: Result := (FImageMargins.Left = DEFAULT_IMAGE_HMARGIN) and + (FImageMargins.Top = 0) and (FImageMargins.Right = 0) and (FImageMargins.Bottom = 0); + iaRight: Result := (FImageMargins.Right = DEFAULT_IMAGE_HMARGIN) and + (FImageMargins.Top = 0) and (FImageMargins.Left = 0) and (FImageMargins.Bottom = 0); + iaTop: Result := (FImageMargins.Top = DEFAULT_IMAGE_VMARGIN) and + (FImageMargins.Left = 0) and (FImageMargins.Right = 0) and (FImageMargins.Bottom = 0); + iaBottom: Result := (FImageMargins.Bottom = DEFAULT_IMAGE_VMARGIN) and + (FImageMargins.Left = 0) and (FImageMargins.Right = 0) and (FImageMargins.Top = 0); + iaCenter: Result := (FImageMargins.Bottom = 0) and + (FImageMargins.Left = 0) and (FImageMargins.Right = 0) and (FImageMargins.Top = 0); + else + Result := False; + end; +end; + +procedure TStyledButtonGroup.CalcDefaultImageMargins(const AValue: TImageAlignment); + + function AdJustMargin(const AMargin, AOffset: Integer): Integer; + begin + Result := AMargin + Round(AOffset*GetScaleFactor); + end; + +begin + if IsDefaultImageMargins then + begin + FImageMargins.Left := 0; + FImageMargins.Right := 0; + FImageMargins.Top := 0; + FImageMargins.Bottom := 0; + case AValue of + iaLeft: FImageMargins.Left := AdJustMargin(FImageMargins.Left, DEFAULT_IMAGE_HMARGIN); + iaRight: FImageMargins.Right := AdJustMargin(FImageMargins.Right, DEFAULT_IMAGE_HMARGIN); + iaTop: FImageMargins.Top := AdJustMargin(FImageMargins.Top, DEFAULT_IMAGE_VMARGIN); + iaBottom: FImageMargins.Bottom := AdJustMargin(FImageMargins.Bottom, DEFAULT_IMAGE_VMARGIN); + end; + end; +end; + +function TStyledButtonGroup.ImageMarginsStored: Boolean; +begin + Result := not IsDefaultImageMargins; +end; + +function TStyledButtonGroup.IsCustomDrawType: Boolean; +begin + Result := FCustomDrawType; +end; + +function TStyledButtonGroup.IsCustomRoundedCorners: Boolean; +begin + Result := StyleRoundedCorners <> ALL_ROUNDED_CORNERS; +end; + +function TStyledButtonGroup.IsCustomRadius: Boolean; +begin + Result := StyleRadius <> DEFAULT_RADIUS; +end; + +function TStyledButtonGroup.IsStoredStyleAppearance: Boolean; +var + LClass: TStyledButtonClass; + LAppearance: TStyledButtonAppearance; + LButtonFamily: TButtonFamily; +begin + StyleFamilyCheckAttributes(FStyleFamily, LClass, LAppearance, LButtonFamily); + Result := FStyleAppearance <> LAppearance; +end; + +function TStyledButtonGroup.IsStoredStyleClass: Boolean; +var + LClass: TStyledButtonClass; + LAppearance: TStyledButtonAppearance; + LButtonFamily: TButtonFamily; +begin + StyleFamilyCheckAttributes(FStyleFamily, LClass, LAppearance, LButtonFamily); + + if AsVCLStyle then + begin + Result := (FStyleClass <> GetActiveStyleName) + and not SameText(FStyleClass, 'Windows'); + end + else + Result := FStyleClass <> LClass; +end; + +function TStyledButtonGroup.IsStoredStyleFamily: Boolean; +begin + Result := FStyleFamily <> DEFAULT_CLASSIC_FAMILY; +end; + +procedure TStyledButtonGroup.Loaded; +begin + inherited; + if not FStyleApplied (*and not HasCustomAttributes*) then + begin + StyleFamilyUpdateAttributes( + FStyleFamily, FStyleClass, FStyleAppearance, + FButtonStyleNormal, FButtonStylePressed, FButtonStyleSelected, + FButtonStyleHot, FButtonStyleDisabled); + StyleApplied := ApplyButtonStyle; + end; +end; + +procedure TStyledButtonGroup.MouseMove(Shift: TShiftState; X, Y: Integer); +var + LIndex: Integer; +begin + inherited; + LIndex := IndexOfButtonAt(X, Y); + if LIndex >= 0 then + inherited Cursor := FButtonsCursor + else + inherited Cursor := FCursor; +end; + +class procedure TStyledButtonGroup.RegisterDefaultRenderingStyle( + const ADrawType: TStyledButtonDrawType; const AFamily: TStyledButtonFamily; + const AClass: TStyledButtonClass; const AAppearance: TStyledButtonAppearance; + const AStyleRadius: Integer; const AButtonsCursor: TCursor); +begin + _DefaultStyleDrawType := ADrawType; + _UseCustomDrawType := True; + _DefaultFamily := AFamily; + _DefaultClass := AClass; + _DefaultAppearance := AAppearance; + _DefaultStyleRadius := AStyleRadius; + _DefaultButtonsCursor := AButtonsCursor; +end; + +function TStyledButtonGroup.ApplyButtonStyle: Boolean; +var + LButtonFamily: TButtonFamily; + LStyleClass: TStyledButtonClass; + LStyleAppearance: TStyledButtonAppearance; +begin + if AsVCLStyle then + begin + //if StyleElements contains seClient then use + //VCL Style assigned to Button or Global VCL Style + if seBorder in StyleElements then + LStyleAppearance := DEFAULT_APPEARANCE; + LStyleClass := GetActiveStyleName; + end + else + begin + LStyleClass := FStyleClass; + LStyleAppearance := FStyleAppearance; + end; + Result := StyleFamilyCheckAttributes(FStyleFamily, + LStyleClass, LStyleAppearance, LButtonFamily); + if Result (*or (csDesigning in ComponentState)*) then + begin + StyleFamilyUpdateAttributes( + FStyleFamily, + LStyleClass, + LStyleAppearance, + FButtonStyleNormal, + FButtonStylePressed, + FButtonStyleSelected, + FButtonStyleHot, + FButtonStyleDisabled); + end; + StyleClass := LStyleClass; + StyleAppearance := LStyleAppearance; + if Result then + Invalidate; +end; + +procedure TStyledButtonGroup.Assign(Source: TPersistent); +begin + inherited Assign(Source); + if Source is TStyledButtonGroup then + begin + FStyleFamily := TStyledButtonGroup(Source).FStyleFamily; + FStyleClass := TStyledButtonGroup(Source).FStyleClass; + FStyleAppearance := TStyledButtonGroup(Source).FStyleAppearance; + FStyleRadius := TStyledButtonGroup(Source).FStyleRadius; + FStyleRoundedCorners := TStyledButtonGroup(Source).FStyleRoundedCorners; + FStyleDrawType := TStyledButtonGroup(Source).FStyleDrawType; + FButtonsCursor := TStyledButtonGroup(Source).FButtonsCursor; + Invalidate; + end; +end; + +function TStyledButtonGroup.AsVCLStyle: Boolean; +begin + Result := (StyleFamily = DEFAULT_CLASSIC_FAMILY) and + (seClient in StyleElements); +end; + +function TStyledButtonGroup.GetAsVCLComponent: Boolean; +begin + Result := (StyleFamily = DEFAULT_CLASSIC_FAMILY) and + (seClient in StyleElements) and + (FStyleClass = GetActiveStyleName); +end; + +function TStyledButtonGroup.GetButtonClass: TGrpButtonItemClass; +begin + Result := TStyledGrpButtonItem; +end; + +function TStyledButtonGroup.GetButtonsClass: TGrpButtonItemsClass; +begin + Result := TStyledGrpButtonItems; +end; + +procedure TStyledButtonGroup.SetAsVCLComponent(const AValue: Boolean); +begin + if AValue <> GetAsVCLComponent then + begin + if AValue then + begin + FStyleFamily := DEFAULT_CLASSIC_FAMILY; + FStyleClass := DEFAULT_WINDOWS_CLASS; + FStyleAppearance := DEFAULT_APPEARANCE; + StyleElements := StyleElements + [seClient]; + FCustomDrawType := False; + end + else if FStyleFamily = DEFAULT_CLASSIC_FAMILY then + begin + StyleElements := StyleElements - [seClient]; + end; + UpdateStyleElements; + end; +end; + +procedure TStyledButtonGroup.UpdateStyleElements; +var + LStyleClass: TStyledButtonClass; +begin + if AsVCLStyle then + begin + //if StyleElements contains seClient then Update style + //as VCL Style assigned to ButtonGroup or Global VCL Style + if seBorder in StyleElements then + StyleAppearance := DEFAULT_APPEARANCE; + LStyleClass := GetActiveStyleName; + FStyleClass := LStyleClass; + StyleApplied := ApplyButtonGroupStyle; + ProcessButtons( + procedure (ABtn: TStyledGrpButtonItem) + begin + //ABtn.UpdateStyleElements; + ABtn.StyleDrawType := Self.StyleDrawType; + end); + end; + inherited; +end; + +function TStyledButtonGroup.ApplyButtonGroupStyle: Boolean; +var + LButtonFamily: TButtonFamily; +begin + Result := StyleFamilyCheckAttributes(FStyleFamily, + FStyleClass, FStyleAppearance, LButtonFamily); + if Result or (csDesigning in ComponentState) then + begin + StyleFamilyUpdateAttributes( + FStyleFamily, + FStyleClass, + FstyleAppearance, + FButtonStyleNormal, + FButtonStylePressed, + FButtonStyleSelected, + FButtonStyleHot, + FButtonStyleDisabled); + end; + Invalidate; +end; + +procedure TStyledButtonGroup.SetSpacing(const AValue: Integer); +begin + if FSpacing <> AValue then + begin + FSpacing := AValue; + Invalidate; + end; +end; + +procedure TStyledButtonGroup.SetStyleAppearance( + const AValue: TStyledButtonAppearance); +var + LValue: TStyledButtonAppearance; +begin + LValue := AValue; + if LValue = '' then + LValue := DEFAULT_APPEARANCE; + if (FStyleAppearance <> LValue) or not FStyleApplied then + begin + if not (csLoading in ComponentState) then + begin + ProcessButtons( + procedure (ABtn: TStyledGrpButtonItem) + begin + if ABtn.StyleAppearance = StyleAppearance then + ABtn.StyleAppearance := LValue; + end); + end; + FStyleAppearance := LValue; + StyleApplied := ApplyButtonGroupStyle; + end; +end; + +procedure TStyledButtonGroup.SetStyleApplied(const AValue: Boolean); +begin + FStyleApplied := AValue and (Items.Count > 0) and + not (csLoading in ComponentState); + if FStyleApplied then + begin + if not (csLoading in ComponentState) then + begin + ProcessButtons( + procedure (ABtn: TStyledGrpButtonItem) + begin + ABtn.LoadDefaultStyles; + end); + end; + end; +end; + +procedure TStyledButtonGroup.SetStyleClass(const AValue: TStyledButtonClass); +var + LValue: TStyledButtonClass; +begin + LValue := AValue; + if LValue = '' then + LValue := DEFAULT_WINDOWS_CLASS; + if (LValue <> Self.FStyleClass) or not FStyleApplied then + begin + if not (csLoading in ComponentState) then + begin + ProcessButtons( + procedure (ABtn: TStyledGrpButtonItem) + begin + if ABtn.StyleClass = StyleClass then + ABtn.StyleClass := LValue; + end); + end; + FStyleClass := LValue; + StyleApplied := ApplyButtonGroupStyle; +// if (FStyleFamily = DEFAULT_CLASSIC_FAMILY) and +// (LValue <> 'Windows') then +// StyleElements := [seFont, seBorder]; + end; +end; + +procedure TStyledButtonGroup.SetStyleDrawType(const AValue: TStyledButtonDrawType); +begin + FCustomDrawType := True; + if FStyleDrawType <> AValue then + begin + ProcessButtons( + procedure (ABtn: TStyledGrpButtonItem) + begin + if ABtn.StyleDrawType = StyleDrawType then + ABtn.StyleDrawType := AValue; + end); + FStyleDrawType := AValue; + StyleApplied := ApplyButtonGroupStyle; + end; +end; + +procedure TStyledButtonGroup.SetStyleFamily(const AValue: TStyledButtonFamily); +var + LValue: TStyledButtonFamily; +begin + LValue := AValue; + if LValue = '' then + LValue := DEFAULT_CLASSIC_FAMILY; + if (LValue <> Self.FStyleFamily) or not FStyleApplied then + begin + if not (csLoading in ComponentState) then + begin + ProcessButtons( + procedure (ABtn: TStyledGrpButtonItem) + begin + if ABtn.StyleFamily = FStyleFamily then + ABtn.StyleFamily := LValue; + end); + end; + FStyleFamily := LValue; + StyleApplied := ApplyButtonGroupStyle; + end; + if FStyleFamily = DEFAULT_CLASSIC_FAMILY then + StyleElements := [seFont, seClient, seBorder]; +end; + +procedure TStyledButtonGroup.SetStyleRadius(const AValue: Integer); +begin + if FStyleRadius <> AValue then + begin + if AValue <= 0 then + raise EReadError.create(SInvalidProperty); + ProcessButtons( + procedure (ABtn: TStyledGrpButtonItem) + begin + if ABtn.StyleRadius = FStyleRadius then + ABtn.StyleRadius := AValue; + end); + FStyleRadius := AValue; + StyleApplied := ApplyButtonGroupStyle; + end; +end; + +procedure TStyledButtonGroup.SetStyleRoundedCorners( + const AValue: TRoundedCorners); +begin + if FStyleRoundedCorners <> AValue then + begin + ProcessButtons( + procedure (ABtn: TStyledGrpButtonItem) + begin + if ABtn.StyleRoundedCorners = FStyleRoundedCorners then + ABtn.StyleRoundedCorners := AValue; + end); + FStyleRoundedCorners := AValue; + StyleApplied := ApplyButtonGroupStyle; + end; +end; + +procedure TStyledButtonGroup.SetButtonGroupStyle( + const AStyleFamily: TStyledButtonFamily; + const AStyleClass: TStyledButtonClass; + const AStyleAppearance: TStyledButtonAppearance); +begin + StyleFamily := AStyleFamily; + StyleClass := AStyleClass; + StyleAppearance := AStyleAppearance; + if not ApplyButtonGroupStyle then + raise EStyledButtonGroupError.CreateFmt(ERROR_SETTING_BUTTONGROUP_STYLE, + [AStyleFamily, AStyleClass, AStyleAppearance]); +end; + +procedure TStyledButtonGroup.SetButtonStyleDisabled( + const AValue: TStyledButtonAttributes); +begin + if FButtonStyleDisabled <> AValue then + begin + FButtonStyleDisabled := AValue; + Invalidate; + end; +end; + +procedure TStyledButtonGroup.SetButtonStyleHot( + const AValue: TStyledButtonAttributes); +begin + if FButtonStyleHot <> AValue then + begin + FButtonStyleHot := AValue; + Invalidate; + end; +end; + +procedure TStyledButtonGroup.SetButtonStyleNormal( + const AValue: TStyledButtonAttributes); +begin + if FButtonStyleNormal <> AValue then + begin + FButtonStyleNormal := AValue; + Invalidate; + end; +end; + +procedure TStyledButtonGroup.SetButtonStylePressed( + const AValue: TStyledButtonAttributes); +begin + if FButtonStylePressed <> AValue then + begin + FButtonStylePressed := AValue; + Invalidate; + end; +end; + +procedure TStyledButtonGroup.SetButtonStyleSelected( + const AValue: TStyledButtonAttributes); +begin + if FButtonStyleSelected <> AValue then + begin + FButtonStyleSelected := AValue; + Invalidate; + end; +end; + +procedure TStyledButtonGroup.SetCaptionAlignment(const AValue: TAlignment); +begin + if FCaptionAlignment <> AValue then + begin + FCaptionAlignment := AValue; + Invalidate; + end; +end; + +procedure TStyledButtonGroup.SetCursor(const AValue: TCursor); +begin + inherited Cursor := AValue; + FCursor := AValue; +end; + +procedure TStyledButtonGroup.SetFlat(const AValue: Boolean); +begin + if FFlat <> AValue then + begin + FFlat := AValue; + Invalidate; + end; +end; + +procedure TStyledButtonGroup.SetGrpButtonItems(const AValue: TStyledGrpButtonItems); +begin + inherited Items := AValue; +end; + +procedure TStyledButtonGroup.SetImageAlignment(const AValue: TImageAlignment); +begin + if FImageAlignment <> AValue then + begin + CalcDefaultImageMargins(AValue); + FImageAlignment := AValue; + if Images <> nil then + Invalidate; + end; +end; + +procedure TStyledButtonGroup.SetImageMargins(const AValue: TImageMargins); +begin + FImageMargins.Assign(AValue); +end; + +function TStyledButtonGroup.GetActiveStyleName: string; +begin + Result := Vcl.ButtonStylesAttributes.GetActiveStyleName(Self); +end; + +function TStyledButtonGroup.GetAttributes(const AMode: TStyledButtonState): TStyledButtonAttributes; +begin + case Amode of + bsmPressed: Result := FButtonStylePressed; + bsmSelected: Result := FButtonStyleSelected; + bsmHot: Result := FButtonStyleHot; + bsmDisabled: Result := FButtonStyleDisabled; + else + Result := FButtonStyleNormal; + end; +end; + +procedure TStyledButtonGroup.GetDrawingStyle(const ACanvas: TCanvas; + const AButtonState: TStyledButtonState; + const AItem: TStyledGrpButtonItem); +var + LCustomAttributes: Boolean; + LSyleAttributes: TStyledButtonAttributes; +begin + LCustomAttributes := ((AItem.FStyleFamily) <> FStyleFamily) or + ((AItem.FStyleClass) <> FStyleClass) or + ((AItem.FStyleAppearance) <> FStyleAppearance); + try + if LCustomAttributes then + begin + //Getting custom drawing styles for single button + StyleFamilyUpdateAttributes( + AItem.FStyleFamily, AItem.FStyleClass, AItem.FStyleAppearance, + FButtonStyleNormal, FButtonStylePressed, FButtonStyleSelected, + FButtonStyleHot, FButtonStyleDisabled); + end; + + //Getting custom drawing styles for all buttons + LSyleAttributes := GetAttributes(AButtonState); + + ACanvas.Pen.Style := LSyleAttributes.PenStyle; + ACanvas.Pen.Width := Round(LSyleAttributes.BorderWidth{$IFDEF D10_3+}*ScaleFactor{$ENDIF}); + ACanvas.Pen.Color := LSyleAttributes.BorderColor; + ACanvas.Brush.Style := LSyleAttributes.BrushStyle; + if LSyleAttributes.ButtonDrawStyle <> btnClear then + ACanvas.Brush.Color := LSyleAttributes.ButtonColor; + ACanvas.Font := Font; + ACanvas.Font.Color := LSyleAttributes.FontColor; + if ParentFont then + ACanvas.Font.Style := LSyleAttributes.FontStyle; + finally + if LCustomAttributes then + begin + //Restore drawing styles for every buttons + StyleFamilyUpdateAttributes( + FStyleFamily, FStyleClass, FStyleAppearance, + FButtonStyleNormal, FButtonStylePressed, FButtonStyleSelected, + FButtonStyleHot, FButtonStyleDisabled); + end; + end; +end; + +function TStyledButtonGroup.GetGrpButtonItems: TStyledGrpButtonItems; +begin + Result := inherited Items as TStyledGrpButtonItems; +end; + +function TStyledButtonGroup.IsStyleEnabled: Boolean; +begin + Result := IsCustomStyleActive and (StyleElements <> []); +end; + +procedure TStyledButtonGroup.ProcessButtons( + AButtonProc: TGrpButtonProc); +var + I: Integer; + LButton: TStyledGrpButtonItem; +begin + if not Assigned(Items) then + Exit; + for I := 0 to Items.Count -1 do + begin + if Items[I] is TStyledGrpButtonItem then + begin + LButton := TStyledGrpButtonItem(Items[I]); + AButtonProc(LButton); + end; + end; +end; + +{ TStyledGrpButtonItem } + +function TStyledGrpButtonItem.ApplyButtonStyle: Boolean; +var + LButtonFamily: TButtonFamily; +begin + if not FStyleApplied then + begin + Result := StyleFamilyCheckAttributes(FStyleFamily, + FStyleClass, FStyleAppearance, LButtonFamily); + if Result then + begin + InvalidateOwner; + FStyleApplied := True; + end; + end + else + Result := False; +end; + +procedure TStyledGrpButtonItem.LoadDefaultStyles; +begin + if Assigned(ButtonGroup) and (ButtonGroup.FStyleApplied) and not FStyleApplied then + begin + FStyleFamily := ButtonGroup.StyleFamily; + FStyleClass := ButtonGroup.StyleClass; + FStyleAppearance := ButtonGroup.StyleAppearance; + FStyleRadius := ButtonGroup.StyleRadius; + FStyleRoundedCorners := ButtonGroup.StyleRoundedCorners; + FStyleDrawType := ButtonGroup.StyleDrawType; + end; +end; + +constructor TStyledGrpButtonItem.Create(Collection: TCollection); +begin + inherited; + FStyleDrawType := TStyledButtonGroup._DefaultStyleDrawType; + FStyleRadius := TStyledButtonGroup._DefaultStyleRadius; + FStyleRoundedCorners := ALL_ROUNDED_CORNERS; + LoadDefaultStyles; +end; + +function TStyledGrpButtonItem.GetStyledButtonGroup: TStyledButtonGroup; +begin + if Collection is TStyledGrpButtonItems then + Result := TStyledGrpButtonItems(Collection).ButtonGroup + else + Result := nil; +end; + +procedure TStyledGrpButtonItem.InvalidateOwner; +begin + if Assigned(ButtonGroup) then + ButtonGroup.Invalidate; +end; + +function TStyledGrpButtonItem.IsCustomDrawType: Boolean; +begin + Result := Assigned(ButtonGroup) and + (FStyleDrawType <> ButtonGroup.FStyleDrawType); +end; + +function TStyledGrpButtonItem.IsCustomRoundedCorners: Boolean; +begin + Result := Assigned(ButtonGroup) and + (FStyleRoundedCorners <> ButtonGroup.FStyleRoundedCorners); +end; + +function TStyledGrpButtonItem.IsCustomRadius: Boolean; +begin + Result := Assigned(ButtonGroup) and + (FStyleRadius <> ButtonGroup.FStyleRadius); +end; + +function TStyledGrpButtonItem.IsStoredStyle: Boolean; +begin + Result := Assigned(ButtonGroup) and + (FStyleFamily <> ButtonGroup.FStyleFamily) or + (FStyleClass <> ButtonGroup.FStyleClass) or + (FStyleAppearance <> ButtonGroup.FStyleAppearance); +end; + +procedure TStyledGrpButtonItem.SetStyleFamily( + const AValue: TStyledButtonFamily); +begin + if FStyleFamily <> AValue then + begin + FStyleFamily := AValue; + InvalidateOwner; + end; + ApplyButtonStyle; +end; + +procedure TStyledGrpButtonItem.SetStyleClass( + const AValue: TStyledButtonClass); +begin + if FStyleClass <> AValue then + begin + FStyleClass := AValue; + InvalidateOwner; + end; + ApplyButtonStyle; +end; + +procedure TStyledGrpButtonItem.SetButtonStyle( + const AStyleFamily: TStyledButtonFamily; + const AStyleClass: TStyledButtonClass; + const AStyleAppearance: TStyledButtonAppearance); +begin + FStyleApplied := False; + FStyleFamily := AStyleFamily; + FStyleClass := AStyleClass; + FStyleAppearance := AStyleAppearance; + if not ApplyButtonStyle then + raise EStyledButtonGroupError.CreateFmt(ERROR_SETTING_BUTTON_STYLE, + [AStyleFamily, AStyleClass, AStyleAppearance]); +end; + +procedure TStyledGrpButtonItem.SetStyleAppearance( + const AValue: TStyledButtonAppearance); +begin + if FStyleAppearance <> AValue then + begin + FStyleAppearance := AValue; + InvalidateOwner; + end; + ApplyButtonStyle; +end; + +procedure TStyledGrpButtonItem.SetStyleDrawType( + const AValue: TStyledButtonDrawType); +begin + if FStyleDrawType <> AValue then + begin + FStyleDrawType := AValue; + InvalidateOwner; + end; + ApplyButtonStyle; +end; + +procedure TStyledGrpButtonItem.SetStyleRadius(const AValue: Integer); +begin + if FStyleRadius <> AValue then + begin + FStyleRadius := AValue; + InvalidateOwner; + end; + ApplyButtonStyle; +end; + +procedure TStyledGrpButtonItem.SetStyleRoundedCorners(const AValue: TRoundedCorners); +begin + if FStyleRoundedCorners <> AValue then + begin + FStyleRoundedCorners := AValue; + InvalidateOwner; + end; + ApplyButtonStyle; +end; + +{ TStyledGrpButtonItems } + +function TStyledGrpButtonItems.Add: TStyledGrpButtonItem; +begin + Result := inherited Add as TStyledGrpButtonItem; +end; + +constructor TStyledGrpButtonItems.Create(const ButtonGroup: TButtonGroup); +begin + inherited; + ; +end; + +function TStyledGrpButtonItems.GetStyledButtonGroup: TStyledButtonGroup; +begin + Result := inherited ButtonGroup as TStyledButtonGroup; +end; + +initialization + TStyledButtonGroup._DefaultStyleDrawType := DEFAULT_STYLEDRAWTYPE; + TStyledButtonGroup._DefaultFamily := DEFAULT_CLASSIC_FAMILY; + TStyledButtonGroup._DefaultClass := DEFAULT_WINDOWS_CLASS; + TStyledButtonGroup._DefaultAppearance := DEFAULT_APPEARANCE; + TStyledButtonGroup._DefaultStyleRadius := DEFAULT_RADIUS; + TStyledButtonGroup._DefaultButtonsCursor := DEFAULT_CURSOR; + +end. diff --git a/Ext/StyledComponents/source/Vcl.StyledCategoryButtons.pas b/Ext/StyledComponents/source/Vcl.StyledCategoryButtons.pas new file mode 100644 index 0000000..27e1aa5 --- /dev/null +++ b/Ext/StyledComponents/source/Vcl.StyledCategoryButtons.pas @@ -0,0 +1,1513 @@ +{******************************************************************************} +{ } +{ StyledCategoryButtons: a Styled CategoryButtons with TStyledButtonItem } +{ Based on TCategoryButtons and TButtonItem } +{ } +{ Copyright (c) 2022-2024 (Ethea S.r.l.) } +{ Author: Carlo Barazzetta } +{ Contributors: } +{ } +{ https://github.com/EtheaDev/StyledComponents } +{ } +{******************************************************************************} +{ } +{ Licensed under the Apache License, Version 2.0 (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.apache.org/licenses/LICENSE-2.0 } +{ } +{ Unless required by applicable law or agreed to in writing, software } +{ distributed under the License is distributed on an "AS IS" BASIS, } +{ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. } +{ See the License for the specific language governing permissions and } +{ limitations under the License. } +{ } +{******************************************************************************} +unit Vcl.StyledCategoryButtons; + +interface + +{$INCLUDE StyledComponents.inc} + +uses + Vcl.ImgList + , System.UITypes + , System.SysUtils + , System.Classes + , System.Math + , Vcl.ToolWin + , Vcl.ComCtrls + , Vcl.StdCtrls + , Vcl.ExtCtrls + , Vcl.Themes + , Vcl.Controls + , Vcl.ActnList + , Vcl.Menus + , Vcl.CategoryButtons + , Winapi.Messages + , Winapi.Windows + , Vcl.StyledButton + , Vcl.ButtonStylesAttributes + , Vcl.StandardButtonStyles + , Vcl.Graphics + ; + +resourcestring + ERROR_SETTING_CATEGORYBUTTONS_STYLE = 'Error setting CategoryButtons Style: %s/%s/%s not available'; + +type + EStyledCategoryButtonsError = Exception; + + TStyledCategoryButtons = class; + TStyledCategoryButtonsClass = class of TStyledCategoryButtons; + TStyledButtonItem = class; + TStyledButtonItemClass = class of TButtonItem; + TStyledButtonCategory = class; + TStyledButtonCategoryClass = class of TStyledButtonCategory; + TStyledButtonCategories = class; + TStyledButtonCategoriesClass = class of TStyledButtonCategories; + + + TButtonProc = reference to procedure (Button: TStyledButtonItem); + + { TStyledButtonCategory } + TStyledButtonCategory = class(TButtonCategory) + public + constructor Create(Collection: TCollection); override; + end; + + { TStyledButtonCategories } + TStyledButtonCategories = class(TButtonCategories) + private + function GetStyledCategoryButtons: TStyledCategoryButtons; + function GetItem(Index: Integer): TStyledButtonCategory; + procedure SetItem(Index: Integer; const AValue: TStyledButtonCategory); + public + constructor Create(const CategoryButtons: TCategoryButtons); override; + function Add: TStyledButtonCategory; + property CategoryButtons: TStyledCategoryButtons read GetStyledCategoryButtons; + property Items[Index: Integer]: TStyledButtonCategory read GetItem write SetItem; default; + end; + + { TStyledButtonItem } + TStyledButtonItem = class(TButtonItem) + private + FCollection: TButtonCollection; + //Styled Attributes + FStyleRadius: Integer; + FStyleRoundedCorners: TRoundedCorners; + FStyleDrawType: TStyledButtonDrawType; + FStyleFamily: TStyledButtonFamily; + FStyleClass: TStyledButtonClass; + FStyleAppearance: TStyledButtonAppearance; + FStyleApplied: Boolean; + procedure InvalidateOwner; + function IsCustomDrawType: Boolean; + function IsCustomRoundedCorners: Boolean; + function IsCustomRadius: Boolean; + function IsStoredStyle: Boolean; + procedure SetStyleFamily(const AValue: TStyledButtonFamily); + procedure SetStyleClass(const AValue: TStyledButtonClass); + procedure SetStyleAppearance(const AValue: TStyledButtonAppearance); + procedure SetStyleDrawType(const AValue: TStyledButtonDrawType); + procedure SetStyleRadius(const AValue: Integer); + procedure SetStyleRoundedCorners(const AValue: TRoundedCorners); + function GetStyledCategoryButtons: TStyledCategoryButtons; + function ApplyButtonStyle: Boolean; + procedure LoadDefaultStyles; + public + constructor Create(Collection: TCollection); override; + procedure SetButtonStyle(const AStyleFamily: TStyledButtonFamily; + const AStyleClass: TStyledButtonClass; + const AStyleAppearance: TStyledButtonAppearance); + published + property CategoryButtons: TStyledCategoryButtons read GetStyledCategoryButtons; + + //StyledComponents Attributes + property StyleRadius: Integer read FStyleRadius write SetStyleRadius stored IsCustomRadius; + property StyleDrawType: TStyledButtonDrawType read FStyleDrawType write SetStyleDrawType stored IsCustomDrawType; + property StyleRoundedCorners: TRoundedCorners read FStyleRoundedCorners write SetStyleRoundedCorners stored IsCustomRoundedCorners; + property StyleFamily: TStyledButtonFamily read FStyleFamily write SetStyleFamily stored IsStoredStyle; + property StyleClass: TStyledButtonClass read FStyleClass write SetStyleClass stored IsStoredStyle; + property StyleAppearance: TStyledButtonAppearance read FStyleAppearance write SetStyleAppearance stored IsStoredStyle; + end; + + + { TStyledCategoryButtons } + [ComponentPlatforms(pidWin32 or pidWin64)] + TStyledCategoryButtons = class(TCategoryButtons) + private + //StyledButton Attributes + FButtonStyleNormal: TStyledButtonAttributes; + FButtonStylePressed: TStyledButtonAttributes; + FButtonStyleSelected: TStyledButtonAttributes; + FButtonStyleHot: TStyledButtonAttributes; + FButtonStyleDisabled: TStyledButtonAttributes; + + //Styled Attributes + FStyleRadius: Integer; + FStyleDrawType: TStyledButtonDrawType; + FStyleRoundedCorners: TRoundedCorners; + FStyleFamily: TStyledButtonFamily; + FStyleClass: TStyledButtonClass; + FStyleAppearance: TStyledButtonAppearance; + FCustomDrawType: Boolean; + FStyleApplied: Boolean; + + FCaptionAlignment: TAlignment; + FImageAlignment: TImageAlignment; + FImageMargins: TImageMargins; + FSpacing: Integer; + FFlat: Boolean; + FButtonsCursor: TCursor; + FCursor: TCursor; + + class var + _DefaultStyleDrawType: TStyledButtonDrawType; + _UseCustomDrawType: Boolean; + _DefaultFamily: TStyledButtonFamily; + _DefaultClass: TStyledButtonClass; + _DefaultAppearance: TStyledButtonAppearance; + _DefaultStyleRadius: Integer; + _DefaultButtonsCursor: TCursor; + + procedure ImageMarginsChange(Sender: TObject); + function IsCustomDrawType: Boolean; + function IsCustomRoundedCorners: Boolean; + function IsCustomRadius: Boolean; + function ImageMarginsStored: Boolean; + function IsStoredStyleAppearance: Boolean; + function IsStoredStyleClass: Boolean; + function IsStoredStyleFamily: Boolean; + procedure SetStyleAppearance(const AValue: TStyledButtonAppearance); + procedure SetStyleClass(const AValue: TStyledButtonClass); + procedure SetStyleDrawType(const AValue: TStyledButtonDrawType); + procedure SetStyleFamily(const AValue: TStyledButtonFamily); + procedure SetStyleRadius(const AValue: Integer); + procedure SetStyleRoundedCorners(const AValue: TRoundedCorners); + function ApplyCategoryButtonsStyle: Boolean; + procedure SetStyleApplied(const AValue: Boolean); + function ApplyButtonStyle: Boolean; + function GetActiveStyleName: string; + function AsVCLStyle: Boolean; + function GetAsVCLComponent: Boolean; + procedure SetAsVCLComponent(const AValue: Boolean); + procedure ProcessButtons(AButtonProc: TButtonProc); + procedure SetButtonStyleDisabled(const AValue: TStyledButtonAttributes); + procedure SetButtonStyleHot(const AValue: TStyledButtonAttributes); + procedure SetButtonStyleNormal(const AValue: TStyledButtonAttributes); + procedure SetButtonStylePressed(const AValue: TStyledButtonAttributes); + procedure SetButtonStyleSelected(const AValue: TStyledButtonAttributes); + procedure GetDrawingStyle(const ACanvas: TCanvas; + const AButtonState: TStyledButtonState; + const AItem: TStyledButtonItem); + function GetAttributes(const AMode: TStyledButtonState): TStyledButtonAttributes; + procedure DrawBackgroundAndBorder(const ACanvas: TCanvas; + const ADrawRect, ADropDownRect: TRect; + const AStyleDrawType: TStyledButtonDrawType; + const ARadius: Single; const ARoundedCorners: TRoundedCorners); + procedure DrawCaptionAndImage(const ACanvas: TCanvas; const ASurfaceRect: TRect; + const ACaption: TCaption; const AImageIndex: Integer); + procedure SetCaptionAlignment(const AValue: TAlignment); + function GetImageSize(out AWidth, AHeight: Integer; + out AImageList: TCustomImageList): boolean; + procedure DrawText(const ASurfaceRect: TRect; + const ACanvas: TCanvas; const AText: string; + const AAlignment: TAlignment; const ASpacing: Integer; var ARect: TRect; + AFlags: Cardinal); + procedure SetSpacing(const AValue: Integer); + procedure SetFlat(const AValue: Boolean); + function IsStyleEnabled: Boolean; + procedure SetCursor(const AValue: TCursor); + procedure SetImageAlignment(const AValue: TImageAlignment); + function GetScaleFactor: Single; + function GetButtonCategories: TStyledButtonCategories; + procedure SetButtonCategories(const AValue: TStyledButtonCategories); + procedure SetImageMargins(const AValue: TImageMargins); + function IsDefaultImageMargins: Boolean; + procedure CalcDefaultImageMargins(const AValue: TImageAlignment); + {$IFNDEF D10_4+} + function IsCustomStyleActive: Boolean; + {$ENDIF} + //Windows messages + procedure CMStyleChanged(var Message: TMessage); message CM_STYLECHANGED; + protected + procedure Loaded; override; + + function GetButtonCategoriesClass: TButtonCategoriesClass; override; + function GetButtonCategoryClass: TButtonCategoryClass; override; + function GetButtonItemClass: TButtonItemClass; override; + + procedure UpdateStyleElements; override; + procedure DrawButton(const AButton: TButtonItem; ACanvas: TCanvas; + ARect: TRect; AState: TButtonDrawState); override; + procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override; + public + procedure Assign(Source: TPersistent); override; + function StyledButtonState(const AState: TButtonDrawState): TStyledButtonState; + class procedure RegisterDefaultRenderingStyle( + const ADrawType: TStyledButtonDrawType; + const AFamily: TStyledButtonFamily = DEFAULT_CLASSIC_FAMILY; + const AClass: TStyledButtonClass = DEFAULT_WINDOWS_CLASS; + const AAppearance: TStyledButtonAppearance = DEFAULT_APPEARANCE; + const AStyleRadius: Integer = DEFAULT_RADIUS; + const AButtonsCursor: TCursor = DEFAULT_CURSOR); virtual; + procedure SetCategoryButtonsStyle(const AStyleFamily: TStyledButtonFamily; + const AStyleClass: TStyledButtonClass; + const AStyleAppearance: TStyledButtonAppearance); + procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override; + //Styled constructor + constructor CreateStyled(AOwner: TComponent; + const AFamily: TStyledButtonFamily; + const AClass: TStyledButtonClass; + const AAppearance: TStyledButtonAppearance); virtual; + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + property AsVCLComponent: Boolean read GetAsVCLComponent write SetAsVCLComponent stored False; + property StyleApplied: Boolean read FStyleApplied write SetStyleApplied; + published + property ButtonsCursor: TCursor read FButtonsCursor write FButtonsCursor default DEFAULT_CURSOR; + property Cursor: TCursor read FCursor write SetCursor default crDefault; + property CaptionAlignment: TAlignment read FCaptionAlignment write SetCaptionAlignment default taLeftJustify; + property Categories: TStyledButtonCategories read GetButtonCategories write SetButtonCategories; + property ImageAlignment: TImageAlignment read FImageAlignment write SetImageAlignment default iaLeft; + property ImageMargins: TImageMargins read FImageMargins write SetImageMargins stored ImageMarginsStored; + property Flat: Boolean read FFlat write SetFlat default False; + property Spacing: Integer read FSpacing write SetSpacing default 4; + + //StyledButton Attributes + property ButtonStyleNormal: TStyledButtonAttributes read FButtonStyleNormal write SetButtonStyleNormal; + property ButtonStylePressed: TStyledButtonAttributes read FButtonStylePressed write SetButtonStylePressed; + property ButtonStyleSelected: TStyledButtonAttributes read FButtonStyleSelected write SetButtonStyleSelected; + property ButtonStyleHot: TStyledButtonAttributes read FButtonStyleHot write SetButtonStyleHot; + property ButtonStyleDisabled: TStyledButtonAttributes read FButtonStyleDisabled write SetButtonStyleDisabled; + + //StyledComponents Attributes + property StyleRadius: Integer read FStyleRadius write SetStyleRadius stored IsCustomRadius; + property StyleDrawType: TStyledButtonDrawType read FStyleDrawType write SetStyleDrawType stored IsCustomDrawType; + property StyleRoundedCorners: TRoundedCorners read FStyleRoundedCorners write SetStyleRoundedCorners stored IsCustomRoundedCorners; + property StyleFamily: TStyledButtonFamily read FStyleFamily write SetStyleFamily stored IsStoredStyleFamily; + property StyleClass: TStyledButtonClass read FStyleClass write SetStyleClass stored IsStoredStyleClass; + property StyleAppearance: TStyledButtonAppearance read FStyleAppearance write SetStyleAppearance stored IsStoredStyleAppearance; + end; + +implementation + +uses + Vcl.Consts + , Vcl.Forms + , System.Types + , System.RTLConsts + ; + +const + DEFAULT_IMAGE_HMARGIN = 2; + DEFAULT_IMAGE_VMARGIN = 2; + +{ TStyledCategoryButtons } + +constructor TStyledCategoryButtons.CreateStyled(AOwner: TComponent; + const AFamily: TStyledButtonFamily; const AClass: TStyledButtonClass; + const AAppearance: TStyledButtonAppearance); +begin + Assert(Assigned(AOwner)); + inherited Create(AOwner); + + //new properties for StyledCategoryButtons + FCaptionAlignment := taLeftJustify; + FSpacing := 4; + FFlat := False; + FImageAlignment := iaLeft; + FButtonsCursor := _DefaultButtonsCursor; + FImageMargins := TImageMargins.Create; + FImageMargins.Left := 2; + FImageMargins.OnChange := ImageMarginsChange; + + FButtonStyleNormal := TStyledButtonAttributes.Create(Self); + FButtonStyleNormal.Name := 'Normal'; + FButtonStylePressed := TStyledButtonAttributes.Create(Self); + FButtonStylePressed.Name := 'Pressed'; + FButtonStyleSelected := TStyledButtonAttributes.Create(Self); + FButtonStyleSelected.Name := 'Selected'; + FButtonStyleHot := TStyledButtonAttributes.Create(Self); + FButtonStyleHot.Name := 'Hot'; + FButtonStyleDisabled := TStyledButtonAttributes.Create(Self); + FButtonStyleDisabled.Name := 'Disabled'; + + FStyleDrawType := _DefaultStyleDrawType; + FStyleRadius := _DefaultStyleRadius; + FStyleRoundedCorners := ALL_ROUNDED_CORNERS; + FStyleFamily := AFamily; + FStyleClass := AClass; + FStyleAppearance := AAppearance; +end; + +procedure TStyledCategoryButtons.CMStyleChanged(var Message: TMessage); +begin + inherited; + ApplyButtonStyle; +end; + +constructor TStyledCategoryButtons.Create(AOwner: TComponent); +begin + CreateStyled(AOwner, + _DefaultFamily, + _DefaultClass, + _DefaultAppearance); +end; + +destructor TStyledCategoryButtons.Destroy; +begin + FreeAndNil(FImageMargins); + FreeAndNil(FButtonStyleNormal); + FreeAndNil(FButtonStylePressed); + FreeAndNil(FButtonStyleSelected); + FreeAndNil(FButtonStyleHot); + FreeAndNil(FButtonStyleDisabled); + inherited Destroy; +end; + +function TStyledCategoryButtons.GetScaleFactor: Single; +begin + Result := {$IFDEF D10_3+}ScaleFactor{$ELSE}1{$ENDIF}; +end; + +procedure TStyledCategoryButtons.DrawBackgroundAndBorder( + const ACanvas: TCanvas; const ADrawRect, ADropDownRect: TRect; + const AStyleDrawType: TStyledButtonDrawType; + const ARadius: Single; const ARoundedCorners: TRoundedCorners); +var + LButtonOffset: Integer; + LDropDownRect: TRect; + LScaleFactor: Single; +begin + LScaleFactor := GetScaleFactor; + LDropDownRect := ADropDownRect; + //Draw Button Shape + CanvasDrawshape(ACanvas, ADrawRect, AStyleDrawType, + ARadius*LScaleFactor, ARoundedCorners); + + //Draw Bar and Triangle + if LDropDownRect.Width > 0 then + begin + if not (AStyleDrawType in [btRounded, btEllipse]) then + begin + CanvasDrawBar(ACanvas, LDropDownRect, + LScaleFactor, + ACanvas.Pen.Color); + CanvasDrawTriangle(ACanvas, LDropDownRect, + LScaleFactor, + ACanvas.Font.Color); + end + else + begin + LButtonOffset := LDropDownRect.Height div 8; + LDropDownRect.Left := LDropDownRect.Left - LButtonOffset; + LDropDownRect.Right := LDropDownRect.Right - LButtonOffset; + CanvasDrawTriangle(ACanvas, LDropDownRect, + LScaleFactor, + ACanvas.Font.Color); + end; + end; +end; + +function TStyledCategoryButtons.GetImageSize(out AWidth, AHeight: Integer; + out AImageList: TCustomImageList): boolean; +begin + AWidth := 0; + AHeight := 0; + //Return True if using ImageList + if Assigned(Images) then + begin + AWidth := Images.Width; + AHeight := Images.Height; + Result := True; + end + else + Result := False; +end; + +procedure TStyledCategoryButtons.DrawText( + const ASurfaceRect: TRect; + const ACanvas: TCanvas; + const AText: string; const AAlignment: TAlignment; + const ASpacing: Integer; + var ARect: TRect; AFlags: Cardinal); +var + R: TRect; + LText: string; +begin + //Drawing Caption + R := ARect; + LText := AText; + Winapi.Windows.DrawText(ACanvas.Handle, PChar(AText), Length(AText), + R, AFlags or DT_CALCRECT); + case AAlignment of + taLeftJustify: + begin + OffsetRect(R, ASpacing, (ARect.Height - R.Height) div 2); + end; + taRightJustify: + begin + OffsetRect(R, ARect.Width - R.Width - ASpacing, (ARect.Height - R.Height) div 2); + end; + else + begin + OffsetRect(R, (ARect.Width - R.Width) div 2, (ARect.Height - R.Height) div 2); + end; + end; + if ASurfaceRect.Right < R.Right + ASpacing then + R.Right := ASurfaceRect.Right - ASpacing; + if ASurfaceRect.Left > R.Left - ASpacing then + R.Left := ASurfaceRect.Left + ASpacing; + ACanvas.TextRect(R, LText, [tfEndEllipsis]); +end; + +procedure TStyledCategoryButtons.DrawCaptionAndImage( + const ACanvas: TCanvas; const ASurfaceRect: TRect; + const ACaption: TCaption; const AImageIndex: Integer); +var + LTextFlags: Cardinal; + LImageRect, LTextRect: TRect; + LImageList: TCustomImageList; + LImageWidth, LImageHeight: Integer; + LUseImageList: Boolean; +begin + if boShowCaptions in ButtonOptions then + begin + case FCaptionAlignment of + taLeftJustify: LTextFlags := DT_NOCLIP or DT_LEFT or DT_VCENTER; + taRightJustify: LTextFlags := DT_NOCLIP or DT_RIGHT or DT_VCENTER; + else + LTextFlags := DT_NOCLIP or DT_CENTER or DT_VCENTER; + end; + LTextFlags := DrawTextBiDiModeFlags(LTextFlags); + (* + if FWordWrap then + LTextFlags := LTextFlags or DT_WORDBREAK; + *) + end + else + begin + LTextFlags := DT_NOCLIP or DT_CENTER or DT_VCENTER; + end; + LUseImageList := GetImageSize(LImageWidth, LImageHeight, LImageList); + + //Calculate LTextRect and LImageRect using ImageMargins and ImageAlignment + CalcImageAndTextRect(ASurfaceRect, ACaption, LTextRect, LImageRect, + LImageWidth, LImageHeight, FImageAlignment, FImageMargins, GetScaleFactor); + + if LUseImageList and not Assigned(OnDrawIcon) then + begin + //Uses an ImageList to draw the Icon + Images.Draw(ACanvas, LImageRect.Left, LImageRect.Top, + AImageIndex, Enabled); + end; + + if boShowCaptions in ButtonOptions then + DrawText(ASurfaceRect, ACanvas, ACaption, FCaptionAlignment, FSpacing, + LTextRect, LTextFlags); +end; + +{$IFNDEF D10_4+} +function TStyledCategoryButtons.IsCustomStyleActive: Boolean; +begin + Result := False; +end; +{$ENDIF} + +function TStyledCategoryButtons.StyledButtonState( + const AState: TButtonDrawState): TStyledButtonState; +begin + //Calculate Styled State based on State + if (bdsHot in AState) and not (bdsDown in AState) then + Result := bsmHot + else if bdsDown in AState then + Result := bsmPressed + else if bdsFocused in AState then + Result := bsmSelected + else if not Enabled then + Result := bsmDisabled + else + Result := bsmNormal; +end; + +procedure TStyledCategoryButtons.DrawButton(const AButton: TButtonItem; + ACanvas: TCanvas; ARect: TRect; AState: TButtonDrawState); +var + LSurfaceRect: TRect; + LOldFontName: TFontName; + LOldFontColor: TColor; + LOldFontStyle: TFontStyles; + LOldParentFont: boolean; + LOldBrushStyle: TBrushStyle; + LOldPenWidth: Integer; + LStyle: TCustomStyleServices; + LState: TStyledButtonState; + LDetails: TThemedElementDetails; + LButtonItem: TStyledButtonItem; + LDropDownRect: TRect; + LColor: TColor; +begin + //Do not call inherited + LButtonItem := AButton as TStyledButtonItem; + Assert(Assigned(LButtonItem)); + + if Assigned(OnDrawButton) and (not (csDesigning in ComponentState)) then + OnDrawButton(Self, LButtonItem, ACanvas, ARect, AState) + else + begin + if Assigned(OnBeforeDrawButton) then + OnBeforeDrawButton(Self, LButtonItem, ACanvas, ARect, AState); + + LState := StyledButtonState(AState); + + LOldParentFont := ParentFont; + LOldFontName := ACanvas.Font.Name; + LOldFontColor := ACanvas.Font.Color; + LOldFontStyle := ACanvas.Font.Style; + LOldBrushStyle := ACanvas.Brush.Style; + LOldPenWidth := ACanvas.Pen.Width; + try + GetDrawingStyle(ACanvas, LState, LButtonItem); + + //At the moment, no DropDown for Buttons + LDropDownRect := TRect.Create(0,0,0,0); + + if FFlat then + begin + LStyle := StyleServices{$IFDEF D10_4+}(Self){$ENDIF}; + if (LState in [bsmDisabled, bsmNormal]) and IsStyleEnabled then + begin + if (bdsSelected in AState) or (bdsDown in AState) then + LDetails := LStyle.GetElementDetails(tcbButtonSelected) + else if bdsHot in AState then + LDetails := LStyle.GetElementDetails(tcbButtonHot) + else + LDetails := LStyle.GetElementDetails(tcbButtonNormal); + + if not (IsCustomStyleActive and not (seFont in StyleElements)) and + LStyle.GetElementColor(LDetails, ecTextColor, LColor) and (LColor <> clNone) then + ACanvas.Font.Color := LColor; + end; + + //Don't draw button Face for Flat Normal/disabled Button + if LState in [bsmDisabled, bsmNormal] then + ACanvas.Brush.Style := bsClear; + end; + + DrawBackgroundAndBorder(ACanvas, ARect, LDropDownRect, + LButtonItem.StyleDrawType, LButtonItem.StyleRadius, LButtonItem.StyleRoundedCorners); + + LSurfaceRect := ARect; + if LDropDownRect.Width <> 0 then + Dec(LSurfaceRect.Right, LDropDownRect.Width); + + DrawCaptionAndImage(ACanvas, LSurfaceRect, LButtonItem.Caption, + LButtonItem.ImageIndex); + + { Draw the icon - prefer the event } + if Assigned(OnDrawIcon) then + OnDrawIcon(Self, LButtonItem, ACanvas, LSurfaceRect, AState, FSpacing); + + LSurfaceRect := ClientRect; + //DrawNotificationBadge(ACanvas, LSurfaceRect); + (* + { Show insert indications } + if [bdsInsertLeft, bdsInsertTop, bdsInsertRight, bdsInsertBottom] * State <> [] then + begin + ACanvas.Brush.Color := GetShadowColor(EdgeColor); + InsertIndication := Rect; + if bdsInsertLeft in State then + begin + Dec(InsertIndication.Left, 2); + InsertIndication.Right := InsertIndication.Left + 2; + end + else if bdsInsertTop in State then + begin + Dec(InsertIndication.Top); + InsertIndication.Bottom := InsertIndication.Top + 2; + end + else if bdsInsertRight in State then + begin + Inc(InsertIndication.Right, 2); + InsertIndication.Left := InsertIndication.Right - 2; + end + else if bdsInsertBottom in State then + begin + Inc(InsertIndication.Bottom); + InsertIndication.Top := InsertIndication.Bottom - 2; + end; + ACanvas.FillRect(InsertIndication); + ACanvas.Brush.Color := FillColor; + end; + *) + + if Assigned(OnAfterDrawButton) then + OnAfterDrawButton(Self, LButtonItem, ACanvas, ARect, AState); + finally + //Restore original values + ACanvas.Font.Name := LOldFontName; + ACanvas.Font.Color := LOldFontColor; + ACanvas.Font.Style := LOldFontStyle; + ACanvas.Brush.Style := LOldBrushStyle; + ACanvas.Pen.Width := LOldPenWidth; + //ACanvas.Brush.Color := Color; + if LOldParentFont then + ParentFont := LOldParentFont; + end; + end; +end; + +procedure TStyledCategoryButtons.SetBounds(ALeft, ATop, AWidth, AHeight: Integer); +begin + inherited; +end; + +procedure TStyledCategoryButtons.ImageMarginsChange(Sender: TObject); +begin + Invalidate; +end; + +function TStyledCategoryButtons.IsDefaultImageMargins: Boolean; +begin + //Default image margins: when all margins are zero except for + case FImageAlignment of + iaLeft: Result := (FImageMargins.Left = DEFAULT_IMAGE_HMARGIN) and + (FImageMargins.Top = 0) and (FImageMargins.Right = 0) and (FImageMargins.Bottom = 0); + iaRight: Result := (FImageMargins.Right = DEFAULT_IMAGE_HMARGIN) and + (FImageMargins.Top = 0) and (FImageMargins.Left = 0) and (FImageMargins.Bottom = 0); + iaTop: Result := (FImageMargins.Top = DEFAULT_IMAGE_VMARGIN) and + (FImageMargins.Left = 0) and (FImageMargins.Right = 0) and (FImageMargins.Bottom = 0); + iaBottom: Result := (FImageMargins.Bottom = DEFAULT_IMAGE_VMARGIN) and + (FImageMargins.Left = 0) and (FImageMargins.Right = 0) and (FImageMargins.Top = 0); + iaCenter: Result := (FImageMargins.Bottom = 0) and + (FImageMargins.Left = 0) and (FImageMargins.Right = 0) and (FImageMargins.Top = 0); + else + Result := False; + end; +end; + +procedure TStyledCategoryButtons.CalcDefaultImageMargins(const AValue: TImageAlignment); + + function AdJustMargin(const AMargin, AOffset: Integer): Integer; + begin + Result := AMargin + Round(AOffset*GetScaleFactor); + end; + +begin + if IsDefaultImageMargins then + begin + FImageMargins.Left := 0; + FImageMargins.Right := 0; + FImageMargins.Top := 0; + FImageMargins.Bottom := 0; + case AValue of + iaLeft: FImageMargins.Left := AdJustMargin(FImageMargins.Left, DEFAULT_IMAGE_HMARGIN); + iaRight: FImageMargins.Right := AdJustMargin(FImageMargins.Right, DEFAULT_IMAGE_HMARGIN); + iaTop: FImageMargins.Top := AdJustMargin(FImageMargins.Top, DEFAULT_IMAGE_VMARGIN); + iaBottom: FImageMargins.Bottom := AdJustMargin(FImageMargins.Bottom, DEFAULT_IMAGE_VMARGIN); + end; + end; +end; + +function TStyledCategoryButtons.ImageMarginsStored: Boolean; +begin + Result := not IsDefaultImageMargins; +end; + +function TStyledCategoryButtons.IsCustomDrawType: Boolean; +begin + Result := FCustomDrawType; +end; + +function TStyledCategoryButtons.IsCustomRoundedCorners: Boolean; +begin + Result := StyleRoundedCorners <> ALL_ROUNDED_CORNERS; +end; + +function TStyledCategoryButtons.IsCustomRadius: Boolean; +begin + Result := StyleRadius <> DEFAULT_RADIUS; +end; + +function TStyledCategoryButtons.IsStoredStyleAppearance: Boolean; +var + LClass: TStyledButtonClass; + LAppearance: TStyledButtonAppearance; + LButtonFamily: TButtonFamily; +begin + StyleFamilyCheckAttributes(FStyleFamily, LClass, LAppearance, LButtonFamily); + Result := FStyleAppearance <> LAppearance; +end; + +function TStyledCategoryButtons.IsStoredStyleClass: Boolean; +var + LClass: TStyledButtonClass; + LAppearance: TStyledButtonAppearance; + LButtonFamily: TButtonFamily; +begin + StyleFamilyCheckAttributes(FStyleFamily, LClass, LAppearance, LButtonFamily); + + if AsVCLStyle then + begin + Result := (FStyleClass <> GetActiveStyleName) + and not SameText(FStyleClass, 'Windows'); + end + else + Result := FStyleClass <> LClass; +end; + +function TStyledCategoryButtons.IsStoredStyleFamily: Boolean; +begin + Result := FStyleFamily <> DEFAULT_CLASSIC_FAMILY; +end; + +procedure TStyledCategoryButtons.Loaded; +begin + inherited; + if not FStyleApplied (*and not HasCustomAttributes*) then + begin + StyleFamilyUpdateAttributes( + FStyleFamily, FStyleClass, FStyleAppearance, + FButtonStyleNormal, FButtonStylePressed, FButtonStyleSelected, + FButtonStyleHot, FButtonStyleDisabled); + StyleApplied := ApplyButtonStyle; + end; +end; + +procedure TStyledCategoryButtons.MouseMove(Shift: TShiftState; X, Y: Integer); +var + LButtonItem: TButtonItem; +begin + inherited; + LButtonItem := GetButtonAt(X, Y); + if Assigned(LButtonItem) then + inherited Cursor := FButtonsCursor + else + inherited Cursor := FCursor; +end; + +class procedure TStyledCategoryButtons.RegisterDefaultRenderingStyle( + const ADrawType: TStyledButtonDrawType; const AFamily: TStyledButtonFamily; + const AClass: TStyledButtonClass; const AAppearance: TStyledButtonAppearance; + const AStyleRadius: Integer; const AButtonsCursor: TCursor); +begin + _DefaultStyleDrawType := ADrawType; + _UseCustomDrawType := True; + _DefaultFamily := AFamily; + _DefaultClass := AClass; + _DefaultAppearance := AAppearance; + _DefaultStyleRadius := AStyleRadius; + _DefaultButtonsCursor := AButtonsCursor; +end; + +function TStyledCategoryButtons.ApplyButtonStyle: Boolean; +var + LButtonFamily: TButtonFamily; + LStyleClass: TStyledButtonClass; + LStyleAppearance: TStyledButtonAppearance; +begin + if AsVCLStyle then + begin + //if StyleElements contains seClient then use + //VCL Style assigned to Button or Global VCL Style + if seBorder in StyleElements then + LStyleAppearance := DEFAULT_APPEARANCE; + LStyleClass := GetActiveStyleName; + end + else + begin + LStyleClass := FStyleClass; + LStyleAppearance := FStyleAppearance; + end; + Result := StyleFamilyCheckAttributes(FStyleFamily, + LStyleClass, LStyleAppearance, LButtonFamily); + if Result (*or (csDesigning in ComponentState)*) then + begin + StyleFamilyUpdateAttributes( + FStyleFamily, + LStyleClass, + LStyleAppearance, + FButtonStyleNormal, + FButtonStylePressed, + FButtonStyleSelected, + FButtonStyleHot, + FButtonStyleDisabled); + end; + StyleClass := LStyleClass; + StyleAppearance := LStyleAppearance; + if Result then + Invalidate; +end; + +procedure TStyledCategoryButtons.Assign(Source: TPersistent); +begin + inherited Assign(Source); + if Source is TStyledCategoryButtons then + begin + FStyleFamily := TStyledCategoryButtons(Source).FStyleFamily; + FStyleClass := TStyledCategoryButtons(Source).FStyleClass; + FStyleAppearance := TStyledCategoryButtons(Source).FStyleAppearance; + FStyleRadius := TStyledCategoryButtons(Source).FStyleRadius; + FStyleRoundedCorners := TStyledCategoryButtons(Source).FStyleRoundedCorners; + FStyleDrawType := TStyledCategoryButtons(Source).FStyleDrawType; + FButtonsCursor := TStyledCategoryButtons(Source).FButtonsCursor; + Invalidate; + end; +end; + +function TStyledCategoryButtons.AsVCLStyle: Boolean; +begin + Result := (StyleFamily = DEFAULT_CLASSIC_FAMILY) and + (seClient in StyleElements); +end; + +function TStyledCategoryButtons.GetAsVCLComponent: Boolean; +begin + Result := (StyleFamily = DEFAULT_CLASSIC_FAMILY) and + (seClient in StyleElements) and + (FStyleClass = GetActiveStyleName); +end; + +function TStyledCategoryButtons.GetButtonCategoriesClass: TButtonCategoriesClass; +begin + Result := TStyledButtonCategories; +end; + +function TStyledCategoryButtons.GetButtonCategoryClass: TButtonCategoryClass; +begin + Result := TStyledButtonCategory; +end; + +function TStyledCategoryButtons.GetButtonItemClass: TButtonItemClass; +begin + Result := TStyledButtonItem; +end; + +procedure TStyledCategoryButtons.SetAsVCLComponent(const AValue: Boolean); +begin + if AValue <> GetAsVCLComponent then + begin + if AValue then + begin + FStyleFamily := DEFAULT_CLASSIC_FAMILY; + FStyleClass := DEFAULT_WINDOWS_CLASS; + FStyleAppearance := DEFAULT_APPEARANCE; + StyleElements := StyleElements + [seClient]; + FCustomDrawType := False; + end + else if FStyleFamily = DEFAULT_CLASSIC_FAMILY then + begin + StyleElements := StyleElements - [seClient]; + end; + UpdateStyleElements; + end; +end; + +procedure TStyledCategoryButtons.UpdateStyleElements; +var + LStyleClass: TStyledButtonClass; +begin + if AsVCLStyle then + begin + //if StyleElements contains seClient then Update style + //as VCL Style assigned to CategoryButtons or Global VCL Style + if seBorder in StyleElements then + StyleAppearance := DEFAULT_APPEARANCE; + LStyleClass := GetActiveStyleName; + FStyleClass := LStyleClass; + StyleApplied := ApplyCategoryButtonsStyle; + ProcessButtons( + procedure (ABtn: TStyledButtonItem) + begin + //ABtn.UpdateStyleElements; + ABtn.StyleDrawType := Self.StyleDrawType; + end); + end; + inherited; +end; + +function TStyledCategoryButtons.ApplyCategoryButtonsStyle: Boolean; +var + LButtonFamily: TButtonFamily; +begin + Result := StyleFamilyCheckAttributes(FStyleFamily, + FStyleClass, FStyleAppearance, LButtonFamily); + if Result or (csDesigning in ComponentState) then + begin + StyleFamilyUpdateAttributes( + FStyleFamily, + FStyleClass, + FstyleAppearance, + FButtonStyleNormal, + FButtonStylePressed, + FButtonStyleSelected, + FButtonStyleHot, + FButtonStyleDisabled); + end; + Invalidate; +end; + +procedure TStyledCategoryButtons.SetSpacing(const AValue: Integer); +begin + if FSpacing <> AValue then + begin + FSpacing := AValue; + Invalidate; + end; +end; + +procedure TStyledCategoryButtons.SetStyleAppearance( + const AValue: TStyledButtonAppearance); +var + LValue: TStyledButtonAppearance; +begin + LValue := AValue; + if LValue = '' then + LValue := DEFAULT_APPEARANCE; + if (FStyleAppearance <> LValue) or not FStyleApplied then + begin + if not (csLoading in ComponentState) then + begin + ProcessButtons( + procedure (ABtn: TStyledButtonItem) + begin + if ABtn.StyleAppearance = StyleAppearance then + ABtn.StyleAppearance := LValue; + end); + end; + FStyleAppearance := LValue; + StyleApplied := ApplyCategoryButtonsStyle; + end; +end; + +procedure TStyledCategoryButtons.SetStyleApplied(const AValue: Boolean); +begin + FStyleApplied := AValue and (Categories.Count > 0) and + not (csLoading in ComponentState); + if FStyleApplied then + begin + if not (csLoading in ComponentState) then + begin + ProcessButtons( + procedure (ABtn: TStyledButtonItem) + begin + ABtn.LoadDefaultStyles; + end); + end; + end; +end; + +procedure TStyledCategoryButtons.SetStyleClass(const AValue: TStyledButtonClass); +var + LValue: TStyledButtonClass; +begin + LValue := AValue; + if LValue = '' then + LValue := DEFAULT_WINDOWS_CLASS; + if (LValue <> Self.FStyleClass) or not FStyleApplied then + begin + if not (csLoading in ComponentState) then + begin + ProcessButtons( + procedure (ABtn: TStyledButtonItem) + begin + if ABtn.StyleClass = StyleClass then + ABtn.StyleClass := LValue; + end); + end; + FStyleClass := LValue; + StyleApplied := ApplyCategoryButtonsStyle; +// if (FStyleFamily = DEFAULT_CLASSIC_FAMILY) and +// (LValue <> 'Windows') then +// StyleElements := [seFont, seBorder]; + end; +end; + +procedure TStyledCategoryButtons.SetStyleDrawType(const AValue: TStyledButtonDrawType); +begin + FCustomDrawType := True; + if FStyleDrawType <> AValue then + begin + ProcessButtons( + procedure (ABtn: TStyledButtonItem) + begin + if ABtn.StyleDrawType = StyleDrawType then + ABtn.StyleDrawType := AValue; + end); + FStyleDrawType := AValue; + StyleApplied := ApplyCategoryButtonsStyle; + end; +end; + +procedure TStyledCategoryButtons.SetStyleFamily(const AValue: TStyledButtonFamily); +var + LValue: TStyledButtonFamily; +begin + LValue := AValue; + if LValue = '' then + LValue := DEFAULT_CLASSIC_FAMILY; + if (LValue <> Self.FStyleFamily) or not FStyleApplied then + begin + if not (csLoading in ComponentState) then + begin + ProcessButtons( + procedure (ABtn: TStyledButtonItem) + begin + if ABtn.StyleFamily = FStyleFamily then + ABtn.StyleFamily := LValue; + end); + end; + FStyleFamily := LValue; + StyleApplied := ApplyCategoryButtonsStyle; + end; + if FStyleFamily = DEFAULT_CLASSIC_FAMILY then + StyleElements := [seFont, seClient, seBorder]; +end; + +procedure TStyledCategoryButtons.SetStyleRadius(const AValue: Integer); +begin + if FStyleRadius <> AValue then + begin + if AValue <= 0 then + raise EReadError.create(SInvalidProperty); + ProcessButtons( + procedure (ABtn: TStyledButtonItem) + begin + if ABtn.StyleRadius = FStyleRadius then + ABtn.StyleRadius := AValue; + end); + FStyleRadius := AValue; + StyleApplied := ApplyCategoryButtonsStyle; + end; +end; + +procedure TStyledCategoryButtons.SetStyleRoundedCorners( + const AValue: TRoundedCorners); +begin + if FStyleRoundedCorners <> AValue then + begin + ProcessButtons( + procedure (ABtn: TStyledButtonItem) + begin + if ABtn.StyleRoundedCorners = FStyleRoundedCorners then + ABtn.StyleRoundedCorners := AValue; + end); + FStyleRoundedCorners := AValue; + StyleApplied := ApplyCategoryButtonsStyle; + end; +end; + +procedure TStyledCategoryButtons.SetCategoryButtonsStyle( + const AStyleFamily: TStyledButtonFamily; + const AStyleClass: TStyledButtonClass; + const AStyleAppearance: TStyledButtonAppearance); +begin + StyleFamily := AStyleFamily; + StyleClass := AStyleClass; + StyleAppearance := AStyleAppearance; + if not ApplyCategoryButtonsStyle then + raise EStyledCategoryButtonsError.CreateFmt(ERROR_SETTING_CATEGORYBUTTONS_STYLE, + [AStyleFamily, AStyleClass, AStyleAppearance]); +end; + +procedure TStyledCategoryButtons.SetButtonStyleDisabled( + const AValue: TStyledButtonAttributes); +begin + if FButtonStyleDisabled <> AValue then + begin + FButtonStyleDisabled := AValue; + Invalidate; + end; +end; + +procedure TStyledCategoryButtons.SetButtonStyleHot( + const AValue: TStyledButtonAttributes); +begin + if FButtonStyleHot <> AValue then + begin + FButtonStyleHot := AValue; + Invalidate; + end; +end; + +procedure TStyledCategoryButtons.SetButtonStyleNormal( + const AValue: TStyledButtonAttributes); +begin + if FButtonStyleNormal <> AValue then + begin + FButtonStyleNormal := AValue; + Invalidate; + end; +end; + +procedure TStyledCategoryButtons.SetButtonStylePressed( + const AValue: TStyledButtonAttributes); +begin + if FButtonStylePressed <> AValue then + begin + FButtonStylePressed := AValue; + Invalidate; + end; +end; + +procedure TStyledCategoryButtons.SetButtonStyleSelected( + const AValue: TStyledButtonAttributes); +begin + if FButtonStyleSelected <> AValue then + begin + FButtonStyleSelected := AValue; + Invalidate; + end; +end; + +procedure TStyledCategoryButtons.SetCaptionAlignment(const AValue: TAlignment); +begin + if FCaptionAlignment <> AValue then + begin + FCaptionAlignment := AValue; + Invalidate; + end; +end; + +procedure TStyledCategoryButtons.SetCursor(const AValue: TCursor); +begin + inherited Cursor := AValue; + FCursor := AValue; +end; + +procedure TStyledCategoryButtons.SetFlat(const AValue: Boolean); +begin + if FFlat <> AValue then + begin + FFlat := AValue; + Invalidate; + end; +end; + +procedure TStyledCategoryButtons.SetButtonCategories(const AValue: TStyledButtonCategories); +begin + inherited Categories := AValue; +end; + +procedure TStyledCategoryButtons.SetImageAlignment(const AValue: TImageAlignment); +begin + if FImageAlignment <> AValue then + begin + CalcDefaultImageMargins(AValue); + FImageAlignment := AValue; + if Images <> nil then + Invalidate; + end; +end; + +procedure TStyledCategoryButtons.SetImageMargins(const AValue: TImageMargins); +begin + FImageMargins.Assign(AValue); +end; + +function TStyledCategoryButtons.GetActiveStyleName: string; +begin + Result := Vcl.ButtonStylesAttributes.GetActiveStyleName(Self); +end; + +function TStyledCategoryButtons.GetAttributes(const AMode: TStyledButtonState): TStyledButtonAttributes; +begin + case Amode of + bsmPressed: Result := FButtonStylePressed; + bsmSelected: Result := FButtonStyleSelected; + bsmHot: Result := FButtonStyleHot; + bsmDisabled: Result := FButtonStyleDisabled; + else + Result := FButtonStyleNormal; + end; +end; + +procedure TStyledCategoryButtons.GetDrawingStyle(const ACanvas: TCanvas; + const AButtonState: TStyledButtonState; + const AItem: TStyledButtonItem); +var + LCustomAttributes: Boolean; + LSyleAttributes: TStyledButtonAttributes; +begin + LCustomAttributes := ((AItem.FStyleFamily) <> FStyleFamily) or + ((AItem.FStyleClass) <> FStyleClass) or + ((AItem.FStyleAppearance) <> FStyleAppearance); + try + if LCustomAttributes then + begin + //Getting custom drawing styles for single button + StyleFamilyUpdateAttributes( + AItem.FStyleFamily, AItem.FStyleClass, AItem.FStyleAppearance, + FButtonStyleNormal, FButtonStylePressed, FButtonStyleSelected, + FButtonStyleHot, FButtonStyleDisabled); + end; + + //Getting custom drawing styles for all buttons + LSyleAttributes := GetAttributes(AButtonState); + + ACanvas.Pen.Style := LSyleAttributes.PenStyle; + ACanvas.Pen.Width := Round(LSyleAttributes.BorderWidth{$IFDEF D10_3+}*ScaleFactor{$ENDIF}); + ACanvas.Pen.Color := LSyleAttributes.BorderColor; + ACanvas.Brush.Style := LSyleAttributes.BrushStyle; + if LSyleAttributes.ButtonDrawStyle <> btnClear then + ACanvas.Brush.Color := LSyleAttributes.ButtonColor; + ACanvas.Font := Font; + ACanvas.Font.Color := LSyleAttributes.FontColor; + if ParentFont then + ACanvas.Font.Style := LSyleAttributes.FontStyle; + finally + if LCustomAttributes then + begin + //Restore drawing styles for every buttons + StyleFamilyUpdateAttributes( + FStyleFamily, FStyleClass, FStyleAppearance, + FButtonStyleNormal, FButtonStylePressed, FButtonStyleSelected, + FButtonStyleHot, FButtonStyleDisabled); + end; + end; +end; + +function TStyledCategoryButtons.GetButtonCategories: TStyledButtonCategories; +begin + Result := inherited Categories as TStyledButtonCategories; +end; + +function TStyledCategoryButtons.IsStyleEnabled: Boolean; +begin + Result := IsCustomStyleActive and (StyleElements <> []); +end; + +procedure TStyledCategoryButtons.ProcessButtons( + AButtonProc: TButtonProc); +var + C, B: Integer; + LCategory: TStyledButtonCategory; + LButton: TStyledButtonItem; +begin + if not Assigned(Categories) then + Exit; + for C := 0 to Categories.Count -1 do + begin + if Categories[C] is TStyledButtonCategory then + begin + LCategory := TStyledButtonCategory(Categories[C]); + for B := 0 to LCategory.Items.Count -1 do + begin + if LCategory.Items[B] is TStyledButtonItem then + begin + LButton := TStyledButtonItem(LCategory.Items[B]); + AButtonProc(LButton); + end; + end; + end; + end; +end; + +{ TStyledButtonItem } + +function TStyledButtonItem.ApplyButtonStyle: Boolean; +var + LButtonFamily: TButtonFamily; +begin + if not FStyleApplied then + begin + Result := StyleFamilyCheckAttributes(FStyleFamily, + FStyleClass, FStyleAppearance, LButtonFamily); + if Result then + begin + InvalidateOwner; + FStyleApplied := True; + end; + end + else + Result := False; +end; + +procedure TStyledButtonItem.LoadDefaultStyles; +begin + if Assigned(CategoryButtons) and (CategoryButtons.FStyleApplied) and not FStyleApplied then + begin + FStyleFamily := CategoryButtons.StyleFamily; + FStyleClass := CategoryButtons.StyleClass; + FStyleAppearance := CategoryButtons.StyleAppearance; + FStyleRadius := CategoryButtons.StyleRadius; + FStyleRoundedCorners := CategoryButtons.StyleRoundedCorners; + FStyleDrawType := CategoryButtons.StyleDrawType; + end; +end; + +constructor TStyledButtonItem.Create(Collection: TCollection); +begin + inherited; + FCollection := Collection as TButtonCollection; + FStyleDrawType := TStyledCategoryButtons._DefaultStyleDrawType; + FStyleRadius := TStyledCategoryButtons._DefaultStyleRadius; + FStyleRoundedCorners := ALL_ROUNDED_CORNERS; + LoadDefaultStyles; +end; + +function TStyledButtonItem.GetStyledCategoryButtons: TStyledCategoryButtons; +begin + if Assigned(FCollection) and Assigned(FCollection.Category) then + Result := FCollection.Category.CategoryButtons as TStyledCategoryButtons + else + Result := nil; +end; + +procedure TStyledButtonItem.InvalidateOwner; +begin + if Assigned(CategoryButtons) then + CategoryButtons.Invalidate; +end; + +function TStyledButtonItem.IsCustomDrawType: Boolean; +begin + Result := Assigned(CategoryButtons) and + (FStyleDrawType <> CategoryButtons.FStyleDrawType); +end; + +function TStyledButtonItem.IsCustomRoundedCorners: Boolean; +begin + Result := Assigned(CategoryButtons) and + (FStyleRoundedCorners <> CategoryButtons.FStyleRoundedCorners); +end; + +function TStyledButtonItem.IsCustomRadius: Boolean; +begin + Result := Assigned(CategoryButtons) and + (FStyleRadius <> CategoryButtons.FStyleRadius); +end; + +function TStyledButtonItem.IsStoredStyle: Boolean; +begin + Result := Assigned(CategoryButtons) and + ((FStyleFamily <> CategoryButtons.FStyleFamily) or + (FStyleClass <> CategoryButtons.FStyleClass) or + (FStyleAppearance <> CategoryButtons.FStyleAppearance)); +end; + +procedure TStyledButtonItem.SetStyleFamily( + const AValue: TStyledButtonFamily); +begin + if FStyleFamily <> AValue then + begin + FStyleFamily := AValue; + InvalidateOwner; + end; + ApplyButtonStyle; +end; + +procedure TStyledButtonItem.SetStyleClass( + const AValue: TStyledButtonClass); +begin + if FStyleClass <> AValue then + begin + FStyleClass := AValue; + InvalidateOwner; + end; + ApplyButtonStyle; +end; + +procedure TStyledButtonItem.SetButtonStyle( + const AStyleFamily: TStyledButtonFamily; + const AStyleClass: TStyledButtonClass; + const AStyleAppearance: TStyledButtonAppearance); +begin + FStyleApplied := False; + FStyleFamily := AStyleFamily; + FStyleClass := AStyleClass; + FStyleAppearance := AStyleAppearance; + if not ApplyButtonStyle then + raise EStyledCategoryButtonsError.CreateFmt(ERROR_SETTING_BUTTON_STYLE, + [AStyleFamily, AStyleClass, AStyleAppearance]); +end; + +procedure TStyledButtonItem.SetStyleAppearance( + const AValue: TStyledButtonAppearance); +begin + if FStyleAppearance <> AValue then + begin + FStyleAppearance := AValue; + InvalidateOwner; + end; + ApplyButtonStyle; +end; + +procedure TStyledButtonItem.SetStyleDrawType( + const AValue: TStyledButtonDrawType); +begin + if FStyleDrawType <> AValue then + begin + FStyleDrawType := AValue; + InvalidateOwner; + end; + ApplyButtonStyle; +end; + +procedure TStyledButtonItem.SetStyleRadius(const AValue: Integer); +begin + if FStyleRadius <> AValue then + begin + FStyleRadius := AValue; + InvalidateOwner; + end; + ApplyButtonStyle; +end; + +procedure TStyledButtonItem.SetStyleRoundedCorners(const AValue: TRoundedCorners); +begin + if FStyleRoundedCorners <> AValue then + begin + FStyleRoundedCorners := AValue; + InvalidateOwner; + end; + ApplyButtonStyle; +end; + +{ TStyledButtonCategories } + +function TStyledButtonCategories.Add: TStyledButtonCategory; +begin + Result := inherited Add as TStyledButtonCategory; +end; + +constructor TStyledButtonCategories.Create(const CategoryButtons: TCategoryButtons); +begin + inherited Create(CategoryButtons); +end; + +function TStyledButtonCategories.GetItem(Index: Integer): TStyledButtonCategory; +begin + Result := inherited GetItem(Index) as TStyledButtonCategory; +end; + +procedure TStyledButtonCategories.SetItem(Index: Integer; + const AValue: TStyledButtonCategory); +begin + inherited SetItem(Index, AValue); +end; + +function TStyledButtonCategories.GetStyledCategoryButtons: TStyledCategoryButtons; +begin + Result := inherited CategoryButtons as TStyledCategoryButtons; +end; + +{ TStyledButtonCategory } + +constructor TStyledButtonCategory.Create(Collection: TCollection); +begin + inherited Create(Collection); +end; + +initialization + TStyledCategoryButtons._DefaultStyleDrawType := DEFAULT_STYLEDRAWTYPE; + TStyledCategoryButtons._DefaultFamily := DEFAULT_CLASSIC_FAMILY; + TStyledCategoryButtons._DefaultClass := DEFAULT_WINDOWS_CLASS; + TStyledCategoryButtons._DefaultAppearance := DEFAULT_APPEARANCE; + TStyledCategoryButtons._DefaultStyleRadius := DEFAULT_RADIUS; + TStyledCategoryButtons._DefaultButtonsCursor := DEFAULT_CURSOR; + +end. diff --git a/Ext/StyledComponents/source/Vcl.StyledCmpMessages.pas b/Ext/StyledComponents/source/Vcl.StyledCmpMessages.pas index bdf96df..3e2d856 100644 --- a/Ext/StyledComponents/source/Vcl.StyledCmpMessages.pas +++ b/Ext/StyledComponents/source/Vcl.StyledCmpMessages.pas @@ -1,12 +1,12 @@ {******************************************************************************} { } -{ StyledCmpMessages: Messages for Styled Component } +{ StyledCmpMessages: Messages translated for Styled Component } { } -{ Copyright (c) 2022-2024 (Ethea S.r.l.) } -{ Author: Carlo Barazzetta } -{ Contributors: } +{ Copyright (c) 2022-2024 (Ethea S.r.l.) } +{ Author: Carlo Barazzetta } +{ Contributors: } { } -{ https://github.com/EtheaDev/StyledComponents } +{ https://github.com/EtheaDev/StyledComponents } { } {******************************************************************************} { } diff --git a/Ext/StyledComponents/source/Vcl.StyledCmpStrUtils.pas b/Ext/StyledComponents/source/Vcl.StyledCmpStrUtils.pas index e350af7..7e3b756 100644 --- a/Ext/StyledComponents/source/Vcl.StyledCmpStrUtils.pas +++ b/Ext/StyledComponents/source/Vcl.StyledCmpStrUtils.pas @@ -1,12 +1,12 @@ {******************************************************************************} { } -{ StyledCmpStrUtils: String utils for Styled Component } +{ StyledCmpStrUtils: String utils for Styled Component } { } -{ Copyright (c) 2022-2024 (Ethea S.r.l.) } -{ Author: Carlo Barazzetta } -{ Contributors: } +{ Copyright (c) 2022-2024 (Ethea S.r.l.) } +{ Author: Carlo Barazzetta } +{ Contributors: } { } -{ https://github.com/EtheaDev/StyledComponents } +{ https://github.com/EtheaDev/StyledComponents } { } {******************************************************************************} { } @@ -38,6 +38,7 @@ function ClearHRefs(const Msg: string; OnlyFileNotExists: boolean = False): stri function GetErrorClassNameDesc(const ExceptionClassName : string; IsAccessViolation: boolean) : string; function GetProjectURL: string; +function GetProjectWikiURL: string; implementation @@ -51,6 +52,11 @@ function GetProjectURL: string; Result := 'https://github.com/EtheaDev/StyledComponents'; end; +function GetProjectWikiURL: string; +begin + Result := 'https://github.com/EtheaDev/StyledComponents/wiki'; +end; + function HRefToString(const HRef: string): string; var DisplayLabel: string; diff --git a/Ext/StyledComponents/source/Vcl.StyledComponentsHooks.pas b/Ext/StyledComponents/source/Vcl.StyledComponentsHooks.pas new file mode 100644 index 0000000..46a98fd --- /dev/null +++ b/Ext/StyledComponents/source/Vcl.StyledComponentsHooks.pas @@ -0,0 +1,74 @@ +{******************************************************************************} +{ } +{ StyledComponentsHooks: an interposer Unit to use Styled Components } +{ using Standard Delphi Controls Class Names } +{ } +{ Copyright (c) 2022-2024 (Ethea S.r.l.) } +{ Author: Carlo Barazzetta } +{ Contributors: } +{ } +{ https://github.com/EtheaDev/StyledComponents } +{ } +{******************************************************************************} +{ } +{ Licensed under the Apache License, Version 2.0 (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.apache.org/licenses/LICENSE-2.0 } +{ } +{ Unless required by applicable law or agreed to in writing, software } +{ distributed under the License is distributed on an "AS IS" BASIS, } +{ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. } +{ See the License for the specific language governing permissions and } +{ limitations under the License. } +{ } +{******************************************************************************} +unit Vcl.StyledComponentsHooks; + +interface + +{$INCLUDE StyledComponents.inc} + +uses + Vcl.StyledButton + , Vcl.StyledDbNavigator + , Vcl.StyledToolbar + , Vcl.StyledButtonGroup + , Vcl.StyledCategoryButtons + ; + +type + //Interposer Class for TButton -> TStyledButton + TButton = class(TStyledButton) end; + + //Interposer Class for TBitBtn -> TStyledBitBtn + TBitBtn = class(TStyledBitBtn) end; + + //Interposer Class for TBitBtn -> TStyledSpeedButton + TSpeedButton = class(TStyledSpeedButton) end; + + //Interposer Class for TDbNavigator -> TStyledDbNavigator + TDbNavigator = class(TStyledDbNavigator) end; + + //Interposer Class for TBindNavigator -> TStyledBindNavigator + TBindNavigator = class(TStyledBindNavigator) end; + + //Interposer Class for TToolbar -> TStyledToolbar + TToolbar = class(TStyledToolbar) end; + + //Interposer Class for TToolbutton -> TStyledToolButton + TToolbutton = class(TStyledToolbutton) end; + + //Interposer Class for TButtonGroup -> TStyledButtonGroup + TButtonGroup = class(TStyledButtonGroup) end; + + //Interposer Class for TCategoryButtons -> TStyledCategoryButtons + TCategoryButtons = class(TStyledCategoryButtons) end; + + //Interposer Class for TButtonCategory -> TStyledButtonCategory + TButtonCategory = class(TStyledButtonCategory) end; + +implementation + +end. diff --git a/Ext/StyledComponents/source/Vcl.StyledDbNavigator.pas b/Ext/StyledComponents/source/Vcl.StyledDbNavigator.pas index 956a115..1520402 100644 --- a/Ext/StyledComponents/source/Vcl.StyledDbNavigator.pas +++ b/Ext/StyledComponents/source/Vcl.StyledDbNavigator.pas @@ -1,13 +1,13 @@ {******************************************************************************} { } -{ StyledDbNavigator: a DbNavigator with TStyledNavButtons inside } -{ Based on TStyledToolbar } +{ StyledDbNavigator: a DbNavigator with TStyledNavButtons inside } +{ Based on TStyledToolbar } { } -{ Copyright (c) 2022-2024 (Ethea S.r.l.) } -{ Author: Carlo Barazzetta } -{ Contributors: } +{ Copyright (c) 2022-2024 (Ethea S.r.l.) } +{ Author: Carlo Barazzetta } +{ Contributors: } { } -{ https://github.com/EtheaDev/StyledComponents } +{ https://github.com/EtheaDev/StyledComponents } { } {******************************************************************************} { } @@ -54,8 +54,11 @@ interface , Winapi.Windows , Vcl.StyledButton , Vcl.ButtonStylesAttributes + , Vcl.StandardButtonStyles , Vcl.DBCtrls , Data.db + , Data.Bind.Components + , Data.Bind.Controls {$IFDEF D10_4+} , Vcl.VirtualImageList , Vcl.ImageCollection @@ -65,9 +68,19 @@ interface resourcestring ERROR_SETTING_DBNAVIGATOR_STYLE = 'Error setting DbNavigator Style: %s/%s/%s not available'; +const + NavigatorDefaultBtns = [ + TNavigateBtn.nbFirst, TNavigateBtn.nbPrior, TNavigateBtn.nbNext, + TNavigateBtn.nbLast, TNavigateBtn.nbInsert, TNavigateBtn.nbDelete, + TNavigateBtn.nbEdit, TNavigateBtn.nbPost, TNavigateBtn.nbCancel, + TNavigateBtn.nbRefresh]; + + NavigatorMoveBtns = [TNavigateBtn.nbFirst..TNavigateBtn.nbLast]; + type EStyledDbnavigatorError = Exception; + TCustomStyledDBNavigator = class; TStyledDbNavigator = class; TStyledNavButton = class; TStyledNavDataLink = class; @@ -75,21 +88,24 @@ TStyledNavDataLink = class; TButtonProc = reference to procedure (Button: TStyledNavButton); TNavButtons = array[TNavigateBtn] of TStyledNavButton; - { TStyledNavButton } + TNavigateButtonEvent = procedure (Sender: TObject; Button: TNavigateButton) of object; + TNavigatorOrientation = (orHorizontal, orVertical); + { TStyledNavButton } TStyledNavButton = class(TStyledGraphicButton) private FIndex: TNavigateBtn; FNavStyle: TNavButtonStyle; FRepeatTimer: TTimer; - FDbNavigator: TStyledDBNavigator; + FDbNavigator: TCustomStyledDBNavigator; FImageAlignment: TImageAlignment; + FDragging: Boolean; procedure TimerExpired(Sender: TObject); procedure UpdateButtonContent; function IsImageAlignmentStored: Boolean; procedure SetImageAlignment(const AValue: TImageAlignment); protected - function GetCaption: TCaption; override; + function GetCaptionToDraw: TCaption; override; procedure SetCaption(const AValue: TCaption); override; procedure Paint; override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; @@ -106,12 +122,10 @@ TStyledNavButton = class(TStyledGraphicButton) property Caption: TCaption read GetCaption write SetCaption stored IsCaptionStored; end; - { TStyledDBNavigator } - - TStyledDBNavigator = class (TCustomPanel) + { TCustomStyledDBNavigator } + TCustomStyledDBNavigator = class(TCustomPanel) private - //Standard support ad TDbNavigator - FDataLink: TStyledNavDataLink; + //Standard support as TDbNavigator FVisibleButtons: TNavButtonSet; FHints: TStrings; FCaptions: TStrings; @@ -149,34 +163,43 @@ TStyledDBNavigator = class (TCustomPanel) {$IFDEF D10_4+} FButtonImages: TVirtualImageList; + //Internal ImageList and Collection for standard images class var FButtonsImageCollection: TImageCollection; class constructor Create; class destructor Destroy; + procedure UpdateButtonsImageIndex; + procedure UpdateButtonsIcons; + + procedure CMStyleChanged(var Message: TMessage); message CM_STYLECHANGED; {$ELSE} procedure UpdateButtonsGlyphs; {$ENDIF} + class var + _DefaultStyleDrawType: TStyledButtonDrawType; + _UseCustomDrawType: Boolean; + _DefaultFamily: TStyledButtonFamily; + _DefaultClass: TStyledButtonClass; + _DefaultAppearance: TStyledButtonAppearance; + _DefaultStyleRadius: Integer; + _DefaultCursor: TCursor; + procedure ImageListChange(Sender: TObject); procedure DisabledImageListChange(Sender: TObject); procedure ProcessButtons(AButtonProc: TButtonProc); - function GetActiveStyleName: string; function AsVCLStyle: Boolean; function ApplyDbnavigatorStyle: Boolean; procedure BtnMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); - procedure ClickHandler(Sender: TObject); - function GetDataSource: TDataSource; function GetHints: TStrings; procedure HintsChanged(Sender: TObject); procedure CaptionsChanged(Sender: TObject); procedure InitButtons; - procedure InitHints; procedure InitCaptions; - procedure SetDataSource(const AValue: TDataSource); procedure SetFlat(const AValue: Boolean); procedure SetHints(const AValue: TStrings); procedure SetKind(const AValue: TDBNavigatorKind); @@ -186,12 +209,7 @@ TStyledDBNavigator = class (TCustomPanel) procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS; procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS; procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE; - procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED; procedure WMWindowPosChanging(var Message: TWMWindowPosChanging); message WM_WINDOWPOSCHANGING; - procedure ApplyUpdates; - function CanApplyUpdates: Boolean; - procedure CancelUpdates; - function CanCancelUpdates: Boolean; function IsCustomDrawType: Boolean; function IsCustomRadius: Boolean; function IsStoredStyleAppearance: Boolean; @@ -209,13 +227,16 @@ TStyledDBNavigator = class (TCustomPanel) procedure UpdateButtons; function GetCaptions: TStrings; procedure SetCaptions(const AValue: TStrings); + function GetAsVCLComponent: Boolean; + procedure SetAsVCLComponent(const AValue: Boolean); protected + function GetActiveStyleName: string; + procedure ClickHandler(Sender: TObject); virtual; abstract; + procedure InitHints; virtual; + function GetButton(const AValue: TNavigateBtn): TStyledNavButton; procedure UpdateStyleElements; override; - procedure ActiveChanged; procedure CalcMinSize(var W, H: Integer); procedure CreateWnd; override; - procedure DataChanged; - procedure EditingChanged; procedure KeyDown(var Key: Word; Shift: TShiftState); override; procedure Loaded; override; procedure Notification(AComponent: TComponent; Operation: TOperation); override; @@ -226,6 +247,14 @@ TStyledDBNavigator = class (TCustomPanel) procedure SetButtonGlyph(Index: TNavigateBtn); virtual; {$ENDIF} public + procedure Assign(Source: TPersistent); override; + class procedure RegisterDefaultRenderingStyle( + const ADrawType: TStyledButtonDrawType; + const AFamily: TStyledButtonFamily = DEFAULT_CLASSIC_FAMILY; + const AClass: TStyledButtonClass = DEFAULT_WINDOWS_CLASS; + const AAppearance: TStyledButtonAppearance = DEFAULT_APPEARANCE; + const AStyleRadius: Integer = DEFAULT_RADIUS; + const ACursor: TCursor = DEFAULT_CURSOR); virtual; //Styled constructor constructor CreateStyled(AOwner: TComponent; const AFamily: TStyledButtonFamily; @@ -238,18 +267,16 @@ TStyledDBNavigator = class (TCustomPanel) const AStyleAppearance: TStyledButtonAppearance); procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override; procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; - procedure BtnClick(Index: TNavigateBtn); virtual; + property StyleApplied: Boolean read FStyleApplied write SetStyleApplied; //Access readonly properties property Buttons: TNavButtons read FButtons; property ButtonWidth: Integer read FButtonWidth; property ButtonHeight: Integer read FButtonHeight; - published - property DataSource: TDataSource read GetDataSource write SetDataSource; - property VisibleButtons: TNavButtonSet read FVisibleButtons write SetVisible - default [nbFirst, nbPrior, nbNext, nbLast, nbInsert, nbDelete, - nbEdit, nbPost, nbCancel, nbRefresh]; + property VisibleButtons: TNavButtonSet read FVisibleButtons write SetVisible default NavigatorDefaultBtns; property MaxErrors: Integer read FMaxErrors write FMaxErrors default -1; + + property AsVCLComponent: Boolean read GetAsVCLComponent write SetAsVCLComponent stored False; property Align; property Anchors; property Constraints; @@ -297,6 +324,83 @@ TStyledDBNavigator = class (TCustomPanel) property StyleAppearance: TStyledButtonAppearance read FStyleAppearance write SetStyleAppearance stored IsStoredStyleAppearance; end; + { TStyledDBNavigator } + [ComponentPlatforms(pidWin32 or pidWin64)] + TStyledDBNavigator = class (TCustomStyledDBNavigator) + private + FDataLink: TStyledNavDataLink; + procedure SetDataSource(const AValue: TDataSource); + function GetDataSource: TDataSource; + procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED; + protected + procedure DataChanged; + procedure EditingChanged; + procedure ActiveChanged; + procedure ClickHandler(Sender: TObject); override; + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + procedure ApplyUpdates; virtual; + function CanApplyUpdates: Boolean; virtual; + procedure CancelUpdates; virtual; + function CanCancelUpdates: Boolean; virtual; + procedure Loaded; override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure BtnClick(Index: TNavigateBtn); virtual; + published + property ActiveStyleName: string read GetActiveStyleName; + property Align; + property Anchors; + property AsVCLComponent stored False; + property BeforeAction; + property Captions; + property ConfirmDelete; + property Constraints; + property Ctl3D; + property Cursor default DEFAULT_CURSOR; + property DataSource: TDataSource read GetDataSource write SetDataSource; + property DragCursor; + property DragKind; + property DragMode; + property DisabledImages; + property Enabled; + property Flat; + property Hints; + property Images; + property Kind; + property MaxErrors; + property ParentCtl3D; + property ParentShowHint; + property PopupMenu; + property ShowCaptions; + property ShowHint; + property StyleElements; + property TabOrder; + property TabStop; + property Visible; + property VisibleButtons; + + property OnClick; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnResize; + property OnStartDock; + property OnStartDrag; + + //StyledComponents Attributes + property StyleRadius; + property StyleDrawType; + property StyleFamily; + property StyleClass; + property StyleAppearance; + end; + { TStyledNavDataLink } TStyledNavDataLink = class(TDataLink) @@ -311,6 +415,91 @@ TStyledNavDataLink = class(TDataLink) destructor Destroy; override; end; + { TStyledBindNavigator } + [ComponentPlatforms(pidWin32 or pidWin64)] + TStyledBindNavigator = class(TCustomStyledDbNavigator, IBindNavigator) + private + FController: TBindNavigatorController; + FBeforeAction: TNavigateButtonEvent; + FOnNavClick: TNavigateButtonEvent; + procedure OnActiveChanged(Sender: TObject); + procedure OnDataChanged(Sender: TObject); + procedure OnEditingChanged(Sender: TObject); + function GetDataSource: TBaseLinkingBindSource; + procedure SetDataSource(Value: TBaseLinkingBindSource); + procedure SetVisible(const Value: TNavigateButtons); + function GetButton(Index: TNavigateButton): TStyledNavButton; + function GetOrientation: TNavigatorOrientation; + procedure SetOrientation(const Value: TNavigatorOrientation); + function NavigateButtonToNavBtn(const AValue: TNavigateButton): TNavigateBtn; + function NavBtnToNavigateButton(const AValue: TNavigateBtn): TNavigateButton; + function NavigateButtonsToNavBtns(const AValue: TNavigateButtons): TNavButtonSet; + function NavBtnsToNavigateButtons(const AValue: TNavButtonSet): TNavigateButtons; + function GetVisibleButtons: TNavigateButtons; + protected + procedure ClickHandler(Sender: TObject); override; + property Buttons[Index: TNavigateButton]: TStyledNavButton read GetButton; + procedure ActiveChanged; + procedure DataChanged; + procedure EditingChanged; + //procedure BtnIDClick(Index: TNavBtnID); override; + public + procedure BtnClick(Index: TNavigateButton); reintroduce; virtual; + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + published + property Align; + property Anchors; + property AsVCLComponent stored False; + property BeforeAction: TNavigateButtonEvent read FBeforeAction write FBeforeAction; + property Captions; + property ConfirmDelete; + property Constraints; + property Ctl3D; + property Cursor default DEFAULT_CURSOR; + property DataSource: TBaseLinkingBindSource read GetDataSource write SetDataSource; + property DragCursor; + property DragKind; + property DragMode; + property DisabledImages; + property Enabled; + property Flat; + property Hints; + property Images; + property Kind; + property MaxErrors; + property Orientation: TNavigatorOrientation read GetOrientation write SetOrientation default orHorizontal; + property ParentCtl3D; + property ParentShowHint; + property PopupMenu; + property ShowCaptions; + property ShowHint; + property StyleElements; + property TabOrder; + property TabStop; + property Visible; + property VisibleButtons: TNavigateButtons read GetVisibleButtons write SetVisible default NavigatorDefaultButtons; + + property OnClick: TNavigateButtonEvent read FOnNavClick write FOnNavClick; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnResize; + property OnStartDock; + property OnStartDrag; + + //StyledComponents Attributes + property StyleRadius; + property StyleDrawType; + property StyleFamily; + property StyleClass; + property StyleAppearance; + end; implementation @@ -321,15 +510,17 @@ implementation , Vcl.Graphics , System.Types , System.RTLConsts - , Vcl.StandardButtonStyles , Vcl.StyledCmpMessages , Vcl.StyledTaskDialog ; const DEFAULT_BTN_IMAGE_SIZE = 15; - -{ TStyledDBNavigator } + COLORED_IMAGE_COLLECTION = 'SNB_'; + WHITE_IMAGE_COLLECTION = 'NAVW_'; + BLACK_IMAGE_COLLECTION = 'NAVB_'; + VERTICAL_ICON = '_VERT'; + DEFAULT_IMAGE_MARGIN = 4; var BtnTypeName: array[TNavigateBtn] of PChar = ('FIRST', 'PRIOR', 'NEXT', @@ -343,45 +534,58 @@ implementation @CaptionPostEdit, @CaptionCancelEdit, @CaptionRefreshRecord, @CaptionApplyUpdates, @CaptionCancelUpdates); {$IFDEF D10_4+} -class constructor TStyledDBNavigator.Create; +class constructor TCustomStyledDBNavigator.Create; begin end; procedure InitButtonsImageCollection; var - I: TNavigateBtn; - LBtnName, LResName: string; + LBtnName: string; + + procedure AddImageToCollection(const APrefix, ABtnName: string); + begin + TCustomStyledDBNavigator.FButtonsImageCollection.Add( + APrefix+ABtnName, HInstance, + APrefix+ABtnName, ['', '_20X']); + end; + begin - if TStyledDBNavigator.FButtonsImageCollection <> nil then + if TCustomStyledDBNavigator.FButtonsImageCollection <> nil then Exit; - TStyledDBNavigator.FButtonsImageCollection := TImageCollection.Create(nil); - for I := Low(BtnTypeName) to High(BtnTypeName) do + TCustomStyledDBNavigator.FButtonsImageCollection := TImageCollection.Create(nil); + for var I := Low(BtnTypeName) to High(BtnTypeName) do begin LBtnName := BtnTypeName[I]; - LResName := 'SNB_' + BtnTypeName[I]; - TStyledDBNavigator.FButtonsImageCollection.Add(LBtnName, HInstance, - LResName, ['', '_20X']); + //Add colored image (prefix SNB in StyledNavButtonsPNG.RES) + AddImageToCollection(COLORED_IMAGE_COLLECTION,LBtnName); + //Add black image (prefix NAVB in StyledNavButtonsPNG.RES) + AddImageToCollection(BLACK_IMAGE_COLLECTION,LBtnName); + //Add white image (prefix NAVW in StyledNavButtonsPNG.RES) + AddImageToCollection(WHITE_IMAGE_COLLECTION,LBtnName); end; //Add also vertical images - for I := nbFirst to nbLast do + for var I := TNavigateBtn.nbFirst to TNavigateBtn.nbLast do begin - LBtnName := BtnTypeName[I] + '_VERT'; - LResName := 'SNB_' + BtnTypeName[I] + '_VERT'; - TStyledDBNavigator.FButtonsImageCollection.Add(LBtnName, HInstance, - LResName, ['', '_20X']); + LBtnName := BtnTypeName[I] + VERTICAL_ICON; + //Add colored image (prefix SNB in StyledNavButtonsPNG.RES) + AddImageToCollection(COLORED_IMAGE_COLLECTION,LBtnName); + //Add black image (prefix NAVB in StyledNavButtonsPNG.RES) + AddImageToCollection(BLACK_IMAGE_COLLECTION,LBtnName); + //Add white image (prefix NAVW in StyledNavButtonsPNG.RES) + AddImageToCollection(WHITE_IMAGE_COLLECTION,LBtnName); end; end; {$ENDIF} -constructor TStyledDBNavigator.Create(AOwner: TComponent); +constructor TCustomStyledDBNavigator.Create(AOwner: TComponent); begin CreateStyled(AOwner, - DEFAULT_CLASSIC_FAMILY, - DEFAULT_WINDOWS_CLASS, - DEFAULT_APPEARANCE); + _DefaultFamily, + _DefaultClass, + _DefaultAppearance); end; -constructor TStyledDBNavigator.CreateStyled(AOwner: TComponent; +constructor TCustomStyledDBNavigator.CreateStyled(AOwner: TComponent; const AFamily: TStyledButtonFamily; const AClass: TStyledButtonClass; const AAppearance: TStyledButtonAppearance); begin @@ -394,20 +598,25 @@ constructor TStyledDBNavigator.CreateStyled(AOwner: TComponent; - [csDoubleClicks, csAcceptsControls, csSetCaption, csGestures] + [csOpaque]; if not NewStyleControls then ControlStyle := ControlStyle + [csFramed]; - FDataLink := TStyledNavDataLink.Create(Self); - FVisibleButtons := [nbFirst, nbPrior, nbNext, nbLast, nbInsert, - nbDelete, nbEdit, nbPost, nbCancel, nbRefresh]; + FVisibleButtons := NavigatorDefaultBtns; FHints := TStringList.Create; FCaptions := TStringList.Create; TStringList(FHints).OnChange := HintsChanged; TStringList(FCaptions).OnChange := CaptionsChanged; {$IFDEF D10_4+} - FButtonImages := TVirtualImageList.Create(Self); - FButtonImages.SetSize(DEFAULT_BTN_IMAGE_SIZE, DEFAULT_BTN_IMAGE_SIZE); + FButtonImages := TVirtualImageList.Create(AOwner); FButtonImages.AutoFill := True; FButtonImages.ImageCollection := FButtonsImageCollection; + FButtonImages.SetSize(DEFAULT_BTN_IMAGE_SIZE, DEFAULT_BTN_IMAGE_SIZE); {$ENDIF} + FStyleDrawType := _DefaultStyleDrawType; + FStyleRadius := _DefaultStyleRadius; + FStyleFamily := AFamily; + FStyleClass := AClass; + FStyleAppearance := AAppearance; + Cursor := _DefaultCursor; + InitButtons; InitHints; InitCaptions; @@ -419,7 +628,7 @@ constructor TStyledDBNavigator.CreateStyled(AOwner: TComponent; Height := 25; FButtonWidth := 0; FButtonHeight := 0; - FocusedButton := nbFirst; + FocusedButton := TNavigateBtn.nbFirst; FConfirmDelete := True; FullRepaint := False; @@ -436,19 +645,10 @@ constructor TStyledDBNavigator.CreateStyled(AOwner: TComponent; ParentColor := True; BevelOuter := bvNone; Flat := False; - - FStyleDrawType := btRounded; - FStyleRadius := DEFAULT_RADIUS; - FStyleFamily := AFamily; - FStyleClass := AClass; - FStyleAppearance := AAppearance; end; -{$IFDEF D10_4+} - - -{$ELSE} -procedure TStyledDBNavigator.UpdateButtonsGlyphs; +{$IFNDEF D10_4+} +procedure TCustomStyledDBNavigator.UpdateButtonsGlyphs; var I: TNavigateBtn; UseGlyphs: Boolean; @@ -464,7 +664,7 @@ procedure TStyledDBNavigator.UpdateButtonsGlyphs; end; {$ENDIF} -procedure TStyledDBNavigator.CreateWnd; +procedure TCustomStyledDBNavigator.CreateWnd; begin inherited; {$IFNDEF D10_4+} @@ -472,31 +672,40 @@ procedure TStyledDBNavigator.CreateWnd; {$ENDIF} end; -destructor TStyledDBNavigator.Destroy; +destructor TCustomStyledDBNavigator.Destroy; begin FreeAndNil(FDefaultHints); FreeAndNil(FDefaultCaptions); - FreeAndNil(FDataLink); FreeAndNil(FHints); FreeAndNil(FCaptions); FreeAndNil(FDisabledImageChangeLink); FreeAndNil(FImageChangeLink); + {$IFDEF D10_4+} + FreeAndNil(FButtonImages); + {$ENDIF} inherited Destroy; end; {$IFDEF D10_4+} -class destructor TStyledDBNavigator.Destroy; +class destructor TCustomStyledDBNavigator.Destroy; begin FreeAndNil(FButtonsImageCollection); end; -procedure TStyledDBNavigator.ChangeScale(M, D: Integer; isDpiChange: Boolean); +procedure TCustomStyledDBNavigator.ChangeScale(M, D: Integer; isDpiChange: Boolean); begin inherited; - FButtonImages.SetSize(MulDiv(FButtonImages.Width, M, D), MulDiv(FButtonImages.Height, M, D)); + if FButtonImages <> nil then + FButtonImages.SetSize(MulDiv(FButtonImages.Width, M, D), MulDiv(FButtonImages.Height, M, D)); +end; + +procedure TCustomStyledDBNavigator.CMStyleChanged(var Message: TMessage); +begin + UpdateButtonsIcons; + Invalidate; end; -procedure TStyledDBNavigator.UpdateButtonsImageIndex; +procedure TCustomStyledDBNavigator.UpdateButtonsImageIndex; var I: TNavigateBtn; Btn: TStyledNavButton; @@ -504,14 +713,63 @@ procedure TStyledDBNavigator.UpdateButtonsImageIndex; for I := Low(FButtons) to High(FButtons) do begin Btn := Buttons[I]; - if (FKind = dbnVertical) and (I in [nbFirst, nbPrior, nbNext, nbLast]) then + if (FKind = dbnVertical) and (I in NavigatorMoveBtns) then Btn.ImageIndex := Ord(I) + Ord(High(FButtons)) +1 else Btn.ImageIndex := Ord(I); end; end; + +procedure TCustomStyledDBNavigator.UpdateButtonsIcons; +var + LStyleName, LBtnName: string; + LThemeAttribute: TThemeAttribute; +begin + if Assigned(FImages) then + begin + UpdateButtonsImageIndex; + Exit; + end; + + if (StyleFamily = DEFAULT_CLASSIC_FAMILY) then + LStyleName := StyleClass; + if LStyleName = 'Windows' then + LStyleName := GetActiveStyleName; + for var I := Low(FButtons) to High(FButtons) do + begin + var Btn := Buttons[I]; + LBtnName := BtnTypeName[I]; + + if (LStyleName = 'Windows') then + begin + //Use colored images (for backward compatibility) + LBtnName := COLORED_IMAGE_COLLECTION+LBtnName; + end + else + begin + if GetStyleAttributes(LStyleName, LThemeAttribute) then + begin + if LThemeAttribute.ThemeType = ttLight then + //Use black images for light theme + LBtnName := BLACK_IMAGE_COLLECTION+LBtnName + else + //Use white images for dark theme + LBtnName := WHITE_IMAGE_COLLECTION+LBtnName; + end + else + //Use colored images (for backward compatibility) + LBtnName := COLORED_IMAGE_COLLECTION+LBtnName; + end; + + //Vertical images + if (FKind = dbnVertical) and + (I in NavigatorMoveBtns) then + LBtnName := LBtnName+VERTICAL_ICON; + Btn.ImageName := LBtnName; + end; +end; {$ELSE} -procedure TStyledDBNavigator.SetButtonGlyph(Index: TNavigateBtn); +procedure TCustomStyledDBNavigator.SetButtonGlyph(Index: TNavigateBtn); var LResName: string; begin @@ -521,7 +779,7 @@ procedure TStyledDBNavigator.SetButtonGlyph(Index: TNavigateBtn); end; {$ENDIF} -procedure TStyledDBNavigator.Paint; +procedure TCustomStyledDBNavigator.Paint; begin if StyleServices.Enabled and not StyleServices.IsSystemStyle then with Canvas do @@ -534,7 +792,7 @@ procedure TStyledDBNavigator.Paint; inherited; end; -procedure TStyledDBNavigator.ImageListChange(Sender: TObject); +procedure TCustomStyledDBNavigator.ImageListChange(Sender: TObject); begin ProcessButtons( procedure (ABtn: TStyledNavButton) @@ -548,13 +806,13 @@ procedure TStyledDBNavigator.ImageListChange(Sender: TObject); {$ENDIF} end); {$IFDEF D10_4+} - UpdateButtonsImageIndex; + UpdateButtonsIcons; {$ELSE} UpdateButtonsGlyphs; {$ENDIF} end; -procedure TStyledDBNavigator.DisabledImageListChange(Sender: TObject); +procedure TCustomStyledDBNavigator.DisabledImageListChange(Sender: TObject); begin ProcessButtons( procedure (ABtn: TStyledNavButton) @@ -564,7 +822,7 @@ procedure TStyledDBNavigator.DisabledImageListChange(Sender: TObject); ); end; -procedure TStyledDBNavigator.ProcessButtons(AButtonProc: TButtonProc); +procedure TCustomStyledDBNavigator.ProcessButtons(AButtonProc: TButtonProc); var I: TNavigateBtn; begin @@ -572,7 +830,21 @@ procedure TStyledDBNavigator.ProcessButtons(AButtonProc: TButtonProc); AButtonProc(FButtons[I]); end; -procedure TStyledDBNavigator.InitButtons; +class procedure TCustomStyledDBNavigator.RegisterDefaultRenderingStyle( + const ADrawType: TStyledButtonDrawType; const AFamily: TStyledButtonFamily; + const AClass: TStyledButtonClass; const AAppearance: TStyledButtonAppearance; + const AStyleRadius: Integer; const ACursor: TCursor); +begin + _DefaultStyleDrawType := ADrawType; + _UseCustomDrawType := True; + _DefaultFamily := AFamily; + _DefaultClass := AClass; + _DefaultAppearance := AAppearance; + _DefaultStyleRadius := AStyleRadius; + _DefaultCursor := ACursor; +end; + +procedure TCustomStyledDBNavigator.InitButtons; var I: TNavigateBtn; Btn: TStyledNavButton; @@ -598,16 +870,16 @@ procedure TStyledDBNavigator.InitButtons; else Y := Y + FMinBtnSize.Y; end; - FButtons[nbPrior].NavStyle := FButtons[nbPrior].NavStyle + [nsAllowTimer]; - FButtons[nbNext].NavStyle := FButtons[nbNext].NavStyle + [nsAllowTimer]; + FButtons[TNavigateBtn.nbPrior].NavStyle := FButtons[TNavigateBtn.nbPrior].NavStyle + [nsAllowTimer]; + FButtons[TNavigateBtn.nbNext].NavStyle := FButtons[TNavigateBtn.nbNext].NavStyle + [nsAllowTimer]; {$IFDEF D10_4+} - UpdateButtonsImageIndex; + UpdateButtonsIcons; {$ELSE} UpdateButtonsGlyphs; {$ENDIF} end; -procedure TStyledDBNavigator.InitCaptions; +procedure TCustomStyledDBNavigator.InitCaptions; var I: Integer; J: TNavigateBtn; @@ -631,7 +903,7 @@ procedure TStyledDBNavigator.InitCaptions; end; end; -procedure TStyledDBNavigator.InitHints; +procedure TCustomStyledDBNavigator.InitHints; var I: Integer; J: TNavigateBtn; @@ -655,17 +927,17 @@ procedure TStyledDBNavigator.InitHints; end; end; -function TStyledDBNavigator.IsCustomDrawType: Boolean; +function TCustomStyledDBNavigator.IsCustomDrawType: Boolean; begin Result := FCustomDrawType; end; -function TStyledDBNavigator.IsCustomRadius: Boolean; +function TCustomStyledDBNavigator.IsCustomRadius: Boolean; begin Result := StyleRadius <> DEFAULT_RADIUS; end; -function TStyledDBNavigator.IsStoredStyleAppearance: Boolean; +function TCustomStyledDBNavigator.IsStoredStyleAppearance: Boolean; var LClass: TStyledButtonClass; LAppearance: TStyledButtonAppearance; @@ -675,7 +947,7 @@ function TStyledDBNavigator.IsStoredStyleAppearance: Boolean; Result := FStyleAppearance <> LAppearance; end; -function TStyledDBNavigator.IsStoredStyleClass: Boolean; +function TCustomStyledDBNavigator.IsStoredStyleClass: Boolean; var LClass: TStyledButtonClass; LAppearance: TStyledButtonAppearance; @@ -683,7 +955,7 @@ function TStyledDBNavigator.IsStoredStyleClass: Boolean; begin StyleFamilyCheckAttributes(FStyleFamily, LClass, LAppearance, LButtonFamily); - if (FStyleFamily = DEFAULT_CLASSIC_FAMILY) and (seClient in StyleElements) then + if AsVCLStyle then begin Result := (FStyleClass <> GetActiveStyleName) and not SameText(FStyleClass, 'Windows'); @@ -692,22 +964,22 @@ function TStyledDBNavigator.IsStoredStyleClass: Boolean; Result := FStyleClass <> LClass; end; -function TStyledDBNavigator.IsStoredStyleFamily: Boolean; +function TCustomStyledDBNavigator.IsStoredStyleFamily: Boolean; begin Result := FStyleFamily <> DEFAULT_CLASSIC_FAMILY; end; -procedure TStyledDBNavigator.HintsChanged(Sender: TObject); +procedure TCustomStyledDBNavigator.HintsChanged(Sender: TObject); begin InitHints; end; -procedure TStyledDBNavigator.CaptionsChanged(Sender: TObject); +procedure TCustomStyledDBNavigator.CaptionsChanged(Sender: TObject); begin InitCaptions; end; -procedure TStyledDBNavigator.SetFlat(const AValue: Boolean); +procedure TCustomStyledDBNavigator.SetFlat(const AValue: Boolean); begin if FFlat <> AValue then begin @@ -720,21 +992,21 @@ procedure TStyledDBNavigator.SetFlat(const AValue: Boolean); end; end; -procedure TStyledDBNavigator.SetHints(const AValue: TStrings); +procedure TCustomStyledDBNavigator.SetHints(const AValue: TStrings); begin if AValue.Text = FDefaultHints.Text then FHints.Clear else FHints.Assign(AValue); end; -procedure TStyledDBNavigator.SetCaptions(const AValue: TStrings); +procedure TCustomStyledDBNavigator.SetCaptions(const AValue: TStrings); begin if AValue.Text = FDefaultCaptions.Text then FCaptions.Clear else FCaptions.Assign(AValue); end; -procedure TStyledDBNavigator.SetImages(const AValue: TCustomImageList); +procedure TCustomStyledDBNavigator.SetImages(const AValue: TCustomImageList); begin if FImages <> AValue then begin @@ -743,7 +1015,7 @@ procedure TStyledDBNavigator.SetImages(const AValue: TCustomImageList); end; end; -function TStyledDBNavigator.GetHints: TStrings; +function TCustomStyledDBNavigator.GetHints: TStrings; begin if (csDesigning in ComponentState) and not (csWriting in ComponentState) and not (csReading in ComponentState) and (FHints.Count = 0) then @@ -751,7 +1023,7 @@ function TStyledDBNavigator.GetHints: TStrings; Result := FHints; end; -function TStyledDBNavigator.GetCaptions: TStrings; +function TCustomStyledDBNavigator.GetCaptions: TStrings; begin if (csDesigning in ComponentState) and not (csWriting in ComponentState) and not (csReading in ComponentState) and (FCaptions.Count = 0) then @@ -759,7 +1031,7 @@ function TStyledDBNavigator.GetCaptions: TStrings; Result := FCaptions; end; -procedure TStyledDBNavigator.SetKind(const AValue: TDBNavigatorKind); +procedure TCustomStyledDBNavigator.SetKind(const AValue: TDBNavigatorKind); begin if FKind <> AValue then begin @@ -767,7 +1039,7 @@ procedure TStyledDBNavigator.SetKind(const AValue: TDBNavigatorKind); if not (csLoading in ComponentState) then SetBounds(Left, Top, Height, Width); {$IFDEF D10_4+} - UpdateButtonsImageIndex; + UpdateButtonsIcons; {$ELSE} UpdateButtonsGlyphs; {$ENDIF} @@ -775,27 +1047,18 @@ procedure TStyledDBNavigator.SetKind(const AValue: TDBNavigatorKind); end; end; -function TStyledDBNavigator.GetActiveStyleName: string; +function TCustomStyledDBNavigator.GetActiveStyleName: string; begin - {$IFDEF D10_4+} - Result := GetStyleName; - if Result = '' then - begin - {$IFDEF D11+} - if (csDesigning in ComponentState) then - Result := TStyleManager.ActiveDesigningStyle.Name - else - Result := TStyleManager.ActiveStyle.Name; - {$ELSE} - Result := TStyleManager.ActiveStyle.Name; - {$ENDIF} - end; - {$ELSE} - Result := TStyleManager.ActiveStyle.Name; - {$ENDIF} + Result := Vcl.ButtonStylesAttributes.GetActiveStyleName(Self); +end; + +function TCustomStyledDBNavigator.GetButton( + const AValue: TNavigateBtn): TStyledNavButton; +begin + Result := FButtons[Avalue]; end; -procedure TStyledDBNavigator.GetChildren(Proc: TGetChildProc; Root: TComponent); +procedure TCustomStyledDBNavigator.GetChildren(Proc: TGetChildProc; Root: TComponent); //var // J: TNavigateBtn; begin @@ -803,14 +1066,12 @@ procedure TStyledDBNavigator.GetChildren(Proc: TGetChildProc; Root: TComponent); // Proc(FButtons[J]); end; -procedure TStyledDBNavigator.Notification(AComponent: TComponent; +procedure TCustomStyledDBNavigator.Notification(AComponent: TComponent; Operation: TOperation); begin inherited Notification(AComponent, Operation); if (Operation = opRemove) then begin - if (FDataLink <> nil) and (AComponent = DataSource) then - DataSource := nil; if (AComponent = Images) then Images := {$IFDEF D10_4+}FButtonImages;{$ELSE}nil;{$ENDIF} if (AComponent = DisabledImages) then @@ -818,7 +1079,7 @@ procedure TStyledDBNavigator.Notification(AComponent: TComponent; end; end; -procedure TStyledDBNavigator.SetVisible(const AValue: TNavButtonSet); +procedure TCustomStyledDBNavigator.SetVisible(const AValue: TNavButtonSet); var I: TNavigateBtn; W, H: Integer; @@ -834,14 +1095,14 @@ procedure TStyledDBNavigator.SetVisible(const AValue: TNavButtonSet); Invalidate; end; -procedure TStyledDBNavigator.UpdateStyleElements; +procedure TCustomStyledDBNavigator.UpdateStyleElements; var LStyleClass: TStyledButtonClass; begin if AsVCLStyle then begin //if StyleElements contains seClient then Update style - //as VCL Style assigned to Toolbar or Global VCL Style + //as VCL Style assigned to Dbnavigator or Global VCL Style if seBorder in StyleElements then StyleAppearance := DEFAULT_APPEARANCE; LStyleClass := GetActiveStyleName; @@ -857,13 +1118,13 @@ procedure TStyledDBNavigator.UpdateStyleElements; inherited; end; -procedure TStyledDBNavigator.CalcMinSize(var W, H: Integer); +procedure TCustomStyledDBNavigator.CalcMinSize(var W, H: Integer); var Count: Integer; I: TNavigateBtn; begin if (csLoading in ComponentState) then Exit; - if FButtons[nbFirst] = nil then Exit; + if FButtons[TNavigateBtn.nbFirst] = nil then Exit; Count := 0; for I := Low(FButtons) to High(FButtons) do @@ -899,7 +1160,7 @@ procedure TStyledDBNavigator.CalcMinSize(var W, H: Integer); {$ENDIF} end; -procedure TStyledDBNavigator.UpdateButtons; +procedure TCustomStyledDBNavigator.UpdateButtons; begin ProcessButtons( procedure (ABtn: TStyledNavButton) @@ -908,7 +1169,7 @@ procedure TStyledDBNavigator.UpdateButtons; end); end; -procedure TStyledDBNavigator.SetShowCaptions(const AValue: Boolean); +procedure TCustomStyledDBNavigator.SetShowCaptions(const AValue: Boolean); begin if FShowCaptions <> AValue then begin @@ -917,7 +1178,7 @@ procedure TStyledDBNavigator.SetShowCaptions(const AValue: Boolean); end; end; -procedure TStyledDBNavigator.SetSize(var W: Integer; var H: Integer); +procedure TCustomStyledDBNavigator.SetSize(var W: Integer; var H: Integer); var Count: Integer; I: TNavigateBtn; @@ -926,7 +1187,7 @@ procedure TStyledDBNavigator.SetSize(var W: Integer; var H: Integer); begin if (csLoading in ComponentState) then Exit; - if FButtons[nbFirst] = nil then + if FButtons[TNavigateBtn.nbFirst] = nil then Exit; CalcMinSize(W, H); @@ -991,7 +1252,7 @@ procedure TStyledDBNavigator.SetSize(var W: Integer; var H: Integer); end; end; -procedure TStyledDBNavigator.SetStyleAppearance( +procedure TCustomStyledDBNavigator.SetStyleAppearance( const AValue: TStyledButtonAppearance); var LValue: TStyledButtonAppearance; @@ -1012,12 +1273,12 @@ procedure TStyledDBNavigator.SetStyleAppearance( end; end; -procedure TStyledDBNavigator.SetStyleApplied(const AValue: Boolean); +procedure TCustomStyledDBNavigator.SetStyleApplied(const AValue: Boolean); begin FStyleApplied := AValue; end; -procedure TStyledDBNavigator.SetStyleClass(const AValue: TStyledButtonClass); +procedure TCustomStyledDBNavigator.SetStyleClass(const AValue: TStyledButtonClass); var LValue: TStyledButtonClass; begin @@ -1029,15 +1290,20 @@ procedure TStyledDBNavigator.SetStyleClass(const AValue: TStyledButtonClass); ProcessButtons( procedure (ABtn: TStyledNavButton) begin - if ABtn.StyleClass = StyleClass then - ABtn.StyleClass := LValue; + ABtn.StyleClass := LValue; end); FStyleClass := LValue; + {$IFDEF D10_4+} + UpdateButtonsIcons; + {$ENDIF} StyleApplied := ApplyDbnavigatorStyle; + if (FStyleFamily = DEFAULT_CLASSIC_FAMILY) and + (LValue <> 'Windows') then + StyleElements := [seFont, seBorder]; end; end; -procedure TStyledDBNavigator.SetStyleDrawType( +procedure TCustomStyledDBNavigator.SetStyleDrawType( const AValue: TStyledButtonDrawType); begin FCustomDrawType := True; @@ -1054,7 +1320,7 @@ procedure TStyledDBNavigator.SetStyleDrawType( end; end; -procedure TStyledDBNavigator.SetStyleFamily(const AValue: TStyledButtonFamily); +procedure TCustomStyledDBNavigator.SetStyleFamily(const AValue: TStyledButtonFamily); var LValue: TStyledButtonFamily; begin @@ -1071,12 +1337,15 @@ procedure TStyledDBNavigator.SetStyleFamily(const AValue: TStyledButtonFamily); end); FStyleFamily := LValue; StyleApplied := ApplyDbnavigatorStyle; + {$IFDEF D10_4+} + UpdateButtonsIcons; + {$ENDIF} end; if FStyleFamily = DEFAULT_CLASSIC_FAMILY then StyleElements := [seFont, seClient, seBorder]; end; -procedure TStyledDBNavigator.SetStyleRadius(const AValue: Integer); +procedure TCustomStyledDBNavigator.SetStyleRadius(const AValue: Integer); begin if FStyleRadius <> AValue then begin @@ -1093,7 +1362,7 @@ procedure TStyledDBNavigator.SetStyleRadius(const AValue: Integer); end; end; -procedure TStyledDBNavigator.SetBounds(ALeft, ATop, AWidth, AHeight: Integer); +procedure TCustomStyledDBNavigator.SetBounds(ALeft, ATop, AWidth, AHeight: Integer); var W, H: Integer; begin @@ -1103,7 +1372,7 @@ procedure TStyledDBNavigator.SetBounds(ALeft, ATop, AWidth, AHeight: Integer); inherited SetBounds (ALeft, ATop, W, H); end; -procedure TStyledDBNavigator.WMSize(var Message: TWMSize); +procedure TCustomStyledDBNavigator.WMSize(var Message: TWMSize); var W, H: Integer; begin @@ -1113,19 +1382,14 @@ procedure TStyledDBNavigator.WMSize(var Message: TWMSize); SetSize(W, H); end; -procedure TStyledDBNavigator.WMWindowPosChanging(var Message: TWMWindowPosChanging); +procedure TCustomStyledDBNavigator.WMWindowPosChanging(var Message: TWMWindowPosChanging); begin inherited; if (SWP_NOSIZE and Message.WindowPos.Flags) = 0 then CalcMinSize(Message.WindowPos.cx, Message.WindowPos.cy); end; -procedure TStyledDBNavigator.ClickHandler(Sender: TObject); -begin - BtnClick(TStyledNavButton(Sender).Index); -end; - -procedure TStyledDBNavigator.BtnMouseDown(Sender: TObject; Button: TMouseButton; +procedure TCustomStyledDBNavigator.BtnMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var OldFocus: TNavigateBtn; @@ -1145,7 +1409,7 @@ procedure TStyledDBNavigator.BtnMouseDown(Sender: TObject; Button: TMouseButton; end; end; -function TStyledDBNavigator.ApplyDbnavigatorStyle: Boolean; +function TCustomStyledDBNavigator.ApplyDbnavigatorStyle: Boolean; var LButtonFamily: TButtonFamily; LAttributesNormal, LAttributesOther: TStyledButtonAttributes; @@ -1182,92 +1446,73 @@ function TStyledDBNavigator.ApplyDbnavigatorStyle: Boolean; end; end; -procedure TStyledDBNavigator.ApplyUpdates; +procedure TCustomStyledDBNavigator.Assign(Source: TPersistent); var - Intf: IDataSetCommandSupport; + LNavigator: TCustomStyledDBNavigator; begin - if (Self.DataSource <> nil) and Supports(Self.DataSource.DataSet, IDataSetCommandSupport, Intf) then - Intf.ExecuteCommand(sApplyUpdatesDataSetCommand, [MaxErrors]) + inherited Assign(Source); + if Source is TCustomStyledDBNavigator then + begin + LNavigator := TCustomStyledDBNavigator(Source); + FFlat := LNavigator.FFlat; + FKind := LNavigator.FKind; + FConfirmDelete := LNavigator.FConfirmDelete; + DisabledImages := LNavigator.FDisabledImages; + Images := LNavigator.FImages; + FShowCaptions := LNavigator.FShowCaptions; + FStyleRadius := LNavigator.FStyleRadius; + FStyleDrawType := LNavigator.FStyleDrawType; + FStyleFamily := LNavigator.FStyleFamily; + FStyleClass := LNavigator.FStyleClass; + FStyleAppearance := LNavigator.FStyleAppearance; + Invalidate; + end; end; -function TStyledDBNavigator.AsVCLStyle: Boolean; +function TCustomStyledDBNavigator.AsVCLStyle: Boolean; begin - //if StyleFamily is Classic and StyleElements contains seClient - //assume to draw the component as the equivalent VCL Result := (StyleFamily = DEFAULT_CLASSIC_FAMILY) and (seClient in StyleElements); end; -function TStyledDBNavigator.CanApplyUpdates: Boolean; -var - Intf: IDataSetCommandSupport; -begin - if (Self.DataSource <> nil) and Supports(Self.DataSource.DataSet, IDataSetCommandSupport, Intf) then - Result := dcEnabled in Intf.GetCommandStates(sApplyUpdatesDataSetCommand) - else - Result := False; -end; - -procedure TStyledDBNavigator.CancelUpdates; -var - Intf: IDataSetCommandSupport; -begin - if (Self.DataSource <> nil) and Supports(Self.DataSource.DataSet, IDataSetCommandSupport, Intf) then - Intf.ExecuteCommand(sCancelUpdatesDataSetCommand, [MaxErrors]) -end; - -function TStyledDBNavigator.CanCancelUpdates: Boolean; -var - Intf: IDataSetCommandSupport; -begin - if (Self.DataSource <> nil) and Supports(Self.DataSource.DataSet, IDataSetCommandSupport, Intf) then - Result := dcEnabled in Intf.GetCommandStates(sCancelUpdatesDataSetCommand) - else - Result := False; -end; - -procedure TStyledDBNavigator.BtnClick(Index: TNavigateBtn); +procedure TCustomStyledDBNavigator.SetAsVCLComponent(const AValue: Boolean); begin - if (DataSource <> nil) and (DataSource.State <> dsInactive) then + if AValue <> GetAsVCLComponent then begin - if not (csDesigning in ComponentState) and Assigned(FBeforeAction) then - FBeforeAction(Self, Index); - with DataSource.DataSet do + if AValue then begin - case Index of - nbPrior: Prior; - nbNext: Next; - nbFirst: First; - nbLast: Last; - nbInsert: Insert; - nbEdit: Edit; - nbCancel: Cancel; - nbPost: Post; - nbRefresh: Refresh; - nbDelete: - if not FConfirmDelete or - (StyledMessageDlg(SDeleteRecordQuestion, mtConfirmation, - mbOKCancel, 0) <> idCancel) then Delete; - nbApplyUpdates: Self.ApplyUpdates; - nbCancelUpdates: Self.CancelUpdates; - end; + FStyleFamily := DEFAULT_CLASSIC_FAMILY; + FStyleClass := DEFAULT_WINDOWS_CLASS; + FStyleAppearance := DEFAULT_APPEARANCE; + StyleElements := StyleElements + [seClient]; + FCustomDrawType := False; + end + else if FStyleFamily = DEFAULT_CLASSIC_FAMILY then + begin + StyleElements := StyleElements - [seClient]; end; + UpdateStyleElements; end; - if not (csDesigning in ComponentState) and Assigned(FOnNavClick) then - FOnNavClick(Self, Index); end; -procedure TStyledDBNavigator.WMSetFocus(var Message: TWMSetFocus); +function TCustomStyledDBNavigator.GetAsVCLComponent: Boolean; +begin + Result := (StyleFamily = DEFAULT_CLASSIC_FAMILY) and + (seClient in StyleElements) and + (FStyleClass = GetActiveStyleName); +end; + +procedure TCustomStyledDBNavigator.WMSetFocus(var Message: TWMSetFocus); begin FButtons[FocusedButton].Invalidate; end; -procedure TStyledDBNavigator.WMKillFocus(var Message: TWMKillFocus); +procedure TCustomStyledDBNavigator.WMKillFocus(var Message: TWMKillFocus); begin FButtons[FocusedButton].Invalidate; end; -procedure TStyledDBNavigator.KeyDown(var Key: Word; Shift: TShiftState); +procedure TCustomStyledDBNavigator.KeyDown(var Key: Word; Shift: TShiftState); var NewFocus: TNavigateBtn; OldFocus: TNavigateBtn; @@ -1312,45 +1557,48 @@ procedure TStyledDBNavigator.KeyDown(var Key: Word; Shift: TShiftState); end; end; -procedure TStyledDBNavigator.WMGetDlgCode(var Message: TWMGetDlgCode); +procedure TCustomStyledDBNavigator.WMGetDlgCode(var Message: TWMGetDlgCode); begin Message.Result := DLGC_WANTARROWS; end; -procedure TStyledDBNavigator.DataChanged; -var - UpEnable, DnEnable: Boolean; - CanModify, CanRefresh: Boolean; +procedure TCustomStyledDBNavigator.SetDbNavigatorStyle( + const AStyleFamily: TStyledButtonFamily; + const AStyleClass: TStyledButtonClass; + const AStyleAppearance: TStyledButtonAppearance); begin - CanModify := Enabled and FDataLink.Active and FDataLink.DataSet.CanModify; - CanRefresh := Enabled and FDataLink.Active and FDataLink.DataSet.CanRefresh; - UpEnable := Enabled and FDataLink.Active and not FDataLink.DataSet.BOF; - DnEnable := Enabled and FDataLink.Active and not FDataLink.DataSet.EOF; - FButtons[nbFirst].Enabled := UpEnable; - FButtons[nbPrior].Enabled := UpEnable; - FButtons[nbNext].Enabled := DnEnable; - FButtons[nbLast].Enabled := DnEnable; - FButtons[nbDelete].Enabled := CanModify and - not (FDataLink.DataSet.BOF and FDataLink.DataSet.EOF); - FButtons[nbRefresh].Enabled := CanRefresh; - FButtons[nbApplyUpdates].Enabled := CanModify and Self.CanApplyUpdates; - FButtons[nbCancelUpdates].Enabled := CanModify and Self.CanCancelUpdates; + StyleFamily := AStyleFamily; + StyleClass := AStyleClass; + StyleAppearance := AStyleAppearance; + if not ApplyDbnavigatorStyle then + raise EStyledButtonError.CreateFmt(ERROR_SETTING_DBNAVIGATOR_STYLE, + [AStyleFamily, AStyleClass, AStyleAppearance]); end; -procedure TStyledDBNavigator.EditingChanged; +procedure TCustomStyledDBNavigator.SetDisabledImages(const AValue: TCustomImageList); +begin + if FDisabledImages <> AValue then + begin + FDisabledImages := AValue; + DisabledImageListChange(Self); + end; +end; + +procedure TCustomStyledDBNavigator.Loaded; var - CanModify: Boolean; + W, H: Integer; begin - CanModify := Enabled and FDataLink.Active and FDataLink.DataSet.CanModify; - Buttons[nbInsert].Enabled := CanModify; - Buttons[nbEdit].Enabled := CanModify and not FDataLink.Editing; - Buttons[nbPost].Enabled := CanModify and FDataLink.Editing; - Buttons[nbCancel].Enabled := CanModify and FDataLink.Editing; - Buttons[nbRefresh].Enabled := Enabled and (nbRefresh in VisibleButtons) and FDataLink.Active and FDataLink.DataSet.CanRefresh; - Buttons[nbApplyUpdates].Enabled := CanModify and (nbApplyUpdates in VisibleButtons) and Self.CanApplyUpdates; - Buttons[nbCancelUpdates].Enabled := CanModify and (nbCancelUpdates in VisibleButtons) and Self.CanCancelUpdates; + inherited Loaded; + W := Width; + H := Height; + SetSize(W, H); + if (W <> Width) or (H <> Height) then + inherited SetBounds (Left, Top, W, H); + InitHints; end; +{ TStyledDBNavigator } + procedure TStyledDBNavigator.ActiveChanged; var I: TNavigateBtn; @@ -1365,6 +1613,79 @@ procedure TStyledDBNavigator.ActiveChanged; end; end; +procedure TStyledDBNavigator.ApplyUpdates; +var + Intf: IDataSetCommandSupport; +begin + if (Self.DataSource <> nil) and Supports(Self.DataSource.DataSet, IDataSetCommandSupport, Intf) then + Intf.ExecuteCommand(sApplyUpdatesDataSetCommand, [MaxErrors]) +end; + +procedure TStyledDBNavigator.BtnClick(Index: TNavigateBtn); +begin + if (DataSource <> nil) and (DataSource.State <> dsInactive) then + begin + if not (csDesigning in ComponentState) and Assigned(FBeforeAction) then + FBeforeAction(Self, Index); + with DataSource.DataSet do + begin + case Index of + TNavigateBtn.nbPrior: Prior; + TNavigateBtn.nbNext: Next; + TNavigateBtn.nbFirst: First; + TNavigateBtn.nbLast: Last; + TNavigateBtn.nbInsert: Insert; + TNavigateBtn.nbEdit: Edit; + TNavigateBtn.nbCancel: Cancel; + TNavigateBtn.nbPost: Post; + TNavigateBtn.nbRefresh: Refresh; + TNavigateBtn.nbDelete: + if not FConfirmDelete or + (StyledMessageDlg(SDeleteRecordQuestion, mtConfirmation, + mbOKCancel, 0) <> idCancel) then Delete; + TNavigateBtn.nbApplyUpdates: Self.ApplyUpdates; + TNavigateBtn.nbCancelUpdates: Self.CancelUpdates; + end; + end; + end; + if not (csDesigning in ComponentState) and Assigned(FOnNavClick) then + FOnNavClick(Self, Index); +end; + +function TStyledDBNavigator.CanApplyUpdates: Boolean; +var + Intf: IDataSetCommandSupport; +begin + if (Self.DataSource <> nil) and Supports(Self.DataSource.DataSet, IDataSetCommandSupport, Intf) then + Result := dcEnabled in Intf.GetCommandStates(sApplyUpdatesDataSetCommand) + else + Result := False; +end; + +function TStyledDBNavigator.CanCancelUpdates: Boolean; +var + Intf: IDataSetCommandSupport; +begin + if (Self.DataSource <> nil) and Supports(Self.DataSource.DataSet, IDataSetCommandSupport, Intf) then + Result := dcEnabled in Intf.GetCommandStates(sCancelUpdatesDataSetCommand) + else + Result := False; +end; + +procedure TStyledDBNavigator.CancelUpdates; +var + Intf: IDataSetCommandSupport; +begin + if (Self.DataSource <> nil) and Supports(Self.DataSource.DataSet, IDataSetCommandSupport, Intf) then + Intf.ExecuteCommand(sCancelUpdatesDataSetCommand, [MaxErrors]) +end; + +procedure TStyledDBNavigator.ClickHandler(Sender: TObject); +begin + inherited; + BtnClick(TStyledNavButton(Sender).Index); +end; + procedure TStyledDBNavigator.CMEnabledChanged(var Message: TMessage); begin inherited; @@ -1372,35 +1693,50 @@ procedure TStyledDBNavigator.CMEnabledChanged(var Message: TMessage); ActiveChanged; end; -procedure TStyledDBNavigator.SetDataSource(const AValue: TDataSource); +constructor TStyledDBNavigator.Create(AOwner: TComponent); begin - FDataLink.DataSource := AValue; - if not (csLoading in ComponentState) then - ActiveChanged; - if AValue <> nil then - AValue.FreeNotification(Self); + inherited Create(AOwner); + FDataLink := TStyledNavDataLink.Create(Self); end; -procedure TStyledDBNavigator.SetDbNavigatorStyle( - const AStyleFamily: TStyledButtonFamily; - const AStyleClass: TStyledButtonClass; - const AStyleAppearance: TStyledButtonAppearance); +procedure TStyledDBNavigator.DataChanged; +var + UpEnable, DnEnable: Boolean; + CanModify, CanRefresh: Boolean; begin - StyleFamily := AStyleFamily; - StyleClass := AStyleClass; - StyleAppearance := AStyleAppearance; - if not ApplyDbnavigatorStyle then - raise EStyledButtonError.CreateFmt(ERROR_SETTING_DBNAVIGATOR_STYLE, - [AStyleFamily, AStyleClass, AStyleAppearance]); + CanModify := Enabled and FDataLink.Active and FDataLink.DataSet.CanModify; + CanRefresh := Enabled and FDataLink.Active and FDataLink.DataSet.CanRefresh; + UpEnable := Enabled and FDataLink.Active and not FDataLink.DataSet.BOF; + DnEnable := Enabled and FDataLink.Active and not FDataLink.DataSet.EOF; + FButtons[TNavigateBtn.nbFirst].Enabled := UpEnable; + FButtons[TNavigateBtn.nbPrior].Enabled := UpEnable; + FButtons[TNavigateBtn.nbNext].Enabled := DnEnable; + FButtons[TNavigateBtn.nbLast].Enabled := DnEnable; + FButtons[TNavigateBtn.nbDelete].Enabled := CanModify and + not (FDataLink.DataSet.BOF and FDataLink.DataSet.EOF); + FButtons[TNavigateBtn.nbRefresh].Enabled := CanRefresh; + FButtons[TNavigateBtn.nbApplyUpdates].Enabled := CanModify and Self.CanApplyUpdates; + FButtons[TNavigateBtn.nbCancelUpdates].Enabled := CanModify and Self.CanCancelUpdates; end; -procedure TStyledDBNavigator.SetDisabledImages(const AValue: TCustomImageList); +destructor TStyledDBNavigator.Destroy; begin - if FDisabledImages <> AValue then - begin - FDisabledImages := AValue; - DisabledImageListChange(Self); - end; + FreeAndNil(FDataLink); + inherited Destroy; +end; + +procedure TStyledDBNavigator.EditingChanged; +var + CanModify: Boolean; +begin + CanModify := Enabled and FDataLink.Active and FDataLink.DataSet.CanModify; + Buttons[TNavigateBtn.nbInsert].Enabled := CanModify; + Buttons[TNavigateBtn.nbEdit].Enabled := CanModify and not FDataLink.Editing; + Buttons[TNavigateBtn.nbPost].Enabled := CanModify and FDataLink.Editing; + Buttons[TNavigateBtn.nbCancel].Enabled := CanModify and FDataLink.Editing; + Buttons[TNavigateBtn.nbRefresh].Enabled := Enabled and (TNavigateBtn.nbRefresh in VisibleButtons) and FDataLink.Active and FDataLink.DataSet.CanRefresh; + Buttons[TNavigateBtn.nbApplyUpdates].Enabled := CanModify and (TNavigateBtn.nbApplyUpdates in VisibleButtons) and Self.CanApplyUpdates; + Buttons[TNavigateBtn.nbCancelUpdates].Enabled := CanModify and (TNavigateBtn.nbCancelUpdates in VisibleButtons) and Self.CanCancelUpdates; end; function TStyledDBNavigator.GetDataSource: TDataSource; @@ -1409,27 +1745,50 @@ function TStyledDBNavigator.GetDataSource: TDataSource; end; procedure TStyledDBNavigator.Loaded; -var - W, H: Integer; begin - inherited Loaded; - W := Width; - H := Height; - SetSize(W, H); - if (W <> Width) or (H <> Height) then - inherited SetBounds (Left, Top, W, H); - InitHints; + inherited; ActiveChanged; end; -{TStyledNavButton} +procedure TStyledDBNavigator.Notification(AComponent: TComponent; + Operation: TOperation); +begin + inherited Notification(AComponent, Operation); + if (Operation = opRemove) then + begin + if (FDataLink <> nil) and (AComponent = DataSource) then + DataSource := nil; + end; +end; + +procedure TStyledDBNavigator.SetDataSource(const AValue: TDataSource); +begin + FDataLink.DataSource := AValue; + if not (csLoading in ComponentState) then + ActiveChanged; + if AValue <> nil then + AValue.FreeNotification(Self); +end; + +{ TStyledNavButton } constructor TStyledNavButton.Create(AOwner: TComponent); begin - inherited; + if AOwner is TCustomStyledDbNavigator then + begin + FDbNavigator := TCustomStyledDbNavigator(AOwner); + inherited CreateStyled(AOwner, + FDbNavigator._DefaultFamily, FDbNavigator._DefaultClass, + FDbNavigator._DefaultAppearance, + FDbNavigator._DefaultStyleDrawType, + FDbNavigator._DefaultCursor, + FDbNavigator._UseCustomDrawType); + StyleRadius := FDbNavigator.StyleRadius; + ControlStyle := [csCaptureMouse, csDoubleClicks, csSetCaption, csOpaque]; + end + else + inherited Create(AOwner); //ControlStyle := ControlStyle + [csCaptureMouse]; - if AOwner is TStyledDbNavigator then - FDbNavigator := TStyledDbNavigator(AOwner); ImageAlignment := iaTop; end; @@ -1440,7 +1799,7 @@ destructor TStyledNavButton.Destroy; inherited Destroy; end; -function TStyledNavButton.GetCaption: TCaption; +function TStyledNavButton.GetCaptionToDraw: TCaption; begin if Assigned(FDbNavigator) and not FDbNavigator.ShowCaptions then Result := '' @@ -1469,14 +1828,26 @@ procedure TStyledNavButton.MouseDown(Button: TMouseButton; Shift: TShiftState; FRepeatTimer.Interval := InitRepeatPause; FRepeatTimer.Enabled := True; end; + if (Button = mbLeft) and Enabled then + begin + FDragging := True; + end; end; procedure TStyledNavButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +var + DoClick: Boolean; begin - inherited MouseUp(Button, Shift, X, Y); if FRepeatTimer <> nil then FRepeatTimer.Enabled := False; + inherited MouseUp(Button, Shift, X, Y); + if FDragging then + begin + FDragging := False; + DoClick := (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight); + if DoClick then Click; + end; end; procedure TStyledNavButton.TimerExpired(Sender: TObject); @@ -1502,10 +1873,10 @@ procedure TStyledNavButton.UpdateButtonContent; begin inherited ImageAlignment := FImageAlignment; case FImageAlignment of - iaLeft: inherited ImageMargins.Left := DEFAULT_IMAGE_VMARGIN; - iaRight: inherited ImageMargins.Right := DEFAULT_IMAGE_VMARGIN; - iaTop: inherited ImageMargins.Top := DEFAULT_IMAGE_VMARGIN; - iaBottom: inherited ImageMargins.Bottom := DEFAULT_IMAGE_VMARGIN; + iaLeft: inherited ImageMargins.Left := DEFAULT_IMAGE_MARGIN; + iaRight: inherited ImageMargins.Right := DEFAULT_IMAGE_MARGIN; + iaTop: inherited ImageMargins.Top := DEFAULT_IMAGE_MARGIN; + iaBottom: inherited ImageMargins.Bottom := DEFAULT_IMAGE_MARGIN; end; end else @@ -1517,6 +1888,7 @@ procedure TStyledNavButton.UpdateButtonContent; else inherited Images := {$IFDEF D10_4+}FDbNavigator.FButtonImages;{$ELSE}nil;{$ENDIF} inherited DisabledImages := FDbNavigator.DisabledImages; + StyleElements := FDbNavigator.StyleElements; end; Invalidate; end; @@ -1561,17 +1933,256 @@ destructor TStyledNavDataLink.Destroy; procedure TStyledNavDataLink.EditingChanged; begin - if FNavigator <> nil then FNavigator.EditingChanged; + if FNavigator <> nil then + FNavigator.EditingChanged; end; procedure TStyledNavDataLink.DataSetChanged; begin - if FNavigator <> nil then FNavigator.DataChanged; + if FNavigator <> nil then + FNavigator.DataChanged; end; procedure TStyledNavDataLink.ActiveChanged; begin - if FNavigator <> nil then FNavigator.ActiveChanged; + if FNavigator <> nil then + FNavigator.ActiveChanged; +end; + +var + NavigateButtonHintId: array[TNavigateButton] of string = (SFirstRecord, SPriorRecord, + SNextRecord, SLastRecord, SInsertRecord, SDeleteRecord, SEditRecord, + SPostEdit, SCancelEdit, SRefreshRecord, + SApplyUpdates, SCancelUpdates); + +{ TStyledBindNavigator } + +procedure TStyledBindNavigator.ClickHandler(Sender: TObject); +begin + inherited; + BtnClick(NavBtnToNavigateButton(TStyledNavButton(Sender).Index)); +end; + +constructor TStyledBindNavigator.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + VisibleButtons := NavigatorDefaultButtons; + FController := TBindNavigatorController.Create(Self); + FController.OnEditingChanged := OnEditingChanged; + FController.OnDataChanged := OnDataChanged; + FController.OnActiveChanged := OnActiveChanged; end; +procedure TStyledBindNavigator.ActiveChanged; +var + LActive: Boolean; +begin + LActive := FController.Active; + if not (Enabled and LActive) then + FController.DisableButtons( + procedure(AButton: TNavigateButton; AEnabled: Boolean) + begin + Buttons[AButton].Enabled := AEnabled; + end) + else + begin + FController.EnableButtons(NavigatorButtons, Self.Enabled, + procedure(AButton: TNavigateButton; AEnabled: Boolean) + begin + Buttons[AButton].Enabled := AEnabled; + end) + end; +end; + +procedure TStyledBindNavigator.DataChanged; +begin + FController.EnableButtons(NavigatorScrollButtons + + [nbDelete, nbApplyUpdates, nbCancelUpdates], Self.Enabled, + procedure(AButton: TNavigateButton; AEnabled: Boolean) + begin + Buttons[AButton].Enabled := AEnabled; + end); +end; + +destructor TStyledBindNavigator.Destroy; +begin + FreeAndNil(FController); + inherited; +end; + +procedure TStyledBindNavigator.EditingChanged; +begin + FController.EnableButtons(NavigatorEditButtons - [nbDelete], Enabled, + procedure(AButton: TNavigateButton; AEnabled: Boolean) + begin + Buttons[AButton].Enabled := AEnabled; + end); +end; + +procedure TStyledBindNavigator.OnEditingChanged(Sender: TObject); +begin + EditingChanged; +end; + +procedure TStyledBindNavigator.OnActiveChanged(Sender: TObject); +begin + ActiveChanged; +end; + +procedure TStyledBindNavigator.OnDataChanged(Sender: TObject); +begin + DataChanged; +end; + +procedure TStyledBindNavigator.SetDataSource(Value: TBaseLinkingBindSource); +begin + if FController.DataSource <> Value then + begin + FController.DataSource := Value; + if not (csLoading in ComponentState) then + ActiveChanged; + end; +end; + +function TStyledBindNavigator.GetOrientation: TNavigatorOrientation; +begin + if inherited Kind = dbnHorizontal then + Result := orHorizontal + else + Result := orVertical; +end; + +function TStyledBindNavigator.GetVisibleButtons: TNavigateButtons; +begin + Result := NavBtnsToNavigateButtons(inherited VisibleButtons); +end; + +procedure TStyledBindNavigator.SetOrientation(const Value: TNavigatorOrientation); +begin + if Value = orHorizontal then + inherited Kind := dbnHorizontal + else + inherited Kind := dbnVertical; +end; + +function TStyledBindNavigator.NavigateButtonsToNavBtns( + const AValue: TNavigateButtons): TNavButtonSet; +begin + Result := []; + if TNavigateButton.nbFirst in AValue then Result := Result + [TNavigateBtn.nbFirst]; + if TNavigateButton.nbPrior in AValue then Result := Result + [TNavigateBtn.nbPrior]; + if TNavigateButton.nbNext in AValue then Result := Result + [TNavigateBtn.nbNext]; + if TNavigateButton.nbLast in AValue then Result := Result + [TNavigateBtn.nbLast]; + if TNavigateButton.nbInsert in AValue then Result := Result + [TNavigateBtn.nbInsert]; + if TNavigateButton.nbDelete in AValue then Result := Result + [TNavigateBtn.nbDelete]; + if TNavigateButton.nbEdit in AValue then Result := Result + [TNavigateBtn.nbEdit]; + if TNavigateButton.nbPost in AValue then Result := Result + [TNavigateBtn.nbPost]; + if TNavigateButton.nbCancel in AValue then Result := Result + [TNavigateBtn.nbCancel]; + if TNavigateButton.nbRefresh in AValue then Result := Result + [TNavigateBtn.nbRefresh]; + if TNavigateButton.nbApplyUpdates in AValue then Result := Result + [TNavigateBtn.nbApplyUpdates]; + if TNavigateButton.nbCancelUpdates in AValue then Result := Result + [TNavigateBtn.nbCancelUpdates]; +end; + +function TStyledBindNavigator.NavBtnsToNavigateButtons( + const AValue: TNavButtonSet): TNavigateButtons; +begin + Result := []; + if TNavigateBtn.nbFirst in AValue then Result := Result + [TNavigateButton.nbFirst]; + if TNavigateBtn.nbPrior in AValue then Result := Result + [TNavigateButton.nbPrior]; + if TNavigateBtn.nbNext in AValue then Result := Result + [TNavigateButton.nbNext]; + if TNavigateBtn.nbLast in AValue then Result := Result + [TNavigateButton.nbLast]; + if TNavigateBtn.nbInsert in AValue then Result := Result + [TNavigateButton.nbInsert]; + if TNavigateBtn.nbDelete in AValue then Result := Result + [TNavigateButton.nbDelete]; + if TNavigateBtn.nbEdit in AValue then Result := Result + [TNavigateButton.nbEdit]; + if TNavigateBtn.nbPost in AValue then Result := Result + [TNavigateButton.nbPost]; + if TNavigateBtn.nbCancel in AValue then Result := Result + [TNavigateButton.nbCancel]; + if TNavigateBtn.nbRefresh in AValue then Result := Result + [TNavigateButton.nbRefresh]; + if TNavigateBtn.nbApplyUpdates in AValue then Result := Result + [TNavigateButton.nbApplyUpdates]; + if TNavigateBtn.nbCancelUpdates in AValue then Result := Result + [TNavigateButton.nbCancelUpdates]; +end; + +function TStyledBindNavigator.NavigateButtonToNavBtn( + const AValue: TNavigateButton): TNavigateBtn; +begin + case AValue of + TNavigateButton.nbFirst: Result := TNavigateBtn.nbFirst; + TNavigateButton.nbPrior: Result := TNavigateBtn.nbPrior; + TNavigateButton.nbNext: Result := TNavigateBtn.nbNext; + TNavigateButton.nbLast: Result := TNavigateBtn.nbLast; + TNavigateButton.nbInsert: Result := TNavigateBtn.nbInsert; + TNavigateButton.nbDelete: Result := TNavigateBtn.nbDelete; + TNavigateButton.nbEdit: Result := TNavigateBtn.nbEdit; + TNavigateButton.nbPost: Result := TNavigateBtn.nbPost; + TNavigateButton.nbCancel: Result := TNavigateBtn.nbCancel; + TNavigateButton.nbRefresh: Result := TNavigateBtn.nbRefresh; + TNavigateButton.nbApplyUpdates: Result := TNavigateBtn.nbApplyUpdates; + TNavigateButton.nbCancelUpdates: Result := TNavigateBtn.nbCancelUpdates; + else + Result := TNavigateBtn.nbFirst; + end; +end; + +function TStyledBindNavigator.NavBtnToNavigateButton( + const AValue: TNavigateBtn): TNavigateButton; +begin + case AValue of + TNavigateBtn.nbFirst : Result := TNavigateButton.nbFirst; + TNavigateBtn.nbPrior : Result := TNavigateButton.nbPrior; + TNavigateBtn.nbNext : Result := TNavigateButton.nbNext; + TNavigateBtn.nbLast : Result := TNavigateButton.nbLast; + TNavigateBtn.nbInsert : Result := TNavigateButton.nbInsert; + TNavigateBtn.nbDelete : Result := TNavigateButton.nbDelete; + TNavigateBtn.nbEdit : Result := TNavigateButton.nbEdit; + TNavigateBtn.nbPost : Result := TNavigateButton.nbPost; + TNavigateBtn.nbCancel : Result := TNavigateButton.nbCancel; + TNavigateBtn.nbRefresh : Result := TNavigateButton.nbRefresh; + TNavigateBtn.nbApplyUpdates : Result := TNavigateButton.nbApplyUpdates; + TNavigateBtn.nbCancelUpdates: Result := TNavigateButton.nbCancelUpdates; + else + Result := TNavigateButton.nbFirst; + end; +end; + +procedure TStyledBindNavigator.SetVisible(const Value: TNavigateButtons); +begin + inherited VisibleButtons := NavigateButtonsToNavBtns(Value); +end; + +function TStyledBindNavigator.GetDataSource: TBaseLinkingBindSource; +begin + Result := FController.DataSource as TBaseLinkingBindSource; +end; + +function TStyledBindNavigator.GetButton(Index: TNavigateButton): TStyledNavButton; +begin + Result := inherited GetButton(NavigateButtonToNavBtn(Index)); +end; + +procedure TStyledBindNavigator.BtnClick(Index: TNavigateButton); +begin + if (DataSource <> nil) then + begin + if not (csDesigning in ComponentState) and Assigned(BeforeAction) then + BeforeAction(Self, Index); + FController.ExecuteButton(Index, + function: Boolean + begin + Result := not ConfirmDelete or + (MessageDlg(SDeleteRecordQuestion, mtConfirmation, + mbOKCancel, 0) <> idCancel); + end + ); + end; + if not (csDesigning in ComponentState) and Assigned(OnClick) then + OnClick(Self, Index); +end; + +initialization + TCustomStyledDBNavigator._DefaultStyleDrawType := DEFAULT_STYLEDRAWTYPE; + TCustomStyledDBNavigator._DefaultFamily := DEFAULT_CLASSIC_FAMILY; + TCustomStyledDBNavigator._DefaultClass := DEFAULT_WINDOWS_CLASS; + TCustomStyledDBNavigator._DefaultAppearance := DEFAULT_APPEARANCE; + TCustomStyledDBNavigator._DefaultStyleRadius := DEFAULT_RADIUS; + TCustomStyledDBNavigator._DefaultCursor := DEFAULT_CURSOR; + end. diff --git a/Ext/StyledComponents/source/Vcl.StyledGraphicsUtils.pas b/Ext/StyledComponents/source/Vcl.StyledGraphicsUtils.pas new file mode 100644 index 0000000..3f93069 --- /dev/null +++ b/Ext/StyledComponents/source/Vcl.StyledGraphicsUtils.pas @@ -0,0 +1,140 @@ +{******************************************************************************} +{ } +{ Vcl.StyledGraphicUtils: utilities for Styled Components } +{ } +{ Copyright (c) 2022-2024 (Ethea S.r.l.) } +{ Author: Carlo Barazzetta } +{ Contributors: } +{ } +{ https://github.com/EtheaDev/StyledComponents } +{ } +{******************************************************************************} +{ } +{ Licensed under the Apache License, Version 2.0 (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.apache.org/licenses/LICENSE-2.0 } +{ } +{ Unless required by applicable law or agreed to in writing, software } +{ distributed under the License is distributed on an "AS IS" BASIS, } +{ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. } +{ See the License for the specific language governing permissions and } +{ limitations under the License. } +{ } +{******************************************************************************} +unit Vcl.StyledGraphicsUtils; + +interface + +{$INCLUDE StyledComponents.inc} + +uses + Classes + , ImgList + , Windows + , Graphics + , Vcl.Imaging.pngimage + , Vcl.StyledButton + , ComCtrls; + +procedure StyledButtonExportToPng(AButtonRender: TStyledButtonRender; + const AWidth, AHeight: Integer; + const AOutFolder: string; const AFileName: string = ''); + +implementation + +uses + System.SysUtils + , System.Types + , System.IOUtils + , Vcl.Themes + , Vcl.Clipbrd + ; + +// Source: http://www.entwickler-ecke.de/topic_Bitmap+pf32bit+mit+Alpha+afPremultipied+zu+PNG+speichern_103159,0.html +type + TRGB = packed record B, G, R: byte end; + TRGBA = packed record B, G, R, A: byte end; + TRGBAArray = array[0..0] of TRGBA; + +{$R-} +function PNG4TransparentBitMap(aBitmap: TBitmap): TPNGImage; +var + X, Y: integer; + BmpRGBA: ^TRGBAArray; + PngRGB: ^TRGB; +begin + //201011 Thomas Wassermann + Result := TPNGImage.CreateBlank(COLOR_RGBALPHA, 8, aBitmap.Width , aBitmap.Height); + + Result.CreateAlpha; + Result.Canvas.CopyMode:= cmSrcCopy; + Result.Canvas.Draw(0, 0, aBitmap); + + for Y := 0 to Pred(aBitmap.Height) do + begin + BmpRGBA := aBitmap.ScanLine[Y]; + PngRGB:= Result.Scanline[Y]; + aBitmap.AlphaFormat := TAlphaFormat.afDefined; // Enable alpha channel + for X := 0 to Pred(aBitmap.width) do + begin + Result.AlphaScanline[Y][X] := BmpRGBA[X].A; + if aBitmap.AlphaFormat in [afDefined, afPremultiplied] then + begin + if BmpRGBA[X].A <> 0 then + begin + PngRGB^.B := Round(BmpRGBA[X].B / BmpRGBA[X].A * 255); + PngRGB^.R := Round(BmpRGBA[X].R / BmpRGBA[X].A * 255); + PngRGB^.G := Round(BmpRGBA[X].G / BmpRGBA[X].A * 255); + end + else + begin + PngRGB^.B := Round(BmpRGBA[X].B * 255); + PngRGB^.R := Round(BmpRGBA[X].R * 255); + PngRGB^.G := Round(BmpRGBA[X].G * 255); + end; + end; + Inc(PngRGB); + end; + end; +end; + +procedure StyledButtonExportToPng(AButtonRender: TStyledButtonRender; + const AWidth, AHeight: Integer; + const AOutFolder: string; + const AFileName: string = ''); +var + LImagePng: TPngImage; + LBitmap: TBitmap; + LFileName: string; + BmpRGBA: ^TRGBAArray; + PngRGB: ^TRGB; +begin + //Notice: this procedure works fine olny with + //DrawTextWithGDIPlus and DrawRectWithGDIPlus compiler directives + LBitmap := nil; + LImagePng := nil; + try + LBitmap := TBitmap.Create; + LBitmap.PixelFormat := TPixelFormat.pf32bit; // 32bit bitmap + LBitmap.AlphaFormat := TAlphaFormat.afDefined; // Enable alpha channel + + // Fill background with transparent + LBitmap.SetSize(AWidth, AHeight); + LBitmap.Canvas.Brush.Style := bsSolid; + LBitmap.Canvas.Brush.Color := AButtonRender.Font.Color; + LBitmap.Canvas.FillRect(Rect(0, 0, AWidth, AHeight)); + + AButtonRender.DrawButton(LBitmap.Canvas, False); + + LImagePng := PNG4TransparentBitMap(LBitmap); + LFileName := ChangeFileExt(TPath.Combine(AOutFolder,AFileName),'.png'); + LImagePng.SaveToFile(LFileName); + finally + LImagePng.free; + LBitmap.Free; + end; +end; + +end. diff --git a/Ext/StyledComponents/source/Vcl.StyledMessagesHooks.pas b/Ext/StyledComponents/source/Vcl.StyledMessagesHooks.pas new file mode 100644 index 0000000..6f4d07b --- /dev/null +++ b/Ext/StyledComponents/source/Vcl.StyledMessagesHooks.pas @@ -0,0 +1,81 @@ +{******************************************************************************} +{ } +{ StyledMessagesHooks: an interposer Unit to use Styled Dialog Boxes } +{ using Standard Delphi calls MessageDialog or ShowMessage } +{ } +{ Copyright (c) 2022-2024 (Ethea S.r.l.) } +{ Author: Carlo Barazzetta } +{ Contributors: } +{ } +{ https://github.com/EtheaDev/StyledComponents } +{ } +{******************************************************************************} +{ } +{ Licensed under the Apache License, Version 2.0 (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.apache.org/licenses/LICENSE-2.0 } +{ } +{ Unless required by applicable law or agreed to in writing, software } +{ distributed under the License is distributed on an "AS IS" BASIS, } +{ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. } +{ See the License for the specific language governing permissions and } +{ limitations under the License. } +{ } +{******************************************************************************} +unit Vcl.StyledMessagesHooks; + +interface + +{$INCLUDE StyledComponents.inc} + +uses + Vcl.Dialogs + ; + +function MessageDlg(const Msg: string; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint): Integer; + +function MessageDlgPos(const Msg: string; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint; + X: Integer = -1; Y: Integer = -1): Integer; + +function TaskDlgPos(const Title, Msg: string; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint; + X: Integer = -1; Y: Integer = -1): Integer; + +procedure ShowMessage(const Msg: string); + +implementation + +uses + Vcl.StyledTaskDialog + ; + +function MessageDlg(const Msg: string; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint): Integer; +begin + Result := StyledMessageDlg(Msg, DlgType, Buttons, HelpCtx); +end; + +function MessageDlgPos(const Msg: string; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint; + X: Integer = -1; Y: Integer = -1): Integer; +begin + Result := StyledMessageDlgPos(Msg, DlgType, Buttons, HelpCtx, X, Y); +end; + +function TaskDlgPos(const Title, Msg: string; DlgType: TMsgDlgType; + Buttons: TMsgDlgButtons; HelpCtx: Longint; + X: Integer = -1; Y: Integer = -1): Integer; +begin + Result := StyledTaskDlgPos(Title, Msg, DlgType, Buttons, HelpCtx, X, Y); +end; + +procedure ShowMessage(const Msg: string); +begin + StyledShowMessage(Msg); +end; + +end. diff --git a/Ext/StyledComponents/source/Vcl.StyledTaskDialog.pas b/Ext/StyledComponents/source/Vcl.StyledTaskDialog.pas index 22f115a..744cd5e 100644 --- a/Ext/StyledComponents/source/Vcl.StyledTaskDialog.pas +++ b/Ext/StyledComponents/source/Vcl.StyledTaskDialog.pas @@ -1,12 +1,12 @@ {******************************************************************************} { } -{ StyledTaskDialog: a Task Dialog Component with StyleButtons } +{ StyledTaskDialog: a Task Dialog Component with StyleButtons } { } -{ Copyright (c) 2022-2024 (Ethea S.r.l.) } -{ Author: Carlo Barazzetta } -{ Contributors: } +{ Copyright (c) 2022-2024 (Ethea S.r.l.) } +{ Author: Carlo Barazzetta } +{ Contributors: } { } -{ https://github.com/EtheaDev/StyledComponents } +{ https://github.com/EtheaDev/StyledComponents } { } {******************************************************************************} { } @@ -39,21 +39,17 @@ interface , Vcl.ButtonStylesAttributes ; +const + DEFAULT_ALPHABLEND = 255; + type TStyledDialogIcons = array[TMsgDlgType] of TIcon; - // Abstraction of a Dialog Launcher - ITaskDialogLauncher = interface - ['{B2F16F98-C163-4706-A803-E624126D8DF6}'] - function DoExecute(ParentWnd: HWND; - const ADialogType: TMsgDlgType; - const ATaskDialog: TCustomTaskDialog; - const ADialogBtnFamily: TStyledButtonFamily): boolean; - end; - {$WARN SYMBOL_PLATFORM OFF} { TaskDialog based message dialog; requires Windows Vista or later } type + { TStyledTaskDialog } + [ComponentPlatforms(pidWin32 or pidWin64)] TStyledTaskDialog = class(TTaskDialog) private FHelpFile: string; @@ -71,6 +67,15 @@ TStyledTaskDialog = class(TTaskDialog) property Position: TPoint read FPosition write FPosition; end; + // Abstraction of a Dialog Launcher + ITaskDialogLauncher = interface + ['{B2F16F98-C163-4706-A803-E624126D8DF6}'] + function DoExecute(ParentWnd: HWND; + const ADialogType: TMsgDlgType; + const ATaskDialog: TStyledTaskDialog; + const ADialogBtnFamily: TStyledButtonFamily): boolean; + end; + function StyledMessageDlg(const Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; HelpCtx: Longint): Integer; overload; function StyledMessageDlg(const Title, Msg: string; DlgType: TMsgDlgType; @@ -104,17 +109,19 @@ function StyledTaskDlgPos(const Title, Msg: string; DlgType: TMsgDlgType; procedure StyledShowMessage(const Msg: string); overload; -procedure SetUseAlwaysTaskDialog(Value: boolean); +procedure SetUseAlwaysTaskDialog(AValue: boolean); procedure RegisterCustomExecute(const AShowStyledTaskDialog: ITaskDialogLauncher; const AButtonFamily: TStyledButtonFamily = ''); procedure UnregisterCustomExecute; procedure InitializeStyledTaskDialogs(AUseTaskDialog: Boolean; AFont: TFont; - const ADialogButtonsFamily: TStyledButtonFamily = ''); + const ADialogButtonsFamily: TStyledButtonFamily = ''; + const AAlphaBlendValue: Byte = DEFAULT_ALPHABLEND); function GetTaskDlgType(const AIcon: TTaskDialogIcon): TMsgDlgType; function GetDialogFont: TFont; function GetDialogBtnFamily: TStyledButtonFamily; function GetDialogTypeTitle(const DlgType: TMsgDlgType): string; +function GetDialogAlphaBlendValue: Byte; implementation @@ -139,11 +146,12 @@ implementation ; var - TaskDialogExecute: ITaskDialogLauncher; - DialogButtonsFamily: TStyledButtonFamily; - CustomIcons: TStyledDialogIcons; - DialogFont: TFont; - UseAlwaysTaskDialog: boolean; + _TaskDialogExecute: ITaskDialogLauncher; + _DialogButtonsFamily: TStyledButtonFamily; + _CustomIcons: TStyledDialogIcons; + _DialogFont: TFont; + _UseAlwaysTaskDialog: boolean; + _AlphaBlendValue: Byte; ButtonNames: array[TMsgDlgBtn] of string = ( 'Yes', 'No', 'OK', 'Cancel', 'Abort', 'Retry', 'Ignore', 'All', 'NoToAll', @@ -152,14 +160,19 @@ implementation mrYes, mrNo, mrOk, mrCancel, mrAbort, mrRetry, mrIgnore, mrAll, mrNoToAll, mrYesToAll, 0, mrClose); +function GetDialogAlphaBlendValue: Byte; +begin + Result := _AlphaBlendValue; +end; + function GetDialogFont: TFont; begin - Result := DialogFont; + Result := _DialogFont; end; function GetDialogBtnFamily: TStyledButtonFamily; begin - Result := DialogButtonsFamily; + Result := _DialogButtonsFamily; end; function IsTaskMessageSupported : Boolean; @@ -260,7 +273,7 @@ function StyledMessageDlgPos(const Msg: string; DlgType: TMsgDlgType; end; begin - if IsTaskMessageSupported and UseAlwaysTaskDialog then + if IsTaskMessageSupported and _UseAlwaysTaskDialog then begin //Use a TaskDialog to Show the message instead of a MessageDialog Result := StyledTaskDlgPos('',Msg,DlgType,Buttons,DefaultButton,HelpCtx,X,Y); @@ -272,8 +285,8 @@ function StyledMessageDlgPos(const Msg: string; DlgType: TMsgDlgType; MyMsg := ClearHRefs(Msg); Dlg := CreateMessageDialog(MyMsg, DlgType, Buttons, DefaultButton); try - if Assigned(DialogFont) then - Dlg.Font.Assign(DialogFont); + if Assigned(_DialogFont) then + Dlg.Font.Assign(_DialogFont); Dlg.HelpContext := HelpCtx; if X >= 0 then Dlg.Left := X; @@ -307,49 +320,51 @@ function StyledMessageDlgPos(const Msg: string; DlgType: TMsgDlgType; tdbHelp = -1; procedure InitializeStyledTaskDialogs(AUseTaskDialog: Boolean; AFont: TFont; - const ADialogButtonsFamily: TStyledButtonFamily = ''); + const ADialogButtonsFamily: TStyledButtonFamily = ''; + const AAlphaBlendValue: Byte = DEFAULT_ALPHABLEND); begin if Assigned(AFont) then begin - if not Assigned(DialogFont) then - DialogFont := TFont.Create; - DialogFont.Assign(AFont); + if not Assigned(_DialogFont) then + _DialogFont := TFont.Create; + _DialogFont.Assign(AFont); end else - FreeAndNil(DialogFont); - UseAlwaysTaskDialog := AUseTaskDialog; - DialogButtonsFamily := ADialogButtonsFamily; + FreeAndNil(_DialogFont); + _UseAlwaysTaskDialog := AUseTaskDialog; + _DialogButtonsFamily := ADialogButtonsFamily; + _AlphaBlendValue := AAlphaBlendValue; end; procedure UnregisterCustomIcons; begin - CustomIcons[mtWarning] := nil; - CustomIcons[mtError] := nil; - CustomIcons[mtInformation] := nil; - CustomIcons[mtConfirmation] := nil; - CustomIcons[mtCustom] := nil; + _CustomIcons[mtWarning] := nil; + _CustomIcons[mtError] := nil; + _CustomIcons[mtInformation] := nil; + _CustomIcons[mtConfirmation] := nil; + _CustomIcons[mtCustom] := nil; end; procedure RegisterCustomIcons(const ACustomIcons: TStyledDialogIcons); begin UnregisterCustomIcons; - CustomIcons := ACustomIcons; + _CustomIcons := ACustomIcons; end; -procedure SetUseAlwaysTaskDialog(Value: boolean); +procedure SetUseAlwaysTaskDialog(AValue: boolean); begin - UseAlwaysTaskDialog := Value; + _UseAlwaysTaskDialog := AValue; end; procedure RegisterCustomExecute(const AShowStyledTaskDialog: ITaskDialogLauncher; const AButtonFamily: TStyledButtonFamily = ''); begin - TaskDialogExecute := AShowStyledTaskDialog; + _TaskDialogExecute := AShowStyledTaskDialog; end; procedure UnRegisterCustomExecute; begin - TaskDialogExecute := nil; + _TaskDialogExecute := nil; end; function GetTaskDlgType( @@ -507,9 +522,9 @@ function TStyledTaskDialog.DoExecute(ParentWnd: HWND): Boolean; LTaskDlgType := GetTaskDlgType(MainIcon); //Use a custom interface if registered - if Assigned(TaskDialogExecute) then - Result := TaskDialogExecute.DoExecute(ParentWnd, - LTaskDlgType, Self, DialogButtonsFamily) + if Assigned(_TaskDialogExecute) then + Result := _TaskDialogExecute.DoExecute(ParentWnd, + LTaskDlgType, Self, _DialogButtonsFamily) else Result := inherited DoExecute(ParentWnd); end; @@ -612,11 +627,12 @@ function GetDialogTypeTitle(const DlgType: TMsgDlgType): string; end; initialization - UseAlwaysTaskDialog := True; - DialogFont := nil; + _UseAlwaysTaskDialog := True; + _AlphaBlendValue := DEFAULT_ALPHABLEND; + _DialogFont := nil; finalization - if Assigned(DialogFont) then - DialogFont.Free; + if Assigned(_DialogFont) then + _DialogFont.Free; end. diff --git a/Ext/StyledComponents/source/Vcl.StyledTaskDialogFormUnit.dfm b/Ext/StyledComponents/source/Vcl.StyledTaskDialogFormUnit.dfm index def1c56..f180788 100644 --- a/Ext/StyledComponents/source/Vcl.StyledTaskDialogFormUnit.dfm +++ b/Ext/StyledComponents/source/Vcl.StyledTaskDialogFormUnit.dfm @@ -166,10 +166,10 @@ object StyledTaskDialogForm: TStyledTaskDialogForm Margins.Top = 4 Margins.Bottom = 4 Align = alRight - OnClick = ButtonClick Caption = 'Yes' ModalResult = 6 TabOrder = 0 + OnClick = ButtonClick end object NoButton: TStyledButton AlignWithMargins = True @@ -180,10 +180,10 @@ object StyledTaskDialogForm: TStyledTaskDialogForm Margins.Top = 4 Margins.Bottom = 4 Align = alRight - OnClick = ButtonClick Caption = 'No' ModalResult = 7 TabOrder = 1 + OnClick = ButtonClick end object OKButton: TStyledButton AlignWithMargins = True @@ -194,10 +194,10 @@ object StyledTaskDialogForm: TStyledTaskDialogForm Margins.Top = 4 Margins.Bottom = 4 Align = alRight - OnClick = ButtonClick Caption = 'OK' ModalResult = 1 TabOrder = 2 + OnClick = ButtonClick end object CancelButton: TStyledButton AlignWithMargins = True @@ -208,10 +208,10 @@ object StyledTaskDialogForm: TStyledTaskDialogForm Margins.Top = 4 Margins.Bottom = 4 Align = alRight - OnClick = ButtonClick Caption = 'Cancel' ModalResult = 2 TabOrder = 3 + OnClick = ButtonClick end object AbortButton: TStyledButton AlignWithMargins = True @@ -222,10 +222,10 @@ object StyledTaskDialogForm: TStyledTaskDialogForm Margins.Top = 4 Margins.Bottom = 4 Align = alRight - OnClick = ButtonClick Caption = 'Abort' ModalResult = 3 TabOrder = 4 + OnClick = ButtonClick end object RetryButton: TStyledButton AlignWithMargins = True @@ -236,10 +236,10 @@ object StyledTaskDialogForm: TStyledTaskDialogForm Margins.Top = 4 Margins.Bottom = 4 Align = alRight - OnClick = ButtonClick Caption = 'Retry' ModalResult = 4 TabOrder = 5 + OnClick = ButtonClick end object IgnoreButton: TStyledButton AlignWithMargins = True @@ -250,10 +250,10 @@ object StyledTaskDialogForm: TStyledTaskDialogForm Margins.Top = 4 Margins.Bottom = 4 Align = alRight - OnClick = ButtonClick Caption = 'Ignore' ModalResult = 5 TabOrder = 6 + OnClick = ButtonClick end object AllButton: TStyledButton AlignWithMargins = True @@ -264,10 +264,10 @@ object StyledTaskDialogForm: TStyledTaskDialogForm Margins.Top = 4 Margins.Bottom = 4 Align = alRight - OnClick = ButtonClick Caption = 'All' ModalResult = 12 TabOrder = 7 + OnClick = ButtonClick end object NoToAllButton: TStyledButton AlignWithMargins = True @@ -278,10 +278,10 @@ object StyledTaskDialogForm: TStyledTaskDialogForm Margins.Top = 4 Margins.Bottom = 4 Align = alRight - OnClick = ButtonClick Caption = 'No to All' ModalResult = 13 TabOrder = 8 + OnClick = ButtonClick end object YesToAllButton: TStyledButton AlignWithMargins = True @@ -292,10 +292,10 @@ object StyledTaskDialogForm: TStyledTaskDialogForm Margins.Top = 4 Margins.Bottom = 4 Align = alRight - OnClick = ButtonClick Caption = 'Yes to All' ModalResult = 14 TabOrder = 9 + OnClick = ButtonClick end object HelpButton: TStyledButton AlignWithMargins = True @@ -306,10 +306,10 @@ object StyledTaskDialogForm: TStyledTaskDialogForm Margins.Top = 4 Margins.Bottom = 4 Align = alRight - OnClick = HelpButtonClick Caption = 'Help' ModalResult = 9 TabOrder = 10 + OnClick = HelpButtonClick end object CloseButton: TStyledButton AlignWithMargins = True @@ -320,10 +320,10 @@ object StyledTaskDialogForm: TStyledTaskDialogForm Margins.Top = 4 Margins.Bottom = 4 Align = alRight - OnClick = ButtonClick Caption = 'Close' ModalResult = 8 TabOrder = 11 + OnClick = ButtonClick end end end diff --git a/Ext/StyledComponents/source/Vcl.StyledTaskDialogFormUnit.pas b/Ext/StyledComponents/source/Vcl.StyledTaskDialogFormUnit.pas index 77d9159..a4daac7 100644 --- a/Ext/StyledComponents/source/Vcl.StyledTaskDialogFormUnit.pas +++ b/Ext/StyledComponents/source/Vcl.StyledTaskDialogFormUnit.pas @@ -1,12 +1,12 @@ {******************************************************************************} { } -{ StyledTaskDialogForm: a Task Dialog Form with StyleButtons } +{ StyledTaskDialogForm: a Task Dialog Form with StyleButtons } { } -{ Copyright (c) 2022-2024 (Ethea S.r.l.) } -{ Author: Carlo Barazzetta } -{ Contributors: } +{ Copyright (c) 2022-2024 (Ethea S.r.l.) } +{ Author: Carlo Barazzetta } +{ Contributors: } { } -{ https://github.com/EtheaDev/StyledComponents } +{ https://github.com/EtheaDev/StyledComponents } { } {******************************************************************************} { } @@ -55,7 +55,7 @@ interface TTaskDialogLauncherHandler = class(TInterfacedObject, ITaskDialogLauncher) function DoExecute(ParentWnd: HWND; const ADialogType: TMsgDlgType; - const ATaskDialog: TCustomTaskDialog; + const ATaskDialog: TStyledTaskDialog; const ADialogBtnFamily: TStyledButtonFamily): Boolean; end; @@ -165,6 +165,7 @@ TStyledTaskDialogForm = class(TForm) property OnVerificationClicked: TNotifyEvent read FOnVerificationClicked write FOnVerificationClicked; *) protected + class function CanUseAnimations: Boolean; virtual; abstract; procedure UpdateCustomIcons; procedure Loaded; override; procedure LoadImage(const AImageIndex: TImageIndex; @@ -207,25 +208,29 @@ implementation ; var - DialogLauncher: ITaskDialogLauncher; - TaskDialogFormClass: TStyledTaskDialogFormClass; - DlgButtonClasses: TButtonClasses; + _DialogLauncher: ITaskDialogLauncher; + _AnimatedTaskDialogFormClass, _TaskDialogFormClass: TStyledTaskDialogFormClass; + _DlgButtonClasses: TButtonClasses; procedure RegisterTaskDialogFormClass(AFormClass: TStyledTaskDialogFormClass); begin - TaskDialogFormClass := AFormClass; + if AFormClass.CanUseAnimations then + _AnimatedTaskDialogFormClass := AFormClass + else + _TaskDialogFormClass := AFormClass; UseStyledDialogForm(True); end; procedure UnregisterTaskDialogFormClass; begin - TaskDialogFormClass := nil; + _AnimatedTaskDialogFormClass := nil; + _TaskDialogFormClass := nil; end; procedure UseStyledDialogForm(const AActivate: Boolean); begin if AActivate then - RegisterCustomExecute(DialogLauncher) + RegisterCustomExecute(_DialogLauncher) else UnregisterCustomExecute; end; @@ -714,19 +719,24 @@ procedure TStyledTaskDialogForm.InitDlgButtonsWithFamily(const AFamily: TStyledB function TTaskDialogLauncherHandler.DoExecute(ParentWnd: HWND; const ADialogType: TMsgDlgType; - const ATaskDialog: TCustomTaskDialog; + const ATaskDialog: TStyledTaskDialog; const ADialogBtnFamily: TStyledButtonFamily): Boolean; var LForm: TStyledTaskDialogForm; LFont: TFont; LDlgBtnFamily: TStyledButtonFamily; begin - LForm := TaskDialogFormClass.Create(nil); + if Assigned(_AnimatedTaskDialogFormClass) then + LForm := _AnimatedTaskDialogFormClass.Create(nil) + else + LForm := _TaskDialogFormClass.Create(nil); try LForm.FTaskDialog := ATaskDialog; LForm.FDialogType := ADialogType; LForm.FDialogBtnFamily := ADialogBtnFamily; LFont := GetDialogFont; + LForm.AlphaBlendValue := GetDialogAlphaBlendValue; + LForm.AlphaBlend := LForm.AlphaBlendValue <> DEFAULT_ALPHABLEND; LDlgBtnFamily := GetDialogBtnFamily; if Assigned(LFont) then LForm.SetDialogFont(LFont) @@ -741,12 +751,12 @@ function TTaskDialogLauncherHandler.DoExecute(ParentWnd: HWND; end; initialization - TaskDialogFormClass := TStyledTaskDialogForm; + _TaskDialogFormClass := TStyledTaskDialogForm; //Create handler for execute custom TaskDialog Form - DialogLauncher := TTaskDialogLauncherHandler.Create; + _DialogLauncher := TTaskDialogLauncherHandler.Create; //Register the handler - RegisterCustomExecute(DialogLauncher); + RegisterCustomExecute(_DialogLauncher); //Init default Dialog buttons Styles - SetLength(DlgButtonClasses, Ord(TMsgDlgBtn.mbClose)+1); + SetLength(_DlgButtonClasses, Ord(TMsgDlgBtn.mbClose)+1); end. diff --git a/Ext/StyledComponents/source/Vcl.StyledTaskDialogStdUnit.dfm b/Ext/StyledComponents/source/Vcl.StyledTaskDialogStdUnit.dfm index ce0657e..a5de868 100644 --- a/Ext/StyledComponents/source/Vcl.StyledTaskDialogStdUnit.dfm +++ b/Ext/StyledComponents/source/Vcl.StyledTaskDialogStdUnit.dfm @@ -1,5 +1,6 @@ inherited StyledTaskDialogStd: TStyledTaskDialogStd Caption = 'StyledTaskDialogStd' + PixelsPerInch = 96 TextHeight = 15 inherited CenterPanel: TPanel inherited ImagePanel: TPanel @@ -23,7 +24,7 @@ inherited StyledTaskDialogStd: TStyledTaskDialogStd Left = 56 Top = 56 Bitmap = { - 494C010106000800040080008000FFFFFFFF2110FFFFFFFFFFFFFFFF424D3600 + 494C010106000800080080008000FFFFFFFF2110FFFFFFFFFFFFFFFF424D3600 0000000000003600000028000000000200000001000001002000000000000000 0800000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 diff --git a/Ext/StyledComponents/source/Vcl.StyledTaskDialogStdUnit.pas b/Ext/StyledComponents/source/Vcl.StyledTaskDialogStdUnit.pas index 7c2316e..94a9525 100644 --- a/Ext/StyledComponents/source/Vcl.StyledTaskDialogStdUnit.pas +++ b/Ext/StyledComponents/source/Vcl.StyledTaskDialogStdUnit.pas @@ -1,13 +1,13 @@ {******************************************************************************} { } -{ StyledTaskDialogStd: an example of Task Dialog Form } -{ using an ImageList and a Image component } +{ StyledTaskDialogStd: an example of Task Dialog Form } +{ using an ImageList and a Image component } { } -{ Copyright (c) 2022-2024 (Ethea S.r.l.) } -{ Author: Carlo Barazzetta } -{ Contributors: } +{ Copyright (c) 2022-2024 (Ethea S.r.l.) } +{ Author: Carlo Barazzetta } +{ Contributors: } { } -{ https://github.com/EtheaDev/StyledComponents } +{ https://github.com/EtheaDev/StyledComponents } { } {******************************************************************************} { } @@ -51,7 +51,8 @@ interface , Vcl.StandardButtonStyles , Vcl.BootstrapButtonStyles , Vcl.AngularButtonStyles - , Vcl.ColorButtonStyles; + , Vcl.ColorButtonStyles + ; type TStyledTaskDialogStd = class(TStyledTaskDialogForm) @@ -59,6 +60,7 @@ TStyledTaskDialogStd = class(TStyledTaskDialogForm) Image: TImage; private protected + class function CanUseAnimations: Boolean; override; procedure LoadImage(const AImageIndex: TImageIndex; AImageName: string); override; public end; @@ -70,6 +72,11 @@ implementation uses Vcl.Themes; +class function TStyledTaskDialogStd.CanUseAnimations: Boolean; +begin + Result := False; +end; + procedure TStyledTaskDialogStd.LoadImage( const AImageIndex: TImageIndex; AImageName: string); var diff --git a/Ext/StyledComponents/source/Vcl.StyledToolbar.pas b/Ext/StyledComponents/source/Vcl.StyledToolbar.pas index b6d706d..aeeac16 100644 --- a/Ext/StyledComponents/source/Vcl.StyledToolbar.pas +++ b/Ext/StyledComponents/source/Vcl.StyledToolbar.pas @@ -1,13 +1,13 @@ {******************************************************************************} { } -{ StyledToolbar: a Toolbar with TStyledToolButtons inside } -{ Based on TFlowPanel and TStyledGraphicButton } +{ StyledToolbar: a Toolbar with TStyledToolButtons inside } +{ Based on TFlowPanel and TStyledGraphicButton } { } -{ Copyright (c) 2022-2024 (Ethea S.r.l.) } -{ Author: Carlo Barazzetta } -{ Contributors: } +{ Copyright (c) 2022-2024 (Ethea S.r.l.) } +{ Author: Carlo Barazzetta } +{ Contributors: } { } -{ https://github.com/EtheaDev/StyledComponents } +{ https://github.com/EtheaDev/StyledComponents } { } {******************************************************************************} { } @@ -44,10 +44,13 @@ interface , Vcl.Controls , Vcl.ActnList , Vcl.Menus + , Vcl.Graphics + , Vcl.GraphUtil , Winapi.Messages , Winapi.Windows , Vcl.StyledButton , Vcl.ButtonStylesAttributes + , Vcl.StandardButtonStyles ; resourcestring @@ -63,27 +66,26 @@ TStyledToolButtonClass = class of TStyledToolButton; TButtonProc = reference to procedure (Button: TStyledToolButton); TControlProc = reference to procedure (Control: TControl); - TStyledToolButton = class(TStyledGraphicButton) + { TStyledToolButton } + TStyledToolButton = class(TCustomStyledGraphicButton) private - FAllowAllUp: Boolean; FAutoSize: Boolean; - FDown: Boolean; FGrouped: Boolean; FMarked: Boolean; FStyle: TToolButtonStyle; FEnabled: Boolean; FImageAlignment: TImageAlignment; FMenuItem: TMenuItem; + function IsStoredCursor: Boolean; function IsStoredFlat: Boolean; function IsCustomRadius: Boolean; + function IsCustomRoundedCorners: Boolean; function IsCustomDrawType: Boolean; function IsStoredStyleFamily: Boolean; function IsStoredStyleAppearance: Boolean; function GetIndex: Integer; - function IsCheckedStored: Boolean; function IsImagesStored: Boolean; function IsWidthStored: Boolean; - procedure SetDown(AValue: Boolean); procedure SetGrouped(AValue: Boolean); procedure SetMarked(AValue: Boolean); procedure SetStyle(AValue: TToolButtonStyle); @@ -101,9 +103,12 @@ TStyledToolButton = class(TStyledGraphicButton) procedure SetMenuItem(const AValue: TMenuItem); function GetWrap: Boolean; procedure SetWrap(const AValue: Boolean); + procedure UpdateGroupIndex; + function GetStyleDrawType: TStyledButtonDrawType; + procedure SetStyleDrawType(const AValue: TStyledButtonDrawType); protected FToolBar: TStyledToolBar; - function GetCaption: TCaption; override; + function GetCaptionToDraw: TCaption; override; procedure SetCaption(const AValue: TCaption); override; function IsStoredStyleClass: Boolean; override; function IsEnabledStored: Boolean; override; @@ -125,36 +130,105 @@ TStyledToolButton = class(TStyledGraphicButton) procedure Click; override; procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override; published - property AllowAllUp: Boolean read FAllowAllUp write FAllowAllUp default False; - property AutoSize: Boolean read FAutoSize write SetAutoSize default False; - property Caption: TCaption read GetCaption write SetCaption stored IsCaptionStored; - property Down: Boolean read FDown write SetDown stored IsCheckedStored default False; + //property ActiveStyleName; + property Action; + property Align; + property AllowAllUp default False; + property Anchors; + property AsVCLComponent stored False; + property Constraints; + property Cursor stored IsStoredCursor; + property Down default False; + property DragCursor; + property DragKind; + property DragMode; property Enabled: Boolean read GetEnable write SetEnable stored IsEnabledStored; + property Font; + property OnContextPopup; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnMouseActivate; + property OnMouseDown; + property OnMouseEnter; + property OnMouseLeave; + property OnMouseMove; + property OnMouseUp; + property OnGesture; + property OnStartDock; + property OnStartDrag; + property OnClick; + property PopUpMenu; + property ParentFont; + property ParentShowHint; + property ShowHint; + {$IFDEF D10_4+} + property StyleName; + {$ENDIF} + property StyleElements; + property Transparent; + property Visible; + property Caption: TCaption read GetCaption write SetCaption stored IsCaptionStored; + property CaptionAlignment; + property CommandLinkHint; + property ImageAlignment: TImageAlignment read FImageAlignment write SetImageAlignment Stored IsImageAlignmentStored; + property DisabledImageIndex; + property DisabledImages; + property DropDownMenu; property Flat stored IsStoredFlat; + property Glyph; + property NumGlyphs; + property HotImageIndex; + property Images stored IsImagesStored; + property ImageIndex; + property Kind; + property PressedImageIndex; + property SelectedImageIndex; + {$IFDEF D10_4+} + property DisabledImageName; + property HotImageName; + property ImageName; + property PressedImageName; + property SelectedImageName; + {$ENDIF} + property ImageMargins; + property ModalResult; + property Tag; + //StyledComponents Attributes + property StyleRadius stored IsCustomRadius; + property StyleRoundedCorners stored IsCustomRoundedCorners; + property StyleDrawType: TStyledButtonDrawType read GetStyleDrawType write SetStyleDrawType stored IsCustomDrawType; + property StyleFamily stored IsStoredStyleFamily; + property StyleClass stored IsStoredStyleClass; + property StyleAppearance stored IsStoredStyleAppearance; + property WordWrap stored False; + property ButtonStyleNormal; + property ButtonStylePressed; + property ButtonStyleSelected; + property ButtonStyleHot; + property ButtonStyleDisabled; + property OnDropDownClick; + + property AutoSize: Boolean read FAutoSize write SetAutoSize default False; property Grouped: Boolean read FGrouped write SetGrouped default False; property Height: Integer read GetHeight write SetHeight stored False; - property Images stored IsImagesStored; - property ImageAlignment: TImageAlignment read FImageAlignment write SetImageAlignment Stored IsImageAlignmentStored; property Index: Integer read GetIndex; property Marked: Boolean read FMarked write SetMarked default False; property MenuItem: TMenuItem read FMenuItem write SetMenuItem; property Style: TToolButtonStyle read FStyle write SetStyle default tbsButton; property Width stored IsWidthStored; - property WordWrap stored False; property Wrap: Boolean read GetWrap write SetWrap default False; - //StyledComponents Attributes - property StyleRadius stored IsCustomRadius; - property StyleDrawType stored IsCustomDrawType; - property StyleFamily stored IsStoredStyleFamily; - property StyleClass stored IsStoredStyleClass; - property StyleAppearance stored IsStoredStyleAppearance; end; TSTBNewButtonEvent = procedure(Sender: TStyledToolbar; AIndex: Integer; var AButton: TStyledToolButton) of object; - TSTBButtonEvent = procedure(Sender: TStyledToolbar; AButton: TStyledGraphicButton) of object; + TSTBButtonEvent = procedure(Sender: TStyledToolbar; + AButton: TCustomStyledGraphicButton) of object; + { TStyledToolbar } + [ComponentPlatforms(pidWin32 or pidWin64)] TStyledToolbar = class(TCustomFlowPanel) private //Private variable of Properties @@ -177,6 +251,14 @@ TStyledToolbar = class(TCustomFlowPanel) FCaptureChangeCancels: Boolean; FInMenuLoop: Boolean; FAutoSize: Boolean; + FButtonsCursor: TCursor; + + //Properties ignores (only for backward compatibility) + FGradientDrawingOptions: TTBGradientDrawingOptions; + FGradientDirection: TGradientDirection; + FDrawingStyle: TTBDrawingStyle; + FGradientEndColor: TColor; + FGradientStartColor: TColor; //Styled Attributes FStyleRadius: Integer; @@ -186,9 +268,18 @@ TStyledToolbar = class(TCustomFlowPanel) FStyleAppearance: TStyledButtonAppearance; FCustomDrawType: Boolean; FStyleApplied: Boolean; - FDisableAlign: Boolean; + FDisableButtonAlign: Integer; FOnToolButtonClick: TNotifyEvent; + class var + _DefaultStyleDrawType: TStyledButtonDrawType; + _UseCustomDrawType: Boolean; + _DefaultFamily: TStyledButtonFamily; + _DefaultClass: TStyledButtonClass; + _DefaultAppearance: TStyledButtonAppearance; + _DefaultStyleRadius: Integer; + _DefaultButtonsCursor: TCursor; + function ControlsWidth: Integer; function ControlsHeight: Integer; procedure InsertButton(Control: TControl); @@ -242,9 +333,20 @@ TStyledToolbar = class(TCustomFlowPanel) procedure UpdateBevelKind; function GetActiveStyleName: string; function AsVCLStyle: Boolean; + function GetAsVCLComponent: Boolean; + procedure SetAsVCLComponent(const AValue: Boolean); function GetAutoWrap: Boolean; function GetAutoSize: Boolean; + procedure SetTransparent(const AValue: Boolean); + function GetDisableButtonAlign: Boolean; + procedure SetDisableButtonAlign(const AValue: Boolean); + function IsGradientEndColorStored: Boolean; + procedure SetButtonsCursor(const AValue: TCursor); + property DisableButtonAlign: Boolean read GetDisableButtonAlign write SetDisableButtonAlign; protected + {$IFDEF D10_1+} + procedure ChangeScale(M, D: Integer; isDpiChange: Boolean); override; + {$ENDIF} procedure SetAutoSize(AValue: Boolean); override; procedure Notification(AComponent: TComponent; AOperation: TOperation); override; function TrackMenu(Button: TStyledToolButton): Boolean; dynamic; @@ -259,7 +361,15 @@ TStyledToolbar = class(TCustomFlowPanel) procedure AlignControls(AControl: TControl; var Rect: TRect); override; procedure AdjustSize; override; function GetStyledToolButtonClass: TStyledToolButtonClass; virtual; + procedure Loaded; override; public + procedure Assign(Source: TPersistent); override; + class procedure RegisterDefaultRenderingStyle( + const ADrawType: TStyledButtonDrawType; + const AFamily: TStyledButtonFamily = DEFAULT_CLASSIC_FAMILY; + const AClass: TStyledButtonClass = DEFAULT_WINDOWS_CLASS; + const AAppearance: TStyledButtonAppearance = DEFAULT_APPEARANCE; + const AStyleRadius: Integer = DEFAULT_RADIUS); virtual; procedure BeginUpdate; virtual; procedure EndUpdate; virtual; procedure ClearButtons; @@ -278,6 +388,7 @@ TStyledToolbar = class(TCustomFlowPanel) function NewButton(out ANewToolButton: TStyledToolButton; const AStyle: TToolButtonStyle = tbsButton): Boolean; procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; + property AsVCLComponent: Boolean read GetAsVCLComponent write SetAsVCLComponent stored False; property ButtonCount: Integer read GetButtonCount; property Buttons[Index: Integer]: TStyledToolButton read GetButton; property StyleApplied: Boolean read FStyleApplied write SetStyleApplied; @@ -286,6 +397,7 @@ TStyledToolbar = class(TCustomFlowPanel) property Align default alTop; property Anchors; property AutoSize: Boolean read GetAutoSize write SetAutoSize default False; + property ButtonsCursor: TCursor read FButtonsCursor write SetButtonsCursor default DEFAULT_CURSOR; property BorderWidth; property ButtonHeight: Integer read FButtonHeight write SetButtonHeight default 22; property ButtonWidth: Integer read FButtonWidth write SetButtonWidth default 23; @@ -306,7 +418,7 @@ TStyledToolbar = class(TCustomFlowPanel) property Enabled; property Flat: Boolean read FFlat write SetFlat default True; property Font; - property Height default 32; + property Height; property HideClippedButtons: Boolean read FHideClippedButtons write SetHideClippedButtons default False; property Images: TCustomImageList read FImages write SetImages; property Indent: Integer read GetIndent write SetIndent default 0; @@ -323,7 +435,7 @@ TStyledToolbar = class(TCustomFlowPanel) property TabOrder; property TabStop; property Touch; - property Transparent: Boolean read FTransparent write FTransparent stored False; + property Transparent: Boolean read FTransparent write SetTransparent stored False; property Visible; property StyleElements; property Wrapable: Boolean read GetWrapable write SetWrapable default True; @@ -354,6 +466,12 @@ TStyledToolbar = class(TCustomFlowPanel) property OnStartDrag; property OnUnDock; + //Properties ignores (only for backward compatibility) + property GradientDrawingOptions: TTBGradientDrawingOptions read FGradientDrawingOptions write FGradientDrawingOptions default [gdoHotTrack, gdoGradient]; + property GradientDirection: TGradientDirection read FGradientDirection write FGradientDirection default gdVertical; + property DrawingStyle: TTBDrawingStyle read FDrawingStyle write FDrawingStyle default TTBDrawingStyle.dsNormal; + property GradientEndColor: TColor read FGradientEndColor write FGradientEndColor stored IsGradientEndColorStored; + property GradientStartColor: TColor read FGradientStartColor write FGradientStartColor default clWindow; //StyledComponents Attributes property StyleRadius: Integer read FStyleRadius write SetStyleRadius stored IsCustomRadius; @@ -375,13 +493,13 @@ implementation , Vcl.Forms , System.Types , System.RTLConsts - , Vcl.StandardButtonStyles ; const - DEFAULT_SEP_WIDTH = 8; + DEFAULT_SEP_WIDTH = 6; DEFAULT_TOOLBUTTON_WIDTH = 23; DEFAULT_TOOLBUTTON_HEIGHT = 22; + DEFAULT_IMAGE_HMARGIN = 8; { TStyledToolButton } @@ -409,11 +527,13 @@ procedure TStyledToolButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin inherited MouseUp(Button, Shift, X, Y); +(* if (Button = mbLeft) and (Style = tbsCheck) then begin - if (FDown and AllowAllUp) or (not FDown) then + if (Down and AllowAllUp) or (not Down) then Down := not Down; end; +*) end; procedure TStyledToolButton.Click; @@ -432,13 +552,13 @@ procedure TStyledToolButton.Click; function TStyledToolButton.GetButtonState: TStyledButtonState; begin - if (Style = tbsCheck) and FDown then + if (Style = tbsCheck) and Down then Result := bsmPressed else Result := inherited GetButtonState; end; -function TStyledToolButton.GetCaption: TCaption; +function TStyledToolButton.GetCaptionToDraw: TCaption; begin if Assigned(FToolBar) and not FToolBar.ShowCaptions then Result := '' @@ -480,6 +600,11 @@ function TStyledToolButton.GetIndex: Integer; Result := -1; end; +function TStyledToolButton.GetStyleDrawType: TStyledButtonDrawType; +begin + Result := inherited StyleDrawType; +end; + function TStyledToolButton.GetText: TCaption; begin if Assigned(FToolBar) and not (FToolBar.ShowCaptions) then @@ -503,12 +628,6 @@ function TStyledToolButton.IsCaptionStored: Boolean; Result := inherited IsCaptionStored; end; -function TStyledToolButton.IsCheckedStored: Boolean; -begin - Result := (ActionLink = nil) or - not TGraphicButtonActionLink(ActionLink).IsCheckedLinked; -end; - function TStyledToolButton.IsImageAlignmentStored: Boolean; begin if Assigned(FToolBar) then @@ -621,22 +740,22 @@ procedure TStyledToolButton.UpdateButtonContent; if not FToolbar.List then begin inherited ImageAlignment := FImageAlignment; - inherited ImageMargins.Left := 0; - inherited ImageMargins.Right := 0; + //inherited ImageMargins.Left := 0; + //inherited ImageMargins.Right := 0; end else begin if IsRightToLeft then begin inherited ImageAlignment := iaRight; - inherited ImageMargins.Right := DEFAULT_IMAGE_HMARGIN; - inherited ImageMargins.Left := 0; + //inherited ImageMargins.Right := DEFAULT_IMAGE_HMARGIN; + //inherited ImageMargins.Left := 0; end else begin inherited ImageAlignment := iaLeft; - inherited ImageMargins.Left := DEFAULT_IMAGE_HMARGIN; - inherited ImageMargins.Right := 0; + //inherited ImageMargins.Left := DEFAULT_IMAGE_HMARGIN; + //inherited ImageMargins.Right := 0; end; end; end @@ -700,32 +819,33 @@ procedure TStyledToolButton.UpAllNextButtons(const AIndex: Integer); end; end; -procedure TStyledToolButton.SetDown(AValue: Boolean); +procedure TStyledToolButton.SetEnable(const AValue: Boolean); begin - if FDown <> AValue then + if FEnabled <> AValue then begin - FDown := AValue; - if FDown and FGrouped then - begin - UpAllPrevButtons(Index-1); - UpAllNextButtons(Index+1); - end; + FEnabled := AValue; UpdateButtonContent; end; end; -procedure TStyledToolButton.SetEnable(const AValue: Boolean); +procedure TStyledToolButton.UpdateGroupIndex; begin - if FEnabled <> AValue then + if Style = tbsCheck then begin - FEnabled := AValue; - UpdateButtonContent; + if FGrouped then + Render.GroupIndex := -1 + else if Render.GroupIndex = -1 then + Render.GroupIndex := 0; end; end; procedure TStyledToolButton.SetGrouped(AValue: Boolean); begin - FGrouped := AValue; + if FGrouped <> AValue then + begin + FGrouped := AValue; + UpdateGroupIndex; + end; end; procedure TStyledToolButton.SetHeight(const AValue: Integer); @@ -780,12 +900,17 @@ function TStyledToolButton.IsCustomRadius: boolean; end; end; +function TStyledToolButton.IsCustomRoundedCorners: Boolean; +begin + Result := StyleRoundedCorners <> ALL_ROUNDED_CORNERS; +end; + function TStyledToolButton.IsCustomDrawType: Boolean; begin if Assigned(FToolBar) then Result := StyleDrawType <> FToolBar.StyleDrawType else - Result := StyleDrawType <> btRounded; + Result := StyleDrawType <> btRoundRect; end; function TStyledToolButton.IsStoredStyleFamily: Boolean; @@ -812,6 +937,14 @@ function TStyledToolButton.IsStoredFlat: Boolean; Result := True; end; +function TStyledToolButton.IsStoredCursor: Boolean; +begin + if Assigned(FToolBar) then + Result := Cursor <> FToolBar.FButtonsCursor + else + Result := Cursor <> DEFAULT_CURSOR; +end; + function TStyledToolButton.IsStoredStyleAppearance: Boolean; begin if Assigned(FToolBar) then @@ -851,24 +984,33 @@ procedure TStyledToolButton.SetStyle(AValue: TToolButtonStyle); if FStyle <> AValue then begin FStyle := AValue; + UpdateGroupIndex; if IsDropDown then begin - inherited Style := bsSplitButton; + inherited Style := TCustomButton.TButtonStyle.bsSplitButton; if FToolBar.AutoSize then FToolBar.ResizeButtons; end else begin - inherited Style := bsPushButton; + inherited Style := TCustomButton.TButtonStyle.bsPushButton; end; if IsSeparator <> WasSeparator then begin Width := DEFAULT_SEP_WIDTH; + StyleDrawType := StyleDrawType; end; UpdateButtonContent; end; end; +procedure TStyledToolButton.SetStyleDrawType( + const AValue: TStyledButtonDrawType); +begin + if not IsSeparator then + inherited StyleDrawType := AValue; +end; + procedure TStyledToolButton.SetToolBar(AToolBar: TStyledToolBar); begin if FToolBar <> AToolBar then @@ -895,7 +1037,7 @@ procedure TStyledToolButton.ValidateContainer(AComponent: TComponent); if (csLoading in ComponentState) and (AComponent is TStyledToolBar) then begin if IsSeparator then - W := Width else + W := DEFAULT_SEP_WIDTH else W := TStyledToolBar(AComponent).ButtonWidth; SetBounds(Left, Top, W, TStyledToolBar(AComponent).ButtonHeight); end; @@ -918,6 +1060,16 @@ procedure TStyledToolbar.CancelMenu; FCaptureChangeCancels := False; end; +{$IFDEF D10_1+} +procedure TStyledToolbar.ChangeScale(M, D: Integer; isDpiChange: Boolean); +begin + FButtonWidth := MulDiv(FButtonWidth, M, D); + FButtonHeight := MulDiv(FButtonHeight, M, D); + inherited ChangeScale(M, D, isDpiChange); +end; +{$ENDIF} + + procedure TStyledToolbar.ClearButtons; var LButton: TStyledToolButton; @@ -964,14 +1116,13 @@ constructor TStyledToolbar.CreateStyled(AOwner: TComponent; Height := 29; FButtonWidth := 23; FButtonHeight := 22; + FButtonsCursor := DEFAULT_CURSOR; BevelKind := bkNone; BevelInner := bvNone; BevelOuter := bvNone; BevelEdges := []; - { The default value for Transparent now depends on if you have - Themes turned on or off (this only works on XP) } - FTransparent := StyleServices.Enabled; + Transparent := StyleServices.Enabled; ParentBackground := True; ParentColor := True; BevelOuter := bvNone; @@ -988,19 +1139,25 @@ constructor TStyledToolbar.CreateStyled(AOwner: TComponent; //FHotImageChangeLink := TChangeLink.Create; //FHotImageChangeLink.OnChange := HotImageListChange; - FStyleDrawType := btRounded; - FStyleRadius := DEFAULT_RADIUS; + FGradientDrawingOptions := [gdoHotTrack,gdoGradient]; + FGradientDirection := gdVertical; + FDrawingStyle := TTBDrawingStyle.dsNormal; + FGradientEndColor := GetShadowColor(clBtnFace, -25); + FGradientStartColor := clWindow; + FStyleDrawType := _DefaultStyleDrawType; + FStyleRadius := _DefaultStyleRadius; FStyleFamily := AFamily; FStyleClass := AClass; FStyleAppearance := AAppearance; + FButtonsCursor := _DefaultButtonsCursor; end; constructor TStyledToolbar.Create(AOwner: TComponent); begin CreateStyled(AOwner, - DEFAULT_CLASSIC_FAMILY, - DEFAULT_WINDOWS_CLASS, - DEFAULT_APPEARANCE); + _DefaultFamily, + _DefaultClass, + _DefaultAppearance); end; destructor TStyledToolbar.Destroy; @@ -1037,6 +1194,20 @@ procedure TStyledToolbar.ImageListChange(Sender: TObject); ); end; +procedure TStyledToolbar.SetButtonsCursor(const AValue: TCursor); +begin + if FButtonsCursor <> AValue then + begin + FButtonsCursor := AValue; + ProcessButtons( + procedure (ABtn: TStyledToolButton) + begin + ABtn.Cursor := AValue; + end + ); + end; +end; + procedure TStyledToolbar.AdjustSize; var LSize: Integer; @@ -1137,6 +1308,7 @@ procedure TStyledToolBar.InsertButton(Control: TControl); LButton.StyleClass := FStyleClass; LButton.StyleAppearance := FStyleAppearance; LButton.StyleElements := StyleElements; + LButton.Cursor := FButtonsCursor; LButton.RescalingButton := True; try LButton.Height := FButtonHeight; @@ -1172,6 +1344,11 @@ function TStyledToolbar.IsCustomRadius: Boolean; Result := StyleRadius <> DEFAULT_RADIUS; end; +function TStyledToolbar.IsGradientEndColorStored: Boolean; +begin + Result := FGradientEndColor <> GetShadowColor(clBtnFace, -25); +end; + function TStyledToolbar.IsStoredStyleAppearance: Boolean; var LClass: TStyledButtonClass; @@ -1190,7 +1367,7 @@ function TStyledToolbar.IsStoredStyleClass: Boolean; begin StyleFamilyCheckAttributes(FStyleFamily, LClass, LAppearance, LButtonFamily); - if (FStyleFamily = DEFAULT_CLASSIC_FAMILY) and (seClient in StyleElements) then + if AsVCLStyle then begin Result := (FStyleClass <> GetActiveStyleName) and not SameText(FStyleClass, 'Windows'); @@ -1204,6 +1381,12 @@ function TStyledToolbar.IsStoredStyleFamily: Boolean; Result := FStyleFamily <> DEFAULT_CLASSIC_FAMILY; end; +procedure TStyledToolbar.Loaded; +begin + inherited; + ResizeButtons; +end; + function TStyledToolbar.FindButtonFromAccel(Accel: Word): TStyledToolButton; var I: Integer; @@ -1241,6 +1424,19 @@ function TStyledToolbar.FindLastControl: TControl; Result := LLastControl; end; +class procedure TStyledToolbar.RegisterDefaultRenderingStyle( + const ADrawType: TStyledButtonDrawType; const AFamily: TStyledButtonFamily; + const AClass: TStyledButtonClass; const AAppearance: TStyledButtonAppearance; + const AStyleRadius: Integer); +begin + _DefaultStyleDrawType := ADrawType; + _UseCustomDrawType := True; + _DefaultFamily := AFamily; + _DefaultClass := AClass; + _DefaultAppearance := AAppearance; + _DefaultStyleRadius := AStyleRadius; +end; + procedure TStyledToolBar.RemoveButton(Control: TControl); var I: Integer; @@ -1272,6 +1468,14 @@ procedure TStyledToolbar.SetImages(const AValue: TCustomImageList); end; end; +procedure TStyledToolbar.SetDisableButtonAlign(const AValue: Boolean); +begin + if AValue then + Inc(FDisableButtonAlign) + else + Dec(FDisableButtonAlign); +end; + procedure TStyledToolbar.SetDisabledImages(const AValue: TCustomImageList); begin if FDisabledImages <> AValue then @@ -1368,14 +1572,67 @@ procedure TStyledToolbar.UpdateButtons; end); end; +procedure TStyledToolbar.Assign(Source: TPersistent); +var + LToolbar: TStyledToolbar; +begin + inherited Assign(Source); + if Source is TStyledToolbar then + begin + LToolbar := TStyledToolbar(Source); + FTransparent := LToolbar.FTransparent; + FShowCaptions := LToolbar.FShowCaptions; + FButtonsCursor := LToolbar.FButtonsCursor; + FButtonHeight := LToolbar.FButtonHeight; + FButtonWidth := LToolbar.FButtonWidth; + FCustomizable := LToolbar.FCustomizable; + DisabledImages := LToolbar.FDisabledImages; + FFlat := LToolbar.FFlat; + FHideClippedButtons := LToolbar.FHideClippedButtons; + Images := LToolbar.FImages; + FList := LToolbar.FList; + FStyleFamily := LToolbar.FStyleFamily; + FStyleClass := LToolbar.FStyleClass; + FStyleAppearance := LToolbar.FStyleAppearance; + FStyleRadius := LToolbar.FStyleRadius; + FStyleDrawType := LToolbar.FStyleDrawType; + Invalidate; + end; +end; + function TStyledToolbar.AsVCLStyle: Boolean; begin - //if StyleFamily is Classic and StyleElements contains seClient - //assume to draw the component as the equivalent VCL Result := (StyleFamily = DEFAULT_CLASSIC_FAMILY) and (seClient in StyleElements); end; +function TStyledToolbar.GetAsVCLComponent: Boolean; +begin + Result := (StyleFamily = DEFAULT_CLASSIC_FAMILY) and + (seClient in StyleElements) and + (FStyleClass = GetActiveStyleName); +end; + +procedure TStyledToolbar.SetAsVCLComponent(const AValue: Boolean); +begin + if AValue <> GetAsVCLComponent then + begin + if AValue then + begin + FStyleFamily := DEFAULT_CLASSIC_FAMILY; + FStyleClass := DEFAULT_WINDOWS_CLASS; + FStyleAppearance := DEFAULT_APPEARANCE; + StyleElements := StyleElements + [seClient]; + FCustomDrawType := False; + end + else if FStyleFamily = DEFAULT_CLASSIC_FAMILY then + begin + StyleElements := StyleElements - [seClient]; + end; + UpdateStyleElements; + end; +end; + procedure TStyledToolbar.UpdateStyleElements; var LStyleClass: TStyledButtonClass; @@ -1469,7 +1726,7 @@ procedure TStyledToolbar.AlignControls(AControl: TControl; var Rect: TRect); I: Integer; LButton, LSourceButton, LTargetButton: TStyledToolButton; begin - if (AControl is TStyledToolButton) and not FDisableAlign then + if (AControl is TStyledToolButton) and not DisableButtonAlign then begin //Move Button selected in new position LSourceButton := TStyledToolButton(AControl); @@ -1518,13 +1775,6 @@ function TStyledToolbar.ApplyToolbarStyle: Boolean; LAttributesOther, LAttributesOther, LAttributesOther); -(* - if not FCustomDrawType then - begin - FStyleDrawType := LAttributesNormal.DrawType; - FCustomDrawType := False; - end; -*) finally LAttributesNormal.Free; LAttributesOther.Free; @@ -1575,6 +1825,9 @@ procedure TStyledToolbar.SetStyleClass(const AValue: TStyledButtonClass); end); FStyleClass := LValue; StyleApplied := ApplyToolbarStyle; + if (FStyleFamily = DEFAULT_CLASSIC_FAMILY) and + (LValue <> 'Windows') then + StyleElements := [seFont, seBorder]; end; end; @@ -1646,6 +1899,17 @@ procedure TStyledToolbar.SetToolbarStyle( [AStyleFamily, AStyleClass, AStyleAppearance]); end; +procedure TStyledToolbar.SetTransparent(const AValue: Boolean); +begin + if FTransparent <> AValue then + begin + FTransparent := AValue; + if AValue then + ControlStyle := ControlStyle - [csOpaque] else + ControlStyle := ControlStyle + [csOpaque]; + end; +end; + function TStyledToolbar.TrackMenu(Button: TStyledToolButton): Boolean; begin { Already in menu loop - click button to drop-down menu } @@ -1696,6 +1960,11 @@ procedure TStyledToolbar.GetChildren(Proc: TGetChildProc; Root: TComponent); end; end; +function TStyledToolbar.GetDisableButtonAlign: Boolean; +begin + Result := FDisableButtonAlign > 0; +end; + function TStyledToolbar.GetEdgeBorders: TEdgeBorders; begin @@ -1752,7 +2021,7 @@ procedure TStyledToolbar.ResizeButtons; if (csLoading in ComponentState) then Exit; - FDisableAlign := True; + DisableButtonAlign := True; try if (FButtonHeight <> 0) and (FButtonWidth <> 0) and (FUpdateCount = 0) then @@ -1782,28 +2051,13 @@ procedure TStyledToolbar.ResizeButtons; end; end; finally - FDisableAlign := False; + DisableButtonAlign := False; end; end; function TStyledToolbar.GetActiveStyleName: string; begin - {$IFDEF D10_4+} - Result := GetStyleName; - if Result = '' then - begin - {$IFDEF D11+} - if (csDesigning in ComponentState) then - Result := TStyleManager.ActiveDesigningStyle.Name - else - Result := TStyleManager.ActiveStyle.Name; - {$ELSE} - Result := TStyleManager.ActiveStyle.Name; - {$ENDIF} - end; - {$ELSE} - Result := TStyleManager.ActiveStyle.Name; - {$ENDIF} + Result := Vcl.ButtonStylesAttributes.GetActiveStyleName(Self); end; function TStyledToolbar.GetAutoSize: Boolean; @@ -1964,7 +2218,7 @@ function TStyledToolbar.NewButton(out ANewToolButton: TStyledToolButton; LLastControl: TControl; begin Result := False; - FDisableAlign := True; + DisableButtonAlign := True; try if Assigned(FOnCustomizeNewButton) then begin @@ -2001,7 +2255,7 @@ function TStyledToolbar.NewButton(out ANewToolButton: TStyledToolButton; end; end; finally - FDisableAlign := False; + DisableButtonAlign := False; end; end; @@ -2018,4 +2272,12 @@ procedure TStyledToolbar.Notification(AComponent: TComponent; end; end; +initialization + TStyledToolbar._DefaultStyleDrawType := DEFAULT_STYLEDRAWTYPE; + TStyledToolbar._DefaultFamily := DEFAULT_CLASSIC_FAMILY; + TStyledToolbar._DefaultClass := DEFAULT_WINDOWS_CLASS; + TStyledToolbar._DefaultAppearance := DEFAULT_APPEARANCE; + TStyledToolbar._DefaultStyleRadius := DEFAULT_RADIUS; + TStyledToolbar._DefaultButtonsCursor := DEFAULT_CURSOR; + end. diff --git a/README.htm b/README.htm new file mode 100644 index 0000000..9ac0b23 --- /dev/null +++ b/README.htm @@ -0,0 +1,171 @@ + +

SKIA Shell Extensions and Lottie Editor License

+

Latest Version 1.5.3 - 09 May 2024

+

A collection of extensions tools for image and animations files, integrated into Microsoft Windows Explorer (7, 8, 10 and 11):

+ +

Animation and file extensions supported:

+

.json or .lottie: animated Lottie files lottiefiles.com

+

.gif: static and animated Gif W3C GIF (tm)

+

.webp: static and animated webp An image format for the Web

+

.tgs: animated telegram stickers core.telegram.org/stickers

+

Features

+ +

Setup using the Installer

+

Click to download the SKIAShellExtensionsSetup.exe located also in the Release area. The Installer works both for 32 and 64 bit system.

+

Lottie Setup_Program

+

For a clean Setup close all the windows explorer instances which have the preview handler active or the preview handler was used (remember the dll remains in memory until the windows explorer was closed).

+

Preview Panel and Thumbnails in action

+

In Windows 11 with Light theme:

+

Preview Thumbnails Light

+

In Windows 11 with Dark theme:

+

Preview Thumbnails Dark

+

Lottie Text Editor

+

A useful Text editor with preview and animation of Lottie files:

+

Lottie Text Editor Dark

+

Settings: Preview page

+

Settings: Preview page

+

Settings: Theme page

+

Settings: Theme page

+

Manual Build and Installation (for Delphi developers)

+

If you have Delphi 11 or Delphi 12, you can manually build the project:

+

Warning: To build the DLL you need also other open-source projects

+ +

To manually install the SKIAShellExtensions.dll follow these steps:

+
    +

  1. Close all the windows explorer instances which have the preview handler active or the preview handler was used (remember the dll remains in memory until the windows explorer was closed).

    +
    2. +

  2. If you have already used the installer uninstall the components from system.

    +
    3. +

  3. To Uninstall/Install manually the dll run the Unregister_Register.cmd (run-as-administrator).

    +
    4. +

  4. If you want to continue to change code and rebuild the dll, Unregister the dlls and beware to close all Explorer instances.

    +
    5. +
+

Release Notes

+

13 Jan 2024: ver. 1.5.2

+ +

26 Oct 2023: ver. 1.5.1

+ +

25 Oct 2023: ver. 1.5.0

+ +

12 Mar 2023: ver. 1.4.0

+ +

27 Feb 2023: ver. 1.3.0

+ +

13 Jan 2023: ver. 1.2.0

+ +

09 Nov 2022: ver. 1.1.0

+ +

24 Set 2022: ver. 1.0.1

+ +

23 Set 2022: ver. 1.0.0

+ +

Credits

+

Many thanks to Rodrigo Ruz V. (author of theroadtodelphi.com Blog) for his wonderful work on delphi-preview-handler from which this project has used a lot of code and inspiration.

+

Powered by Skia4Delphi

+

Logo

+

Many thanks to the project “Skia4Delphi”

+

Skia4Delphi is a cross-platform 2D graphics API for Delphi based on Google's Skia graphics library.

+

License

+

Licensed under the Apache License, Version 2.0 (the “License”); +Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an “AS IS” BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License.

+

The Initial Developer of the Original Code is Rodrigo Ruz V. Portions created by him are Copyright © 2011-2021 Rodrigo Ruz V.

+

Third Party libraries and tools used from Ethea:

+ +

Third Party libraries and tools used:

+ +

Delphi Support

+

Related links: embarcadero.com - learndelphi.org

diff --git a/README.md b/README.md index 5b62861..6a0a5e7 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # SKIA Shell Extensions and Lottie Editor [![License](https://img.shields.io/badge/License-Apache%202.0-yellowgreen.svg)](https://opensource.org/licenses/Apache-2.0) -**Latest Version 1.5.2 - 13 Jan 2024** +**Latest Version 1.5.3 - 09 May 2024** **A collection of extensions tools for image and animations files, integrated into Microsoft Windows Explorer (7, 8, 10 and 11):** @@ -88,6 +88,12 @@ To manually install the SKIAShellExtensions.dll follow these steps: ## Release Notes ## +09 May 2024: ver. 1.5.3 +- Added File Changed notification and reload +- Built with Delphi 12.1 +- Built with Latest Image32 Library +- Built with Latest Skia4Delphi 6.1 Library + 13 Jan 2024: ver. 1.5.2 - Aligned to Image32 Library - Updated Copyright diff --git a/Setup/Output/SKIAShellExtensionsSetup.exe b/Setup/Output/SKIAShellExtensionsSetup.exe index d700e17..a91803b 100644 Binary files a/Setup/Output/SKIAShellExtensionsSetup.exe and b/Setup/Output/SKIAShellExtensionsSetup.exe differ diff --git a/Setup/SKIAShellExtensions.iss b/Setup/SKIAShellExtensions.iss index 0fbfa35..5ad3c48 100644 --- a/Setup/SKIAShellExtensions.iss +++ b/Setup/SKIAShellExtensions.iss @@ -1,7 +1,7 @@ ; Script generated by the Inno Setup Script Wizard. ; SEE THE DOCUMENTATION FOR DETAILS ON CREATING INNO SETUP SCRIPT FILES! #define MyAppName 'SKIA Shell Extensions and Lottie Text Editor' -#define MyAppVersion '1.5.2' +#define MyAppVersion '1.5.3' [Setup] AppName={#MyAppName} @@ -42,6 +42,10 @@ Name: eng; MessagesFile: compiler:Default.isl; LicenseFile: .\License_ENG.rtf Name: ita; MessagesFile: compiler:Languages\Italian.isl; LicenseFile: .\Licenza_ITA.rtf +[CustomMessages] +UninstallMessage=Undefined +eng.UninstallMessage=An older version of "SKIA Shell Extensions and Lottie Text Editor" was detected. The uninstaller will be executed... +ita.UninstallMessage=È stata rilevata una versione precedente di "SKIA Shell Extensions and Lottie Text Editor". Il programma di disinstallazione verrà eseguito... [Tasks] Name: desktopicon; Description: {cm:CreateDesktopIcon}; GroupDescription: {cm:AdditionalIcons}; Flags: unchecked; Components: Editor @@ -75,6 +79,23 @@ Root: "HKCR"; Subkey: "OpenLottieEditor\Shell\Open\Command"; ValueType: string; Root: "HKCR"; Subkey: "OpenLottieEditor\DefaultIcon"; ValueType: string; ValueData: "{app}\LottieTextEditor.exe,0"; Flags: uninsdeletevalue [Code] + +function IsSilentMode(): Boolean; +var + j: Cardinal; +begin + Result := false; + begin + for j := 0 to ParamCount do + begin + Result := (ParamStr(j)='/verysilent') or (ParamStr(j)='/silent') or + (ParamStr(j)='/VERYSILENT') or (ParamStr(j)='/SILENT'); + if Result then + break; + end; + end; +end; + function InitializeSetup(): Boolean; begin Result:=True; @@ -116,7 +137,8 @@ begin // get the uninstall string of the old app sUnInstallString := GetUninstallString(); - if sUnInstallString <> '' then begin + if sUnInstallString <> '' then + begin sUnInstallString := RemoveQuotes(sUnInstallString); if Exec(sUnInstallString, '/SILENT /NORESTART /SUPPRESSMSGBOXES', '', SW_HIDE, ewWaitUntilTerminated, iResultCode) then Result := 3 @@ -132,7 +154,8 @@ begin begin if (IsUpgrade()) then begin - MsgBox(ExpandConstant('An old version of "SKIA Shell Extensions and Lottie Text Editor" was detected. The uninstaller will be executed...'), mbInformation, MB_OK); + if not IsSilentMode() then + MsgBox(ExpandConstant('{cm:UninstallMessage}'), mbInformation, MB_OK); UnInstallOldVersion(); end; end; diff --git a/Source/EditorMainForm.dfm b/Source/EditorMainForm.dfm index 8ffa819..697a7de 100644 --- a/Source/EditorMainForm.dfm +++ b/Source/EditorMainForm.dfm @@ -68,6 +68,7 @@ object frmMain: TfrmMain ParentColor = True TabOrder = 1 Visible = False + StyleElements = [seFont, seBorder] object SVGIconImageCloseButton: TSVGIconImage Left = 0 Top = 0 @@ -109,8 +110,6 @@ object frmMain: TfrmMain item Width = 80 end> - ExplicitTop = 568 - ExplicitWidth = 895 end object ImagePanel: TPanel Left = 576 @@ -200,7 +199,6 @@ object frmMain: TfrmMain Align = alBottom ParentBackground = False TabOrder = 2 - ExplicitTop = 498 object StatusImage: TSVGIconImage Left = 1 Top = 1 @@ -216,8 +214,8 @@ object frmMain: TfrmMain AlignWithMargins = True Left = 36 Top = 4 - Width = 4 - Height = 4 + Width = 283 + Height = 26 Align = alClient Alignment = taCenter TabOrder = 0 @@ -336,7 +334,6 @@ object frmMain: TfrmMain OnClosing = SVClosing OnOpened = SVOpened OnOpening = SVOpening - ExplicitHeight = 532 object catMenuItems: TCategoryButtons Left = 0 Top = 0 @@ -442,7 +439,6 @@ object frmMain: TfrmMain OnGetHint = catMenuItemsGetHint OnMouseLeave = catMenuItemsMouseLeave OnMouseMove = catMenuItemsMouseMove - ExplicitHeight = 532 end end object panlTop: TPanel @@ -456,7 +452,7 @@ object frmMain: TfrmMain TabOrder = 4 object lblTitle: TLabel AlignWithMargins = True - Left = 41 + Left = 40 Top = 3 Width = 88 Height = 30 @@ -527,7 +523,7 @@ object frmMain: TfrmMain AlignWithMargins = True Left = 3 Top = 3 - Width = 32 + Width = 31 Height = 30 Align = alLeft AutoSize = True @@ -1225,4 +1221,10 @@ object frmMain: TfrmMain Left = 448 Top = 368 end + object CheckFileChangedTimer: TTimer + Interval = 3000 + OnTimer = CheckFileChangedTimerTimer + Left = 296 + Top = 356 + end end diff --git a/Source/EditorMainForm.pas b/Source/EditorMainForm.pas index 342f615..4128574 100644 --- a/Source/EditorMainForm.pas +++ b/Source/EditorMainForm.pas @@ -79,12 +79,14 @@ interface STR_UNEXPECTED_ERROR = 'UNEXPECTED ERROR!'; CONFIRM_CHANGES = 'ATTENTION: the content of file "%s" is changed: do you want to save the file?'; LOTTIE_PARSING_OK = 'Lottie Parsing is correct.'; + FILE_CHANGED_RELOAD = 'File "%s" Date/Time changed! Do you want to reload it?'; type TEditingFile = class private FIcon : TIcon; FFileName : string; + FFileAge: TDateTime; FName : string; FExtension: string; procedure ReadFromFile; @@ -200,6 +202,7 @@ TfrmMain = class(TForm, IDragDrop) PauseAction: TAction; ToolButtonStop: TToolButton; ToolButtonPlayInverse: TToolButton; + CheckFileChangedTimer: TTimer; procedure PlayActionExecute(Sender: TObject); procedure StopActionExecute(Sender: TObject); procedure WMGetMinMaxInfo(var Message: TWMGetMinMaxInfo); message WM_GETMINMAXINFO; @@ -284,6 +287,7 @@ TfrmMain = class(TForm, IDragDrop) procedure PageControlMouseEnter(Sender: TObject); procedure PageControlMouseLeave(Sender: TObject); procedure SVGIconImageCloseButtonClick(Sender: TObject); + procedure CheckFileChangedTimerTimer(Sender: TObject); private FirstAction: Boolean; SkAnimatedImageEx: TSkAnimatedImageEx; @@ -351,6 +355,7 @@ TfrmMain = class(TForm, IDragDrop) procedure SkAnimatedImageAnimationProcess(Sender: TObject); procedure UpdateRunLabel; procedure ShowTabCloseButtonOnHotTab; + procedure UpdateTabsheetImage(ATabSheet: TTabSheet; AModified: Boolean); property EditorFontSize: Integer read FFontSize write SetEditorFontSize; protected procedure CreateWindowHandle(const Params: TCreateParams); override; @@ -465,12 +470,15 @@ destructor TEditingFile.Destroy; procedure TEditingFile.LoadFromFile(const AFileName: string); begin SynEditor.Lines.LoadFromFile(AFileName, TEncoding.UTF8); + SynEditor.Modified := False; + FileAge(AFileName, FFileAge); end; procedure TEditingFile.SaveToFile; begin SynEditor.Lines.SaveToFile(Self.FileName); SynEditor.Modified := False; + FileAge(Self.FileName, FFileAge); SynEditor.OnChange(SynEditor); end; @@ -1039,14 +1047,20 @@ procedure TfrmMain.acEditUndoUpdate(Sender: TObject); acEditUndo.Enabled := (CurrentEditor <> nil) and CurrentEditor.Modified; end; +procedure TfrmMain.UpdateTabsheetImage(ATabSheet: TTabSheet; + AModified: Boolean); +begin + if AModified then + ATabSheet.ImageName := 'lottie-logo' + else + ATabSheet.ImageName := 'lottie-logo-gray'; +end; + procedure TfrmMain.SynEditChange(Sender: TObject); begin if Sender = CurrentEditor then begin - if CurrentEditor.Modified then - pageControl.ActivePage.Imagename := 'lottie-logo' - else - pageControl.ActivePage.Imagename := 'lottie-logo-gray'; + UpdateTabsheetImage(pageControl.ActivePage, CurrentEditor.Modified); AssignLottieTextToImage; end; end; @@ -1270,6 +1284,36 @@ procedure TfrmMain.acSaveUpdate(Sender: TObject); acSave.Enabled := (CurrentEditor <> nil) and (CurrentEditor.Modified); end; +procedure TfrmMain.CheckFileChangedTimerTimer(Sender: TObject); +var + LFileAge: TDateTime; +begin + CheckFileChangedTimer.Enabled := False; + Try + //Check if opened files are changed on Disk + for var I := 0 to EditFileList.Count -1 do + begin + var LEditFile := TEditingFile(EditFileList.items[I]); + FileAge(LEditFile.FileName, LFileAge); + if LFileAge <> LEditFile.FFileAge then + begin + var LConfirm := StyledMessageDlg(Format(FILE_CHANGED_RELOAD,[LEditFile.FileName]), + mtWarning, [mbYes, mbNo], 0); + if LConfirm = mrYes then + begin + LEditFile.ReadFromFile; + UpdateTabsheetImage(LEditFile.TabSheet, False); + SynEditChange(LEditFile.SynEditor); + end + else + LEditFile.FFileAge := LFileAge; + end; + end; + Finally + CheckFileChangedTimer.Enabled := True; + End; +end; + procedure TfrmMain.CloseSplitViewMenu; begin SV.Close; @@ -1944,6 +1988,7 @@ procedure TfrmMain.ShowTabCloseButtonOnHotTab; PanelCloseButton.Top := rectOver.Top + ((rectOver.Height div 2) - (PanelCloseButton.Height div 2)) + 1; PanelCloseButton.Tag := iot; + PanelCloseButton.Color := Self.Color; PanelCloseButton.Show; end else diff --git a/Source/LottieTextEditor.dproj b/Source/LottieTextEditor.dproj index 3d9f9be..473da09 100644 --- a/Source/LottieTextEditor.dproj +++ b/Source/LottieTextEditor.dproj @@ -12,6 +12,7 @@ Win64 3 Application + LottieTextEditor true @@ -67,7 +68,7 @@ ..\Icons\logo.ico $(BDS)\bin\default_app.manifest 1033 - CompanyName=Ethea S.r.l.;FileDescription=SKIA/Lottie Text Editor;FileVersion=1.5.2.0;InternalName=;LegalCopyright=Copyright © 2022-2024 - Ethea S.r.l.;LegalTrademarks=;OriginalFilename=;ProductName=SKIA/Lottie Text Editor;ProductVersion=1.5;Comments= + CompanyName=Ethea S.r.l.;FileDescription=SKIA/Lottie Text Editor;FileVersion=1.5.3.0;InternalName=;LegalCopyright=Copyright © 2022-2024 - Ethea S.r.l.;LegalTrademarks=;OriginalFilename=;ProductName=SKIA/Lottie Text Editor;ProductVersion=1.5;Comments= Glow|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Glow.vsf;Sky|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Sky.vsf;Windows10|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10.vsf;"Windows10 Dark|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10Dark.vsf";"Windows10 SlateGray|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10SlateGray.vsf";"Windows11 Modern Dark|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows11_Modern_Dark.vsf";"Windows11 Modern Light|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows11_Modern_Light.vsf";"Flat UI Light|VCLSTYLE|$(BDSCOMMONDIR)\Styles\FlatUILight.vsf";"Windows10 BlackPearl|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10BlackPearl.vsf";"Windows10 Blue Whale|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10BlueWhale.vsf";"Windows10 Blue Whale LE|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10BlueWhaleLE.vsf";"Windows10 Clear Day|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10ClearDay.vsf";"Windows10 Malibu|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10Malibu.vsf" 0 false @@ -77,7 +78,7 @@ ..\..\exe\InstantXMLEditor.exe VCLSTYLEUTILS;SKIA;$(DCC_Define) 5 - 2 + 3 System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Bde;$(DCC_Namespace) @@ -165,6 +166,8 @@ LottieTextEditor.dpr + Ethea InstantSolutions 8.6 Vcl Library + Ethea InstantSolutions 8.6 Framework Library Microsoft Office 2000 Sample Automation Server Wrapper Components Microsoft Office XP Sample Automation Server Wrapper Components @@ -838,6 +841,9 @@ 1 + + 1 + @@ -1099,6 +1105,7 @@ + 12 diff --git a/Source/LottieTextEditor.res b/Source/LottieTextEditor.res index 165b1d6..8c886a5 100644 Binary files a/Source/LottieTextEditor.res and b/Source/LottieTextEditor.res differ diff --git a/Source/SKIAShellExtensions.dproj b/Source/SKIAShellExtensions.dproj index e875f22..4080912 100644 --- a/Source/SKIAShellExtensions.dproj +++ b/Source/SKIAShellExtensions.dproj @@ -10,6 +10,7 @@ 2 Library SKIAShellExtensions.dpr + SKIAShellExtensions true @@ -58,7 +59,7 @@ ..\Icons\logo.ico $(BDS)\bin\default_app.manifest 1033 - CompanyName=Ethea S.r.l.;FileDescription=SKIA Shell Extensions 64bit;FileVersion=1.5.2.0;InternalName=;LegalCopyright=Copyright © 2022-2024 Ethea S.r.l.;LegalTrademarks=;OriginalFilename=;ProductName=SKIA Shell Extensions 32bit;ProductVersion=1.5;Comments= + CompanyName=Ethea S.r.l.;FileDescription=SKIA Shell Extensions 64bit;FileVersion=1.5.3.0;InternalName=;LegalCopyright=Copyright © 2022-2024 Ethea S.r.l.;LegalTrademarks=;OriginalFilename=;ProductName=SKIA Shell Extensions 32bit;ProductVersion=1.5;Comments= Glow|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Glow.vsf;Sky|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Sky.vsf;Windows10|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10.vsf;"Windows10 Dark|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10Dark.vsf";"Windows10 SlateGray|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10SlateGray.vsf";"Windows11 Modern Dark|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows11_Modern_Dark.vsf";"Windows11 Modern Light|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows11_Modern_Light.vsf";"Flat UI Light|VCLSTYLE|$(BDSCOMMONDIR)\Styles\FlatUILight.vsf";"Windows10 BlackPearl|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10BlackPearl.vsf";"Windows10 Blue Whale|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10BlueWhale.vsf";"Windows10 Blue Whale LE|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10BlueWhaleLE.vsf";"Windows10 Clear Day|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10ClearDay.vsf";"Windows10 Malibu|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10Malibu.vsf" rtl;vcl;vclx;vclactnband;xmlrtl;VclSmp;vclimg;svnui;svn;bdertl;TeeUI;TeeDB;Tee;vcldb;dbrtl;vcldbx;vcltouch;dsnap;dsnapcon;vclib;ibxpress;adortl;IndyCore;IndySystem;IndyProtocols;inet;intrawebdb_110_150;Intraweb_110_150;vclie;websnap;webdsnap;inetdb;inetdbbde;inetdbxpress;soaprtl;vclribbon;dbexpress;DbxCommonDriver;DataSnapIndy10ServerTransport;DataSnapProviderClient;DbxClientDriver;DataSnapClient;dbxcds;DataSnapServer;AzureCloud;DBXInterBaseDriver;DBXMySQLDriver;DBXFirebirdDriver;DBXSybaseASEDriver;DBXSybaseASADriver;DBXOracleDriver;DBXMSSQLDriver;DBXInformixDriver;DBXDb2Driver;Hydra_Core_D15;SynEdit_RXE;mbColorLibDXE;JclDeveloperTools;Jcl;JclVcl;JclContainers;JvCore;JvSystem;JvStdCtrls;JvAppFrm;JvBands;JvDB;JvDlgs;JvBDE;JvControls;JvCmp;JvCrypt;JvCustom;JvDocking;JvDotNetCtrls;JvGlobus;JvHMI;JvJans;JvManagedThreads;JvMM;JvNet;JvPageComps;JvPascalInterpreter;JvPluginSystem;JvPrintPreview;JvRuntimeDesign;JvTimeFramework;JvWizards;JvXPCtrls;WinSkinDXE;bsfd2011;IceTabSet;$(DCC_UsePackage) .\$(Config)\$(Platform) @@ -68,7 +69,7 @@ ..\Bin64 true 5 - 2 + 3 D:\ETHEA\SVGShellExtensions\Debug\Preview Handlers\OpenDialog\OpenDialogTest.exe @@ -198,6 +199,8 @@ c:\temp + Ethea InstantSolutions 8.6 Vcl Library + Ethea InstantSolutions 8.6 Framework Library Microsoft Office 2000 Sample Automation Server Wrapper Components Microsoft Office XP Sample Automation Server Wrapper Components @@ -803,6 +806,9 @@ 1 + + 1 + @@ -1064,6 +1070,7 @@ + 12 diff --git a/Source/SKIAShellExtensions.res b/Source/SKIAShellExtensions.res index 6e9a026..e5373bd 100644 Binary files a/Source/SKIAShellExtensions.res and b/Source/SKIAShellExtensions.res differ diff --git a/Source/SKIAShellExtensions32.dproj b/Source/SKIAShellExtensions32.dproj index 67526b5..8eb0c87 100644 --- a/Source/SKIAShellExtensions32.dproj +++ b/Source/SKIAShellExtensions32.dproj @@ -10,6 +10,7 @@ 1 Library SKIAShellExtensions32.dpr + SKIAShellExtensions32 true @@ -58,7 +59,7 @@ ..\Icons\logo.ico $(BDS)\bin\default_app.manifest 1033 - CompanyName=Ethea S.r.l.;FileDescription=SKIA Shell Extensions 32bit;FileVersion=1.5.2.0;InternalName=;LegalCopyright=Copyright © 2022-2024 Ethea S.r.l.;LegalTrademarks=;OriginalFilename=;ProductName=SKIA Shell Extensions 32bit;ProductVersion=1.5;Comments= + CompanyName=Ethea S.r.l.;FileDescription=SKIA Shell Extensions 32bit;FileVersion=1.5.3.0;InternalName=;LegalCopyright=Copyright © 2022-2024 Ethea S.r.l.;LegalTrademarks=;OriginalFilename=;ProductName=SKIA Shell Extensions 32bit;ProductVersion=1.5;Comments= Glow|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Glow.vsf;Sky|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Sky.vsf;Windows10|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10.vsf;"Windows10 Dark|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10Dark.vsf";"Windows10 SlateGray|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10SlateGray.vsf";"Windows11 Modern Dark|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows11_Modern_Dark.vsf";"Windows11 Modern Light|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows11_Modern_Light.vsf";"Flat UI Light|VCLSTYLE|$(BDSCOMMONDIR)\Styles\FlatUILight.vsf";"Windows10 BlackPearl|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10BlackPearl.vsf";"Windows10 Blue Whale|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10BlueWhale.vsf";"Windows10 Blue Whale LE|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10BlueWhaleLE.vsf";"Windows10 Clear Day|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10ClearDay.vsf";"Windows10 Malibu|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10Malibu.vsf" rtl;vcl;vclx;vclactnband;xmlrtl;VclSmp;vclimg;svnui;svn;bdertl;TeeUI;TeeDB;Tee;vcldb;dbrtl;vcldbx;vcltouch;dsnap;dsnapcon;vclib;ibxpress;adortl;IndyCore;IndySystem;IndyProtocols;inet;intrawebdb_110_150;Intraweb_110_150;vclie;websnap;webdsnap;inetdb;inetdbbde;inetdbxpress;soaprtl;vclribbon;dbexpress;DbxCommonDriver;DataSnapIndy10ServerTransport;DataSnapProviderClient;DbxClientDriver;DataSnapClient;dbxcds;DataSnapServer;AzureCloud;DBXInterBaseDriver;DBXMySQLDriver;DBXFirebirdDriver;DBXSybaseASEDriver;DBXSybaseASADriver;DBXOracleDriver;DBXMSSQLDriver;DBXInformixDriver;DBXDb2Driver;Hydra_Core_D15;SynEdit_RXE;mbColorLibDXE;JclDeveloperTools;Jcl;JclVcl;JclContainers;JvCore;JvSystem;JvStdCtrls;JvAppFrm;JvBands;JvDB;JvDlgs;JvBDE;JvControls;JvCmp;JvCrypt;JvCustom;JvDocking;JvDotNetCtrls;JvGlobus;JvHMI;JvJans;JvManagedThreads;JvMM;JvNet;JvPageComps;JvPascalInterpreter;JvPluginSystem;JvPrintPreview;JvRuntimeDesign;JvTimeFramework;JvWizards;JvXPCtrls;WinSkinDXE;bsfd2011;IceTabSet;$(DCC_UsePackage) .\$(Config)\$(Platform) @@ -68,7 +69,7 @@ ..\Bin32 true 5 - 2 + 3 PerMonitorV2 @@ -199,6 +200,8 @@ c:\temp + Ethea InstantSolutions 8.6 Vcl Library + Ethea InstantSolutions 8.6 Framework Library Microsoft Office 2000 Sample Automation Server Wrapper Components Microsoft Office XP Sample Automation Server Wrapper Components @@ -805,6 +808,9 @@ 1 + + 1 + @@ -1066,6 +1072,7 @@ + 12 diff --git a/Source/SKIAShellExtensions32.res b/Source/SKIAShellExtensions32.res index 951a525..b8c55c2 100644 Binary files a/Source/SKIAShellExtensions32.res and b/Source/SKIAShellExtensions32.res differ