mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-04-06 09:57:54 +02:00
9766005317
Merge request freepascal.org/lazarus/lazarus!46 with minor change (enabled aliasing for FPC 3.2.3 too).
(cherry picked from commit 53fe133e43)
2845 lines
104 KiB
ObjectPascal
2845 lines
104 KiB
ObjectPascal
{
|
|
/***************************************************************************
|
|
graphics.pp
|
|
-----------
|
|
Graphic Controls
|
|
Initial Revision : Mon Jul 26 0:02:58 1999
|
|
|
|
***************************************************************************/
|
|
|
|
*****************************************************************************
|
|
This file is part of the Lazarus Component Library (LCL)
|
|
|
|
See the file COPYING.modifiedLGPL.txt, included in this distribution,
|
|
for details about the license.
|
|
*****************************************************************************
|
|
}
|
|
unit Graphics;
|
|
|
|
{$mode objfpc}{$H+}
|
|
{$I lcl_defines.inc}
|
|
|
|
interface
|
|
|
|
{$ifdef Trace}
|
|
{$ASSERTIONS ON}
|
|
{$endif}
|
|
|
|
{$IF FPC_FULLVERSION>=20601}
|
|
{$DEFINE HasFPCanvas1}
|
|
{$ENDIF}
|
|
|
|
{$IF FPC_FULLVERSION>=20603}
|
|
{$DEFINE HasFPEndCap}
|
|
{$ENDIF}
|
|
|
|
{$IF FPC_FULLVERSION>=20603}
|
|
{$DEFINE HasFPJoinStyle}
|
|
{$ENDIF}
|
|
|
|
{$IF FPC_FULLVERSION>=30203}
|
|
{$DEFINE UseSystemUITypes}
|
|
{$ENDIF}
|
|
|
|
uses
|
|
// RTL + FCL
|
|
SysUtils, Math, Types, Classes, Contnrs, Laz_AVL_Tree,
|
|
FPImage, FPCanvas,
|
|
FPWriteBMP, // bmp support
|
|
FPWritePNG, PNGComn, // png support
|
|
{$IFNDEF DisableLCLPNM}
|
|
FPReadPNM, FPWritePNM, // PNM (Portable aNyMap) support
|
|
{$ENDIF}
|
|
{$IFNDEF DisableLCLJPEG}
|
|
FPReadJpeg, FPWriteJpeg, // jpg support
|
|
{$ENDIF}
|
|
{$IFNDEF DisableLCLTIFF}
|
|
FPReadTiff, FPTiffCmn, // tiff support
|
|
{$ENDIF}
|
|
{$IFNDEF DisableLCLGIF}
|
|
FPReadGif,
|
|
{$ENDIF}
|
|
{$IFDEF UseSystemUITypes}
|
|
System.UITypes,
|
|
{$ENDIF}
|
|
// LCL
|
|
LCLVersion, LCLStrConsts, LCLType, LCLProc, LMessages, LResources, LCLResCache,
|
|
IntfGraphics, IcnsTypes, WSReferences,
|
|
// LazUtils
|
|
GraphType, GraphMath, FPCAdds, LazLoggerBase, LazTracer, LazUtilities;
|
|
|
|
type
|
|
PColor = {$IFDEF UseSystemUITypes}System.UITypes.PColor{$ELSE}^TColor{$ENDIF};
|
|
TColor = TGraphicsColor;
|
|
|
|
TFontPitch = (fpDefault, fpVariable, fpFixed);
|
|
TFontName = string;
|
|
TFontDataName = string[LF_FACESIZE -1];
|
|
TFontStyle = (fsBold, fsItalic, fsUnderline, fsStrikeOut);
|
|
TFontStyles = set of TFontStyle;
|
|
TFontStylesbase = set of TFontStyle;
|
|
TFontCharSet = 0..255;
|
|
TFontQuality = (fqDefault, fqDraft, fqProof, fqNonAntialiased, fqAntialiased,
|
|
fqCleartype, fqCleartypeNatural);
|
|
|
|
TFontData = record
|
|
Handle: HFont;
|
|
Height: Integer;
|
|
Pitch: TFontPitch;
|
|
Style: TFontStylesBase;
|
|
CharSet: TFontCharSet;
|
|
Quality: TFontQuality;
|
|
Name: TFontDataName;
|
|
Orientation: Integer;
|
|
end;
|
|
|
|
var
|
|
// New TFont instances are initialized with the values in this structure.
|
|
// About font default values: The default font is chosen by the interfaces
|
|
// depending on the context. For example, there can be a different default
|
|
// font for a button and a groupbox.
|
|
DefFontData: TFontData = (
|
|
Handle: 0;
|
|
Height: 0;
|
|
Pitch: fpDefault;
|
|
Style: [];
|
|
Charset: DEFAULT_CHARSET;
|
|
Quality: fqDefault;
|
|
Name: 'default';
|
|
Orientation: 0;
|
|
);
|
|
|
|
type
|
|
{ Reflects text style when drawn in a rectangle }
|
|
|
|
TTextLayout = (tlTop, tlCenter, tlBottom);
|
|
TTextStyle = packed record
|
|
Alignment : TAlignment; // TextRect Only: horizontal alignment
|
|
|
|
Layout : TTextLayout; // TextRect Only: vertical alignment
|
|
|
|
SingleLine: boolean; // If WordBreak is false then process #13, #10 as
|
|
// standard chars and perform no Line breaking.
|
|
|
|
Clipping : boolean; // TextRect Only: Clip Text to passed Rectangle
|
|
|
|
ExpandTabs: boolean; // Replace #9 by apropriate amount of spaces (default is usually 8)
|
|
|
|
ShowPrefix: boolean; // TextRect Only: Process first single '&' per
|
|
// line as an underscore and draw '&&' as '&'
|
|
|
|
Wordbreak : boolean; // TextRect Only: If line of text is too long
|
|
// too fit between left and right boundaries
|
|
// try to break into multiple lines between
|
|
// words
|
|
// See also EndEllipsis.
|
|
|
|
Opaque : boolean; // TextRect: Fills background with current Brush
|
|
// TextOut : Fills background with current
|
|
// foreground color
|
|
|
|
SystemFont: Boolean; // Use the system font instead of Canvas Font
|
|
|
|
RightToLeft: Boolean; //For RightToLeft text reading (Text Direction)
|
|
|
|
EndEllipsis: Boolean; // TextRect Only: If line of text is too long
|
|
// to fit between left and right boundaries
|
|
// truncates the text and adds "..."
|
|
// If Wordbreak is set as well, Workbreak will
|
|
// dominate.
|
|
end;
|
|
|
|
const
|
|
psSolid = FPCanvas.psSolid;
|
|
psDash = FPCanvas.psDash;
|
|
psDot = FPCanvas.psDot;
|
|
psDashDot = FPCanvas.psDashDot;
|
|
psDashDotDot = FPCanvas.psDashDotDot;
|
|
psClear = FPCanvas.psClear;
|
|
psInsideframe = FPCanvas.psInsideframe;
|
|
psPattern = FPCanvas.psPattern;
|
|
|
|
pmBlack = FPCanvas.pmBlack;
|
|
pmWhite = FPCanvas.pmWhite;
|
|
pmNop = FPCanvas.pmNop;
|
|
pmNot = FPCanvas.pmNot;
|
|
pmCopy = FPCanvas.pmCopy;
|
|
pmNotCopy = FPCanvas.pmNotCopy;
|
|
pmMergePenNot = FPCanvas.pmMergePenNot;
|
|
pmMaskPenNot = FPCanvas.pmMaskPenNot;
|
|
pmMergeNotPen = FPCanvas.pmMergeNotPen;
|
|
pmMaskNotPen = FPCanvas.pmMaskNotPen;
|
|
pmMerge = FPCanvas.pmMerge;
|
|
pmNotMerge = FPCanvas.pmNotMerge;
|
|
pmMask = FPCanvas.pmMask;
|
|
pmNotMask = FPCanvas.pmNotMask;
|
|
pmXor = FPCanvas.pmXor;
|
|
pmNotXor = FPCanvas.pmNotXor;
|
|
|
|
bsSolid = FPCanvas.bsSolid;
|
|
bsClear = FPCanvas.bsClear;
|
|
bsHorizontal = FPCanvas.bsHorizontal;
|
|
bsVertical = FPCanvas.bsVertical;
|
|
bsFDiagonal = FPCanvas.bsFDiagonal;
|
|
bsBDiagonal = FPCanvas.bsBDiagonal;
|
|
bsCross = FPCanvas.bsCross;
|
|
bsDiagCross = FPCanvas.bsDiagCross;
|
|
|
|
{$IFDEF HasFPEndCap}
|
|
pecRound = FPCanvas.pecRound;
|
|
pecSquare = FPCanvas.pecSquare;
|
|
pecFlat = FPCanvas.pecFlat;
|
|
{$ENDIF}
|
|
|
|
{$IFDEF HasFPJoinStyle}
|
|
pjsRound = FPCanvas.pjsRound;
|
|
pjsBevel = FPCanvas.pjsBevel;
|
|
pjsMiter =FPCanvas.pjsMiter;
|
|
{$ENDIF}
|
|
|
|
type
|
|
TFillStyle = TGraphicsFillStyle;
|
|
TFillMode = (fmAlternate, fmWinding);
|
|
|
|
TCopymode = longint;
|
|
|
|
TCanvasStates = (csHandleValid,
|
|
csFontValid, // true if Font properties correspond to
|
|
// selected Font Handle in DC
|
|
csPenvalid, csBrushValid, csRegionValid);
|
|
TCanvasState = set of TCanvasStates;
|
|
TCanvasOrientation = (csLefttoRight, coRighttoLeft);
|
|
|
|
{ TProgressEvent }
|
|
TProgressStage = TFPImgProgressStage;
|
|
TProgressEvent = TFPImgProgressEvent;
|
|
|
|
{ For Delphi compatibility }
|
|
TPixelFormat = (
|
|
pfDevice,
|
|
pf1bit,
|
|
pf4bit,
|
|
pf8bit,
|
|
pf15bit,
|
|
pf16bit,
|
|
pf24bit,
|
|
pf32bit,
|
|
pfCustom
|
|
);
|
|
|
|
const
|
|
PIXELFORMAT_BPP: array[TPixelFormat] of Byte = (
|
|
0, 1, 4, 8, 15, 16, 24, 32, 0
|
|
);
|
|
|
|
|
|
type
|
|
TTransparentMode = (
|
|
tmAuto,
|
|
tmFixed
|
|
);
|
|
|
|
const
|
|
// The following colors match the predefined Delphi Colors
|
|
|
|
// standard colors
|
|
clBlack = TColor($000000);
|
|
clMaroon = TColor($000080);
|
|
clGreen = TColor($008000);
|
|
clOlive = TColor($008080);
|
|
clNavy = TColor($800000);
|
|
clPurple = TColor($800080);
|
|
clTeal = TColor($808000);
|
|
clGray = TColor($808080);
|
|
clSilver = TColor($C0C0C0);
|
|
clRed = TColor($0000FF);
|
|
clLime = TColor($00FF00);
|
|
clYellow = TColor($00FFFF);
|
|
clBlue = TColor($FF0000);
|
|
clFuchsia = TColor($FF00FF);
|
|
clAqua = TColor($FFFF00);
|
|
clLtGray = TColor($C0C0C0); // clSilver alias
|
|
clDkGray = TColor($808080); // clGray alias
|
|
clWhite = TColor($FFFFFF);
|
|
StandardColorsCount = 16;
|
|
|
|
// extended colors
|
|
clMoneyGreen = TColor($C0DCC0);
|
|
clSkyBlue = TColor($F0CAA6);
|
|
clCream = TColor($F0FBFF);
|
|
clMedGray = TColor($A4A0A0);
|
|
ExtendedColorCount = 4;
|
|
|
|
// special colors
|
|
clNone = TColor($1FFFFFFF);
|
|
clDefault = TColor($20000000);
|
|
|
|
// system colors
|
|
clScrollBar = TColor(SYS_COLOR_BASE or COLOR_SCROLLBAR);
|
|
clBackground = TColor(SYS_COLOR_BASE or COLOR_BACKGROUND);
|
|
clActiveCaption = TColor(SYS_COLOR_BASE or COLOR_ACTIVECAPTION);
|
|
clInactiveCaption = TColor(SYS_COLOR_BASE or COLOR_INACTIVECAPTION);
|
|
clMenu = TColor(SYS_COLOR_BASE or COLOR_MENU);
|
|
clWindow = TColor(SYS_COLOR_BASE or COLOR_WINDOW);
|
|
clWindowFrame = TColor(SYS_COLOR_BASE or COLOR_WINDOWFRAME);
|
|
clMenuText = TColor(SYS_COLOR_BASE or COLOR_MENUTEXT);
|
|
clWindowText = TColor(SYS_COLOR_BASE or COLOR_WINDOWTEXT);
|
|
clCaptionText = TColor(SYS_COLOR_BASE or COLOR_CAPTIONTEXT);
|
|
clActiveBorder = TColor(SYS_COLOR_BASE or COLOR_ACTIVEBORDER);
|
|
clInactiveBorder = TColor(SYS_COLOR_BASE or COLOR_INACTIVEBORDER);
|
|
clAppWorkspace = TColor(SYS_COLOR_BASE or COLOR_APPWORKSPACE);
|
|
clHighlight = TColor(SYS_COLOR_BASE or COLOR_HIGHLIGHT);
|
|
clHighlightText = TColor(SYS_COLOR_BASE or COLOR_HIGHLIGHTTEXT);
|
|
clBtnFace = TColor(SYS_COLOR_BASE or COLOR_BTNFACE);
|
|
clBtnShadow = TColor(SYS_COLOR_BASE or COLOR_BTNSHADOW);
|
|
clGrayText = TColor(SYS_COLOR_BASE or COLOR_GRAYTEXT);
|
|
clBtnText = TColor(SYS_COLOR_BASE or COLOR_BTNTEXT);
|
|
clInactiveCaptionText = TColor(SYS_COLOR_BASE or COLOR_INACTIVECAPTIONTEXT);
|
|
clBtnHighlight = TColor(SYS_COLOR_BASE or COLOR_BTNHIGHLIGHT);
|
|
cl3DDkShadow = TColor(SYS_COLOR_BASE or COLOR_3DDKSHADOW);
|
|
cl3DLight = TColor(SYS_COLOR_BASE or COLOR_3DLIGHT);
|
|
clInfoText = TColor(SYS_COLOR_BASE or COLOR_INFOTEXT);
|
|
clInfoBk = TColor(SYS_COLOR_BASE or COLOR_INFOBK);
|
|
|
|
clHotLight = TColor(SYS_COLOR_BASE or COLOR_HOTLIGHT);
|
|
clGradientActiveCaption = TColor(SYS_COLOR_BASE or COLOR_GRADIENTACTIVECAPTION);
|
|
clGradientInactiveCaption = TColor(SYS_COLOR_BASE or COLOR_GRADIENTINACTIVECAPTION);
|
|
clMenuHighlight = TColor(SYS_COLOR_BASE or COLOR_MENUHILIGHT);
|
|
clMenuBar = TColor(SYS_COLOR_BASE or COLOR_MENUBAR);
|
|
clForm = TColor(SYS_COLOR_BASE or COLOR_FORM);
|
|
|
|
// synonyms: do not show them in color lists
|
|
clColorDesktop = TColor(SYS_COLOR_BASE or COLOR_DESKTOP);
|
|
cl3DFace = TColor(SYS_COLOR_BASE or COLOR_3DFACE);
|
|
cl3DShadow = TColor(SYS_COLOR_BASE or COLOR_3DSHADOW);
|
|
cl3DHiLight = TColor(SYS_COLOR_BASE or COLOR_3DHIGHLIGHT);
|
|
clBtnHiLight = TColor(SYS_COLOR_BASE or COLOR_BTNHILIGHT);
|
|
|
|
clFirstSpecialColor = clBtnHiLight;
|
|
|
|
clMask = clWhite;
|
|
clDontMask = clBlack;
|
|
|
|
// !! deprecated colors !!
|
|
{$IFDEF DefineCLXColors}
|
|
// CLX base, mapped, pseudo, rgb values
|
|
clForeground = TColor(-1) deprecated;
|
|
clButton = TColor(-2) deprecated;
|
|
clLight = TColor(-3) deprecated;
|
|
clMidlight = TColor(-4) deprecated;
|
|
clDark = TColor(-5) deprecated;
|
|
clMid = TColor(-6) deprecated;
|
|
clText = TColor(-7) deprecated;
|
|
clBrightText = TColor(-8) deprecated;
|
|
clButtonText = TColor(-9) deprecated;
|
|
clBase = TColor(-10) deprecated;
|
|
clxBackground = TColor(-11) deprecated;
|
|
clShadow = TColor(-12) deprecated;
|
|
clxHighlight = TColor(-13) deprecated;
|
|
clHighlightedText = TColor(-14) deprecated;
|
|
|
|
// CLX mapped role offsets
|
|
cloNormal = 32 deprecated;
|
|
cloDisabled = 64 deprecated;
|
|
cloActive = 96 deprecated;
|
|
|
|
// CLX normal, mapped, pseudo, rgb values
|
|
clNormalForeground = TColor(clForeground - cloNormal) deprecated;
|
|
clNormalButton = TColor(clButton - cloNormal) deprecated;
|
|
clNormalLight = TColor(clLight - cloNormal) deprecated;
|
|
clNormalMidlight = TColor(clMidlight - cloNormal) deprecated;
|
|
clNormalDark = TColor(clDark - cloNormal) deprecated;
|
|
clNormalMid = TColor(clMid - cloNormal) deprecated;
|
|
clNormalText = TColor(clText - cloNormal) deprecated;
|
|
clNormalBrightText = TColor(clBrightText - cloNormal) deprecated;
|
|
clNormalButtonText = TColor(clButtonText - cloNormal) deprecated;
|
|
clNormalBase = TColor(clBase - cloNormal) deprecated;
|
|
clNormalBackground = TColor(clxBackground - cloNormal) deprecated;
|
|
clNormalShadow = TColor(clShadow - cloNormal) deprecated;
|
|
clNormalHighlight = TColor(clxHighlight - cloNormal) deprecated;
|
|
clNormalHighlightedText = TColor(clHighlightedText - cloNormal) deprecated;
|
|
|
|
// CLX disabled, mapped, pseudo, rgb values
|
|
clDisabledForeground = TColor(clForeground - cloDisabled) deprecated;
|
|
clDisabledButton = TColor(clButton - cloDisabled) deprecated;
|
|
clDisabledLight = TColor(clLight - cloDisabled) deprecated;
|
|
clDisabledMidlight = TColor(clMidlight - cloDisabled) deprecated;
|
|
clDisabledDark = TColor(clDark - cloDisabled) deprecated;
|
|
clDisabledMid = TColor(clMid - cloDisabled) deprecated;
|
|
clDisabledText = TColor(clText - cloDisabled) deprecated;
|
|
clDisabledBrightText = TColor(clBrightText - cloDisabled) deprecated;
|
|
clDisabledButtonText = TColor(clButtonText - cloDisabled) deprecated;
|
|
clDisabledBase = TColor(clBase - cloDisabled) deprecated;
|
|
clDisabledBackground = TColor(clxBackground - cloDisabled) deprecated;
|
|
clDisabledShadow = TColor(clShadow - cloDisabled) deprecated;
|
|
clDisabledHighlight = TColor(clxHighlight - cloDisabled) deprecated;
|
|
clDisabledHighlightedText = TColor(clHighlightedText - cloDisabled) deprecated;
|
|
|
|
// CLX active, mapped, pseudo, rgb values
|
|
clActiveForeground = TColor(clForeground - cloActive) deprecated;
|
|
clActiveButton = TColor(clButton - cloActive) deprecated;
|
|
clActiveLight = TColor(clLight - cloActive) deprecated;
|
|
clActiveMidlight = TColor(clMidlight - cloActive) deprecated;
|
|
clActiveDark = TColor(clDark - cloActive) deprecated;
|
|
clActiveMid = TColor(clMid - cloActive) deprecated;
|
|
clActiveText = TColor(clText - cloActive) deprecated;
|
|
clActiveBrightText = TColor(clBrightText - cloActive) deprecated;
|
|
clActiveButtonText = TColor(clButtonText - cloActive) deprecated;
|
|
clActiveBase = TColor(clBase - cloActive) deprecated;
|
|
clActiveBackground = TColor(clxBackground - cloActive) deprecated;
|
|
clActiveShadow = TColor(clShadow - cloActive) deprecated;
|
|
clActiveHighlight = TColor(clxHighlight - cloActive) deprecated;
|
|
clActiveHighlightedText = TColor(clHighlightedText - cloActive) deprecated;
|
|
|
|
type
|
|
TMappedColor = clActiveHighlightedText..clNormalForeground;
|
|
|
|
TColorGroup = (cgInactive, cgDisabled, cgActive);
|
|
TColorRole = (crForeground, crButton, crLight, crMidlight, crDark, crMid,
|
|
crText, crBrightText, crButtonText, crBase, crBackground, crShadow,
|
|
crHighlight, crHighlightText, crNoRole);
|
|
{$ENDIF}
|
|
|
|
const
|
|
cmBlackness = BLACKNESS;
|
|
cmDstInvert = DSTINVERT;
|
|
cmMergeCopy = MERGECOPY;
|
|
cmMergePaint = MERGEPAINT;
|
|
cmNotSrcCopy = NOTSRCCOPY;
|
|
cmNotSrcErase = NOTSRCERASE;
|
|
cmPatCopy = PATCOPY;
|
|
cmPatInvert = PATINVERT;
|
|
cmPatPaint = PATPAINT;
|
|
cmSrcAnd = SRCAND;
|
|
cmSrcCopy = SRCCOPY;
|
|
cmSrcErase = SRCERASE;
|
|
cmSrcInvert = SRCINVERT;
|
|
cmSrcPaint = SRCPAINT;
|
|
cmWhiteness = WHITENESS;
|
|
|
|
|
|
type
|
|
TCanvas = class;
|
|
|
|
// base class
|
|
TRasterImage = class;
|
|
TRasterImageClass = class of TRasterImage;
|
|
TCustomBitmap = class;
|
|
TCustomBitmapClass = class of TCustomBitmap;
|
|
// standard LCL graphic formats
|
|
TBitmap = class; // bmp
|
|
TPixmap = class; // xpm
|
|
TIcon = class; // ico
|
|
TPortableNetworkGraphic = class; // png
|
|
{$IFNDEF DisableLCLPNM}
|
|
TPortableAnyMapGraphic = class; // pnm formats: pbm, pgm and ppm
|
|
{$ENDIF}
|
|
{$IFNDEF DisableLCLJPEG}
|
|
TJpegImage = class; // jpg
|
|
{$ENDIF}
|
|
{$IFNDEF DisableLCLGIF}
|
|
TGIFImage = class; // gif (read only)
|
|
{$ENDIF}
|
|
|
|
{ TGraphicsObject
|
|
In Delphi VCL this is the ancestor of TFont, TPen and TBrush.
|
|
Since FPC 2.0 the LCL uses TFPCanvasHelper as ancestor. }
|
|
|
|
TGraphicsObject = class(TPersistent)
|
|
private
|
|
FOnChanging: TNotifyEvent;
|
|
FOnChange: TNotifyEvent;
|
|
procedure DoChange(var Msg); message LM_CHANGED;
|
|
protected
|
|
procedure Changing; virtual;
|
|
procedure Changed; virtual;
|
|
procedure Lock;
|
|
procedure UnLock;
|
|
public
|
|
property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
|
|
property OnChange: TNotifyEvent read FOnChange write FOnChange;
|
|
end;
|
|
|
|
{ TFontHandleCacheDescriptor }
|
|
|
|
TFontHandleCacheDescriptor = class(TResourceCacheDescriptor)
|
|
public
|
|
LogFont: TLogFont;
|
|
LongFontName: string;
|
|
end;
|
|
|
|
{ TFontHandleCache }
|
|
|
|
TFontHandleCache = class(TResourceCache)
|
|
protected
|
|
procedure RemoveItem(Item: TResourceCacheItem); override;
|
|
public
|
|
constructor Create;
|
|
function CompareDescriptors(Tree: TAvlTree; Desc1, Desc2: Pointer): integer; override;
|
|
function FindFont(TheFont: TLCLHandle): TResourceCacheItem;
|
|
function FindFontDesc(const LogFont: TLogFont;
|
|
const LongFontName: string): TFontHandleCacheDescriptor;
|
|
function Add(TheFont: TLCLHandle; const LogFont: TLogFont;
|
|
const LongFontName: string): TFontHandleCacheDescriptor;
|
|
end;
|
|
|
|
{ TFont }
|
|
|
|
TFont = class(TFPCustomFont)
|
|
private
|
|
FIsMonoSpace: boolean;
|
|
FIsMonoSpaceValid: boolean;
|
|
FOrientation: Integer;
|
|
FPitch: TFontPitch;
|
|
FQuality: TFontQuality;
|
|
FStyle: TFontStylesBase;
|
|
FCharSet: TFontCharSet;
|
|
FPixelsPerInch: Integer;
|
|
FUpdateCount: integer;
|
|
FChanged: boolean;
|
|
FFontHandleCached: boolean;
|
|
FColor: TColor;
|
|
FHeight: integer; // FHeight = -(FSize * FPixelsPerInch) div 72
|
|
FReference: TWSFontReference;
|
|
procedure FreeReference;
|
|
function GetHandle: HFONT;
|
|
function GetData: TFontData;
|
|
function GetIsMonoSpace: boolean;
|
|
function GetReference: TWSFontReference;
|
|
function IsHeightStored: boolean;
|
|
function IsNameStored: boolean;
|
|
procedure SetData(const FontData: TFontData);
|
|
procedure SetHandle(const Value: HFONT);
|
|
procedure ReferenceNeeded;
|
|
procedure SetPixelsPerInch(const APixelsPerInch: Integer);
|
|
protected
|
|
function GetCharSet: TFontCharSet;
|
|
function GetHeight: Integer;
|
|
function GetName: string;
|
|
function GetOrientation: Integer;
|
|
function GetPitch: TFontPitch;
|
|
function GetSize: Integer;
|
|
function GetStyle: TFontStyles;
|
|
procedure Changed; override;
|
|
procedure DoAllocateResources; override;
|
|
procedure DoCopyProps(From: TFPCanvasHelper); override;
|
|
procedure DoDeAllocateResources; override;
|
|
procedure SetCharSet(const AValue: TFontCharSet);
|
|
procedure SetColor(const NewColor: TColor; const NewFPColor: TFPColor); virtual;
|
|
procedure SetColor(Value: TColor);
|
|
function GetColor: TColor;
|
|
procedure SetFlags(Index: integer; AValue: boolean); override;
|
|
procedure SetFPColor(const AValue: TFPColor); override;
|
|
procedure SetHeight(Avalue: Integer);
|
|
procedure SetName(AValue: string); override;
|
|
procedure SetOrientation(AValue: Integer); override; // This was introduced in 2.5 quite late, and the Android pre-compiled compiler was before this, so I prefer to let it only for 2.6
|
|
procedure SetPitch(Value: TFontPitch);
|
|
procedure SetSize(AValue: integer); override;
|
|
procedure SetStyle(Value: TFontStyles);
|
|
procedure SetQuality(const AValue: TFontQuality);
|
|
public
|
|
constructor Create; override;
|
|
destructor Destroy; override;
|
|
procedure Assign(Source: TPersistent); override;
|
|
procedure Assign(const ALogFont: TLogFont);
|
|
procedure BeginUpdate;
|
|
procedure EndUpdate;
|
|
property FontData: TFontData read GetData write SetData;
|
|
function HandleAllocated: boolean;
|
|
property Handle: HFONT read GetHandle write SetHandle;
|
|
function IsDefault: boolean;
|
|
function IsEqual(AFont: TFont): boolean; virtual;
|
|
property IsMonoSpace: boolean read GetIsMonoSpace;
|
|
procedure SetDefault;
|
|
property PixelsPerInch: Integer read FPixelsPerInch write SetPixelsPerInch;
|
|
property Reference: TWSFontReference read GetReference;
|
|
published
|
|
property CharSet: TFontCharSet read GetCharSet write SetCharSet default DEFAULT_CHARSET;
|
|
property Color: TColor read FColor write SetColor default {$ifdef UseCLDefault}clDefault{$else}clWindowText{$endif};
|
|
property Height: Integer read GetHeight write SetHeight stored IsHeightStored;
|
|
property Name: string read GetName write SetName stored IsNameStored;
|
|
property Orientation: Integer read GetOrientation write SetOrientation default 0;
|
|
property Pitch: TFontPitch read GetPitch write SetPitch default fpDefault;
|
|
property Quality: TFontQuality read FQuality write SetQuality default fqDefault;
|
|
property Size: Integer read GetSize write SetSize stored false;
|
|
property Style: TFontStyles read GetStyle write SetStyle default [];
|
|
end;
|
|
|
|
{ TPen }
|
|
|
|
TPenStyle = TFPPenStyle;
|
|
TPenMode = TFPPenMode;
|
|
|
|
// pen end caps. valid only for geometric pens
|
|
{$IFDEF HasFPEndCap}
|
|
TPenEndCap = TFPPenEndCap;
|
|
{$ELSE}
|
|
TPenEndCap = (
|
|
pecRound,
|
|
pecSquare,
|
|
pecFlat
|
|
);
|
|
{$ENDIF}
|
|
|
|
// join style. valid only for geometric pens
|
|
{$IFDEF HasFPJoinStyle}
|
|
TPenJoinStyle = FPCanvas.TFPPenJoinStyle;
|
|
{$ELSE}
|
|
TPenJoinStyle = (
|
|
pjsRound,
|
|
pjsBevel,
|
|
pjsMiter
|
|
);
|
|
{$ENDIF}
|
|
|
|
TPenPattern = array of LongWord;
|
|
|
|
{ TPenHandleCacheDescriptor }
|
|
|
|
TPenHandleCacheDescriptor = class(TResourceCacheDescriptor)
|
|
public
|
|
ExtPen: TExtLogPen;
|
|
Pattern: TPenPattern;
|
|
end;
|
|
|
|
{ TPenHandleCache }
|
|
|
|
TPenHandleCache = class(TResourceCache)
|
|
protected
|
|
procedure RemoveItem(Item: TResourceCacheItem); override;
|
|
public
|
|
constructor Create;
|
|
function CompareDescriptors(Tree: TAvlTree; Desc1, Desc2: Pointer): integer; override;
|
|
function FindPen(APen: TLCLHandle): TResourceCacheItem;
|
|
function FindPenDesc(const AExtPen: TExtLogPen;
|
|
const APattern: TPenPattern): TPenHandleCacheDescriptor;
|
|
function Add(APen: TLCLHandle; const AExtPen: TExtLogPen;
|
|
const APattern: TPenPattern): TPenHandleCacheDescriptor;
|
|
end;
|
|
|
|
TPen = class(TFPCustomPen)
|
|
private
|
|
FColor: TColor;
|
|
{$IFNDEF HasFPEndCap}
|
|
FEndCap: TPenEndCap;
|
|
{$ENDIF}
|
|
FCosmetic: Boolean;
|
|
{$IFNDEF HasFPJoinStyle}
|
|
FJoinStyle: TPenJoinStyle;
|
|
{$ENDIF}
|
|
FPattern: TPenPattern;
|
|
FPenHandleCached: boolean;
|
|
FReference: TWSPenReference;
|
|
procedure FreeReference;
|
|
function GetHandle: HPEN;
|
|
function GetReference: TWSPenReference;
|
|
procedure ReferenceNeeded;
|
|
procedure SetCosmetic(const AValue: Boolean);
|
|
procedure SetHandle(const Value: HPEN);
|
|
protected
|
|
procedure DoAllocateResources; override;
|
|
procedure DoDeAllocateResources; override;
|
|
procedure DoCopyProps(From: TFPCanvasHelper); override;
|
|
procedure SetColor(const NewColor: TColor; const NewFPColor: TFPColor); virtual;
|
|
procedure SetFPColor(const AValue: TFPColor); override;
|
|
procedure SetColor(Value: TColor);
|
|
procedure SetEndCap(AValue: TPenEndCap); {$IFDEF HasFPEndCap}override;{$ENDIF}
|
|
procedure SetJoinStyle(AValue: TPenJoinStyle); {$IFDEF HasFPJoinStyle}override;{$ENDIF}
|
|
procedure SetMode(Value: TPenMode); override;
|
|
procedure SetStyle(Value: TPenStyle); override;
|
|
procedure SetWidth(value: Integer); override;
|
|
public
|
|
constructor Create; override;
|
|
destructor Destroy; override;
|
|
procedure Assign(Source: TPersistent); override;
|
|
property Handle: HPEN read GetHandle write SetHandle; deprecated;
|
|
property Reference: TWSPenReference read GetReference;
|
|
|
|
function GetPattern: TPenPattern;
|
|
procedure SetPattern(APattern: TPenPattern); reintroduce;
|
|
published
|
|
property Color: TColor read FColor write SetColor default clBlack;
|
|
property Cosmetic: Boolean read FCosmetic write SetCosmetic default True;
|
|
{$IFDEF HasFPEndCap}
|
|
property EndCap default pecRound;
|
|
{$ELSE}
|
|
property EndCap: TPenEndCap read FEndCap write SetEndCap default pecRound;
|
|
{$ENDIF}
|
|
{$IFDEF HasFPJoinStyle}
|
|
property JoinStyle default pjsRound;
|
|
{$ELSE}
|
|
property JoinStyle: TPenJoinStyle read FJoinStyle write SetJoinStyle default pjsRound;
|
|
{$ENDIF}
|
|
property Mode default pmCopy;
|
|
property Style default psSolid;
|
|
property Width default 1;
|
|
end;
|
|
|
|
{ TBrush }
|
|
|
|
TBrushStyle = TFPBrushStyle;
|
|
|
|
TBrushHandleCache = class(TBlockResourceCache)
|
|
protected
|
|
procedure RemoveItem(Item: TResourceCacheItem); override;
|
|
public
|
|
constructor Create;
|
|
end;
|
|
|
|
TBrush = class(TFPCustomBrush)
|
|
private
|
|
FBrushHandleCached: boolean;
|
|
FColor: TColor;
|
|
FBitmap: TCustomBitmap;
|
|
FReference: TWSBrushReference;
|
|
FInternalUpdateIndex: Integer;
|
|
procedure FreeReference;
|
|
function GetHandle: HBRUSH;
|
|
function GetReference: TWSBrushReference;
|
|
function GetColor: TColor;
|
|
procedure ReferenceNeeded;
|
|
procedure SetHandle(const Value: HBRUSH);
|
|
procedure DoChange(var Msg); message LM_CHANGED;
|
|
protected
|
|
procedure DoAllocateResources; override;
|
|
procedure DoDeAllocateResources; override;
|
|
procedure DoCopyProps(From: TFPCanvasHelper); override;
|
|
procedure SetColor(const NewColor: TColor; const NewFPColor: TFPColor); virtual;
|
|
procedure SetFPColor(const AValue: TFPColor); override;
|
|
procedure SetBitmap(Value: TCustomBitmap);
|
|
procedure SetColor(Value: TColor);
|
|
procedure SetStyle(Value: TBrushStyle); override;
|
|
public
|
|
procedure Assign(Source: TPersistent); override;
|
|
constructor Create; override;
|
|
destructor Destroy; override;
|
|
function EqualsBrush(ABrush: TBrush): boolean;
|
|
property Bitmap: TCustomBitmap read FBitmap write SetBitmap;
|
|
property Handle: HBRUSH read GetHandle write SetHandle; deprecated; // use instead Reference.Handle
|
|
property Reference: TWSBrushReference read GetReference;
|
|
published
|
|
property Color: TColor read FColor write SetColor default clWhite;
|
|
property Style default bsSolid;
|
|
end;
|
|
|
|
TRegionCombineMode = (rgnAnd, rgnCopy, rgnDiff, rgnOr, rgnXOR);
|
|
|
|
TRegionOperationType = (rgnNewRect, rgnCombine);
|
|
|
|
TRegionOperation = record
|
|
ROType: TRegionOperationType;
|
|
Source1, Source2, Dest: Integer; // Index to the list of sub-regions, -1 indicates the main region
|
|
CombineMode: TRegionCombineMode; // Used only if ROType=rgnCombine
|
|
Rect: TRect; // Used for ROType=rgnNewRect
|
|
end;
|
|
|
|
TRegionOperations = array of TRegionOperation;
|
|
|
|
{ TRegion }
|
|
|
|
TRegion = class(TGraphicsObject)
|
|
private
|
|
FReference: TWSRegionReference;
|
|
// Description of the region
|
|
//RegionOperations: TRegionOperations;
|
|
//SubRegions: array of HRGN;
|
|
procedure AddOperation(AOp: TRegionOperation);
|
|
procedure ClearSubRegions();
|
|
procedure AddSubRegion(AHandle: HRGN);
|
|
//
|
|
procedure FreeReference;
|
|
function GetReference: TWSRegionReference;
|
|
function GetHandle: HRGN;
|
|
procedure ReferenceNeeded;
|
|
procedure SetHandle(const Value: HRGN);
|
|
protected
|
|
procedure SetClipRect(value: TRect);
|
|
function GetClipRect: TRect;
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
procedure Assign(Source: TPersistent); override;
|
|
|
|
// Convenience routines to add elements to the region
|
|
procedure AddRectangle(X1, Y1, X2, Y2: Integer);
|
|
|
|
property ClipRect: TRect read GetClipRect write SetClipRect;
|
|
property Handle: HRGN read GetHandle write SetHandle; deprecated;
|
|
property Reference: TWSRegionReference read GetReference;
|
|
end;
|
|
|
|
|
|
{ TGraphic }
|
|
|
|
{ TGraphic is an abstract base class for images like TRasterImage,
|
|
TCustomBitmap, TBitmap, etc. }
|
|
|
|
TGraphic = class(TPersistent)
|
|
private
|
|
FModified: Boolean;
|
|
FOnChange: TNotifyEvent;
|
|
FOnProgress: TProgressEvent;
|
|
FPaletteModified: Boolean;
|
|
protected
|
|
procedure Changed(Sender: TObject); virtual;
|
|
function Equals(Graphic: TGraphic): Boolean; virtual; {$IF declared(vmtEquals)}overload;{$ENDIF}
|
|
procedure DefineProperties(Filer: TFiler); override;
|
|
procedure Draw(ACanvas: TCanvas; const Rect: TRect); virtual; abstract;
|
|
function GetEmpty: Boolean; virtual; abstract;
|
|
function GetHeight: Integer; virtual; abstract;
|
|
function GetMimeType: string; virtual;
|
|
function GetPalette: HPALETTE; virtual;
|
|
function GetTransparent: Boolean; virtual; abstract;
|
|
function GetWidth: Integer; virtual; abstract;
|
|
procedure Progress(Sender: TObject; Stage: TProgressStage;
|
|
PercentDone: Byte; RedrawNow: Boolean; const R: TRect;
|
|
const Msg: string; var DoContinue: boolean); virtual;
|
|
procedure Progress(Sender: TObject; Stage: TProgressStage;
|
|
PercentDone: Byte; RedrawNow: Boolean; const R: TRect;
|
|
const Msg: string); virtual;
|
|
procedure ReadData(Stream: TStream); virtual; // used by Filer
|
|
procedure SetHeight(Value: Integer); virtual; abstract;
|
|
procedure SetPalette(Value: HPALETTE); virtual;
|
|
procedure SetTransparent(Value: Boolean); virtual; abstract;
|
|
procedure SetWidth(Value: Integer); virtual; abstract;
|
|
procedure SetModified(Value: Boolean);
|
|
procedure WriteData(Stream: TStream); virtual; // used by filer
|
|
public
|
|
procedure Assign(ASource: TPersistent); override;
|
|
constructor Create; virtual;
|
|
procedure Clear; virtual;
|
|
{$IF declared(vmtEquals)}
|
|
function Equals(Obj: TObject): Boolean; override; overload;
|
|
{$ENDIF}
|
|
function LazarusResourceTypeValid(const AResourceType: string): boolean; virtual;
|
|
procedure LoadFromFile(const Filename: string); virtual;
|
|
procedure LoadFromStream(Stream: TStream); virtual; abstract;
|
|
procedure LoadFromMimeStream(AStream: TStream; const AMimeType: string); virtual;
|
|
procedure LoadFromLazarusResource(const ResName: String); virtual;
|
|
procedure LoadFromResourceName(Instance: THandle; const ResName: String); virtual;
|
|
procedure LoadFromResourceID(Instance: THandle; ResID: PtrInt); virtual;
|
|
procedure LoadFromClipboardFormat(FormatID: TClipboardFormat); virtual;
|
|
procedure LoadFromClipboardFormatID(ClipboardType: TClipboardType;
|
|
FormatID: TClipboardFormat); virtual;
|
|
procedure SaveToFile(const Filename: string); virtual;
|
|
procedure SaveToStream(Stream: TStream); virtual; abstract;
|
|
procedure SaveToClipboardFormat(FormatID: TClipboardFormat); virtual;
|
|
procedure SaveToClipboardFormatID(ClipboardType: TClipboardType;
|
|
FormatID: TClipboardFormat); virtual;
|
|
procedure GetSupportedSourceMimeTypes(List: TStrings); virtual;
|
|
function GetResourceType: TResourceType; virtual;
|
|
class function GetFileExtensions: string; virtual;
|
|
class function IsStreamFormatSupported(Stream: TStream): Boolean; virtual;
|
|
public
|
|
property Empty: Boolean read GetEmpty;
|
|
property Height: Integer read GetHeight write SetHeight;
|
|
property Modified: Boolean read FModified write SetModified;
|
|
property MimeType: string read GetMimeType;
|
|
property OnChange: TNotifyEvent read FOnChange write FOnChange;
|
|
property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
|
|
property Palette: HPALETTE read GetPalette write SetPalette;
|
|
property PaletteModified: Boolean read FPaletteModified write FPaletteModified;
|
|
property Transparent: Boolean read GetTransparent write SetTransparent;
|
|
property Width: Integer read GetWidth write SetWidth;
|
|
end;
|
|
|
|
TGraphicClass = class of TGraphic;
|
|
|
|
|
|
{ TPicture }
|
|
|
|
TPicture = class(TPersistent)
|
|
private
|
|
FGraphic: TGraphic;
|
|
FOnChange: TNotifyEvent;
|
|
//FNotify: IChangeNotifier;
|
|
FOnProgress: TProgressEvent;
|
|
procedure ForceType(GraphicType: TGraphicClass);
|
|
function GetBitmap: TBitmap;
|
|
function GetIcon: TIcon;
|
|
{$IFNDEF DisableLCLJPEG}
|
|
function GetJpeg: TJpegImage;
|
|
{$ENDIF}
|
|
function GetPNG: TPortableNetworkGraphic;
|
|
{$IFNDEF DisableLCLPNM}
|
|
function GetPNM: TPortableAnyMapGraphic;
|
|
{$ENDIF}
|
|
function GetPixmap: TPixmap;
|
|
function GetHeight: Integer;
|
|
function GetWidth: Integer;
|
|
procedure ReadData(Stream: TStream);
|
|
procedure SetBitmap(Value: TBitmap);
|
|
procedure SetIcon(Value: TIcon);
|
|
{$IFNDEF DisableLCLJPEG}
|
|
procedure SetJpeg(Value: TJpegImage);
|
|
{$ENDIF}
|
|
procedure SetPNG(const AValue: TPortableNetworkGraphic);
|
|
{$IFNDEF DisableLCLPNM}
|
|
procedure SetPNM(const AValue: TPortableAnyMapGraphic);
|
|
{$ENDIF}
|
|
procedure SetPixmap(Value: TPixmap);
|
|
procedure SetGraphic(Value: TGraphic);
|
|
procedure WriteData(Stream: TStream);
|
|
protected
|
|
procedure AssignTo(Dest: TPersistent); override;
|
|
procedure Changed(Sender: TObject); virtual;
|
|
procedure DefineProperties(Filer: TFiler); override;
|
|
procedure Progress(Sender: TObject; Stage: TProgressStage;
|
|
PercentDone: Byte; RedrawNow: Boolean; const R: TRect;
|
|
const Msg: string; var DoContinue: boolean); virtual;
|
|
procedure LoadFromStreamWithClass(Stream: TStream; AClass: TGraphicClass);
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
|
|
procedure Clear; virtual;
|
|
// load methods
|
|
procedure LoadFromClipboardFormat(FormatID: TClipboardFormat);
|
|
procedure LoadFromClipboardFormatID(ClipboardType: TClipboardType; FormatID: TClipboardFormat);
|
|
procedure LoadFromFile(const Filename: string);
|
|
procedure LoadFromResourceName(Instance: THandle; const ResName: String);
|
|
procedure LoadFromResourceName(Instance: THandle; const ResName: String; AClass: TGraphicClass);
|
|
procedure LoadFromLazarusResource(const AName: string);
|
|
procedure LoadFromStream(Stream: TStream);
|
|
procedure LoadFromStreamWithFileExt(Stream: TStream; const FileExt: string);
|
|
// save methods
|
|
procedure SaveToClipboardFormat(FormatID: TClipboardFormat);
|
|
procedure SaveToFile(const Filename: string; const FileExt: string = '');
|
|
procedure SaveToStream(Stream: TStream);
|
|
procedure SaveToStreamWithFileExt(Stream: TStream; const FileExt: string);
|
|
|
|
class function SupportsClipboardFormat(FormatID: TClipboardFormat): Boolean;
|
|
procedure Assign(Source: TPersistent); override;
|
|
class procedure RegisterFileFormat(const AnExtension, ADescription: string;
|
|
AGraphicClass: TGraphicClass);
|
|
class procedure RegisterClipboardFormat(FormatID: TClipboardFormat;
|
|
AGraphicClass: TGraphicClass);
|
|
class procedure UnregisterGraphicClass(AClass: TGraphicClass);
|
|
class function FindGraphicClassWithFileExt(const Ext: string;
|
|
ExceptionOnNotFound: boolean = true): TGraphicClass;
|
|
public
|
|
property Bitmap: TBitmap read GetBitmap write SetBitmap;
|
|
property Icon: TIcon read GetIcon write SetIcon;
|
|
{$IFNDEF DisableLCLJPEG}
|
|
property Jpeg: TJpegImage read GetJpeg write SetJpeg;
|
|
{$ENDIF}
|
|
property Pixmap: TPixmap read GetPixmap write SetPixmap;
|
|
property PNG: TPortableNetworkGraphic read GetPNG write SetPNG;
|
|
{$IFNDEF DisableLCLPNM}
|
|
property PNM: TPortableAnyMapGraphic read GetPNM write SetPNM;
|
|
{$ENDIF}
|
|
property Graphic: TGraphic read FGraphic write SetGraphic;
|
|
//property PictureAdapter: IChangeNotifier read FNotify write FNotify;
|
|
property Height: Integer read GetHeight;
|
|
property Width: Integer read GetWidth;
|
|
property OnChange: TNotifyEvent read FOnChange write FOnChange;
|
|
property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
|
|
end;
|
|
|
|
|
|
EGraphicException = class(Exception);
|
|
EInvalidGraphic = class(EGraphicException);
|
|
EInvalidGraphicOperation = class(EGraphicException);
|
|
|
|
type
|
|
TGradientDirection = (
|
|
gdVertical, // Fill vertical
|
|
gdHorizontal // Fill Horizontal
|
|
);
|
|
|
|
TAntialiasingMode = (
|
|
amDontCare, // default antialiasing
|
|
amOn, // enabled
|
|
amOff // disabled
|
|
);
|
|
|
|
TLCLTextMetric = record
|
|
Ascender: Integer;
|
|
Descender: Integer;
|
|
Height: Integer;
|
|
end;
|
|
|
|
TDefaultColorType = (
|
|
dctBrush,
|
|
dctFont
|
|
);
|
|
|
|
{ TCanvas }
|
|
|
|
TCanvas = class(TFPCustomCanvas)
|
|
private
|
|
FAntialiasingMode: TAntialiasingMode;
|
|
FAutoRedraw: Boolean;
|
|
FState: TCanvasState;
|
|
FSavedFontHandle: HFont;
|
|
FSavedPenHandle: HPen;
|
|
FSavedBrushHandle: HBrush;
|
|
FSavedRegionHandle: HRGN;
|
|
FCopyMode: TCopyMode;
|
|
FHandle: HDC;
|
|
FOnChange: TNotifyEvent;
|
|
FOnChanging: TNotifyEvent;
|
|
FTextStyle: TTextStyle;
|
|
FLock: TCriticalSection;// FLock is initialized on demand
|
|
FRegion: TRegion;
|
|
FLazPen: TPen;
|
|
FLazFont: TFont;
|
|
FLazBrush: TBrush;
|
|
FSavedHandleStates: TFPList;
|
|
procedure BrushChanged(ABrush: TObject);
|
|
procedure FontChanged(AFont: TObject);
|
|
procedure PenChanged(APen: TObject);
|
|
procedure RegionChanged(ARegion: TObject);
|
|
function GetHandle: HDC;
|
|
procedure SetAntialiasingMode(const AValue: TAntialiasingMode);
|
|
procedure SetAutoRedraw(Value: Boolean); virtual;
|
|
procedure SetLazFont(Value: TFont);
|
|
procedure SetLazPen(Value: TPen);
|
|
procedure SetLazBrush(Value: TBrush);
|
|
procedure SetRegion(Value: TRegion);
|
|
protected
|
|
function DoCreateDefaultFont: TFPCustomFont; override;
|
|
function DoCreateDefaultPen: TFPCustomPen; override;
|
|
function DoCreateDefaultBrush: TFPCustomBrush; override;
|
|
procedure SetColor(x, y: integer; const Value: TFPColor); override;
|
|
function GetColor(x, y: integer): TFPColor; override;
|
|
procedure SetHeight(AValue: integer); override;
|
|
function GetHeight: integer; override;
|
|
procedure SetWidth(AValue: integer); override;
|
|
function GetWidth: integer; override;
|
|
procedure SetPenPos(const AValue: TPoint); override;
|
|
procedure DoLockCanvas; override;
|
|
procedure DoUnlockCanvas; override;
|
|
procedure DoTextOut(x, y: integer; Text: string); override;
|
|
procedure DoGetTextSize(Text: string; var w,h:integer); override;
|
|
function DoGetTextHeight(Text: string): integer; override;
|
|
function DoGetTextWidth(Text: string): integer; override;
|
|
procedure DoRectangle(const Bounds: TRect); override;
|
|
procedure DoRectangleFill(const Bounds: TRect); override;
|
|
procedure DoRectangleAndFill(const Bounds: TRect); override;
|
|
procedure DoEllipse(const Bounds: TRect); override;
|
|
procedure DoEllipseFill(const Bounds: TRect); override;
|
|
procedure DoEllipseAndFill(const Bounds: TRect); override;
|
|
procedure DoPolygon(const Points: array of TPoint); override;
|
|
procedure DoPolygonFill(const Points: array of TPoint); override;
|
|
procedure DoPolygonAndFill(const Points: array of TPoint); override;
|
|
procedure DoPolyline(const Points: array of TPoint); override;
|
|
procedure DoPolyBezier(Points: PPoint; NumPts: Integer;
|
|
Filled: boolean = False;
|
|
Continuous: boolean = False); override;
|
|
procedure DoFloodFill(x, y: integer); override;
|
|
procedure DoMoveTo(x, y: integer); override;
|
|
procedure DoLineTo(x, y: integer); override;
|
|
procedure DoLine(x1, y1, x2, y2: integer); override;
|
|
procedure DoCopyRect(x, y: integer; SrcCanvas: TFPCustomCanvas;
|
|
const SourceRect: TRect); override;
|
|
procedure DoDraw(x, y: integer; const Image: TFPCustomImage); override;
|
|
procedure CheckHelper(AHelper: TFPCanvasHelper); override;
|
|
function GetDefaultColor(const ADefaultColorType: TDefaultColorType): TColor; virtual;
|
|
protected
|
|
function GetClipRect: TRect; override;
|
|
procedure SetClipRect(const ARect: TRect); override;
|
|
function GetClipping: Boolean; override;
|
|
procedure SetClipping(const AValue: boolean); override;
|
|
function GetPixel(X,Y: Integer): TColor; virtual;
|
|
procedure CreateBrush; virtual;
|
|
procedure CreateFont; virtual;
|
|
procedure CreateHandle; virtual;
|
|
procedure CreatePen; virtual;
|
|
procedure CreateRegion; virtual;
|
|
procedure DeselectHandles; virtual;
|
|
procedure PenChanging(APen: TObject); virtual;
|
|
procedure FontChanging(AFont: TObject); virtual;
|
|
procedure BrushChanging(ABrush: TObject); virtual;
|
|
procedure RegionChanging(ARegion: TObject); virtual;
|
|
procedure RealizeAutoRedraw; virtual;
|
|
procedure RealizeAntialiasing; virtual;
|
|
procedure RequiredState(ReqState: TCanvasState); virtual;
|
|
procedure SetHandle(NewHandle: HDC); virtual;
|
|
procedure SetInternalPenPos(const Value: TPoint); virtual;
|
|
procedure SetPixel(X,Y: Integer; Value: TColor); virtual;
|
|
procedure FreeHandle;virtual;
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
procedure Lock; virtual;
|
|
function TryLock: Boolean;
|
|
procedure Unlock; virtual;
|
|
procedure Refresh; virtual;
|
|
procedure Changing; virtual;
|
|
procedure Changed; virtual;
|
|
procedure SaveHandleState; virtual;
|
|
procedure RestoreHandleState; virtual;
|
|
|
|
// extra drawing methods (there are more in the ancestor TFPCustomCanvas)
|
|
procedure Arc(ALeft, ATop, ARight, ABottom, Angle16Deg, Angle16DegLength: Integer); virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
|
|
procedure Arc(ALeft, ATop, ARight, ABottom, SX, SY, EX, EY: Integer); virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
|
|
procedure ArcTo(ALeft, ATop, ARight, ABottom, SX, SY, EX, EY: Integer); virtual; //As Arc(), but updates pen position
|
|
procedure AngleArc(X, Y: Integer; Radius: Longword; StartAngle, SweepAngle: Single);
|
|
procedure BrushCopy(ADestRect: TRect; ABitmap: TBitmap; ASourceRect: TRect;
|
|
ATransparentColor: TColor); virtual;
|
|
procedure Chord(x1, y1, x2, y2,
|
|
Angle16Deg, Angle16DegLength: Integer); virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
|
|
procedure Chord(x1, y1, x2, y2, SX, SY, EX, EY: Integer); virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
|
|
procedure CopyRect(const Dest: TRect; SrcCanvas: TCanvas;
|
|
const Source: TRect); virtual; reintroduce;
|
|
procedure Draw(X,Y: Integer; SrcGraphic: TGraphic); virtual; reintroduce;
|
|
procedure DrawFocusRect(const ARect: TRect); virtual;
|
|
procedure StretchDraw(const DestRect: TRect; SrcGraphic: TGraphic); virtual; reintroduce;
|
|
procedure Ellipse(const ARect: TRect); {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
|
|
procedure Ellipse(x1, y1, x2, y2: Integer); virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
|
|
procedure FillRect(const ARect: TRect); virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
|
|
procedure FillRect(X1,Y1,X2,Y2: Integer); {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
|
|
procedure FloodFill(X, Y: Integer; FillColor: TColor;
|
|
FillStyle: TFillStyle); virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
|
|
procedure Frame3d(var ARect: TRect; const FrameWidth: integer;
|
|
const Style: TGraphicsBevelCut); virtual;
|
|
procedure Frame3D(var ARect: TRect; TopColor, BottomColor: TColor;
|
|
const FrameWidth: integer); overload;
|
|
procedure Frame(const ARect: TRect); virtual; // border using pen
|
|
procedure Frame(X1,Y1,X2,Y2: Integer); // border using pen
|
|
procedure FrameRect(const ARect: TRect); virtual; // border using brush
|
|
procedure FrameRect(X1,Y1,X2,Y2: Integer); // border using brush
|
|
function GetTextMetrics(out TM: TLCLTextMetric): boolean; virtual;
|
|
procedure GradientFill(ARect: TRect; AStart, AStop: TColor; ADirection: TGradientDirection);
|
|
procedure RadialPie(x1, y1, x2, y2,
|
|
StartAngle16Deg, Angle16DegLength: Integer); virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
|
|
procedure Pie(EllipseX1,EllipseY1,EllipseX2,EllipseY2,
|
|
StartX,StartY,EndX,EndY: Integer); virtual;
|
|
procedure PolyBezier(Points: PPoint; NumPts: Integer;
|
|
Filled: boolean = False;
|
|
Continuous: boolean = True); virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
|
|
procedure PolyBezier(const Points: array of TPoint;
|
|
Filled: boolean = False;
|
|
Continuous: boolean = True); {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
|
|
procedure Polygon(const Points: array of TPoint;
|
|
Winding: Boolean;
|
|
StartIndex: Integer = 0;
|
|
NumPts: Integer = -1);
|
|
procedure Polygon(Points: PPoint; NumPts: Integer;
|
|
Winding: boolean = False); virtual;
|
|
procedure Polygon(const Points: array of TPoint); {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
|
|
procedure Polyline(const Points: array of TPoint;
|
|
StartIndex: Integer;
|
|
NumPts: Integer = -1);
|
|
procedure Polyline(Points: PPoint; NumPts: Integer); virtual;
|
|
procedure Polyline(const Points: array of TPoint); {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
|
|
procedure Rectangle(X1,Y1,X2,Y2: Integer); virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
|
|
procedure Rectangle(const ARect: TRect); {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
|
|
procedure RoundRect(X1, Y1, X2, Y2: Integer; RX,RY: Integer); virtual;
|
|
procedure RoundRect(const Rect: TRect; RX,RY: Integer);
|
|
procedure TextOut(X,Y: Integer; const Text: String); virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
|
|
procedure TextRect(const ARect: TRect; X, Y: integer; const Text: string);
|
|
procedure TextRect(ARect: TRect; X, Y: integer; const Text: string;
|
|
const Style: TTextStyle); virtual;
|
|
function TextExtent(const Text: string): TSize; virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
|
|
function TextHeight(const Text: string): Integer; virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
|
|
function TextWidth(const Text: string): Integer; virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
|
|
function TextFitInfo(const Text: string; MaxWidth: Integer): Integer;
|
|
function HandleAllocated: boolean; virtual;
|
|
function GetUpdatedHandle(ReqState: TCanvasState): HDC; virtual;
|
|
public
|
|
property Pixels[X, Y: Integer]: TColor read GetPixel write SetPixel;
|
|
property Handle: HDC read GetHandle write SetHandle;
|
|
property TextStyle: TTextStyle read FTextStyle write FTextStyle;
|
|
published
|
|
property AntialiasingMode: TAntialiasingMode read FAntialiasingMode write SetAntialiasingMode default amDontCare;
|
|
property AutoRedraw: Boolean read FAutoRedraw write SetAutoRedraw;
|
|
property Brush: TBrush read FLazBrush write SetLazBrush;
|
|
property CopyMode: TCopyMode read FCopyMode write FCopyMode default cmSrcCopy;
|
|
property Font: TFont read FLazFont write SetLazFont;
|
|
property Height: integer read GetHeight;
|
|
property Pen: TPen read FLazPen write SetLazPen;
|
|
property Region: TRegion read FRegion write SetRegion;
|
|
property Width: integer read GetWidth;
|
|
property OnChange: TNotifyEvent read FOnChange write FOnChange;
|
|
property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
|
|
end;
|
|
|
|
|
|
{ TSharedImage - base class for reference counted images }
|
|
|
|
TSharedImage = class
|
|
private
|
|
FRefCount: Integer;
|
|
protected
|
|
procedure Reference; // increase reference count
|
|
procedure Release; // decrease reference count
|
|
procedure FreeHandle; virtual; abstract;
|
|
property RefCount: Integer read FRefCount;
|
|
public
|
|
function HandleAllocated: boolean; virtual; abstract;
|
|
end;
|
|
|
|
|
|
{ TCustomBitmapImage
|
|
|
|
Descendent of TSharedImage for TCustomBitmap. If a TCustomBitmap is assigned to another
|
|
TCustomBitmap, only the reference count will be increased and both will share the
|
|
same TCustomBitmapImage }
|
|
|
|
TBitmapHandleType = (bmDIB, bmDDB);
|
|
|
|
{ TSharedCustomBitmap }
|
|
|
|
{ TSharedCustomBitmap is base class used for sharing imagedata for derived
|
|
classes of TCustomBitmap. Data can only be shared between classes of the
|
|
same type. IE. TBitmap data can only be shared with (descendant of) TBitmap.
|
|
Therefore each graphic "end" class should define its own share class.
|
|
}
|
|
|
|
TSharedRasterImage = class(TSharedImage)
|
|
private
|
|
FHandle: THandle; // generic type, can be HBITMAP or HICON or ....
|
|
FBitmapCanvas: TCanvas; // current canvas selected into
|
|
FSaveStream: TMemoryStream;
|
|
protected
|
|
procedure FreeHandle; override;
|
|
function ReleaseHandle: THandle; virtual;
|
|
function IsEmpty: boolean; virtual;
|
|
public
|
|
constructor Create; virtual;
|
|
procedure CreateDefaultHandle(AWidth, AHeight: Integer; ABPP: Byte); virtual; abstract;
|
|
destructor Destroy; override;
|
|
function HandleAllocated: boolean; override;
|
|
property BitmapCanvas: TCanvas read FBitmapCanvas write FBitmapCanvas;
|
|
property SaveStream: TMemoryStream read FSaveStream write FSaveStream;
|
|
end;
|
|
|
|
TSharedRasterImageClass = class of TSharedRasterImage;
|
|
|
|
{ TRasterImage }
|
|
|
|
TRasterImage = class(TGraphic)
|
|
private
|
|
FCanvas: TCanvas;
|
|
FTransparentColor: TColor;
|
|
FTransparentMode: TTransparentMode;
|
|
FUpdateCount: Integer;
|
|
FUpdateCanvasOnly: Boolean;
|
|
FMasked: Boolean;
|
|
|
|
procedure CanvasChanging(Sender: TObject);
|
|
procedure CreateCanvas;
|
|
procedure CreateMask(AColor: TColor = clDefault);
|
|
procedure FreeCanvasContext;
|
|
function GetCanvas: TCanvas;
|
|
function GetRawImage: TRawImage;
|
|
function GetScanline(ARow: Integer): Pointer;
|
|
function GetTransparentColor: TColor;
|
|
procedure SetTransparentColor(AValue: TColor);
|
|
protected
|
|
FSharedImage: TSharedRasterImage;
|
|
function CanShareImage(AClass: TSharedRasterImageClass): Boolean; virtual;
|
|
procedure Changed(Sender: TObject); override;
|
|
function CreateDefaultBitmapHandle(const ADesc: TRawImageDescription): HBITMAP; virtual;
|
|
procedure Draw(DestCanvas: TCanvas; const DestRect: TRect); override;
|
|
function GetEmpty: Boolean; override;
|
|
function GetHandle: THandle;
|
|
function GetBitmapHandle: HBITMAP; virtual; abstract;
|
|
function GetMasked: Boolean; virtual;
|
|
function GetMaskHandle: HBITMAP; virtual; abstract;
|
|
function GetMimeType: string; override;
|
|
function GetPixelFormat: TPixelFormat; virtual; abstract;
|
|
function GetRawImagePtr: PRawImage; virtual; abstract;
|
|
function GetRawImageDescriptionPtr: PRawImageDescription; virtual; abstract;
|
|
function GetTransparent: Boolean; override;
|
|
class function GetSharedImageClass: TSharedRasterImageClass; virtual;
|
|
function GetHeight: Integer; override;
|
|
function GetWidth: Integer; override;
|
|
procedure BitmapHandleNeeded; virtual;
|
|
procedure HandleNeeded; virtual; abstract;
|
|
procedure MaskHandleNeeded; virtual; abstract;
|
|
procedure PaletteNeeded; virtual; abstract;
|
|
function InternalReleaseBitmapHandle: HBITMAP; virtual; abstract;
|
|
function InternalReleaseMaskHandle: HBITMAP; virtual; abstract;
|
|
function InternalReleasePalette: HPALETTE; virtual; abstract;
|
|
procedure SetBitmapHandle(AValue: HBITMAP);
|
|
procedure SetMasked(AValue: Boolean); virtual;
|
|
procedure SetMaskHandle(AValue: HBITMAP);
|
|
procedure SetTransparent(AValue: Boolean); override;
|
|
procedure UnshareImage(CopyContent: boolean); virtual; abstract;
|
|
function UpdateHandles(ABitmap, AMask: HBITMAP): Boolean; virtual; abstract; // called when handles are created from rawimage (true when handle changed)
|
|
procedure SaveStreamNeeded;
|
|
procedure FreeSaveStream;
|
|
procedure ReadData(Stream: TStream); override;
|
|
procedure ReadStream(AStream: TMemoryStream; ASize: Longint); virtual; abstract; // loads imagedata into rawimage, this method shouldn't call changed().
|
|
procedure SetSize(AWidth, AHeight: integer); virtual; abstract;
|
|
procedure SetHandle(AValue: THandle); virtual;
|
|
procedure SetHeight(AHeight: Integer); override;
|
|
procedure SetWidth(AWidth: Integer); override;
|
|
procedure SetTransparentMode(AValue: TTransparentMode);
|
|
procedure SetPixelFormat(AValue: TPixelFormat); virtual; abstract;
|
|
procedure WriteData(Stream: TStream); override;
|
|
procedure WriteStream(AStream: TMemoryStream); virtual; abstract;
|
|
function RequestTransparentColor: TColor;
|
|
public
|
|
constructor Create; override;
|
|
destructor Destroy; override;
|
|
procedure Assign(Source: TPersistent); override;
|
|
procedure Clear; override;
|
|
procedure BeginUpdate(ACanvasOnly: Boolean = False);
|
|
procedure EndUpdate(AStreamIsValid: Boolean = False);
|
|
procedure FreeImage; virtual;
|
|
function BitmapHandleAllocated: boolean; virtual; abstract;
|
|
function MaskHandleAllocated: boolean; virtual; abstract;
|
|
function PaletteAllocated: boolean; virtual; abstract;
|
|
procedure LoadFromBitmapHandles(ABitmap, AMask: HBitmap; ARect: PRect = nil);
|
|
procedure LoadFromDevice(DC: HDC); virtual;
|
|
procedure LoadFromStream(AStream: TStream); overload; override;
|
|
procedure LoadFromStream(AStream: TStream; ASize: Cardinal); overload; virtual;
|
|
procedure LoadFromMimeStream(AStream: TStream; const AMimeType: string); override;
|
|
procedure LoadFromRawImage(const AIMage: TRawImage; ADataOwner: Boolean);
|
|
procedure LoadFromIntfImage(IntfImage: TLazIntfImage);
|
|
procedure SaveToStream(AStream: TStream); override;
|
|
procedure GetSupportedSourceMimeTypes(List: TStrings); override;
|
|
procedure GetSize(out AWidth, AHeight: Integer);
|
|
procedure Mask(ATransparentColor: TColor);
|
|
procedure SetHandles(ABitmap, AMask: HBITMAP); virtual; abstract; // called when handles are set by user
|
|
function ReleaseBitmapHandle: HBITMAP;
|
|
function ReleaseMaskHandle: HBITMAP;
|
|
function ReleasePalette: HPALETTE;
|
|
function CreateIntfImage: TLazIntfImage;
|
|
public
|
|
property Canvas: TCanvas read GetCanvas;
|
|
function HandleAllocated: boolean;
|
|
property BitmapHandle: HBITMAP read GetBitmapHandle write SetBitmapHandle;
|
|
property Masked: Boolean read GetMasked write SetMasked;
|
|
property MaskHandle: HBITMAP read GetMaskHandle write SetMaskHandle;
|
|
property PixelFormat: TPixelFormat read GetPixelFormat write SetPixelFormat default pfDevice;
|
|
property RawImage: TRawImage read GetRawImage; // be carefull with this, modify only within a begin/endupdate
|
|
property ScanLine[Row: Integer]: Pointer read GetScanLine; platform; // Use only when wrpped by a begin/endupdate
|
|
property TransparentColor: TColor read GetTransparentColor
|
|
write SetTransparentColor default clDefault;
|
|
property TransparentMode: TTransparentMode read FTransparentMode
|
|
write SetTransparentMode default tmAuto;
|
|
end;
|
|
|
|
TSharedCustomBitmap = class(TSharedRasterImage)
|
|
private
|
|
FHandleType: TBitmapHandleType;
|
|
FImage: TRawImage;
|
|
FHasMask: Boolean; // set if atleast one maskpixel is set
|
|
FPalette: HPALETTE;
|
|
function GetHeight: Integer;
|
|
function GetWidth: Integer;
|
|
protected
|
|
procedure FreeHandle; override;
|
|
procedure FreePalette;
|
|
procedure FreeImage;
|
|
function ReleasePalette: HPALETTE;
|
|
function GetPixelFormat: TPixelFormat;
|
|
function IsEmpty: boolean; override;
|
|
public
|
|
constructor Create; override;
|
|
destructor Destroy; override;
|
|
function HandleAllocated: boolean; override;
|
|
function ImageAllocated: boolean;
|
|
property HandleType: TBitmapHandleType read FHandleType write FHandleType;
|
|
property Height: Integer read GetHeight;
|
|
property PixelFormat: TPixelFormat read GetPixelFormat;
|
|
property Width: Integer read GetWidth;
|
|
end;
|
|
|
|
{ TCustomBitmap
|
|
is the data of an image. The image can be loaded from a file,
|
|
stream or resource in .bmp (windows bitmap format) or .xpm (XPixMap format)
|
|
The loading routine automatically recognizes the format, so it is also used
|
|
to load the imagess from Delphi form streams (e.g. .dfm files).
|
|
When the handle is created, it is up to the interface (gtk, win32, ...)
|
|
to convert it automatically to the best internal format. That is why the
|
|
Handle is interface dependent.
|
|
To access the raw data, see TLazIntfImage in IntfGraphics.pas }
|
|
|
|
TCustomBitmap = class(TRasterImage)
|
|
private
|
|
FPixelFormat: TPixelFormat;
|
|
FPixelFormatNeedsUpdate: Boolean;
|
|
FMaskHandle: HBITMAP; // mask is not part of the image, so not shared
|
|
function GetHandleType: TBitmapHandleType;
|
|
function GetMonochrome: Boolean;
|
|
procedure SetBitmapHandle(const AValue: HBITMAP);
|
|
procedure SetHandleType(AValue: TBitmapHandleType);
|
|
procedure SetMonochrome(AValue: Boolean);
|
|
procedure UpdatePixelFormat;
|
|
protected
|
|
procedure MaskHandleNeeded; override;
|
|
procedure PaletteNeeded; override;
|
|
function CanShareImage(AClass: TSharedRasterImageClass): Boolean; override;
|
|
procedure Changed(Sender: TObject); override;
|
|
function CreateDefaultBitmapHandle(const ADesc: TRawImageDescription): HBITMAP; override;
|
|
procedure FreeMaskHandle;
|
|
function GetBitmapHandle: HBITMAP; override;
|
|
function GetMaskHandle: HBITMAP; override;
|
|
function GetPalette: HPALETTE; override;
|
|
function GetPixelFormat: TPixelFormat; override;
|
|
function GetRawImagePtr: PRawImage; override;
|
|
function GetRawImageDescriptionPtr: PRawImageDescription; override;
|
|
class function GetSharedImageClass: TSharedRasterImageClass; override;
|
|
procedure HandleNeeded; override;
|
|
function InternalReleaseBitmapHandle: HBITMAP; override;
|
|
function InternalReleaseMaskHandle: HBITMAP; override;
|
|
function InternalReleasePalette: HPALETTE; override;
|
|
procedure RawimageNeeded(ADescOnly: Boolean);
|
|
procedure SetHandle(AValue: THandle); override;
|
|
procedure SetPixelFormat(AValue: TPixelFormat); override;
|
|
procedure UnshareImage(CopyContent: boolean); override;
|
|
function UpdateHandles(ABitmap, AMask: HBITMAP): Boolean; override;
|
|
public
|
|
constructor Create; override;
|
|
destructor Destroy; override;
|
|
procedure Assign(Source: TPersistent); override;
|
|
procedure Clear; override;
|
|
procedure FreeImage; override;
|
|
function LazarusResourceTypeValid(const ResourceType: string): Boolean; override;
|
|
function BitmapHandleAllocated: boolean; override;
|
|
function MaskHandleAllocated: boolean; override;
|
|
function PaletteAllocated: boolean; override;
|
|
function ReleaseHandle: HBITMAP;
|
|
|
|
procedure SetHandles(ABitmap, AMask: HBITMAP); override;
|
|
procedure SetSize(AWidth, AHeight: integer); override;
|
|
|
|
property Handle: HBITMAP read GetBitmapHandle write SetBitmapHandle; // for custombitmap handle = bitmaphandle
|
|
property HandleType: TBitmapHandleType read GetHandleType write SetHandleType;
|
|
property Monochrome: Boolean read GetMonochrome write SetMonochrome;
|
|
end;
|
|
|
|
{ TFPImageBitmap }
|
|
{ Use this class to easily create a TCustomBitmap descendent for FPImage
|
|
reader and writer }
|
|
|
|
TFPImageBitmap = class(TCustomBitmap)
|
|
private
|
|
protected
|
|
function GetMimeType: string; override;
|
|
class function GetReaderClass: TFPCustomImageReaderClass; virtual; abstract;
|
|
class function GetWriterClass: TFPCustomImageWriterClass; virtual; abstract;
|
|
procedure InitializeReader(AImage: TLazIntfImage; AReader: TFPCustomImageReader); virtual;
|
|
procedure InitializeWriter(AImage: TLazIntfImage; AWriter: TFPCustomImageWriter); virtual;
|
|
procedure FinalizeReader(AReader: TFPCustomImageReader); virtual;
|
|
procedure FinalizeWriter(AWriter: TFPCustomImageWriter); virtual;
|
|
procedure ReadStream(AStream: TMemoryStream; ASize: Longint); override;
|
|
procedure WriteStream(AStream: TMemoryStream); override;
|
|
public
|
|
class function GetFileExtensions: string; override;
|
|
class function IsStreamFormatSupported(Stream: TStream): Boolean; override;
|
|
class function IsFileExtensionSupported(const FileExtension: string): boolean;
|
|
function LazarusResourceTypeValid(const ResourceType: string): boolean; override;
|
|
end;
|
|
|
|
TFPImageBitmapClass = class of TFPImageBitmap;
|
|
|
|
|
|
{ TSharedBitmap }
|
|
|
|
TSharedBitmap = class(TSharedCustomBitmap)
|
|
end;
|
|
|
|
{ TBitmap }
|
|
|
|
TBitmap = class(TFPImageBitmap)
|
|
protected
|
|
procedure InitializeReader(AImage: TLazIntfImage; AReader: TFPCustomImageReader); override;
|
|
class function GetReaderClass: TFPCustomImageReaderClass; override;
|
|
class function GetWriterClass: TFPCustomImageWriterClass; override;
|
|
class function GetSharedImageClass: TSharedRasterImageClass; override;
|
|
public
|
|
class function GetFileExtensions: string; override;
|
|
function GetResourceType: TResourceType; override;
|
|
procedure LoadFromStream(AStream: TStream; ASize: Cardinal); override;
|
|
end;
|
|
|
|
|
|
{ TSharedPixmap }
|
|
|
|
TSharedPixmap = class(TSharedCustomBitmap)
|
|
end;
|
|
|
|
{ TPixmap }
|
|
|
|
TPixmap = class(TFPImageBitmap)
|
|
protected
|
|
class function GetReaderClass: TFPCustomImageReaderClass; override;
|
|
class function GetWriterClass: TFPCustomImageWriterClass; override;
|
|
class function GetSharedImageClass: TSharedRasterImageClass; override;
|
|
public
|
|
function LazarusResourceTypeValid(const ResourceType: string): boolean; override;
|
|
class function GetFileExtensions: string; override;
|
|
end;
|
|
|
|
{ TSharedPortableNetworkGraphic }
|
|
|
|
TSharedPortableNetworkGraphic = class(TSharedCustomBitmap)
|
|
end;
|
|
|
|
{ TPortableNetworkGraphic }
|
|
|
|
TPortableNetworkGraphic = class(TFPImageBitmap)
|
|
protected
|
|
class function GetReaderClass: TFPCustomImageReaderClass; override;
|
|
class function GetWriterClass: TFPCustomImageWriterClass; override;
|
|
procedure InitializeWriter(AImage: TLazIntfImage; AWriter: TFPCustomImageWriter); override;
|
|
class function GetSharedImageClass: TSharedRasterImageClass; override;
|
|
public
|
|
class function IsStreamFormatSupported(Stream: TStream): Boolean; override;
|
|
class function GetFileExtensions: string; override;
|
|
end;
|
|
|
|
|
|
{$IFNDEF DisableLCLPNM}
|
|
{ TSharedPortableAnyMapGraphic }
|
|
|
|
TSharedPortableAnyMapGraphic = class(TSharedCustomBitmap)
|
|
end;
|
|
|
|
{ TPortableAnyMapGraphic }
|
|
|
|
TPortableAnyMapGraphic = class(TFPImageBitmap)
|
|
protected
|
|
class function GetReaderClass: TFPCustomImageReaderClass; override;
|
|
class function GetWriterClass: TFPCustomImageWriterClass; override;
|
|
class function GetSharedImageClass: TSharedRasterImageClass; override;
|
|
public
|
|
class function IsStreamFormatSupported(Stream: TStream): Boolean; override;
|
|
class function GetFileExtensions: string; override;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
TIconImage = class;
|
|
TIconImageClass = class of TIconImage;
|
|
|
|
{ TSharedIcon }
|
|
|
|
TSharedIcon = class(TSharedRasterImage)
|
|
private
|
|
FImages: TFPList;
|
|
protected
|
|
procedure FreeHandle; override;
|
|
procedure UpdateFromHandle(NewHandle: THandle); virtual;
|
|
function IsEmpty: boolean; override;
|
|
function GetImage(const AIndex: Integer): TIconImage;
|
|
public
|
|
constructor Create; override;
|
|
destructor Destroy; override;
|
|
procedure Clear;
|
|
procedure Delete(AIndex: Integer);
|
|
function GetIndex(AFormat: TPixelFormat; AHeight, AWidth: Word): Integer;
|
|
class function GetImagesClass: TIconImageClass; virtual;
|
|
procedure Add(AIconImage: TIconImage);
|
|
procedure Sort;
|
|
function Count: Integer;
|
|
property Images[AIndex: Integer]: TIconImage read GetImage;
|
|
end;
|
|
|
|
{ TIconImage }
|
|
|
|
TIconImage = class
|
|
private
|
|
FHeight: Word;
|
|
FPixelFormat: TPixelFormat;
|
|
FWidth: Word;
|
|
FImage: TRawImage;
|
|
FHandle: HBITMAP;
|
|
FMaskHandle: HBITMAP;
|
|
FPalette: HPALETTE;
|
|
function GetPalette: HPALETTE;
|
|
protected
|
|
procedure RawImageNeeded(ADescOnly: Boolean);
|
|
procedure UpdateFromImage(const AImage: TRawImage);
|
|
public
|
|
constructor Create(AFormat: TPixelFormat; AHeight, AWidth: Word);
|
|
constructor Create(const AImage: TRawImage);
|
|
constructor Create(const AInfo: TIconInfo); virtual;
|
|
destructor Destroy; override;
|
|
|
|
function ReleaseHandle: HBITMAP;
|
|
function ReleaseMaskHandle: HBITMAP;
|
|
function ReleasePalette: HPALETTE;
|
|
function UpdateHandles(ABitmap, AMask: HBITMAP): Boolean;
|
|
|
|
property Height: Word read FHeight;
|
|
property Width: Word read FWidth;
|
|
property PixelFormat: TPixelFormat read FPixelFormat;
|
|
property Handle: HBITMAP read FHandle;
|
|
property MaskHandle: HBITMAP read FMaskHandle;
|
|
property Palette: HPALETTE read GetPalette;
|
|
property RawImage: TRawImage read FImage;
|
|
end;
|
|
|
|
|
|
{ TIcon }
|
|
{
|
|
TIcon reads and writes .ICO file format.
|
|
A .ico file typically contains several versions of the same image. When loading,
|
|
the largest/most colourful image is loaded as the TCustomBitmap and so can be handled
|
|
as any other bitmap. Any other versions of the images are available via the
|
|
Bitmaps property
|
|
Writing is not (yet) implemented.
|
|
}
|
|
|
|
|
|
{ TCustomIcon }
|
|
|
|
TCustomIcon = class(TRasterImage)
|
|
private
|
|
function GetCount: Integer;
|
|
procedure SetCurrent(const AValue: Integer);
|
|
protected
|
|
FCurrent: Integer;
|
|
FRequestedSize: TSize;
|
|
procedure MaskHandleNeeded; override;
|
|
procedure PaletteNeeded; override;
|
|
function CanShareImage(AClass: TSharedRasterImageClass): Boolean; override;
|
|
procedure CheckRequestedSize;
|
|
function GetIndex(AFormat: TPixelFormat; AHeight, AWidth: Word): Integer;
|
|
function GetBitmapHandle: HBITMAP; override;
|
|
class function GetDefaultSize: TSize; virtual;
|
|
function GetMaskHandle: HBITMAP; override;
|
|
function GetPalette: HPALETTE; override;
|
|
function GetPixelFormat: TPixelFormat; override;
|
|
function GetRawImagePtr: PRawImage; override;
|
|
function GetRawImageDescriptionPtr: PRawImageDescription; override;
|
|
function GetTransparent: Boolean; override;
|
|
class function GetSharedImageClass: TSharedRasterImageClass; override;
|
|
class function GetStreamSignature: Cardinal; virtual;
|
|
class function GetTypeID: Word; virtual;
|
|
procedure HandleNeeded; override;
|
|
function InternalReleaseBitmapHandle: HBITMAP; override;
|
|
function InternalReleaseMaskHandle: HBITMAP; override;
|
|
function InternalReleasePalette: HPALETTE; override;
|
|
procedure ReadData(Stream: TStream); override;
|
|
procedure ReadStream(AStream: TMemoryStream; ASize: Longint); override;
|
|
procedure SetMasked(AValue: Boolean); override;
|
|
procedure SetPixelFormat(AValue: TPixelFormat); override;
|
|
procedure SetTransparent(Value: Boolean); override;
|
|
procedure UnshareImage(CopyContent: boolean); override;
|
|
procedure UpdateCurrentView;
|
|
procedure SetHandle(AValue: THandle); override;
|
|
function UpdateHandle(AValue: HICON): Boolean; virtual;
|
|
function UpdateHandles(ABitmap, AMask: HBITMAP): Boolean; override;
|
|
procedure WriteStream(AStream: TMemoryStream); override;
|
|
public
|
|
constructor Create; override;
|
|
|
|
procedure Add(AFormat: TPixelFormat; AHeight, AWidth: Word);
|
|
procedure Assign(Source: TPersistent); override;
|
|
procedure AssignImage(ASource: TRasterImage); virtual;
|
|
procedure Clear; override;
|
|
procedure Delete(Aindex: Integer);
|
|
procedure Remove(AFormat: TPixelFormat; AHeight, AWidth: Word);
|
|
procedure GetDescription(Aindex: Integer; out AFormat: TPixelFormat; out AHeight, AWidth: Word);
|
|
procedure SetSize(AWidth, AHeight: integer); override;
|
|
class function GetFileExtensions: string; override;
|
|
function LazarusResourceTypeValid(const ResourceType: string): boolean; override;
|
|
procedure LoadFromResourceName(Instance: THandle; const ResName: String); override;
|
|
procedure LoadFromResourceID(Instance: THandle; ResID: PtrInt); override;
|
|
procedure LoadFromResourceHandle(Instance: THandle; ResHandle: TFPResourceHandle); virtual;
|
|
function BitmapHandleAllocated: boolean; override;
|
|
function MaskHandleAllocated: boolean; override;
|
|
function PaletteAllocated: boolean; override;
|
|
procedure SetHandles(ABitmap, AMask: HBITMAP); override;
|
|
procedure Sort;
|
|
function GetBestIndexForSize(ASize: TSize): Integer;
|
|
|
|
property Current: Integer read FCurrent write SetCurrent;
|
|
property Count: Integer read GetCount;
|
|
end;
|
|
|
|
{ TIcon }
|
|
|
|
TIcon = class(TCustomIcon)
|
|
private
|
|
function GetIconHandle: HICON;
|
|
procedure SetIconHandle(const AValue: HICON);
|
|
protected
|
|
class function GetStreamSignature: Cardinal; override;
|
|
class function GetTypeID: Word; override;
|
|
procedure HandleNeeded; override;
|
|
public
|
|
procedure LoadFromResourceHandle(Instance: THandle; ResHandle: TFPResourceHandle); override;
|
|
function ReleaseHandle: HICON;
|
|
function GetResourceType: TResourceType; override;
|
|
property Handle: HICON read GetIconHandle write SetIconHandle;
|
|
end;
|
|
|
|
TIcnsRec = record
|
|
IconType: TicnsIconType;
|
|
RawImage: TRawImage;
|
|
end;
|
|
PIcnsRec = ^TIcnsRec;
|
|
|
|
{ TIcnsList }
|
|
|
|
TIcnsList = class(TList)
|
|
private
|
|
function GetItem(Index: Integer): PIcnsRec;
|
|
procedure SetItem(Index: Integer; const AValue: PIcnsRec);
|
|
protected
|
|
procedure Notify(Ptr: Pointer; Action: TListNotification); override;
|
|
public
|
|
function Add(AIconType: TicnsIconType; ARawImage: TRawImage): Integer; reintroduce;
|
|
property Items[Index: Integer]: PIcnsRec read GetItem write SetItem; default;
|
|
end;
|
|
|
|
TSharedIcnsIcon = class(TSharedIcon)
|
|
end;
|
|
|
|
{ TIcnsIcon }
|
|
|
|
TIcnsIcon = class(TCustomIcon)
|
|
private
|
|
FImageList: TIcnsList;
|
|
FMaskList: TIcnsList;
|
|
procedure IcnsAdd(AIconType: TicnsIconType; ARawImage: TRawImage);
|
|
procedure IcnsProcess;
|
|
protected
|
|
class function GetSharedImageClass: TSharedRasterImageClass; override;
|
|
procedure ReadData(Stream: TStream); override;
|
|
procedure ReadStream(AStream: TMemoryStream; ASize: Longint); override;
|
|
procedure WriteStream(AStream: TMemoryStream); override;
|
|
public
|
|
constructor Create; override;
|
|
destructor Destroy; override;
|
|
|
|
class function GetFileExtensions: string; override;
|
|
function LazarusResourceTypeValid(const ResourceType: string): boolean; override;
|
|
end;
|
|
|
|
{ TSharedCursorImage }
|
|
|
|
TSharedCursorImage = class(TSharedIcon)
|
|
protected
|
|
procedure FreeHandle; override;
|
|
public
|
|
class function GetImagesClass: TIconImageClass; override;
|
|
end;
|
|
|
|
{ TCursorImageImage }
|
|
|
|
TCursorImageImage = class(TIconImage)
|
|
private
|
|
FHotSpot: TPoint;
|
|
public
|
|
constructor Create(const AInfo: TIconInfo); override;
|
|
property HotSpot: TPoint read FHotSpot write FHotSpot;
|
|
end;
|
|
|
|
{ TCursorImage }
|
|
TCursorImage = class(TCustomIcon)
|
|
private
|
|
function GetHotSpot: TPoint;
|
|
procedure SetHotSpot(const P: TPoint);
|
|
function GetCursorHandle: HCURSOR;
|
|
procedure SetCursorHandle(AValue: HCURSOR);
|
|
protected
|
|
procedure HandleNeeded; override;
|
|
class function GetDefaultSize: TSize; override;
|
|
class function GetStreamSignature: Cardinal; override;
|
|
class function GetSharedImageClass: TSharedRasterImageClass; override;
|
|
class function GetTypeID: Word; override;
|
|
public
|
|
class function GetFileExtensions: string; override;
|
|
function GetResourceType: TResourceType; override;
|
|
procedure LoadFromResourceHandle(Instance: THandle; ResHandle: TFPResourceHandle); override;
|
|
function LazarusResourceTypeValid(const ResourceType: string): boolean; override;
|
|
function ReleaseHandle: HCURSOR;
|
|
procedure SetCenterHotSpot;
|
|
property HotSpot: TPoint read GetHotSpot write SetHotSpot;
|
|
property Handle: HCURSOR read GetCursorHandle write SetCursorHandle;
|
|
end;
|
|
|
|
|
|
{$IFNDEF DisableLCLJPEG}
|
|
{ TSharedJpegImage }
|
|
|
|
TSharedJpegImage = class(TSharedCustomBitmap)
|
|
end;
|
|
|
|
{ TJpegImage }
|
|
|
|
TJPEGQualityRange = TFPJPEGCompressionQuality;
|
|
TJPEGPerformance = TJPEGReadPerformance;
|
|
|
|
TJPEGImage = class(TFPImageBitmap)
|
|
private
|
|
FGrayScale: Boolean;
|
|
FMinHeight: Integer;
|
|
FMinWidth: Integer;
|
|
FPerformance: TJPEGPerformance;
|
|
FProgressiveEncoding: boolean;
|
|
FQuality: TJPEGQualityRange;
|
|
FScale: TJPEGScale;
|
|
FSmoothing: Boolean;
|
|
procedure SetCompressionQuality(AValue: TJPEGQualityRange);
|
|
procedure SetGrayScale(AValue: Boolean);
|
|
procedure SetProgressiveEncoding(AValue: Boolean);
|
|
protected
|
|
procedure InitializeReader(AImage: TLazIntfImage; AReader: TFPCustomImageReader); override;
|
|
procedure InitializeWriter(AImage: TLazIntfImage; AWriter: TFPCustomImageWriter); override;
|
|
procedure FinalizeReader(AReader: TFPCustomImageReader); override;
|
|
class function GetReaderClass: TFPCustomImageReaderClass; override;
|
|
class function GetWriterClass: TFPCustomImageWriterClass; override;
|
|
class function GetSharedImageClass: TSharedRasterImageClass; override;
|
|
public
|
|
constructor Create; override;
|
|
procedure Compress;
|
|
class function IsStreamFormatSupported(Stream: TStream): Boolean; override;
|
|
class function GetFileExtensions: string; override;
|
|
public
|
|
property CompressionQuality: TJPEGQualityRange read FQuality write SetCompressionQuality;
|
|
property GrayScale: Boolean read FGrayScale {$IF FPC_FullVersion >= 30004} write SetGrayScale{$IFEND};
|
|
property MinHeight: Integer read FMinHeight write FMinHeight;
|
|
property MinWidth: Integer read FMinWidth write FMinWidth;
|
|
property ProgressiveEncoding: boolean read FProgressiveEncoding write SetProgressiveEncoding;
|
|
property Performance: TJPEGPerformance read FPerformance write FPerformance;
|
|
property Scale: TJPEGScale read FScale write FScale;
|
|
property Smoothing: Boolean read FSmoothing write FSmoothing;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
{$IFNDEF DisableLCLTIFF}
|
|
{ TSharedTiffImage }
|
|
|
|
TSharedTiffImage = class(TSharedCustomBitmap)
|
|
end;
|
|
|
|
{ TTiffImage }
|
|
|
|
TTiffUnit = (
|
|
tuUnknown,
|
|
tuNone, // No absolute unit of measurement. Used for images that may have a non-square
|
|
// aspect ratio, but no meaningful absolute dimensions.
|
|
tuInch,
|
|
tuCentimeter
|
|
);
|
|
|
|
TTiffImage = class(TFPImageBitmap)
|
|
private
|
|
FArtist: string;
|
|
FCopyright: string;
|
|
FDateTime: TDateTime;
|
|
FDocumentName: string;
|
|
FHostComputer: string;
|
|
FImageDescription: string;
|
|
FMake: string; {ScannerManufacturer}
|
|
FModel: string; {Scanner}
|
|
FResolutionUnit: TTiffUnit;
|
|
FSoftware: string;
|
|
FXResolution: TTiffRational;
|
|
FYResolution: TTiffRational;
|
|
protected
|
|
procedure InitializeReader(AImage: TLazIntfImage; AReader: TFPCustomImageReader); override;
|
|
procedure InitializeWriter(AImage: TLazIntfImage; AWriter: TFPCustomImageWriter); override;
|
|
procedure FinalizeReader(AReader: TFPCustomImageReader); override;
|
|
class function GetReaderClass: TFPCustomImageReaderClass; override;
|
|
class function GetWriterClass: TFPCustomImageWriterClass; override;
|
|
class function GetSharedImageClass: TSharedRasterImageClass; override;
|
|
public
|
|
constructor Create; override;
|
|
class function GetFileExtensions: string; override;
|
|
public
|
|
property Artist: string read FArtist write FArtist;
|
|
property Copyright: string read FCopyright write FCopyright;
|
|
property DateTime: TDateTime read FDateTime write FDateTime;
|
|
property DocumentName: string read FDocumentName write FDocumentName;
|
|
property HostComputer: string read FHostComputer write FHostComputer;
|
|
property ImageDescription: string read FImageDescription write FImageDescription;
|
|
// property ImageIsMask: Boolean;
|
|
// property ImageIsPage: Boolean;
|
|
// property ImageIsThumbNail: Boolean;
|
|
property Make: string read FMake write FMake;
|
|
property Model: string read FModel write FModel;
|
|
property ResolutionUnit: TTiffUnit read FResolutionUnit write FResolutionUnit;
|
|
property Software: string read FSoftware write FSoftware;
|
|
property XResolution: TTiffRational read FXResolution write FXResolution;
|
|
property YResolution: TTiffRational read FYResolution write FYResolution;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
{$IFNDEF DisableLCLGIF}
|
|
{ TSharedGIFImage }
|
|
|
|
TSharedGIFImage = class(TSharedCustomBitmap)
|
|
end;
|
|
|
|
{ TGIFImage }
|
|
|
|
TGIFImage = class(TFPImageBitmap)
|
|
private
|
|
FTransparent: Boolean;
|
|
FInterlaced: Boolean;
|
|
FBitsPerPixel: byte;
|
|
protected
|
|
procedure InitializeReader(AImage: TLazIntfImage; AReader: TFPCustomImageReader); override;
|
|
procedure FinalizeReader(AReader: TFPCustomImageReader); override;
|
|
class function GetReaderClass: TFPCustomImageReaderClass; override;
|
|
class function GetSharedImageClass: TSharedRasterImageClass; override;
|
|
public
|
|
constructor Create; override;
|
|
class function IsStreamFormatSupported(Stream: TStream): Boolean; override;
|
|
class function GetFileExtensions: string; override;
|
|
public
|
|
property Transparent: Boolean read FTransparent;
|
|
property Interlaced: Boolean read FInterlaced;
|
|
property BitsPerPixel: byte read FBitsPerPixel;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
function GraphicFilter(GraphicClass: TGraphicClass): string;
|
|
function GraphicExtension(GraphicClass: TGraphicClass): string;
|
|
function GraphicFileMask(GraphicClass: TGraphicClass): string;
|
|
function GetGraphicClassForFileExtension(const FileExt: string): TGraphicClass;
|
|
|
|
type
|
|
// Color / Identifier mapping
|
|
TGetColorStringProc = procedure(const s: AnsiString) of object;
|
|
|
|
function IdentEntry(Entry: Longint; out MapEntry: TIdentMapEntry): boolean;
|
|
function ColorToIdent(Color: Longint; out Ident: String): Boolean;
|
|
function IdentToColor(const Ident: string; out Color: Longint): Boolean;
|
|
function ColorIndex(Color: Longint; out Index: Integer): Boolean;
|
|
function SysColorToSysColorIndex(Color: TColor): integer;
|
|
function ColorToRGB(Color: TColor): Longint;
|
|
function ColorToString(Color: TColor): AnsiString;
|
|
function StringToColor(const S: shortstring): TColor;
|
|
function StringToColorDef(const S: shortstring; const DefaultValue: TColor): TColor;
|
|
procedure GetColorValues(Proc: TGetColorStringProc);
|
|
function InvertColor(AColor: TColor): TColor;
|
|
function DecColor(AColor: TColor; AQuantity: Byte): TColor;
|
|
function IsSysColor(AColor: TColorRef): Boolean;
|
|
|
|
function Blue(rgb: TColorRef): BYTE; // does not work on system color
|
|
function Green(rgb: TColorRef): BYTE; // does not work on system color
|
|
function Red(rgb: TColorRef): BYTE; // does not work on system color
|
|
function RGBToColor(R, G, B: Byte): TColor;
|
|
procedure RedGreenBlue(rgb: TColorRef; out Red, Green, Blue: Byte); // does not work on system color
|
|
function FPColorToTColorRef(const FPColor: TFPColor): TColorRef;
|
|
function FPColorToTColor(const FPColor: TFPColor): TColor;
|
|
function TColorToFPColor(const c: TColorRef): TFPColor; overload;
|
|
function TColorToFPColor(const c: TColor): TFPColor; overload; // does not work on system color
|
|
|
|
// fonts
|
|
procedure GetCharsetValues(Proc: TGetStrProc);
|
|
function CharsetToIdent(Charset: Longint; out Ident: string): Boolean;
|
|
function IdentToCharset(const Ident: string; out Charset: Longint): Boolean;
|
|
function GetFontData(Font: HFont): TFontData;
|
|
|
|
function GetDefFontCharSet: TFontCharSet;
|
|
function IsFontNameXLogicalFontDesc(const LongFontName: string): boolean;
|
|
function XLFDNameToLogFont(const XLFDName: string): TLogFont;
|
|
function ExtractXLFDItem(const XLFDName: string; Index: integer): string;
|
|
function ExtractFamilyFromXLFDName(const XLFDName: string): string;
|
|
function ClearXLFDItem(const LongFontName: string; Index: integer): string;
|
|
function ClearXLFDHeight(const LongFontName: string): string;
|
|
function ClearXLFDPitch(const LongFontName: string): string;
|
|
function ClearXLFDStyle(const LongFontName: string): string;
|
|
function XLFDHeightIsSet(const LongFontName: string): boolean;
|
|
procedure FontNameToPangoFontDescStr(const LongFontName: string;
|
|
out aFamily,aStyle:String; out aSize: Integer; out aSizeInPixels: Boolean);
|
|
|
|
// graphics
|
|
type
|
|
TOnLoadGraphicFromClipboardFormat =
|
|
procedure(Dest: TGraphic; ClipboardType: TClipboardType;
|
|
FormatID: TClipboardFormat);
|
|
TOnSaveGraphicToClipboardFormat =
|
|
procedure(Src: TGraphic; ClipboardType: TClipboardType;
|
|
FormatID: TClipboardFormat);
|
|
TOnGetSystemFont = function: HFONT;
|
|
|
|
var
|
|
OnLoadSaveClipBrdGraphicValid: boolean = false;
|
|
OnLoadGraphicFromClipboardFormat: TOnLoadGraphicFromClipboardFormat=nil;
|
|
OnSaveGraphicToClipboardFormat: TOnSaveGraphicToClipboardFormat=nil;
|
|
OnGetSystemFont: TOnGetSystemFont = nil;
|
|
|
|
function TestStreamIsBMP(const AStream: TStream): boolean;
|
|
function TestStreamIsXPM(const AStream: TStream): boolean;
|
|
function TestStreamIsIcon(const AStream: TStream): boolean;
|
|
function TestStreamIsCursor(const AStream: TStream): boolean;
|
|
|
|
function XPMToPPChar(const XPM: string): PPChar;
|
|
function LazResourceXPMToPPChar(const ResourceName: string): PPChar;
|
|
function ReadXPMFromStream(Stream: TStream; Size: integer): PPChar;
|
|
function ReadXPMSize(XPM: PPChar; var Width, Height, ColorCount: integer): boolean;
|
|
function LoadCursorFromLazarusResource(ACursorName: String): HCursor;
|
|
function LoadBitmapFromLazarusResource(const ResourceName: String): TBitmap; deprecated;
|
|
function LoadBitmapFromLazarusResourceHandle(Handle: TLResource): TBitmap; deprecated;
|
|
|
|
// technically a bitmap is created and not loaded
|
|
function CreateGraphicFromResourceName(Instance: THandle; const ResName: String): TGraphic;
|
|
function CreateBitmapFromResourceName(Instance: THandle; const ResName: String): TCustomBitmap;
|
|
function CreateBitmapFromLazarusResource(const AName: String): TCustomBitmap;
|
|
function CreateBitmapFromLazarusResource(const AName: String; AMinimumClass: TCustomBitmapClass): TCustomBitmap;
|
|
function CreateBitmapFromLazarusResource(AHandle: TLResource): TCustomBitmap;
|
|
function CreateBitmapFromLazarusResource(AHandle: TLResource; AMinimumClass: TCustomBitmapClass): TCustomBitmap;
|
|
|
|
function CreateCompatibleBitmaps(const ARawImage: TRawImage; out ABitmap, AMask: HBitmap; ASkipMask: Boolean = False): Boolean;
|
|
|
|
function CreateBitmapFromFPImage(Img: TFPCustomImage): TBitmap;
|
|
function AllocPatternBitmap(colorBG, colorFG: TColor): TBitmap;
|
|
|
|
|
|
var
|
|
{ Stores information about the current screen
|
|
- initialized on Interface startup }
|
|
ScreenInfo: TScreenInfo = (
|
|
PixelsPerInchX: 72;
|
|
PixelsPerInchY: 72;
|
|
ColorDepth: 24;
|
|
Initialized: False;
|
|
);
|
|
|
|
FontResourceCache: TFontHandleCache;
|
|
PenResourceCache: TPenHandleCache;
|
|
BrushResourceCache: TBrushHandleCache;
|
|
|
|
const
|
|
FontCharsets: array[0..18] of TIdentMapEntry = (
|
|
(Value: ANSI_CHARSET; Name: 'ANSI_CHARSET'),
|
|
(Value: DEFAULT_CHARSET; Name: 'DEFAULT_CHARSET'),
|
|
(Value: SYMBOL_CHARSET; Name: 'SYMBOL_CHARSET'),
|
|
(Value: MAC_CHARSET; Name: 'MAC_CHARSET'),
|
|
(Value: SHIFTJIS_CHARSET; Name: 'SHIFTJIS_CHARSET'),
|
|
(Value: HANGEUL_CHARSET; Name: 'HANGEUL_CHARSET'),
|
|
(Value: JOHAB_CHARSET; Name: 'JOHAB_CHARSET'),
|
|
(Value: GB2312_CHARSET; Name: 'GB2312_CHARSET'),
|
|
(Value: CHINESEBIG5_CHARSET; Name: 'CHINESEBIG5_CHARSET'),
|
|
(Value: GREEK_CHARSET; Name: 'GREEK_CHARSET'),
|
|
(Value: TURKISH_CHARSET; Name: 'TURKISH_CHARSET'),
|
|
(Value: VIETNAMESE_CHARSET; Name: 'VIETNAMESE_CHARSET'),
|
|
(Value: HEBREW_CHARSET; Name: 'HEBREW_CHARSET'),
|
|
(Value: ARABIC_CHARSET; Name: 'ARABIC_CHARSET'),
|
|
(Value: BALTIC_CHARSET; Name: 'BALTIC_CHARSET'),
|
|
(Value: RUSSIAN_CHARSET; Name: 'RUSSIAN_CHARSET'),
|
|
(Value: THAI_CHARSET; Name: 'THAI_CHARSET'),
|
|
(Value: EASTEUROPE_CHARSET; Name: 'EASTEUROPE_CHARSET'),
|
|
(Value: OEM_CHARSET; Name: 'OEM_CHARSET'));
|
|
|
|
|
|
(***************************************************************************
|
|
***************************************************************************)
|
|
|
|
function DbgS(const Style: TFontStyles): string; overload;
|
|
|
|
function ScaleX(const SizeX, FromDPI: Integer): Integer;
|
|
function ScaleY(const SizeY, FromDPI: Integer): Integer;
|
|
|
|
procedure Register;
|
|
procedure UpdateHandleObjects;
|
|
|
|
implementation
|
|
|
|
uses
|
|
SyncObjs, LCLIntf, InterfaceBase;
|
|
|
|
var
|
|
GraphicsUpdateCount: Integer = 0;
|
|
UpdateLock: TCriticalSection;
|
|
|
|
procedure UpdateHandleObjects;
|
|
begin
|
|
// renew all brushes, pens, fonts, ...
|
|
UpdateLock.Enter;
|
|
try
|
|
if GraphicsUpdateCount=High(GraphicsUpdateCount) then
|
|
GraphicsUpdateCount:=Low(GraphicsUpdateCount);
|
|
inc(GraphicsUpdateCount);
|
|
// at moment update only brushes, but later maybe we will need to update others
|
|
// don't clear BrushResourceCache because TBrush instances have references to cache items
|
|
// BrushResourceCache.Clear;
|
|
finally
|
|
UpdateLock.Leave;
|
|
end;
|
|
end;
|
|
|
|
function DbgS(const Style: TFontStyles): string;
|
|
|
|
procedure Add(const s: string);
|
|
begin
|
|
if Result<>'' then Result:=Result+',';
|
|
Result:=Result+s;
|
|
end;
|
|
|
|
begin
|
|
Result:='';
|
|
if fsBold in Style then Add('fsBold');
|
|
if fsItalic in Style then Add('fsItalic');
|
|
if fsStrikeOut in Style then Add('fsStrikeOut');
|
|
if fsUnderline in Style then Add('fsUnderline');
|
|
Result:='['+Result+']';
|
|
end;
|
|
|
|
function LoadCursorFromLazarusResource(ACursorName: String): HCursor;
|
|
var
|
|
CursorImage: TCursorImage;
|
|
begin
|
|
CursorImage := TCursorImage.Create;
|
|
try
|
|
CursorImage.LoadFromLazarusResource(ACursorName);
|
|
Result := CursorImage.ReleaseHandle;
|
|
finally
|
|
CursorImage.Free;
|
|
end;
|
|
end;
|
|
|
|
function LocalLoadBitmap(hInstance: THandle; lpBitmapName: PChar): HBitmap;
|
|
var
|
|
Bmp: TBitmap;
|
|
begin
|
|
Bmp := TBitmap.Create;
|
|
try
|
|
if PtrUInt(lpBitmapName) > High(Word)
|
|
then Bmp.LoadFromResourceName(hInstance, lpBitmapName)
|
|
else Bmp.LoadFromResourceID(hInstance, PtrInt(lpBitmapName));
|
|
Result := Bmp.ReleaseHandle;
|
|
finally
|
|
Bmp.Free;
|
|
end;
|
|
end;
|
|
|
|
function LocalLoadCursor(hInstance: THandle; lpCursorName: PChar): HCursor;
|
|
var
|
|
Cur: TCursorImage;
|
|
begin
|
|
Cur := TCursorImage.Create;
|
|
try
|
|
if PtrUInt(lpCursorName) > High(Word)
|
|
then Cur.LoadFromResourceName(hInstance, lpCursorName)
|
|
else Cur.LoadFromResourceID(hInstance, PtrInt(lpCursorName));
|
|
Result := Cur.ReleaseHandle;
|
|
finally
|
|
Cur.Free;
|
|
end;
|
|
end;
|
|
|
|
function LocalLoadIcon(hInstance: THandle; lpIconName: PChar): HIcon;
|
|
var
|
|
Ico: TIcon;
|
|
begin
|
|
Ico := TIcon.Create;
|
|
try
|
|
if PtrUInt(lpIconName) > High(Word)
|
|
then Ico.LoadFromResourceName(hInstance, lpIconName)
|
|
else Ico.LoadFromResourceID(hInstance, PtrInt(lpIconName));
|
|
Result := Ico.ReleaseHandle;
|
|
finally
|
|
Ico.Free;
|
|
end;
|
|
end;
|
|
|
|
function CreateBitmapFromLazarusResource(AStream: TLazarusResourceStream; AMinimumClass: TCustomBitmapClass): TCustomBitmap;
|
|
var
|
|
GraphicClass: TGraphicClass;
|
|
begin
|
|
Result := nil;
|
|
if AStream = nil then Exit;
|
|
|
|
GraphicClass := GetGraphicClassForFileExtension(AStream.Res.ValueType);
|
|
if GraphicClass = nil then Exit;
|
|
if not GraphicClass.InheritsFrom(AMinimumClass) then Exit;
|
|
|
|
Result := TCustomBitmap(GraphicClass.Create);
|
|
try
|
|
Result.LoadFromStream(AStream);
|
|
except
|
|
Result.Free;
|
|
Result := nil;
|
|
raise;
|
|
end;
|
|
end;
|
|
|
|
function CreateBitmapFromLazarusResource(const AName: String): TCustomBitmap;
|
|
begin
|
|
Result := CreateBitmapFromLazarusResource(AName, TCustomBitmap);
|
|
end;
|
|
|
|
function CreateBitmapFromLazarusResource(const AName: String; AMinimumClass: TCustomBitmapClass): TCustomBitmap;
|
|
var
|
|
Stream: TLazarusResourceStream;
|
|
begin
|
|
Stream := TLazarusResourceStream.Create(AName, nil);
|
|
try
|
|
Result := CreateBitmapFromLazarusResource(Stream, AMinimumClass);
|
|
finally
|
|
Stream.Free;
|
|
end;
|
|
end;
|
|
|
|
function CreateBitmapFromLazarusResource(AHandle: TLResource): TCustomBitmap;
|
|
begin
|
|
Result := CreateBitmapFromLazarusResource(AHandle, TCustomBitmap);
|
|
end;
|
|
|
|
function CreateBitmapFromLazarusResource(AHandle: TLResource; AMinimumClass: TCustomBitmapClass): TCustomBitmap;
|
|
var
|
|
Stream: TLazarusResourceStream;
|
|
begin
|
|
Stream := TLazarusResourceStream.CreateFromHandle(AHandle);
|
|
try
|
|
Result := CreateBitmapFromLazarusResource(Stream, AMinimumClass);
|
|
finally
|
|
Stream.Free;
|
|
end;
|
|
end;
|
|
|
|
function LoadBitmapFromLazarusResourceHandle(Handle: TLResource): TBitmap;
|
|
var
|
|
CB: TCustomBitmap;
|
|
begin
|
|
CB := CreateBitmapFromLazarusResource(Handle, TCustomBitmap);
|
|
if CB is TBitmap
|
|
then begin
|
|
Result := TBitmap(CB);
|
|
Exit;
|
|
end;
|
|
|
|
Result := TBitmap.Create;
|
|
Result.Assign(CB);
|
|
CB.Free;
|
|
end;
|
|
|
|
function LoadBitmapFromLazarusResource(const ResourceName: String): TBitmap;
|
|
var
|
|
CB: TCustomBitmap;
|
|
begin
|
|
CB := CreateBitmapFromLazarusResource(ResourceName, TCustomBitmap);
|
|
|
|
if CB is TBitmap
|
|
then begin
|
|
Result := TBitmap(CB);
|
|
Exit;
|
|
end;
|
|
|
|
Result := TBitmap.Create;
|
|
Result.Assign(CB);
|
|
CB.Free;
|
|
end;
|
|
|
|
//TODO: publish ?? (as RawImage_CreateCompatibleBitmaps)
|
|
function CreateCompatibleBitmaps(const ARawImage: TRawImage; out ABitmap, AMask: HBitmap; ASkipMask: Boolean = False): Boolean;
|
|
var
|
|
Desc: TRawImageDescription absolute ARawimage.Description;
|
|
|
|
ImagePtr: PRawImage;
|
|
DevImage: TRawImage;
|
|
DevDesc: TRawImageDescription;
|
|
SrcImage, DstImage: TLazIntfImage;
|
|
QueryFlags: TRawImageQueryFlags;
|
|
W, H: Integer;
|
|
begin
|
|
W := Desc.Width;
|
|
if W < 1 then W := 1;
|
|
H := Desc.Height;
|
|
if H < 1 then H := 1;
|
|
|
|
if Desc.Depth = 1
|
|
then QueryFlags := [riqfMono]
|
|
else QueryFlags := [riqfRGB];
|
|
if Desc.AlphaPrec <> 0
|
|
then Include(QueryFlags, riqfAlpha);
|
|
if Desc.MaskBitsPerPixel <> 0
|
|
then Include(QueryFlags, riqfMask);
|
|
QueryDescription(DevDesc, QueryFlags, W, H);
|
|
|
|
if DevDesc.IsEqual(Desc)
|
|
then begin
|
|
// image is compatible, so use it
|
|
DstImage := nil;
|
|
ImagePtr := @ARawImage;
|
|
end
|
|
else begin
|
|
// create compatible copy
|
|
SrcImage := TLazIntfImage.Create(ARawImage, False);
|
|
DstImage := TLazIntfImage.Create(0,0,[]);
|
|
// create mask for alphachannel when device has no alpha support
|
|
if (DevDesc.AlphaPrec = 0) and (riqfAlpha in QueryFlags)
|
|
then begin
|
|
//add mask if not already queried
|
|
if not (riqfMask in QueryFlags)
|
|
then QueryDescription(DevDesc, [riqfMask, riqfUpdate]);
|
|
DstImage.DataDescription := DevDesc;
|
|
DstImage.CopyPixels(SrcImage, 0, 0, True, $8000);
|
|
end
|
|
else begin
|
|
// update DevDesc because of unusual bitmaps. issue #12362
|
|
// widgetset can provide same DevDesc, but also can change it
|
|
// like gtk/gtk2 does since it expects XBM format for mono bitmaps.
|
|
if DevDesc.Depth = 1 then
|
|
begin
|
|
QueryFlags := QueryFlags + [riqfUpdate];
|
|
QueryDescription(DevDesc, QueryFlags);
|
|
end;
|
|
DstImage.DataDescription := DevDesc;
|
|
DstImage.CopyPixels(SrcImage);
|
|
end;
|
|
SrcImage.Free;
|
|
DstImage.GetRawImage(DevImage);
|
|
ImagePtr := @DevImage;
|
|
end;
|
|
|
|
try
|
|
Result := RawImage_CreateBitmaps(ImagePtr^, ABitmap, AMask, ASkipMask);
|
|
finally
|
|
DstImage.Free;
|
|
end;
|
|
end;
|
|
|
|
function CreateBitmapFromFPImage(Img: TFPCustomImage): TBitmap;
|
|
var
|
|
IntfImg: TLazIntfImage;
|
|
ok: Boolean;
|
|
begin
|
|
Result:=nil;
|
|
IntfImg:=nil;
|
|
ok:=false;
|
|
try
|
|
Result:=TBitmap.Create;
|
|
IntfImg:=Result.CreateIntfImage;
|
|
IntfImg.SetSize(Img.Width,Img.Height);
|
|
IntfImg.CopyPixels(Img);
|
|
Result.LoadFromIntfImage(IntfImg);
|
|
ok:=true;
|
|
finally
|
|
if not ok then FreeAndNil(Result);
|
|
IntfImg.Free;
|
|
end;
|
|
end;
|
|
|
|
function ScaleX(const SizeX, FromDPI: Integer): Integer;
|
|
begin
|
|
Result := MulDiv(SizeX, ScreenInfo.PixelsPerInchX, FromDPI);
|
|
end;
|
|
|
|
function ScaleY(const SizeY, FromDPI: Integer): Integer;
|
|
begin
|
|
Result := MulDiv(SizeY, ScreenInfo.PixelsPerInchY, FromDPI);
|
|
end;
|
|
|
|
procedure Register;
|
|
begin
|
|
RegisterClasses([TBitmap,TPixmap,TPortableNetworkGraphic,
|
|
{$IFNDEF DisableLCLPNM}TPortableAnyMapGraphic,{$ENDIF}
|
|
{$IFNDEF DisableLCLJPEG}TJpegImage,{$ENDIF}
|
|
{$IFNDEF DisableLCLGIF}TGIFImage,{$ENDIF}
|
|
TPicture,
|
|
TFont,TPen,TBrush,TRegion]);
|
|
end;
|
|
|
|
const
|
|
GraphicsFinalized: boolean = false;
|
|
|
|
type
|
|
TBitmapCanvas = class(TCanvas)
|
|
private
|
|
FImage: TRasterImage;
|
|
FOldBitmap: HBITMAP;
|
|
FOldPalette: HPALETTE;
|
|
procedure FreeDC; // called by TCustomBitmap.FreeCanvasContext
|
|
protected
|
|
procedure CreateHandle; override;
|
|
public
|
|
constructor Create(AImage: TRasterImage);
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
|
|
{ Color mapping routines }
|
|
|
|
const
|
|
FirstDeprecatedColorIndex = 53;
|
|
LastDeprecatedColorIndex = 106;
|
|
{$IFDEF DefineCLXColors}
|
|
Colors: array[0..106] of TIdentMapEntry = (
|
|
{$ELSE}
|
|
Colors: array[0..52] of TIdentMapEntry = (
|
|
{$ENDIF}
|
|
// standard colors
|
|
(Value: clBlack; Name: 'clBlack'),
|
|
(Value: clMaroon; Name: 'clMaroon'),
|
|
(Value: clGreen; Name: 'clGreen'),
|
|
(Value: clOlive; Name: 'clOlive'),
|
|
(Value: clNavy; Name: 'clNavy'),
|
|
(Value: clPurple; Name: 'clPurple'),
|
|
(Value: clTeal; Name: 'clTeal'),
|
|
(Value: clGray; Name: 'clGray'),
|
|
(Value: clSilver; Name: 'clSilver'),
|
|
(Value: clRed; Name: 'clRed'),
|
|
(Value: clLime; Name: 'clLime'),
|
|
(Value: clYellow; Name: 'clYellow'),
|
|
(Value: clBlue; Name: 'clBlue'),
|
|
(Value: clFuchsia; Name: 'clFuchsia'),
|
|
(Value: clAqua; Name: 'clAqua'),
|
|
(Value: clWhite; Name: 'clWhite'),
|
|
|
|
// extended colors
|
|
(Value: clMoneyGreen; Name: 'clMoneyGreen'),
|
|
(Value: clSkyBlue; Name: 'clSkyBlue'),
|
|
(Value: clCream; Name: 'clCream'),
|
|
(Value: clMedGray; Name: 'clMedGray'),
|
|
|
|
// special colors
|
|
(Value: clNone; Name: 'clNone'),
|
|
(Value: clDefault; Name: 'clDefault'),
|
|
|
|
// system colors
|
|
(Value: clScrollBar; Name: 'clScrollBar'),
|
|
(Value: clBackground; Name: 'clBackground'),
|
|
(Value: clActiveCaption; Name: 'clActiveCaption'),
|
|
(Value: clInactiveCaption; Name: 'clInactiveCaption'),
|
|
(Value: clMenu; Name: 'clMenu'),
|
|
(Value: clMenuBar; Name: 'clMenuBar'),
|
|
(Value: clMenuHighlight; Name: 'clMenuHighlight'),
|
|
(Value: clMenuText; Name: 'clMenuText'),
|
|
(Value: clWindow; Name: 'clWindow'),
|
|
(Value: clWindowFrame; Name: 'clWindowFrame'),
|
|
(Value: clWindowText; Name: 'clWindowText'),
|
|
(Value: clCaptionText; Name: 'clCaptionText'),
|
|
(Value: clActiveBorder; Name: 'clActiveBorder'),
|
|
(Value: clInactiveBorder; Name: 'clInactiveBorder'),
|
|
(Value: clAppWorkspace; Name: 'clAppWorkspace'),
|
|
(Value: clHighlight; Name: 'clHighlight'),
|
|
(Value: clHighlightText; Name: 'clHighlightText'),
|
|
(Value: clBtnFace; Name: 'clBtnFace'),
|
|
(Value: clBtnShadow; Name: 'clBtnShadow'),
|
|
(Value: clGrayText; Name: 'clGrayText'),
|
|
(Value: clBtnText; Name: 'clBtnText'),
|
|
(Value: clInactiveCaptionText; Name: 'clInactiveCaptionText'),
|
|
(Value: clBtnHighlight; Name: 'clBtnHighlight'),
|
|
(Value: cl3DDkShadow; Name: 'cl3DDkShadow'),
|
|
(Value: cl3DLight; Name: 'cl3DLight'),
|
|
(Value: clInfoText; Name: 'clInfoText'),
|
|
(Value: clInfoBk; Name: 'clInfoBk'),
|
|
|
|
(Value: clHotLight; Name: 'clHotLight'),
|
|
(Value: clGradientActiveCaption; Name: 'clGradientActiveCaption'),
|
|
(Value: clGradientInactiveCaption; Name: 'clGradientInactiveCaption'),
|
|
|
|
// one our special color
|
|
(Value: clForm; Name: 'clForm')
|
|
|
|
{$IFDEF DefineCLXColors}
|
|
// CLX base, mapped, pseudo, rgb values
|
|
,(Value: clForeground; Name: 'clForeground'),
|
|
(Value: clButton; Name: 'clButton'),
|
|
(Value: clLight; Name: 'clLight'),
|
|
(Value: clMidlight; Name: 'clMidlight'),
|
|
(Value: clDark; Name: 'clDark'),
|
|
(Value: clMid; Name: 'clMid'),
|
|
(Value: clText; Name: 'clText'),
|
|
(Value: clBrightText; Name: 'clBrightText'),
|
|
(Value: clButtonText; Name: 'clButtonText'),
|
|
(Value: clBase; Name: 'clBase'),
|
|
//clBackground
|
|
(Value: clShadow; Name: 'clShadow'),
|
|
//clHighlight
|
|
(Value: clHighlightedText; Name: 'clHighlightedText'),
|
|
|
|
// CLX normal, mapped, pseudo, rgb values
|
|
(Value: clNormalForeground; Name: 'clNormalForeground'),
|
|
(Value: clNormalButton; Name: 'clNormalButton'),
|
|
(Value: clNormalLight; Name: 'clNormalLight'),
|
|
(Value: clNormalMidlight; Name: 'clNormalMidlight'),
|
|
(Value: clNormalDark; Name: 'clNormalDark'),
|
|
(Value: clNormalMid; Name: 'clNormalMid'),
|
|
(Value: clNormalText; Name: 'clNormalText'),
|
|
(Value: clNormalBrightText; Name: 'clNormalBrightText'),
|
|
(Value: clNormalButtonText; Name: 'clNormalButtonText'),
|
|
(Value: clNormalBase; Name: 'clNormalBase'),
|
|
(Value: clNormalBackground; Name: 'clNormalBackground'),
|
|
(Value: clNormalShadow; Name: 'clNormalShadow'),
|
|
(Value: clNormalHighlight; Name: 'clNormalHighlight'),
|
|
(Value: clNormalHighlightedText; Name: 'clNormalHighlightedText'),
|
|
|
|
// CLX disabled, mapped, pseudo, rgb values
|
|
(Value: clDisabledForeground; Name: 'clDisabledForeground'),
|
|
(Value: clDisabledButton; Name: 'clDisabledButton'),
|
|
(Value: clDisabledLight; Name: 'clDisabledLight'),
|
|
(Value: clDisabledMidlight; Name: 'clDisabledMidlight'),
|
|
(Value: clDisabledDark; Name: 'clDisabledDark'),
|
|
(Value: clDisabledMid; Name: 'clDisabledMid'),
|
|
(Value: clDisabledText; Name: 'clDisabledText'),
|
|
(Value: clDisabledBrightText; Name: 'clDisabledBrightText'),
|
|
(Value: clDisabledButtonText; Name: 'clDisabledButtonText'),
|
|
(Value: clDisabledBase; Name: 'clDisabledBase'),
|
|
(Value: clDisabledBackground; Name: 'clDisabledBackground'),
|
|
(Value: clDisabledShadow; Name: 'clDisabledShadow'),
|
|
(Value: clDisabledHighlight; Name: 'clDisabledHighlight'),
|
|
(Value: clDisabledHighlightedText; Name: 'clDisabledHighlightedText'),
|
|
|
|
// CLX active, mapped, pseudo, rgb values
|
|
(Value: clActiveForeground; Name: 'clActiveForeground'),
|
|
(Value: clActiveButton; Name: 'clActiveButton'),
|
|
(Value: clActiveLight; Name: 'clActiveLight'),
|
|
(Value: clActiveMidlight; Name: 'clActiveMidlight'),
|
|
(Value: clActiveDark; Name: 'clActiveDark'),
|
|
(Value: clActiveMid; Name: 'clActiveMid'),
|
|
(Value: clActiveText; Name: 'clActiveText'),
|
|
(Value: clActiveBrightText; Name: 'clActiveBrightText'),
|
|
(Value: clActiveButtonText; Name: 'clActiveButtonText'),
|
|
(Value: clActiveBase; Name: 'clActiveBase'),
|
|
(Value: clActiveBackground; Name: 'clActiveBackground'),
|
|
(Value: clActiveShadow; Name: 'clActiveShadow'),
|
|
(Value: clActiveHighlight; Name: 'clActiveHighlight'),
|
|
(Value: clActiveHighlightedText; Name: 'clActiveHighlightedText')
|
|
{$ENDIF}
|
|
);
|
|
|
|
function IdentEntry(Entry: Longint; out MapEntry: TIdentMapEntry): boolean;
|
|
begin
|
|
Result := False;
|
|
if (Entry >= 0) and (Entry <= High(Colors)) then
|
|
begin
|
|
MapEntry := Colors[Entry];
|
|
Result := True;
|
|
end;
|
|
end;
|
|
|
|
function ColorToIdent(Color: Longint; out Ident: String): Boolean;
|
|
begin
|
|
Result := IntToIdent(Color, Ident, Colors);
|
|
end;
|
|
|
|
function IdentToColor(const Ident: string; out Color: Longint): Boolean;
|
|
begin
|
|
Result := IdentToInt(Ident, Color, Colors);
|
|
end;
|
|
|
|
function ColorIndex(Color: Longint; out Index: Integer): Boolean;
|
|
var
|
|
i: integer;
|
|
begin
|
|
for i := Low(Colors) to High(Colors) do
|
|
if Colors[i].Value = Color then
|
|
begin
|
|
Result := True;
|
|
Index := i;
|
|
exit;
|
|
end;
|
|
Result := False;
|
|
end;
|
|
|
|
function SysColorToSysColorIndex(Color: TColor): integer;
|
|
begin
|
|
if (Cardinal(Color) and Cardinal(SYS_COLOR_BASE)) <> 0 then begin
|
|
{$IFDEF DefineCLXColors}
|
|
case Color of
|
|
clHighlightedText..clForeground: // Deprecated values!
|
|
Result:=clForeground+COLOR_clForeground-Color;
|
|
clNormalHighlightedText..clNormalForeground:
|
|
Result:=clNormalForeground+COLOR_clNormalForeground-Color;
|
|
clDisabledHighlightedText..clDisabledForeground:
|
|
Result:=clDisabledForeground+COLOR_clDisabledForeground-Color;
|
|
clActiveHighlightedText..clActiveForeground:
|
|
Result:=clActiveForeground+COLOR_clActiveForeground-Color;
|
|
else
|
|
{$ENDIF}
|
|
Result:=Color and $FF;
|
|
{$IFDEF DefineCLXColors}
|
|
end;
|
|
{$ENDIF}
|
|
end else begin
|
|
Result:=-1;
|
|
end;
|
|
end;
|
|
|
|
function ColorToRGB(Color: TColor): Longint;
|
|
var
|
|
i: integer;
|
|
begin
|
|
i := SysColorToSysColorIndex(Color);
|
|
if i <> -1 then
|
|
Result := GetSysColor(i)
|
|
else
|
|
Result := Color;
|
|
Result := Result and $FFFFFF;
|
|
end;
|
|
|
|
function ColorToString(Color: TColor): AnsiString;
|
|
begin
|
|
Result := '';
|
|
if not ColorToIdent(Color, Result) then
|
|
Result:='$'+HexStr(Color,8);
|
|
end;
|
|
|
|
function StringToColor(const S: shortstring): TColor;
|
|
begin
|
|
Result := clNone;
|
|
if not IdentToColor(S, Longint(Result)) then
|
|
Result := TColor(StrToInt(S));
|
|
end;
|
|
|
|
function StringToColorDef(const S: shortstring; const DefaultValue: TColor): TColor;
|
|
begin
|
|
Result := DefaultValue;
|
|
if not IdentToColor(S, Longint(Result)) then
|
|
Result := TColor(StrToIntDef(S,DefaultValue));
|
|
end;
|
|
|
|
procedure GetColorValues(Proc: TGetColorStringProc);
|
|
var
|
|
I: Integer;
|
|
begin
|
|
for I := Low(Colors) to High(Colors) do
|
|
if (I >= FirstDeprecatedColorIndex) and (I <= LastDeprecatedColorIndex) then
|
|
Continue
|
|
else
|
|
Proc(Colors[I].Name);
|
|
end;
|
|
|
|
function InvertColor(AColor: TColor): TColor;
|
|
var
|
|
R, G, B: Integer;
|
|
begin
|
|
R := AColor and $ff;
|
|
G := (AColor shr 8) and $ff;
|
|
B := (AColor shr 16) and $ff;
|
|
|
|
if Abs($80 - R) + Abs($80 - G) + Abs($80 - B) < $140 then
|
|
begin
|
|
if R<$80 then
|
|
R:=Min($ff,R+$a0)
|
|
else
|
|
R:=Max(0,R-$a0);
|
|
if G<$80 then
|
|
G:=Min($ff,G+$a0)
|
|
else
|
|
G:=Max(0,G-$a0);
|
|
if B<$80 then
|
|
B:=Min($ff,B+$a0)
|
|
else
|
|
B:=Max(0,B-$a0);
|
|
end
|
|
else
|
|
begin
|
|
R := $ff - R;
|
|
G := $ff - G;
|
|
B := $ff - B;
|
|
end;
|
|
|
|
Result := ((B and $ff) shl 16) or ((G and $ff) shl 8) or (R and $ff);
|
|
end;
|
|
|
|
function Blue(rgb: TColorRef): BYTE;
|
|
begin
|
|
Result := (rgb shr 16) and $000000ff;
|
|
end;
|
|
|
|
function Green(rgb: TColorRef): BYTE;
|
|
begin
|
|
Result := (rgb shr 8) and $000000ff;
|
|
end;
|
|
|
|
function Red(rgb: TColorRef): BYTE;
|
|
begin
|
|
Result := rgb and $000000ff;
|
|
end;
|
|
|
|
function RGBToColor(R, G, B: Byte): TColor;
|
|
begin
|
|
Result := (B shl 16) or (G shl 8) or R;
|
|
end;
|
|
|
|
procedure RedGreenBlue(rgb: TColorRef; out Red, Green, Blue: Byte);
|
|
begin
|
|
Red := rgb and $000000ff;
|
|
Green := (rgb shr 8) and $000000ff;
|
|
Blue := (rgb shr 16) and $000000ff;
|
|
end;
|
|
|
|
function FPColorToTColorRef(const FPColor: TFPColor): TColorRef;
|
|
begin
|
|
Result:=((FPColor.Red shr 8) and $ff)
|
|
or (FPColor.Green and $ff00)
|
|
or ((FPColor.Blue shl 8) and $ff0000);
|
|
end;
|
|
|
|
function FPColorToTColor(const FPColor: TFPColor): TColor;
|
|
begin
|
|
Result:=TColor(FPColorToTColorRef(FPColor));
|
|
end;
|
|
|
|
function TColorToFPColor(const c: TColorRef): TFPColor;
|
|
begin
|
|
Result.Red:=(c and $ff);
|
|
Result.Red:=Result.Red+(Result.Red shl 8);
|
|
Result.Green:=(c and $ff00);
|
|
Result.Green:=Result.Green+(Result.Green shr 8);
|
|
Result.Blue:=(c and $ff0000) shr 8;
|
|
Result.Blue:=Result.Blue+(Result.Blue shr 8);
|
|
Result.Alpha:=FPImage.alphaOpaque;
|
|
end;
|
|
|
|
function TColorToFPColor(const c: TColor): TFPColor;
|
|
begin
|
|
Result:=TColorToFPColor(TColorRef(c));
|
|
end;
|
|
|
|
// ------------------------------------------------------------------
|
|
// Decrease the component RGBs of a color of the quantity' passed
|
|
//
|
|
// Color : Color to decrease
|
|
// Quantity : Decrease quantity
|
|
// ------------------------------------------------------------------
|
|
function DecColor(AColor: TColor; AQuantity: Byte) : TColor;
|
|
var
|
|
R, G, B : Byte;
|
|
begin
|
|
RedGreenBlue(ColorToRGB(AColor), R, G, B);
|
|
R := Max(0, Integer(R) - AQuantity);
|
|
G := Max(0, Integer(G) - AQuantity);
|
|
B := Max(0, Integer(B) - AQuantity);
|
|
Result := RGBToColor(R, G, B);
|
|
end;
|
|
|
|
function IsSysColor(AColor: TColorRef): Boolean;
|
|
begin
|
|
Result := (AColor and SYS_COLOR_BASE) <> 0;
|
|
end;
|
|
|
|
|
|
{$I graphicsobject.inc}
|
|
{$I graphic.inc}
|
|
{$I picture.inc}
|
|
{$I sharedimage.inc}
|
|
{$I sharedrasterimage.inc}
|
|
{$I sharedcustombitmap.inc}
|
|
{$I rasterimage.inc}
|
|
{$I custombitmap.inc}
|
|
{$I bitmapcanvas.inc}
|
|
{$I pen.inc}
|
|
{$I brush.inc}
|
|
{$I region.inc}
|
|
{$I font.inc}
|
|
{$I canvas.inc}
|
|
{$I pixmap.inc}
|
|
{$I png.inc}
|
|
{$IFNDEF DisableLCLPNM}
|
|
{$I pnm.inc}
|
|
{$ENDIF}
|
|
{$IFNDEF DisableLCLJPEG}
|
|
{$I jpegimage.inc}
|
|
{$ENDIF}
|
|
{$I icon.inc}
|
|
{$I icnsicon.inc}
|
|
{$I cursorimage.inc}
|
|
{$I fpimagebitmap.inc}
|
|
{$I bitmap.inc}
|
|
{$IFNDEF DisableLCLTIFF}
|
|
{$I tiffimage.inc}
|
|
{$ENDIF}
|
|
{$IFNDEF DisableLCLGIF}
|
|
{$I gifimage.inc}
|
|
{$ENDIF}
|
|
{$I patternbitmap.inc}
|
|
|
|
function CreateGraphicFromResourceName(Instance: THandle; const ResName: String): TGraphic;
|
|
var
|
|
ResHandle: TFPResourceHandle;
|
|
begin
|
|
// test Icon
|
|
ResHandle := FindResource(Instance, PChar(ResName), PChar(RT_GROUP_ICON));
|
|
if ResHandle <> 0 then
|
|
begin
|
|
Result := TIcon.Create;
|
|
TIcon(Result).LoadFromResourceHandle(Instance, ResHandle);
|
|
Exit;
|
|
end;
|
|
// test Cursor
|
|
ResHandle := FindResource(Instance, PChar(ResName), PChar(RT_GROUP_CURSOR));
|
|
if ResHandle <> 0 then
|
|
begin
|
|
Result := TCursorImage.Create;
|
|
TCursorImage(Result).LoadFromResourceHandle(Instance, ResHandle);
|
|
end
|
|
else
|
|
Result := CreateBitmapFromResourceName(Instance, ResName)
|
|
end;
|
|
|
|
function CreateBitmapFromResourceName(Instance: THandle; const ResName: String): TCustomBitmap;
|
|
var
|
|
ResHandle: TFPResourceHandle;
|
|
Stream: TResourceStream;
|
|
GraphicClass: TGraphicClass;
|
|
begin
|
|
ResHandle := FindResource(Instance, PChar(ResName), PChar(RT_BITMAP));
|
|
if ResHandle <> 0 then
|
|
begin
|
|
Result := TBitmap.Create;
|
|
Result.LoadFromResourceName(Instance, ResName);
|
|
Exit;
|
|
end;
|
|
ResHandle := FindResource(Instance, PChar(ResName), PChar(RT_RCDATA));
|
|
if ResHandle <> 0 then
|
|
begin
|
|
Stream := TResourceStream.Create(Instance, ResName, RT_RCDATA);
|
|
try
|
|
GraphicClass := GetPicFileFormats.FindByStreamFormat(Stream);
|
|
if Assigned(GraphicClass) and GraphicClass.InheritsFrom(TCustomBitmap) then
|
|
begin
|
|
Result := TCustomBitmap(GraphicClass.Create);
|
|
Result.LoadFromStream(Stream);
|
|
end
|
|
else
|
|
Result := nil;
|
|
finally
|
|
Stream.Free;
|
|
end;
|
|
end
|
|
else
|
|
Result := nil;
|
|
end;
|
|
|
|
function LocalGetSystemFont: HFont;
|
|
begin
|
|
Result := GetStockObject(DEFAULT_GUI_FONT);
|
|
end;
|
|
|
|
procedure InterfaceInit;
|
|
begin
|
|
//debugln('Graphics.InterfaceInit');
|
|
FontResourceCache:=TFontHandleCache.Create;
|
|
PenResourceCache:=TPenHandleCache.Create;
|
|
BrushResourceCache:=TBrushHandleCache.Create;
|
|
PatternBitmapCache := TPatternBitmapCache.Create;
|
|
end;
|
|
|
|
procedure InterfaceFinal;
|
|
begin
|
|
//debugln('Graphics.InterfaceFinal');
|
|
FreeAndNil(PatternBitmapCache);
|
|
FreeAndNil(FontResourceCache);
|
|
FreeAndNil(PenResourceCache);
|
|
FreeAndNil(BrushResourceCache);
|
|
end;
|
|
|
|
{ TCursorImageImage }
|
|
|
|
constructor TCursorImageImage.Create(const AInfo: TIconInfo);
|
|
begin
|
|
inherited Create(AInfo);
|
|
FHotSpot.x := AInfo.xHotspot;
|
|
FHotSpot.y := AInfo.yHotspot;
|
|
end;
|
|
|
|
initialization
|
|
UpdateLock := TCriticalSection.Create;
|
|
OnGetSystemFont := @LocalGetSystemFont;
|
|
LoadBitmapFunction := @LocalLoadBitmap;
|
|
LoadCursorFunction := @LocalLoadCursor;
|
|
LoadIconFunction := @LocalLoadIcon;
|
|
RegisterIntegerConsts(TypeInfo(TColor), TIdentToInt(@IdentToColor), TIntToIdent(@ColorToIdent));
|
|
RegisterIntegerConsts(TypeInfo(TFontCharset), TIdentToInt(@IdentToCharset), TIntToIdent(@CharsetToIdent));
|
|
RegisterInterfaceInitializationHandler(@InterfaceInit);
|
|
RegisterInterfaceFinalizationHandler(@InterfaceFinal);
|
|
|
|
finalization
|
|
GraphicsFinalized:=true;
|
|
OnLoadSaveClipBrdGraphicValid:=false;
|
|
FreeAndNil(PicClipboardFormats);
|
|
FreeAndNil(PicFileFormats);
|
|
UpdateLock.Free;
|
|
|
|
end.
|