opensource/HeidiSQL
1
0
Fork 0
mirror of https://github.com/HeidiSQL/HeidiSQL.git synced 2025-08-06 18:24:26 +08:00
Code Issues Packages Projects Releases Wiki Activity
Files
HeidiSQL/components/virtualtreeview/Source/VirtualTrees.FMX.pas

1782 lines
59 KiB
ObjectPascal
Raw Permalink Blame History

unit VirtualTrees.FMX;
{$SCOPEDENUMS ON}
{***********************************************************}
{ Project : VirtualTrees }
{ }
{ author : Karol Bieniaszewski }
{ year : 2018 }
{ contibutors : }
{***********************************************************}
interface
uses
System.Classes
, System.UITypes
, System.Types
, System.ImageList
, System.Math.Vectors
, FMX.ImgList
, FMX.Graphics
, FMX.Controls
, FMX.Types
, FMX.StdCtrls;
//-------- type aliasing -------------------------------------------------------------------------------------------------------------------
type
TRect = System.Types.TRectF;
PRect = System.Types.PRectF;
TPoint = System.Types.TPointF;
PPoint = System.Types.PPointF;
PSize = System.Types.PSizeF;
TSize = System.Types.TSizeF;
TColor = System.UITypes.TAlphaColor;
PAnsiChar = System.MarshaledAString;
UINT = LongWord;
PUINT = ^UINT;
TCustomControl = TControl; //Alias for VCL compatibility as on FMX there is not TCustomControl
//------- color aliasing -------------------------------------------------------------------------------------------------------------------
const
clBtnFace = TAlphaColor($FFF0F0F0); //TAlphaColorRec.Gray;
clBtnText = TAlphaColorRec.Black;
clBtnHighlight = TAlphaColorRec.DkGray;
clBtnShadow = TAlphaColorRec.Darkgray;
clHighlight = TAlphaColorRec.Lightblue;
clWindow = TAlphaColorRec.White;
clWindowText = TAlphaColorRec.Black;
clHighlightText = TAlphaColorRec.White;
clWhite = TAlphaColorRec.White;
clSilver = TAlphaColorRec.Silver;
clGray = TAlphaColorRec.Gray;
clBlack = TAlphaColorRec.Black;
clGreen = TAlphaColorRec.Green;
clBlue = TAlphaColorRec.Blue;
clGrayText = TAlphaColorRec.DkGray;
clInactiveCaption = TAlphaColorRec.Darkblue; //TODO: color
clInactiveCaptionText = TAlphaColorRec.Yellow; //TODO: color
clDkGray = TAlphaColorRec.DkGray;
//------- needed for migration -------------------------------------------------------------------------------------------------------------
const
{ 3D border styles }
BDR_RAISEDOUTER = 1;
BDR_SUNKENOUTER = 2;
BDR_RAISEDINNER = 4;
BDR_SUNKENINNER = 8;
BDR_OUTER = 3;
BDR_INNER = 12;
BDR_RAISED = 5;
BDR_SUNKEN = 10;
EDGE_RAISED = (BDR_RAISEDOUTER or BDR_RAISEDINNER);
EDGE_SUNKEN = (BDR_SUNKENOUTER or BDR_SUNKENINNER);
EDGE_ETCHED = (BDR_SUNKENOUTER or BDR_RAISEDINNER);
EDGE_BUMP = (BDR_RAISEDOUTER or BDR_SUNKENINNER);
ETO_OPAQUE = 2;
ETO_CLIPPED = 4;
ETO_RTLREADING = $80;
RTLFlag: array[Boolean] of Integer = (0, ETO_RTLREADING);
{ Border flags }
BF_LEFT = 1;
BF_TOP = 2;
BF_RIGHT = 4;
BF_BOTTOM = 8;
BF_TOPLEFT = (BF_TOP or BF_LEFT);
BF_TOPRIGHT = (BF_TOP or BF_RIGHT);
BF_BOTTOMLEFT = (BF_BOTTOM or BF_LEFT);
BF_BOTTOMRIGHT = (BF_BOTTOM or BF_RIGHT);
BF_RECT = (BF_LEFT or BF_TOP or BF_RIGHT or BF_BOTTOM);
BF_MIDDLE = $800; { Fill in the middle }
BF_SOFT = $1000; { For softer buttons }
BF_ADJUST = $2000; { Calculate the space left over }
BF_FLAT = $4000; { For flat rather than 3D borders }
BF_MONO = $8000; { For monochrome borders }
{ DrawText() Format Flags }
DT_TOP = 0;
DT_LEFT = 0;
DT_CENTER = 1;
DT_RIGHT = 2;
DT_VCENTER = 4;
DT_BOTTOM = 8;
DT_WORDBREAK = $10;
DT_SINGLELINE = $20;
DT_EXPANDTABS = $40;
DT_TABSTOP = $80;
DT_NOCLIP = $100;
DT_EXTERNALLEADING = $200;
DT_CALCRECT = $400;
DT_NOPREFIX = $800;
DT_INTERNAL = $1000;
DT_EDITCONTROL = $2000;
DT_PATH_ELLIPSIS = $4000;
DT_END_ELLIPSIS = $8000;
DT_MODIFYSTRING = $10000;
DT_RTLREADING = $20000;
DT_WORD_ELLIPSIS = $40000;
DT_NOFULLWIDTHCHARBREAK = $0080000;
DT_HIDEPREFIX = $00100000;
DT_PREFIXONLY = $00200000;
MAXDWORD = DWORD($FFFFFFFF);
WHEEL_DELTA = 120; { Value for rolling one detent }
WHEEL_PAGESCROLL = MAXDWORD; { Scroll one page }
{ WM_SIZE message wParam values }
SIZE_RESTORED = 0;
SIZE_MINIMIZED = 1;
SIZE_MAXIMIZED = 2;
SIZE_MAXSHOW = 3;
SIZE_MAXHIDE = 4;
{ Scroll Bar Constants }
SB_HORZ = 0;
SB_VERT = 1;
SB_CTL = 2;
SB_BOTH = 3;
SIF_RANGE = 1;
SIF_PAGE = 2;
SIF_POS = 4;
SIF_DISABLENOSCROLL = 8;
SIF_TRACKPOS = $10;
SIF_ALL = (SIF_RANGE or SIF_PAGE or SIF_POS or SIF_TRACKPOS);
{ Scroll Bar Commands }
SB_LINEUP = 0;
SB_LINELEFT = 0;
SB_LINEDOWN = 1;
SB_LINERIGHT = 1;
SB_PAGEUP = 2;
SB_PAGELEFT = 2;
SB_PAGEDOWN = 3;
SB_PAGERIGHT = 3;
SB_THUMBPOSITION = 4;
SB_THUMBTRACK = 5;
SB_TOP = 6;
SB_LEFT = 6;
SB_BOTTOM = 7;
SB_RIGHT = 7;
SB_ENDSCROLL = 8;
{ RedrawWindow() flags }
RDW_INVALIDATE = 1;
RDW_INTERNALPAINT = 2;
RDW_ERASE = 4;
RDW_VALIDATE = 8;
RDW_NOINTERNALPAINT = $10;
RDW_NOERASE = $20;
RDW_NOCHILDREN = $40;
RDW_ALLCHILDREN = $80;
RDW_UPDATENOW = $100;
RDW_ERASENOW = $200;
RDW_FRAME = $400;
RDW_NOFRAME = $800;
{ GetSystemMetrics() codes }
SM_CXVSCROLL = 2;
SM_CYHSCROLL = 3;
var
// Clipboard format IDs used in OLE drag'n drop and clipboard transfers.
CF_VIRTUALTREE,
CF_VTREFERENCE, // A reference to a virtual tree
CF_VTHEADERREFERENCE, // drapg and drop of column headers
CF_VRTF,
CF_VRTFNOOBJS, // Unfortunately CF_RTF* is already defined as being
// registration strings so I have to use different identifiers.
CF_HTML,
CF_CSV: Word;
type
tagSCROLLINFO = record
cbSize: UINT;
fMask: UINT;
nMin: Single;
nMax: Single;
nPage: Single;
nPos: Single;
nTrackPos: Single;
end;
PScrollInfo = ^TScrollInfo;
TScrollInfo = tagSCROLLINFO;
SCROLLINFO = tagSCROLLINFO;
TBorderWidth = Single;
TBevelCut = (bvNone, bvLowered, bvRaised, bvSpace);
TBevelEdge = (beLeft, beTop, beRight, beBottom);
TBevelEdges = set of TBevelEdge;
TBevelKind = (bkNone, bkTile, bkSoft, bkFlat);
TBevelWidth = 1..MaxInt;
TFormBorderStyle = (bsNone, bsSingle, bsSizeable, bsDialog, bsToolWindow, bsSizeToolWin);
TBorderStyle = TFormBorderStyle.bsNone..TFormBorderStyle.bsSingle;
TChangeLink = class(TImageLink)
private
function GetSender: TCustomImageList; inline;
procedure SetSender(const Value: TCustomImageList); inline;
public
constructor Create; override;
property Sender: TCustomImageList read GetSender write SetSender;
end;
INT_PTR = Integer; //do not change on Int64 //System.IntPtr; // NativeInt;
{$EXTERNALSYM INT_PTR}
UINT_PTR = Cardinal; //do not change on Int64 //System.UIntPtr; // NativeUInt;
WPARAM = UINT_PTR;
LPARAM = INT_PTR;
LRESULT = INT_PTR;
TDWordFiller = record
{$IFDEF CPUX64}
Filler: array[1..4] of Byte; // Pad DWORD to make it 8 bytes (4+4) [x64 only]
{$ENDIF}
end;
//--------- Windows messages simulations ---------------------------------------------------------------------------------------------------
const
WM_APP = $8000;
WM_MOUSEFIRST = $0200;
WM_MOUSEMOVE = $0200;
WM_LBUTTONDOWN = $0201;
WM_LBUTTONUP = $0202;
WM_LBUTTONDBLCLK = $0203;
WM_RBUTTONDOWN = $0204;
WM_RBUTTONUP = $0205;
WM_RBUTTONDBLCLK = $0206;
WM_MBUTTONDOWN = $0207;
WM_MBUTTONUP = $0208;
WM_MBUTTONDBLCLK = $0209;
WM_MOUSEWHEEL = $020A;
WM_SIZE = $0005;
WM_NCMBUTTONDOWN = $00A7;
WM_NCMBUTTONUP = $00A8;
WM_NCMBUTTONDBLCLK = $00A9;
WM_NCLBUTTONDBLCLK = $00A3;
WM_NCRBUTTONDOWN = $00A4;
WM_NCRBUTTONUP = $00A5;
WM_NCRBUTTONDBLCLK = $00A6;
WM_NCLBUTTONDOWN = $00A1;
WM_NCLBUTTONUP = $00A2;
WM_NCMOUSEMOVE = $00A0;
WM_KEYDOWN = $0100;
WM_KEYUP = $0101;
WM_SETFOCUS = $0007;
WM_KILLFOCUS = $0008;
WM_SETCURSOR = $0020;
WM_HSCROLL = $0114;
WM_VSCROLL = $0115;
WM_CHANGESTATE = WM_APP + 32;
CM_BASE = $B000;
{$IF DEFINED(CLR)}
CM_CLROFFSET = $100;
{$ELSE}
CM_CLROFFSET = $0; // Only applicable in CLR
{$ENDIF}
CM_ACTIVATE = CM_BASE + 0;
CM_DEACTIVATE = CM_BASE + 1;
CM_GOTFOCUS = CM_BASE + 2;
CM_LOSTFOCUS = CM_BASE + 3;
CM_CANCELMODE = CM_BASE + CM_CLROFFSET + 4;
CM_DIALOGKEY = CM_BASE + 5;
CM_DIALOGCHAR = CM_BASE + 6;
{$IF NOT DEFINED(CLR)}
CM_FOCUSCHANGED = CM_BASE + 7;
{$ENDIF}
CM_PARENTFONTCHANGED = CM_BASE + CM_CLROFFSET + 8;
CM_PARENTCOLORCHANGED = CM_BASE + 9;
CM_BIDIMODECHANGED = CM_BASE + 60;
CM_PARENTBIDIMODECHANGED = CM_BASE + 61;
CM_MOUSEWHEEL = CM_BASE + 67;
VK_ESCAPE = 27;
type
PMessage = ^TMessage;
TMessage = record
Msg: Cardinal; //4
tmp: Integer; //4
case Integer of
0: (
WParam: WPARAM; //4
LParam: LPARAM; //4
Result: LRESULT //4
); //= 12 + 4 = 16
1: (
WParamLo: Word; //2
WParamHi: Word; //2
//WParamFiller: TDWordFiller;
LParamLo: Word; //2
LParamHi: Word; //2
//LParamFiller: TDWordFiller;
ResultLo: Word; //2
ResultHi: Word; //2
//=12 + 8 = 20
);
end;
TWMMouse = record
Msg: Cardinal; //4
Keys: Longint; //TShiftState; //4
//KeysFiller: TDWordFiller;
case Integer of
0: (
XPos: Single; //4
YPos: Single; //4
Result: LRESULT; //4
);
1: (
Pos: TPoint; //8
ResultLo: Word; //2
ResultHi: Word; //2
); //=12 + 8=20
end;
TWMMouseMove = TWMMouse;
TWMNCHitTest = record
Msg: Cardinal;
//MsgFiller: TDWordFiller;
Unused: WPARAM;
case Integer of
0: (
XPos: Single;
YPos: Single;
//XYPosFiller: TDWordFiller
);
1: (
Pos: TPoint;
//PosFiller: TDWordFiller;
Result: LRESULT);
end;
TWMNCHitMessage = record
Msg: Cardinal; //4
//MsgFiller: TDWordFiller;
HitTest: Longint; //4
//HitTestFiller: TDWordFiller;
XCursor: Single; //4
YCursor: Single; //4
//XYCursorFiller: TDWordFiller;
Result: LRESULT; //4
end; //=20
TWMNCLButtonDblClk = TWMNCHitMessage;
TWMNCLButtonDown = TWMNCHitMessage;
TWMNCLButtonUp = TWMNCHitMessage;
TWMNCMButtonDblClk = TWMNCHitMessage;
TWMNCMButtonDown = TWMNCHitMessage;
TWMNCMButtonUp = TWMNCHitMessage;
TWMNCMouseMove = TWMNCHitMessage;
TWMNCRButtonDblClk = TWMNCHitMessage;
TWMNCRButtonDown = TWMNCHitMessage;
TWMNCRButtonUp = TWMNCHitMessage;
TWMLButtonDblClk = TWMMouse;
TWMLButtonDown = TWMMouse;
TWMLButtonUp = TWMMouse;
TWMMButtonDblClk = TWMMouse;
TWMMButtonDown = TWMMouse;
TWMMButtonUp = TWMMouse;
TWMKey = record
Msg: Cardinal; //4
tmp: Integer; //4
CharCode: Word; //4
//Unused: Word; //2
KeyData: Longint; //4
Result: LRESULT; //4
end; //=20
TWMKeyDown = TWMKey;
TWMKeyUp = TWMKey;
TWMSize = record
Msg: Cardinal; //4
//MsgFiller: TDWordFiller;
SizeType: WPARAM; { SIZE_MAXIMIZED, SIZE_MINIMIZED, SIZE_RESTORED, //4
SIZE_MAXHIDE, SIZE_MAXSHOW }
Width: Single; //4
Height: Single; //4
//WidthHeightFiller: TDWordFiller;
Result: LRESULT; //4
end; //=20
TWMScroll = record
Msg: Cardinal; //4
//MsgFiller: TDWordFiller;
ScrollCode: {Smallint}Integer; { SB_xxxx } //4
Pos: Single; //4
//ScrollCodePosFiller: TDWordFiller;
ScrollBar: Integer; //4 nBar
Result: LRESULT; //4
end; //=20
TWMHScroll = TWMScroll;
TWMVScroll = TWMScroll;
TCMMouseWheel = record
Msg: Cardinal; //4
//MsgFiller: TDWordFiller;
ShiftState: TShiftState; //2
WheelDelta: SmallInt; //2
//ShiftStateWheel: TDWordFiller;
case Integer of
0: (
XPos: Single; //4
YPos: Single; //4
//XYPos: TDWordFiller
); //=24!
1: (
Pos: TPoint; //8
//PosFiller: TDWordFiller;
Result: LRESULT //4
); //=28!
end;
procedure FillTWMMouse(Var MM: TWMMouse; Button: TMouseButton; Shift: TShiftState; X: Single; Y: Single; IsNC: Boolean; IsUp: Boolean);
//--------- Text metrics -------------------------------------------------------------------------------------------------------------------
type
TTextMetric = record
tmHeight: Single; //The height (ascent + descent) of characters.
tmAscent: Single; //The ascent (units above the base line) of characters.
tmDescent: Single; //The descent (units below the base line) of characters.
tmInternalLeading: Single; //The amount of leading (space) inside the bounds set by the tmHeight member. Accent marks and other diacritical characters may occur in this area. The designer may set this member to zero
tmExternalLeading: Single; //The amount of extra leading (space) that the application adds between rows. Since this area is outside the font, it contains no marks and is not altered by text output calls in either OPAQUE or TRANSPARENT mode. The designer may set this member to zero.
tmAveCharWidth: Single; //The average width of characters in the font (generally defined as the width of the letter x ). This value does not include the overhang required for bold or italic characters.
tmMaxCharWidth: Single; //The width of the widest character in the font.
tmWeight: Single; //The weight of the font.
tmOverhang: Single;
tmDigitizedAspectX: Single; //The horizontal aspect of the device for which the font was designed.
tmDigitizedAspectY: Single; //The vertical aspect of the device for which the font was designed. The ratio of the tmDigitizedAspectX and tmDigitizedAspectY members is the aspect ratio of the device for which the font was designed.
tmFirstChar: WideChar; //The value of the first character defined in the font.
tmLastChar: WideChar; //The value of the last character defined in the font.
tmDefaultChar: WideChar; //The value of the character to be substituted for characters not in the font.
tmBreakChar: WideChar; //The value of the character that will be used to define word breaks for text justification.
tmItalic: Byte; //Specifies an italic font if it is nonzero.
tmUnderlined: Byte; //Specifies an underlined font if it is nonzero.
tmStruckOut: Byte; //A strikeout font if it is nonzero.
tmPitchAndFamily: Byte; //Specifies information about the pitch, the technology, and the family of a physical font. TMPF_FIXED_PITCH, TMPF_VECTOR, TMPF_TRUETYPE, TMPF_DEVICE
tmCharSet: Byte; //The character set of the font. The character set can be one of the following values. ANSI_CHARSET, GREEK_CHARSET....
end;
procedure GetTextMetrics(ACanvas: TCanvas; var TM: TTextMetric);
//-------- function aliassing --------------------------------------------------------------------------------------------------------------
function Rect(ALeft, ATop, ARight, ABottom: Single): TRect; overload; inline;
function Rect(const ATopLeft, ABottomRight: TPoint): TRect; overload; inline;
function Point(AX, AY: Single): TPoint; overload; inline;
procedure Inc(Var V: Single; OIle: Single=1.0); overload;
procedure Dec(Var V: Single; OIle: Single=1.0); overload;
function MulDiv(const A, B, C: Single): Single; overload;
procedure FillMemory(Destination: Pointer; Length: NativeUInt; Fill: Byte);
procedure ZeroMemory(Destination: Pointer; Length: NativeUInt);
procedure MoveMemory(Destination: Pointer; Source: Pointer; Length: NativeUInt);
procedure CopyMemory(Destination: Pointer; Source: Pointer; Length: NativeUInt);
procedure DrawTextW(ACanvas: TCanvas; CaptionText: String; Len: Integer; Var Bounds: TRect; DrawFormat: Cardinal{this is windows format - must be converted to FMX});
procedure GetTextExtentPoint32W(ACanvas: TCanvas; CaptionText: String; Len: Integer; Var Size: TSize);
procedure DrawEdge(Canvas: TCanvas; R: TRect; edge, grfFlags: Cardinal);
type
THighQualityBitmap = class(TBitmap)
public
constructor Create; override;
end;
//fill system images
procedure FillSystemCheckImages(Parent: TFmxObject; List: TImageList);
type
TCanvasHelper = class helper for TCanvas
private
function GetBrush: TBrush; inline;
function GetPen: TStrokeBrush; inline;
public
property Brush: TBrush read GetBrush;
property Pen: TStrokeBrush read GetPen;
procedure FillRect(const ARect: TRectF); overload; inline;
procedure DrawRect(const ARect: TRectF); overload; inline;
procedure DrawFocusRect(const AFocusRect: TRect);
procedure FrameRect(const AFocusRect: TRect);
procedure RoundRect(X1, Y1, X2, Y2: Single; const XRadius, YRadius: Single); overload;
procedure RoundRect(const Rect: TRect; const XRadius, YRadius: Single); overload;
procedure Polygon(const Points: TPolygon);
procedure Draw(const X, Y: Single; const Bitmap: TBitmap);
end;
TFontHelper = class helper for TFont
private
function GetOnChange: TNotifyEvent;
procedure SetOnChange(const Value: TNotifyEvent);
public
property OnChange: TNotifyEvent read GetOnChange write SetOnChange;
end;
{ Draws a solid triangular arrow that can point in any TScrollDirection }
type
TScrollDirection = (sdLeft, sdRight, sdUp, sdDown);
TArrowType = (atSolid, atArrows);
procedure DrawArrow(ACanvas: TCanvas; Direction: TScrollDirection; Location: TPoint; Size: Single);
procedure ChangeBiDiModeAlignment(var Alignment: TAlignment);
procedure OleUninitialize();
function timeGetTime: Int64;
implementation
uses
System.SysUtils
, FMX.TextLayout
, FMX.MultiResBitmap
, FMX.Objects
, FMX.Effects
, VirtualTrees.Utils
;
//----------------------------------------------------------------------------------------------------------------------
procedure DrawArrow(ACanvas: TCanvas; Direction: TScrollDirection; Location: TPoint; Size: Single);
begin
//TODO: DrawArrow implementation
end;
//----------------------------------------------------------------------------------------------------------------------
{ TCanvasHelper }
procedure TCanvasHelper.Draw(const X, Y: Single; const Bitmap: TBitmap);
begin
DrawBitmap(Bitmap
, Rect(0, 0, Bitmap.Width, Bitmap.Height)
, Rect(X, Y, X+Bitmap.Width, Y+ Bitmap.Height)
, 1.0
);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TCanvasHelper.DrawFocusRect(const AFocusRect: TRect);
begin
DrawDashRect(AFocusRect, 0, 0, AllCorners, 1.0{?}, $A0909090);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TCanvasHelper.DrawRect(const ARect: TRectF);
begin
DrawRect(ARect, 0, 0, [], 1.0);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TCanvasHelper.FillRect(const ARect: TRectF);
begin
FillRect(ARect, 0, 0, [], 1.0);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TCanvasHelper.FrameRect(const AFocusRect: TRect);
begin
DrawRect(AFocusRect);
end;
//----------------------------------------------------------------------------------------------------------------------
function TCanvasHelper.GetBrush: TBrush;
begin
Result:= Fill;
end;
//----------------------------------------------------------------------------------------------------------------------
function TCanvasHelper.GetPen: TStrokeBrush;
begin
Result:= Stroke;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TCanvasHelper.Polygon(const Points: TPolygon);
begin
DrawPolygon(Points, 1.0);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TCanvasHelper.RoundRect(const Rect: TRect; const XRadius, YRadius: Single);
begin
DrawRect(Rect, XRadius, YRadius, allCorners, 1.0);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TCanvasHelper.RoundRect(X1, Y1, X2, Y2: Single; const XRadius, YRadius: Single);
begin
RoundRect(Rect(X1, Y1, X2, Y2), XRadius, YRadius);
end;
//----------------------------------------------------------------------------------------------------------------------
type
TImageListHelper = class helper for TImageList
function Add(aBitmap: TBitmap): integer;
end;
function TImageListHelper.Add(aBitmap: TBitmap): integer;
const
SCALE = 1;
var
vSource: TCustomSourceItem;
vBitmapItem: TCustomBitmapItem;
vDest: TCustomDestinationItem;
vLayer: TLayer;
begin
Result := -1;
if (aBitmap.Width = 0) or (aBitmap.Height = 0) then exit;
// add source bitmap
vSource := Source.Add;
vSource.MultiResBitmap.TransparentColor := TColorRec.Fuchsia;
vSource.MultiResBitmap.SizeKind := TSizeKind.Source;
vSource.MultiResBitmap.Width := Round(aBitmap.Width / SCALE);
vSource.MultiResBitmap.Height := Round(aBitmap.Height / SCALE);
vBitmapItem := vSource.MultiResBitmap.ItemByScale(SCALE, True, True);
if vBitmapItem = nil then
begin
vBitmapItem := vSource.MultiResBitmap.Add;
vBitmapItem.Scale := Scale;
end;
vBitmapItem.Bitmap.Assign(aBitmap);
vDest := Destination.Add;
vLayer := vDest.Layers.Add;
vLayer.SourceRect.Rect := TRectF.Create(TPoint.Zero, vSource.MultiResBitmap.Width,
vSource.MultiResBitmap.Height);
vLayer.Name := vSource.Name;
Result := vDest.Index;
end;
//----------------------------------------------------------------------------------------------------------------------
//https://stackoverflow.com/questions/22813461/is-there-an-equivalent-to-floodfill-in-fmx-for-a-tbitmap
procedure Bitmap_FloodFill(fBitmap: TBitmap; StartX,StartY : Integer; FillColor: TAlphaColor);
var
fBitmapData : TBitmapData;
X, Y : Integer;
ReplaceColor : TAlphaColor;
Stack : Array of System.Types.TPoint;
fHeight : Integer;
fWidth : Integer;
procedure PutInStack(X, Y: Integer);
begin
SetLength(Stack, Length(Stack)+1);
Stack[Length(Stack)-1] := Point(X, Y);
end;
procedure GetFromStack(var X, Y: Integer);
begin
X := Stack[Length(Stack)-1].X;
Y := Stack[Length(Stack)-1].Y;
SetLength(Stack, Length(Stack)-1);
end;
begin
X := StartX;
Y := StartY;
fHeight := fBitmap.Height;
fWidth := fBitmap.Width;
if (X >= fWidth) or (Y >= fHeight) then Exit;
if fBitmap.Map(TMapAccess.ReadWrite,fBitmapData) then
try
ReplaceColor := fBitmapData.GetPixel(X,Y);
if ReplaceColor <> FillColor then
begin
PutInStack(X,Y);
while Length(Stack) > 0 do
begin
GetFromStack(X,Y);
while (X > 0) and (fBitmapData.GetPixel(X-1, Y) = ReplaceColor) do System.Dec(X);
while (X < fWidth) and (fBitmapData.GetPixel(X , Y) = ReplaceColor) do
begin
if Y > 0 then If fBitmapData.GetPixel(X, Y-1) = ReplaceColor then PutInStack(X, Y-1);
if Y+1 < fHeight then If fBitmapData.GetPixel(X, Y+1) = ReplaceColor then PutInStack(X, Y+1);
fBitmapData.SetPixel(X,Y,FillColor);
System.Inc(X);
end;
end;
end;
finally
fBitmap.Canvas.Bitmap.Unmap(fBitmapData);
end;
end;
//----------------------------------------------------------------------------------------------------------------------
{
ckEmpty = 0; // an empty image used as place holder
// radio buttons
ckRadioUncheckedNormal = 1;
ckRadioUncheckedHot = 2;
ckRadioUncheckedPressed = 3;
ckRadioUncheckedDisabled = 4;
ckRadioCheckedNormal = 5;
ckRadioCheckedHot = 6;
ckRadioCheckedPressed = 7;
ckRadioCheckedDisabled = 8;
// check boxes
ckCheckUncheckedNormal = 9;
ckCheckUncheckedHot = 10;
ckCheckUncheckedPressed = 11;
ckCheckUncheckedDisabled = 12;
ckCheckCheckedNormal = 13;
ckCheckCheckedHot = 14;
ckCheckCheckedPressed = 15;
ckCheckCheckedDisabled = 16;
ckCheckMixedNormal = 17;
ckCheckMixedHot = 18;
ckCheckMixedPressed = 19;
ckCheckMixedDisabled = 20;
// simple button
ckButtonNormal = 21; //???
ckButtonHot = 22; //???
ckButtonPressed = 23; //???
ckButtonDisabled = 24; //???
}
procedure FillSystemCheckImages(Parent: TFmxObject; List: TImageList);
Var cb: TCheckBox;
rb: TRadioButton;
BMP: TBitmap;
eff: TInnerGlowEffect;
procedure AddCtrlBmp(c: TControl);
Var tmpBMP: TBitmap;
begin
tmpBMP:= c.MakeScreenshot;
try
BMP.SetSize(tmpBMP.Height, tmpBMP.Height);
BMP.Clear(TAlphaColorRec.Null); //this somehow can sometimes clear BeginSceneCount and must be before BeginScene
if BMP.Canvas.BeginScene() then
begin
try
BMP.Canvas.DrawBitmap(
tmpBMP
, Rect(2, 2, BMP.Width, BMP.Height)
, Rect(0, 0, BMP.Width-2, BMP.Height-2)
, 1.0
, false
);
finally
BMP.Canvas.EndScene;
end;
end;
finally
FreeAndNil(tmpBMP);
end;
end;
begin
BMP:= TBitmap.Create;
try
BMP.SetSize(16, 16);
BMP.Clear(TAlphaColorRec.Null);
List.Add(BMP); //ckEmpty
rb:= TRadioButton.Create(Parent);
try
rb.Parent:= Parent;
rb.Text:= ' ';
eff:= TInnerGlowEffect.Create(rb); //auto free
eff.Parent:= rb;
eff.GlowColor:= TAlphaColorRec.Teal;
eff.Softness:= 8;
eff.Opacity:= 0.7;
eff.Enabled:= false;
//------------------IsUnChecked--------------------------
rb.IsChecked:= false;
eff.Enabled:= false;
AddCtrlBmp(rb);
List.Add(BMP); //ckRadioUncheckedNormal
eff.Enabled:= false;
AddCtrlBmp(rb);
eff.Enabled:= true;
eff.GlowColor:= TAlphaColorRec.Lightyellow;
List.Add(BMP); //ckRadioUncheckedHot
eff.Enabled:= false;
eff.Enabled:= true;
eff.GlowColor:= TAlphaColorRec.Lightblue;
AddCtrlBmp(rb);
List.Add(BMP); //ckRadioUncheckedPressed
eff.Enabled:= false;
rb.Enabled:= false;
eff.Enabled:= true;
eff.GlowColor:= TAlphaColorRec.Gray;
AddCtrlBmp(rb);
List.Add(BMP); //ckRadioUncheckedDisabled
eff.Enabled:= false;
//------------------IsChecked---------------------------
rb.IsChecked:= true;
//rb.IsPressed:= false;
rb.Enabled:= true;
eff.Enabled:= false;
AddCtrlBmp(rb);
List.Add(BMP); //ckRadioCheckedNormal
eff.Enabled:= false;
eff.Enabled:= true;
eff.GlowColor:= TAlphaColorRec.Lightyellow;
AddCtrlBmp(rb);
List.Add(BMP); //ckRadioCheckedHot
eff.Enabled:= false;
rb.Enabled:= true;
eff.Enabled:= true;
eff.GlowColor:= TAlphaColorRec.Lightblue;
AddCtrlBmp(rb);
List.Add(BMP); //ckRadioCheckedPressed
eff.Enabled:= false;
rb.Enabled:= false;
eff.Enabled:= true;
eff.GlowColor:= TAlphaColorRec.Gray;
AddCtrlBmp(rb);
List.Add(BMP); //ckRadioCheckedDisabled
eff.Enabled:= false;
finally
FreeAndNil(rb);
end;
cb:= TCheckBox.Create(Parent);
try
cb.Parent:= Parent;
cb.Text:= ' ';
eff:= TInnerGlowEffect.Create(cb); //auto free
eff.Parent:= cb;
eff.GlowColor:= TAlphaColorRec.Teal;
eff.Softness:= 8;
eff.Opacity:= 0.7;
eff.Enabled:= false;
//------------------IsUnChecked--------------------------
cb.IsChecked:= false;
eff.Enabled:= false;
AddCtrlBmp(cb);
List.Add(BMP); //ckCheckUncheckedNormal
eff.Enabled:= false;
eff.Enabled:= true;
eff.GlowColor:= TAlphaColorRec.Lightyellow;
AddCtrlBmp(cb);
List.Add(BMP); //ckCheckUncheckedHot
eff.Enabled:= false;
//cb.IsPressed:= true;
eff.Enabled:= true;
eff.GlowColor:= TAlphaColorRec.Lightblue;
AddCtrlBmp(cb);
List.Add(BMP); //ckCheckUncheckedPressed
eff.Enabled:= false;
//cb.IsPressed:= false;
cb.Enabled:= false;
eff.Enabled:= true;
eff.GlowColor:= TAlphaColorRec.Gray;
AddCtrlBmp(cb);
eff.Enabled:= false;
List.Add(BMP); //ckCheckUncheckedDisabled
//------------------IsChecked---------------------------
cb.IsChecked:= true;
cb.Enabled:= true;
eff.Enabled:= false;
AddCtrlBmp(cb);
List.Add(BMP); //ckCheckCheckedNormal
eff.Enabled:= false;
eff.Enabled:= true;
eff.GlowColor:= TAlphaColorRec.Lightyellow;
eff.Opacity:= 0.3;
AddCtrlBmp(cb);
List.Add(BMP); //ckCheckCheckedHot
eff.Opacity:= 0.7;
eff.Enabled:= false;
eff.Enabled:= false;
cb.Enabled:= true;
eff.Enabled:= true;
eff.GlowColor:= TAlphaColorRec.Lightblue;
AddCtrlBmp(cb);
List.Add(BMP); //ckCheckCheckedPressed
eff.Enabled:= false;
cb.Enabled:= false;
eff.Enabled:= true;
eff.GlowColor:= TAlphaColorRec.Gray;
AddCtrlBmp(cb);
List.Add(BMP); //ckCheckCheckedDisabled
eff.Enabled:= false;
//------------------Mixed---------------------------
//how to support mixed style?
//maybe draw unchecked and fill in the center of bitmap???
//i use ~teal for fill
//changed to InnerGlowEffect
cb.IsChecked:= true;
eff.Enabled:= true;
eff.GlowColor:= TAlphaColorRec.Green;
AddCtrlBmp(cb);
List.Add(BMP); //ckCheckMixedNormal
eff.Enabled:= false;
eff.Enabled:= true;
eff.GlowColor:= TAlphaColorRec.Lightyellow;
AddCtrlBmp(cb);
List.Add(BMP); //ckCheckMixedHot
eff.Enabled:= false;
eff.Enabled:= true;
eff.GlowColor:= TAlphaColorRec.Lightblue;
AddCtrlBmp(cb);
List.Add(BMP); //ckCheckMixedPressed
eff.Enabled:= false;
cb.Enabled:= false;
eff.Enabled:= true;
eff.GlowColor:= TAlphaColorRec.Gray;
AddCtrlBmp(cb);
List.Add(BMP); //ckCheckMixedDisabled
eff.Enabled:= false;
finally
FreeAndNil(cb);
end;
eff.Enabled:= false;
eff.Parent:= nil;
finally
FreeAndNil(BMP);
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure FillTWMMouse(Var MM: TWMMouse; Button: TMouseButton; Shift: TShiftState; X: Single; Y: Single; IsNC: Boolean; IsUp: Boolean);
begin
MM.Msg:= 0;
if ssDouble in Shift then
begin
if ssLeft in Shift then
begin
if IsNC then
MM.Msg:= WM_NCLBUTTONDBLCLK else
MM.Msg:= WM_LBUTTONDBLCLK;
end else
if ssRight in Shift then
begin
if IsNC then
MM.Msg:= WM_NCRBUTTONDBLCLK else
MM.Msg:= WM_RBUTTONDBLCLK;
end else
if ssMiddle in Shift then
begin
if IsNC then
MM.Msg:= WM_NCMBUTTONDBLCLK else
MM.Msg:= WM_MBUTTONDBLCLK;
end;
end else
begin
if (ssLeft in Shift) or (Button=TMouseButton.mbLeft) then
begin
if IsUp then
begin
if IsNC then
MM.Msg:= WM_NCLBUTTONUP else
MM.Msg:= WM_LBUTTONUP;
end else
begin
if IsNC then
MM.Msg:= WM_NCLBUTTONDOWN else
MM.Msg:= WM_LBUTTONDOWN;
end;
end else
if (ssRight in Shift) or (Button=TMouseButton.mbRight) then
begin
if IsUp then
begin
if IsNC then
MM.Msg:= WM_NCRBUTTONUP else
MM.Msg:= WM_RBUTTONUP;
end else
begin
if IsNC then
MM.Msg:= WM_NCRBUTTONDOWN else
MM.Msg:= WM_RBUTTONDOWN;
end;
end else
if (ssMiddle in Shift) or (Button=TMouseButton.mbMiddle) then
begin
if IsUp then
begin
if IsNC then
MM.Msg:= WM_NCMBUTTONUP else
MM.Msg:= WM_MBUTTONUP;
end else
begin
if IsNC then
MM.Msg:= WM_NCMBUTTONDOWN else
MM.Msg:= WM_MBUTTONDOWN;
end;
end;
end;
MM.XPos:= X;
MM.YPos:= Y;
MM.Keys:= LongInt(Word(Shift));
end;
//----------------------------------------------------------------------------------------------------------------------
procedure DrawTextW(ACanvas: TCanvas; CaptionText: String; Len: Integer; Var Bounds: TRect; DrawFormat: Cardinal{this is windows format - must be converted to FMX});
Var
hAlign: TTextAlign;
vAlign: TTextAlign;
Flags: TFillTextFlags;
begin
//TTextLayout. render
//TODO: DrawFormat: Cardinal{this is windows format - must be converted to FMX}
hAlign:= TTextAlign.Leading;
if DrawFormat and DT_CENTER<>0 then
hAlign:= TTextAlign.Center;
if DrawFormat and DT_RIGHT<>0 then
hAlign:= TTextAlign.Trailing;
vAlign:= TTextAlign.Center;
if DrawFormat and DT_VCENTER<>0 then
vAlign:= TTextAlign.Center;
if DrawFormat and DT_BOTTOM<>0 then
vAlign:= TTextAlign.Trailing;
Flags:= [];
if DrawFormat and DT_RTLREADING<>0 then
Flags:= Flags + [TFillTextFlag.RightToLeft];
ACanvas.FillText(Bounds, CaptionText, false, 1.0, Flags, hAlign, vAlign);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure DrawEdge(Canvas: TCanvas; R: TRect; edge, grfFlags: Cardinal);
Var tmpR: TRect;
IsSoft, IsFlat, IsMono: Boolean;
begin
if grfFlags and BF_SOFT<>0 then
IsSoft:= true else
IsSoft:= false;
if grfFlags and BF_FLAT<>0 then
IsFlat:= true else
IsFlat:= false;
if grfFlags and BF_MONO<>0 then
IsMono:= true else
IsMono:= false;
if grfFlags and BF_MIDDLE<>0 then
begin
Canvas.Fill.Color:= clBtnFace;
Canvas.FillRect(R, 0, 0, [], 1.0);
end;
tmpR:= R;
if grfFlags and BF_LEFT<>0 then
begin
tmpR:= R;
if edge and BDR_RAISEDOUTER<>0 then
begin
if isSoft then
begin
Canvas.Stroke.Color:= TColors.White;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Left, tmpR.Bottom), 1.0);
end else
if IsFlat then
begin
Canvas.Stroke.Color:= $FFA0A0A0;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Left, tmpR.Bottom), 1.0);
end else
if isMono then
begin
Canvas.Stroke.Color:= $FF646464;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Left, tmpR.Bottom), 1.0);
end else
begin
Canvas.Stroke.Color:= $FFE3E3E3;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Left, tmpR.Bottom), 1.0);
end;
InflateRect(tmpR, -1, -1)
end;
if edge and BDR_SUNKENOUTER<>0 then
begin
if isSoft then
begin
Canvas.Stroke.Color:= $FF696969;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Left, tmpR.Bottom), 1.0);
end else
if IsFlat then
begin
Canvas.Stroke.Color:= $FFA0A0A0;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Left, tmpR.Bottom), 1.0);
end else
if isMono then
begin
Canvas.Stroke.Color:= $FF646464;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Left, tmpR.Bottom), 1.0);
end else
begin
Canvas.Stroke.Color:= $FFA0A0A0;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Left, tmpR.Bottom), 1.0);
end;
InflateRect(tmpR, -1, -1)
end;
if edge and BDR_RAISEDINNER<>0 then
begin
if isSoft then
begin
Canvas.Stroke.Color:= $FFE3E3E3;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Left, tmpR.Bottom), 1.0);
end else
if IsFlat then
begin
Canvas.Stroke.Color:= $FFF0F0F0;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Left, tmpR.Bottom), 1.0);
end else
if isMono then
begin
Canvas.Stroke.Color:= TAlphaColorRec.White;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Left, tmpR.Bottom), 1.0);
end else
begin
Canvas.Stroke.Color:= TAlphaColorRec.White;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Left, tmpR.Bottom), 1.0);
end;
end;
if edge and BDR_SUNKENINNER<>0 then
begin
if isSoft then
begin
Canvas.Stroke.Color:= $FFA0A0A0;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Left, tmpR.Bottom), 1.0);
end else
if IsFlat then
begin
Canvas.Stroke.Color:= $FFF0F0F0;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Left, tmpR.Bottom), 1.0);
end else
if isMono then
begin
Canvas.Stroke.Color:= TAlphaColorRec.White;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Left, tmpR.Bottom), 1.0);
end else
begin
Canvas.Stroke.Color:= $FF696969;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Left, tmpR.Bottom), 1.0);
end;
end;
end;
if grfFlags and BF_TOP<>0 then
begin
tmpR:= R;
if edge and BDR_RAISEDOUTER<>0 then
begin
if isSoft then
begin
Canvas.Stroke.Color:= TAlphaColorRec.White;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Right, tmpR.Top), 1.0);
end else
if IsFlat then
begin
Canvas.Stroke.Color:= $FFA0A0A0;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Right, tmpR.Top), 1.0);
end else
if isMono then
begin
Canvas.Stroke.Color:= $FF646464;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Right, tmpR.Top), 1.0);
end else
begin
Canvas.Stroke.Color:= $FFE3E3E3;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Right, tmpR.Top), 1.0);
end;
InflateRect(tmpR, -1, -1)
end;
if edge and BDR_SUNKENOUTER<>0 then
begin
if isSoft then
begin
Canvas.Stroke.Color:= $FF696969;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Right, tmpR.Top), 1.0);
end else
if IsFlat then
begin
Canvas.Stroke.Color:= $FFA0A0A0;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Right, tmpR.Top), 1.0);
end else
if isMono then
begin
Canvas.Stroke.Color:= $FF646464;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Right, tmpR.Top), 1.0);
end else
begin
Canvas.Stroke.Color:= $FFA0A0A0;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Right, tmpR.Top), 1.0);
end;
InflateRect(tmpR, -1, -1)
end;
if edge and BDR_RAISEDINNER<>0 then
begin
if isSoft then
begin
Canvas.Stroke.Color:= $FFE3E3E3;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Right, tmpR.Top), 1.0);
end else
if IsFlat then
begin
Canvas.Stroke.Color:= $FFF0F0F0;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Right, tmpR.Top), 1.0);
end else
if isMono then
begin
Canvas.Stroke.Color:= TAlphaColorRec.White;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Right, tmpR.Top), 1.0);
end else
begin
Canvas.Stroke.Color:= TAlphaColorRec.White;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Right, tmpR.Top), 1.0);
end;
end;
if edge and BDR_SUNKENINNER<>0 then
begin
if isSoft then
begin
Canvas.Stroke.Color:= $FFA0A0A0;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Right, tmpR.Top), 1.0);
end else
if IsFlat then
begin
Canvas.Stroke.Color:= $FFF0F0F0;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Right, tmpR.Top), 1.0);
end else
if isMono then
begin
Canvas.Stroke.Color:= TAlphaColorRec.White;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Right, tmpR.Top), 1.0);
end else
begin
Canvas.Stroke.Color:= $FF696969;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Top), Point(tmpR.Right, tmpR.Top), 1.0);
end;
end;
end;
if grfFlags and BF_RIGHT<>0 then
begin
tmpR:= R;
if edge and BDR_RAISEDOUTER<>0 then
begin
if isSoft then
begin
Canvas.Stroke.Color:= $FF696969;
Canvas.DrawLine(Point(tmpR.Right-1, tmpR.Top), Point(tmpR.Right-1, tmpR.Bottom), 1.0);
end else
if IsFlat then
begin
Canvas.Stroke.Color:= $FFA0A0A0;
Canvas.DrawLine(Point(tmpR.Right-1, tmpR.Top), Point(tmpR.Right-1, tmpR.Bottom), 1.0);
end else
if isMono then
begin
Canvas.Stroke.Color:= $FF646464;
Canvas.DrawLine(Point(tmpR.Right-1, tmpR.Top), Point(tmpR.Right-1, tmpR.Bottom), 1.0);
end else
begin
Canvas.Stroke.Color:= $FF696969;
Canvas.DrawLine(Point(tmpR.Right-1, tmpR.Top), Point(tmpR.Right-1, tmpR.Bottom), 1.0);
end;
InflateRect(tmpR, -1, -1)
end;
if edge and BDR_SUNKENOUTER<>0 then
begin
if isSoft then
begin
Canvas.Stroke.Color:= TAlphaColorRec.White;
Canvas.DrawLine(Point(tmpR.Right-1, tmpR.Top), Point(tmpR.Right-1, tmpR.Bottom), 1.0);
end else
if IsFlat then
begin
Canvas.Stroke.Color:= $FFA0A0A0;
Canvas.DrawLine(Point(tmpR.Right-1, tmpR.Top), Point(tmpR.Right-1, tmpR.Bottom), 1.0);
end else
if isMono then
begin
Canvas.Stroke.Color:= $FF646464;
Canvas.DrawLine(Point(tmpR.Right-1, tmpR.Top), Point(tmpR.Right-1, tmpR.Bottom), 1.0);
end else
begin
Canvas.Stroke.Color:= TAlphaColorRec.White;
Canvas.DrawLine(Point(tmpR.Right-1, tmpR.Top), Point(tmpR.Right-1, tmpR.Bottom), 1.0);
end;
InflateRect(tmpR, -1, -1)
end;
Dec(tmpR.Right);
if edge and BDR_RAISEDINNER<>0 then
begin
if isSoft then
begin
Canvas.Stroke.Color:= $FFA0A0A0;
Canvas.DrawLine(Point(tmpR.Right, tmpR.Top), Point(tmpR.Right, tmpR.Bottom), 1.0);
end else
if IsFlat then
begin
Canvas.Stroke.Color:= $FFF0F0F0;
Canvas.DrawLine(Point(tmpR.Right, tmpR.Top), Point(tmpR.Right, tmpR.Bottom), 1.0);
end else
if isMono then
begin
Canvas.Stroke.Color:= TAlphaColorRec.White;
Canvas.DrawLine(Point(tmpR.Right, tmpR.Top), Point(tmpR.Right, tmpR.Bottom), 1.0);
end else
begin
Canvas.Stroke.Color:= $FFA0A0A0;
Canvas.DrawLine(Point(tmpR.Right, tmpR.Top), Point(tmpR.Right, tmpR.Bottom), 1.0);
end;
end;
if edge and BDR_SUNKENINNER<>0 then
begin
if isSoft then
begin
Canvas.Stroke.Color:= $FFE3E3E3;
Canvas.DrawLine(Point(tmpR.Right, tmpR.Top), Point(tmpR.Right, tmpR.Bottom), 1.0);
end else
if IsFlat then
begin
Canvas.Stroke.Color:= $FFE3E3E3;
Canvas.DrawLine(Point(tmpR.Right, tmpR.Top), Point(tmpR.Right, tmpR.Bottom), 1.0);
end else
if isMono then
begin
Canvas.Stroke.Color:= TAlphaColorRec.White;
Canvas.DrawLine(Point(tmpR.Right, tmpR.Top), Point(tmpR.Right, tmpR.Bottom), 1.0);
end else
begin
Canvas.Stroke.Color:= $FFE3E3E3;
Canvas.DrawLine(Point(tmpR.Right, tmpR.Top), Point(tmpR.Right, tmpR.Bottom), 1.0);
end;
end;
end;
if grfFlags and BF_BOTTOM<>0 then
begin
tmpR:= R;
Dec(tmpR.Bottom);
if edge and BDR_RAISEDOUTER<>0 then
begin
if isSoft then
begin
Canvas.Stroke.Color:= $FF696969;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Bottom), Point(tmpR.Right, tmpR.Bottom), 1.0);
end else
if IsFlat then
begin
Canvas.Stroke.Color:= $FFA0A0A0;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Bottom), Point(tmpR.Right, tmpR.Bottom), 1.0);
end else
if isMono then
begin
Canvas.Stroke.Color:= $FF646464;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Bottom), Point(tmpR.Right, tmpR.Bottom), 1.0);
end else
begin
Canvas.Stroke.Color:= $FF696969;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Bottom), Point(tmpR.Right, tmpR.Bottom), 1.0);
end;
InflateRect(tmpR, -1, -1)
end;
if edge and BDR_SUNKENOUTER<>0 then
begin
if isSoft then
begin
Canvas.Stroke.Color:= TAlphaColorRec.White;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Bottom), Point(tmpR.Right, tmpR.Bottom), 1.0);
end else
if IsFlat then
begin
Canvas.Stroke.Color:= $FFA0A0A0;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Bottom), Point(tmpR.Right, tmpR.Bottom), 1.0);
end else
if isMono then
begin
Canvas.Stroke.Color:= $FF646464;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Bottom), Point(tmpR.Right, tmpR.Bottom), 1.0);
end else
begin
Canvas.Stroke.Color:= TAlphaColorRec.White;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Bottom), Point(tmpR.Right, tmpR.Bottom), 1.0);
end;
InflateRect(tmpR, -1, -1)
end;
if edge and BDR_RAISEDINNER<>0 then
begin
if isSoft then
begin
Canvas.Stroke.Color:= $FFA0A0A0;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Bottom), Point(tmpR.Right, tmpR.Bottom), 1.0);
end else
if IsFlat then
begin
Canvas.Stroke.Color:= $FFF0F0F0;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Bottom), Point(tmpR.Right, tmpR.Bottom), 1.0);
end else
if isMono then
begin
Canvas.Stroke.Color:= TAlphaColorRec.White;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Bottom), Point(tmpR.Right, tmpR.Bottom), 1.0);
end else
begin
Canvas.Stroke.Color:= $FFA0A0A0;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Bottom), Point(tmpR.Right, tmpR.Bottom), 1.0);
end;
end;
if edge and BDR_SUNKENINNER<>0 then
begin
if isSoft then
begin
Canvas.Stroke.Color:= $FFE3E3E3;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Bottom), Point(tmpR.Right, tmpR.Bottom), 1.0);
end else
if IsFlat then
begin
Canvas.Stroke.Color:= $FFE3E3E3;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Bottom), Point(tmpR.Right, tmpR.Bottom), 1.0);
end else
if isMono then
begin
Canvas.Stroke.Color:= $FFE3E3E3;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Bottom), Point(tmpR.Right, tmpR.Bottom), 1.0);
end else
begin
Canvas.Stroke.Color:= $FFE3E3E3;
Canvas.DrawLine(Point(tmpR.Left, tmpR.Bottom), Point(tmpR.Right, tmpR.Bottom), 1.0);
end;
end;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure GetTextExtentPoint32W(ACanvas: TCanvas; CaptionText: String; Len: Integer; Var Size: TSize);
begin
Size.cx:= ACanvas.TextWidth(Copy(CaptionText, 1, Len));
Size.cy:= ACanvas.TextHeight(Copy(CaptionText, 1, Len));
end;
//----------------------------------------------------------------------------------------------------------------------
procedure GetTextMetrics(ACanvas: TCanvas; var TM: TTextMetric);
Var P: TPathData;
tx: TTextLayout;
R: TRectF;
begin
{
tmHeight: Single; //The height (ascent + descent) of characters.
tmAscent: Single; //The ascent (units above the base line) of characters.
tmDescent: Single; //The descent (units below the base line) of characters.
tmInternalLeading: Single; //The amount of leading (space) inside the bounds set by the tmHeight member. Accent marks and other diacritical characters may occur in this area. The designer may set this member to zero
tmExternalLeading: Single; //The amount of extra leading (space) that the application adds between rows. Since this area is outside the font, it contains no marks and is not altered by text output calls in either OPAQUE or TRANSPARENT mode. The designer may set this member to zero.
tmAveCharWidth: Single; //The average width of characters in the font (generally defined as the width of the letter x ). This value does not include the overhang required for bold or italic characters.
tmMaxCharWidth: Single; //The width of the widest character in the font.
tmWeight: Single; //The weight of the font.
tmOverhang: Single;
tmDigitizedAspectX: Single; //The horizontal aspect of the device for which the font was designed.
tmDigitizedAspectY: Single; //The vertical aspect of the device for which the font was designed. The ratio of the tmDigitizedAspectX and tmDigitizedAspectY members is the aspect ratio of the device for which the font was designed.
tmFirstChar: WideChar; //The value of the first character defined in the font.
tmLastChar: WideChar; //The value of the last character defined in the font.
tmDefaultChar: WideChar; //The value of the character to be substituted for characters not in the font.
tmBreakChar: WideChar; //The value of the character that will be used to define word breaks for text justification.
tmItalic: Byte; //Specifies an italic font if it is nonzero.
tmUnderlined: Byte; //Specifies an underlined font if it is nonzero.
tmStruckOut: Byte; //A strikeout font if it is nonzero.
tmPitchAndFamily: Byte; //Specifies information about the pitch, the technology, and the family of a physical font. TMPF_FIXED_PITCH, TMPF_VECTOR, TMPF_TRUETYPE, TMPF_DEVICE
tmCharSet: Byte; //The character set of the font. The character set can be one of the following values. ANSI_CHARSET, GREEK_CHARSET....
}
TM.tmExternalLeading:= 0;
TM.tmWeight:= 0; //boldness???
TM.tmOverhang:= 0;
TM.tmDigitizedAspectX:= 0;
TM.tmDigitizedAspectY:= 0;
TM.tmFirstChar:= 'a'; //???
TM.tmLastChar:= 'z'; //???
TM.tmDefaultChar:= ' ';
TM.tmBreakChar:= ' ';
TM.tmItalic:= 0;
TM.tmUnderlined:= 0;
TM.tmStruckOut:= 0;
TM.tmPitchAndFamily:= 0;
TM.tmCharSet:= 0;
tx:= TTextLayoutManager.DefaultTextLayout.Create(ACanvas);
P:= TPathData.Create;
try
tx.Text:= 'W';
tx.ConvertToPath(p);
R:= P.GetBounds();
TM.tmHeight:= R.Height;
TM.tmMaxCharWidth:= R.Width;
//------------------------------------
tx.Text:= 'Ó';
p.Clear;
tx.ConvertToPath(p);
R:= P.GetBounds();
TM.tmInternalLeading:= R.Height - TM.tmHeight;
//------------------------------------
tx.Text:= 'x';
p.Clear;
tx.ConvertToPath(p);
R:= P.GetBounds();
TM.tmAscent:= R.Height - TM.tmHeight;
TM.tmAveCharWidth:= R.Width;
//------------------------------------
tx.Text:= 'y';
p.Clear;
tx.ConvertToPath(p);
TM.tmDescent:= P.GetBounds().Height - R.Height;
TM.tmHeight:= TM.tmHeight + TM.tmDescent;
finally
FreeAndNil(P);
FreeAndNil(tx);
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function Rect(ALeft, ATop, ARight, ABottom: Single): TRect;
begin
Result:= RectF(ALeft, ATop, ARight, ABottom);
end;
//----------------------------------------------------------------------------------------------------------------------
function Rect(const ATopLeft, ABottomRight: TPoint): TRect;
begin
Result:= RectF(ATopLeft.X, ATopLeft.Y, ABottomRight.X, ABottomRight.Y);
end;
//----------------------------------------------------------------------------------------------------------------------
function Point(AX, AY: Single): TPoint;
begin
Result.X:= AX;
Result.Y:= AY;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure Inc(Var V: Single; OIle: Single=1.0);
begin
V:= V + OIle;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure Dec(Var V: Single; OIle: Single=1.0);
begin
V:= V - OIle;
end;
//----------------------------------------------------------------------------------------------------------------------
function MulDiv(const A, B, C: Single): Single;
begin
Result:= (A * B) / C;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure FillMemory(Destination: Pointer; Length: NativeUInt; Fill: Byte);
begin
FillChar(Destination^, Length, Fill);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure ZeroMemory(Destination: Pointer; Length: NativeUInt);
begin
FillChar(Destination^, Length, 0);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure MoveMemory(Destination: Pointer; Source: Pointer; Length: NativeUInt);
begin
Move(Source^, Destination^, Length);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure CopyMemory(Destination: Pointer; Source: Pointer; Length: NativeUInt);
begin
Move(Source^, Destination^, Length);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure ChangeBiDiModeAlignment(var Alignment: TAlignment);
begin
case Alignment of
taLeftJustify: Alignment := taRightJustify;
taRightJustify: Alignment := taLeftJustify;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure OleUninitialize();
begin
//nothing
end;
//----------------------------------------------------------------------------------------------------------------------
function timeGetTime: Int64;
begin
Result:= TThread.GetTickCount;
end;
{ TChangeLink }
//----------------------------------------------------------------------------------------------------------------------
constructor TChangeLink.Create;
begin
inherited;
IgnoreIndex := True;
IgnoreImages := True;
end;
//----------------------------------------------------------------------------------------------------------------------
function TChangeLink.GetSender: TCustomImageList;
begin
Result := TCustomImageList(Images);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TChangeLink.SetSender(const Value: TCustomImageList);
begin
Images := TBaseImageList(Value);
end;
{ THighQualityBitmap }
constructor THighQualityBitmap.Create;
begin
inherited;
end;
{ TFontHelper }
function TFontHelper.GetOnChange: TNotifyEvent;
begin
Result:= OnChanged;
end;
procedure TFontHelper.SetOnChange(const Value: TNotifyEvent);
begin
OnChanged:= Value;
end;
end.
Reference in New Issue View Git Blame Copy Permalink