{ $Id$ } { /*************************************************************************** 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.LCL, included in this distribution, * * for details about the copyright. * * * * This program is distributed in the hope that it will be useful, * * but WITHOUT ANY WARRANTY; without even the implied warranty of * * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. * * * ***************************************************************************** } unit Graphics; {$mode objfpc}{$H+} interface {$ifdef Trace} {$ASSERTIONS ON} {$endif} uses SysUtils, Types, Classes, Contnrs, FPCAdds, FPImage, FPReadPNG, FPWritePNG, FPReadBMP, FPWriteBMP, FPReadPNM, FPWritePNM, IntfGraphics, FPCanvas, AvgLvlTree, LCLStrConsts, LCLType, LCLProc, LMessages, LCLIntf, LResources, LCLResCache, GraphType, GraphMath, InterfaceBase; type PColor = ^TColor; TColor = TGraphicsColor; TFontPitch = (fpDefault, fpVariable, fpFixed); TFontName = string; TFontDataName = string[LF_FACESIZE -1]; TFontStyle = (fsBold, fsItalic, fsStrikeOut, fsUnderline); TFontStyles = set of TFontStyle; TFontStylesbase = set of TFontStyle; TFontCharSet = 0..255; TFontData = record Handle: HFont; Height: Integer; Pitch: TFontPitch; Style: TFontStylesBase; CharSet: TFontCharSet; Name: TFontDataName; end; const // 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; Name: 'default' ); 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; // currently ignored 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 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 end; type TPenStyle = TFPPenStyle; TPenMode = TFPPenMode; TBrushStyle = TFPBrushStyle; const psSolid = FPCanvas.psSolid; psDash = FPCanvas.psDash; psDot = FPCanvas.psDot; psDashDot = FPCanvas.psDashDot; psDashDotDot = FPCanvas.psDashDotDot; psClear = FPCanvas.psClear; //psInsideframe = FPCanvas.psInsideframe; 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; 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 is a generic progress notification event which may be used by TGraphic classes with computationally intensive (slow) operations, such as loading, storing, or transforming image data. Event params: Stage - Indicates whether this call to the OnProgress event is to prepare for, process, or clean up after a graphic operation. If OnProgress is called at all, the first call for a graphic operation will be with Stage = psStarting, to allow the OnProgress event handler to allocate whatever resources it needs to process subsequent progress notifications. After Stage = psStarting, you are guaranteed that OnProgress will be called again with Stage = psEnding to allow you to free those resources, even if the graphic operation is aborted by an exception. Zero or more calls to OnProgress with Stage = psRunning may occur between the psStarting and psEnding calls. PercentDone - The ratio of work done to work remaining, on a scale of 0 to 100. Values may repeat or even regress (get smaller) in successive calls. PercentDone is usually only a guess, and the guess may be dramatically altered as new information is discovered in decoding the image. RedrawNow - Indicates whether the graphic can be/should be redrawn immediately. Useful for showing successive approximations of an image as data is available instead of waiting for all the data to arrive before drawing anything. Since there is no message loop activity during graphic operations, you should call Update to force a control to be redrawn immediately in the OnProgress event handler. Redrawing a graphic when RedrawNow = False could corrupt the image and/or cause exceptions. Rect - Area of image that has changed and needs to be redrawn. Msg - Optional text describing in one or two words what the graphic class is currently working on. Ex: "Loading" "Storing" "Reducing colors". The Msg string can also be empty. Msg strings should be resourced for translation, should not contain trailing periods, and should be used only for display purposes. (do not: if Msg = 'Loading' then...) } TProgressStage = (psStarting, psRunning, psEnding); TProgressEvent = procedure (Sender: TObject; Stage: TProgressStage; PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string; var DoContinue: Boolean) of object; { For Delphi compatibility } TPixelFormat = ( pfDevice, pf1bit, pf4bit, pf8bit, pf15bit, pf16bit, pf24bit, pf32bit, pfCustom ); TTransparentMode = ( tmAuto, tmFixed ); const // The following colors match the predefined Delphi 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); clDkGray = TColor($808080); clWhite = TColor($FFFFFF); clCream = TColor($F0FBFF); 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); clForm = TColor(SYS_COLOR_BASE or COLOR_FORM); clEndColors = TColor(SYS_COLOR_BASE or COLOR_ENDCOLORS); 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; // CLX base, mapped, pseudo, rgb values clForeground = TColor(-1); clButton = TColor(-2); clLight = TColor(-3); clMidlight = TColor(-4); clDark = TColor(-5); clMid = TColor(-6); clText = TColor(-7); clBrightText = TColor(-8); clButtonText = TColor(-9); clBase = TColor(-10); clxBackground = TColor(-11); // only used as base for the CLX colors clShadow = TColor(-12); clxHighlight = TColor(-13); // only used as base for the CLX colors clHighlightedText = TColor(-14); // CLX mapped role offsets cloNormal = 32; cloDisabled = 64; cloActive = 96; // CLX normal, mapped, pseudo, rgb values clNormalForeground = TColor(clForeground - cloNormal); clNormalButton = TColor(clButton - cloNormal); clNormalLight = TColor(clLight - cloNormal); clNormalMidlight = TColor(clMidlight - cloNormal); clNormalDark = TColor(clDark - cloNormal); clNormalMid = TColor(clMid - cloNormal); clNormalText = TColor(clText - cloNormal); clNormalBrightText = TColor(clBrightText - cloNormal); clNormalButtonText = TColor(clButtonText - cloNormal); clNormalBase = TColor(clBase - cloNormal); clNormalBackground = TColor(clxBackground - cloNormal); clNormalShadow = TColor(clShadow - cloNormal); clNormalHighlight = TColor(clxHighlight - cloNormal); clNormalHighlightedText = TColor(clHighlightedText - cloNormal); // CLX disabled, mapped, pseudo, rgb values clDisabledForeground = TColor(clForeground - cloDisabled); clDisabledButton = TColor(clButton - cloDisabled); clDisabledLight = TColor(clLight - cloDisabled); clDisabledMidlight = TColor(clMidlight - cloDisabled); clDisabledDark = TColor(clDark - cloDisabled); clDisabledMid = TColor(clMid - cloDisabled); clDisabledText = TColor(clText - cloDisabled); clDisabledBrightText = TColor(clBrightText - cloDisabled); clDisabledButtonText = TColor(clButtonText - cloDisabled); clDisabledBase = TColor(clBase - cloDisabled); clDisabledBackground = TColor(clxBackground - cloDisabled); clDisabledShadow = TColor(clShadow - cloDisabled); clDisabledHighlight = TColor(clxHighlight - cloDisabled); clDisabledHighlightedText = TColor(clHighlightedText - cloDisabled); // CLX active, mapped, pseudo, rgb values clActiveForeground = TColor(clForeground - cloActive); clActiveButton = TColor(clButton - cloActive); clActiveLight = TColor(clLight - cloActive); clActiveMidlight = TColor(clMidlight - cloActive); clActiveDark = TColor(clDark - cloActive); clActiveMid = TColor(clMid - cloActive); clActiveText = TColor(clText - cloActive); clActiveBrightText = TColor(clBrightText - cloActive); clActiveButtonText = TColor(clButtonText - cloActive); clActiveBase = TColor(clBase - cloActive); clActiveBackground = TColor(clxBackground - cloActive); clActiveShadow = TColor(clShadow - cloActive); clActiveHighlight = TColor(clxHighlight - cloActive); clActiveHighlightedText = TColor(clHighlightedText - cloActive); type TMappedColor = clActiveHighlightedText..clNormalForeground; TColorGroup = (cgInactive, cgDisabled, cgActive); TColorRole = (crForeground, crButton, crLight, crMidlight, crDark, crMid, crText, crBrightText, crButtonText, crBase, crBackground, crShadow, crHighlight, crHighlightText, crNoRole); 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; // standard LCL graphic formats TBitmap = class; // bmp TPixmap = class; // xpm TIcon = class; // ico TPortableNetworkGraphic = class; // png TPortableAnyMapGraphic = class; // pnm formats: pbm, pgm and ppm {$IFDEF UseSimpleJpeg} {$error will be added to the LCL, when fpc 2.0 is released. Use the jpeg package in the components/jpeg directory instead. } // MG: will be added to the LCL, when fpc 2.0 is released // but then with the advanced features of the existing package {$ENDIF} { TGraphicsObject In Delphi VCL this is the ancestor of TFon, TPen and TBrush. With FPC 2.0 the LCL uses TFPCanvasHelper. } TGraphicsObject = class(TPersistent) private FOnChanging: TNotifyEvent; FOnChange: TNotifyEvent; Procedure DoChange(var Msg); message LM_CHANGED; protected procedure Changing; dynamic; procedure Changed; dynamic; 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: TAvgLvlTree; Desc1, Desc2: Pointer): integer; override; function FindFont(TheFont: HFONT): TResourceCacheItem; function FindFontDesc(const LogFont: TLogFont; const LongFontName: string): TFontHandleCacheDescriptor; function Add(TheFont: HFONT; const LogFont: TLogFont; const LongFontName: string): TFontHandleCacheDescriptor; end; { TFont } TFont = class(TFPCustomFont) private FCanUTF8: boolean; FHandle: HFont; FPitch: TFontPitch; FStyle: TFontStylesBase; FCharSet: TFontCharSet; FPixelsPerInch: Integer; FUpdateCount: integer; FChanged: boolean; FFontHandleCached: boolean; FColor: TColor; FHeight: integer; // FHeight = -(FSize * FPixelsPerInch) div 72 procedure FreeHandle; procedure GetData(var FontData: TFontData); function IsNameStored: boolean; procedure SetData(const FontData: TFontData); protected procedure DoAllocateResources; override; procedure DoDeAllocateResources; override; procedure DoCopyProps(From: TFPCanvasHelper); override; procedure SetFlags(Index: integer; AValue: boolean); override; procedure SetName(AValue: string); override; procedure SetSize(AValue: integer); override; procedure SetColor(const NewColor: TColor; const NewFPColor: TFPColor); virtual; procedure SetFPColor(const AValue: TFPColor); override; procedure Changed; override; function GetCharSet: TFontCharSet; function GetHandle: HFONT; function GetHeight: Integer; function GetName: string; function GetPitch: TFontPitch; function GetSize: Integer; function GetStyle: TFontStyles; procedure SetCharSet(const AValue: TFontCharSet); procedure SetColor(Value: TColor); procedure SetHandle(const Value: HFONT); procedure SetHeight(value: Integer); procedure SetPitch(Value: TFontPitch); procedure SetStyle(Value: TFontStyles); public constructor Create; override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; procedure Assign(const ALogFont: TLogFont); function IsEqual(AFont: TFont): boolean; virtual; procedure BeginUpdate; procedure EndUpdate; function HandleAllocated: boolean; function IsDefault: boolean; // Extra properties // TODO: implement them through GetTextMetrics, not here //Function GetWidth(Value: String): Integer; //property Width: Integer read FWidth write FWidth; //property XBias: Integer read FXBias write FXBias; //property YBias: Integer read FYBias write FYBias; property Handle: HFONT read GetHandle write SetHandle; property PixelsPerInch: Integer read FPixelsPerInch write FPixelsPerInch; property CanUTF8: boolean read FCanUTF8; published property CharSet: TFontCharSet read GetCharSet write SetCharSet default DEFAULT_CHARSET; property Color: TColor read FColor write SetColor default clWindowText; property Height: Integer read GetHeight write SetHeight; property Name: string read GetName write SetName stored IsNameStored; property Pitch: TFontPitch read GetPitch write SetPitch default fpDefault; property Size: Integer read GetSize write SetSize stored false; property Style: TFontStyles read GetStyle write SetStyle; end; { TPen } TPenData = record Handle: HPen; Color: TColor; Width: Integer; Style: TPenStyle; end; TPenHandleCache = class(TBlockResourceCache) protected procedure RemoveItem(Item: TResourceCacheItem); override; public constructor Create; end; TPen = class(TFPCustomPen) private FHandle: HPen; FColor: TColor; FPenHandleCached: boolean; procedure FreeHandle; 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; function GetHandle: HPEN; procedure SetHandle(const Value: HPEN); procedure SetColor(Value: TColor); 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; published property Color: TColor read FColor write SetColor default clBlack; property Mode default pmCopy; property Style default psSolid; property Width default 1; end; { TBrush } TBrushData = record Handle: HBrush; Color: TColor; Bitmap: TBitmap; Style: TBrushStyle; end; TBrushHandleCache = class(TBlockResourceCache) protected procedure RemoveItem(Item: TResourceCacheItem); override; public constructor Create; end; TBrush = class(TFPCustomBrush) private FHandle: HBrush; FBrushHandleCached: boolean; FColor: TColor; FBitmap: TBitmap; procedure FreeHandle; 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; function GetHandle: HBRUSH; procedure SetBitmap(Value: TBitmap); procedure SetColor(Value: TColor); procedure SetHandle(const Value: HBRUSH); Procedure SetStyle(Value: TBrushStyle); override; public procedure Assign(Source: TPersistent); override; constructor Create; override; destructor Destroy; override; property Bitmap: TBitmap read FBitmap write SetBitmap; property Handle: HBRUSH read GetHandle write SetHandle; published property Color: TColor read FColor write SetColor default clWhite; property Style default bsSolid; end; { TRegion } TRegionData = record Handle: HRgn; Rect: TRect; {Polygon Region Info - not used yet} Polygon: PPoint;//Polygon Points NumPoints: Longint;//Number of Points Winding: Boolean;//Use Winding mode end; TRegion = class(TGraphicsObject) private FRegionData: TRegionData; procedure FreeHandle; protected function GetHandle: HRGN; procedure SetHandle(const Value: HRGN); procedure SetClipRect(value: TRect); Function GetClipRect: TRect; public constructor Create; destructor Destroy; override; procedure Assign(Source: TPersistent); override; property Handle: HRGN read GetHandle write SetHandle; property ClipRect: TRect read GetClipRect write SetClipRect; end; { TGraphic } { The TGraphic class is an abstract base class for dealing with graphic images such as bitmaps, pixmaps, icons, and other image formats. LoadFromFile - Read the graphic from the file system. The old contents of the graphic are lost. If the file is not of the right format, an exception will be generated. SaveToFile - Writes the graphic to disk in the file provided. LoadFromStream - Like LoadFromFile except source is a stream (e.g. TBlobStream). SaveToStream - stream analogue of SaveToFile. LoadFromClipboardFormat - Replaces the current image with the data provided. If the TGraphic does not support that format it will generate an exception. SaveToClipboardFormats - Converts the image to a clipboard format. If the image does not support being translated into a clipboard format it will generate an exception. Height - The native, unstretched, height of the graphic. Palette - Color palette of image. Zero if graphic doesn't need/use palettes. Transparent - Some parts of the image are not opaque. aka the background can be seen through. Width - The native, unstretched, width of the graphic. OnChange - Called whenever the graphic changes PaletteModified - Indicates in OnChange whether color palette has changed. Stays true until whoever's responsible for realizing this new palette (ex: TImage) sets it to False. OnProgress - Generic progress indicator event. Propagates out to TPicture and TImage OnProgress events.} TGraphic = class(TPersistent) private FModified: Boolean; FTransparent: Boolean; FOnChange: TNotifyEvent; FOnProgress: TProgressEvent; FPaletteModified: Boolean; protected procedure Changed(Sender: TObject); virtual; function Equals(Graphic: TGraphic): Boolean; virtual; 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 GetPalette: HPALETTE; virtual; function GetTransparent: Boolean; virtual; function GetWidth: Integer; virtual; abstract; procedure Progress(Sender: TObject; Stage: TProgressStage; PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string; var DoContinue: boolean); dynamic; procedure ReadData(Stream: TStream); virtual; procedure SetHeight(Value: Integer); virtual; abstract; procedure SetPalette(Value: HPALETTE); virtual; procedure SetTransparent(Value: Boolean); virtual; procedure SetWidth(Value: Integer); virtual; abstract; procedure SetModified(Value: Boolean); procedure WriteData(Stream: TStream); virtual; public constructor Create; virtual; procedure LoadFromFile(const Filename: string); virtual; procedure SaveToFile(const Filename: string); virtual; procedure LoadFromStream(Stream: TStream); virtual; abstract; procedure SaveToStream(Stream: TStream); virtual; abstract; procedure LoadFromMimeStream(Stream: TStream; const MimeType: string); virtual; procedure LoadFromLazarusResource(const ResName: String); virtual; abstract; procedure LoadFromClipboardFormat(FormatID: TClipboardFormat); virtual; procedure LoadFromClipboardFormatID(ClipboardType: TClipboardType; FormatID: TClipboardFormat); virtual; procedure SaveToClipboardFormat(FormatID: TClipboardFormat); virtual; procedure SaveToClipboardFormatID(ClipboardType: TClipboardType; FormatID: TClipboardFormat); virtual; procedure GetSupportedSourceMimeTypes(List: TStrings); virtual; function GetDefaultMimeType: string; virtual; class function GetFileExtensions: string; virtual; class function GetFPReaderForFileExt( const FileExtension: string): TFPCustomImageReaderClass; virtual; class function GetFPWriterForFileExt( const FileExtension: string): TFPCustomImageWriterClass; virtual; class function GetDefaultFPReader: TFPCustomImageReaderClass; virtual; class function GetDefaultFPWriter: TFPCustomImageWriterClass; virtual; public property Empty: Boolean read GetEmpty; property Height: Integer read GetHeight write SetHeight; property Modified: Boolean read FModified write SetModified; 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 is a TGraphic container. It is used in place of a TGraphic if the graphic can be of any TGraphic class. LoadFromFile and SaveToFile are polymorphic. For example, if the TPicture is holding an Icon, you can LoadFromFile a bitmap file, where if the class is TIcon you could only read .ICO files. LoadFromFile - Reads a picture from disk. The TGraphic class created determined by the file extension of the file. If the file extension is not recognized an exception is generated. SaveToFile - Writes the picture to disk. LoadFromClipboardFormat - ToDo: Reads the picture from the handle provided in the given clipboard format. If the format is not supported, an exception is generated. SaveToClipboardFormats - ToDo: Allocates a global handle and writes the picture in its native clipboard format (CF_BITMAP for bitmaps, CF_METAFILE for metafiles, etc.). Formats will contain the formats written. Returns the number of clipboard items written to the array pointed to by Formats and Datas or would be written if either Formats or Datas are nil. SupportsClipboardFormat - Returns true if the given clipboard format is supported by LoadFromClipboardFormat. Assign - Copys the contents of the given TPicture. Used most often in the implementation of TPicture properties. RegisterFileFormat - Register a new TGraphic class for use in LoadFromFile. RegisterClipboardFormat - Registers a new TGraphic class for use in LoadFromClipboardFormat. UnRegisterGraphicClass - Removes all references to the specified TGraphic class and all its descendents from the file format and clipboard format internal lists. Height - The native, unstretched, height of the picture. Width - The native, unstretched, width of the picture. Graphic - The TGraphic object contained by the TPicture Bitmap - Returns a bitmap. If the contents is not already a bitmap, the contents are thrown away and a blank bitmap is returned. Pixmap - Returns a pixmap. If the contents is not already a pixmap, the contents are thrown away and a blank pixmap is returned. PNG - Returns a png. If the contents is not already a png, the contents are thrown away and a blank png (TPortableNetworkGraphic) is returned. PNM - Returns a pnm. If the contents is not already a pnm, the contents are thrown away and a blank pnm (TPortableAnyMapGraphic) is returned. } TPicture = class(TPersistent) private FGraphic: TGraphic; FOnChange: TNotifyEvent; //FNotify: IChangeNotifier; FOnProgress: TProgressEvent; procedure ForceType(GraphicType: TGraphicClass); function GetBitmap: TBitmap; function GetPNG: TPortableNetworkGraphic; function GetPNM: TPortableAnyMapGraphic; function GetPixmap: TPixmap; function GetIcon: TIcon; function GetHeight: Integer; function GetWidth: Integer; procedure ReadData(Stream: TStream); procedure SetBitmap(Value: TBitmap); procedure SetPNG(const AValue: TPortableNetworkGraphic); procedure SetPNM(const AValue: TPortableAnyMapGraphic); procedure SetPixmap(Value: TPixmap); procedure SetIcon(Value: TIcon); procedure SetGraphic(Value: TGraphic); procedure WriteData(Stream: TStream); protected procedure AssignTo(Dest: TPersistent); override; procedure Changed(Sender: TObject); dynamic; procedure DefineProperties(Filer: TFiler); override; procedure Progress(Sender: TObject; Stage: TProgressStage; PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string; var DoContinue: boolean); dynamic; public constructor Create; destructor Destroy; override; procedure LoadFromFile(const Filename: string); procedure SaveToFile(const Filename: string); procedure LoadFromClipboardFormat(FormatID: TClipboardFormat); procedure LoadFromClipboardFormatID(ClipboardType: TClipboardType; FormatID: TClipboardFormat); procedure SaveToClipboardFormat(FormatID: TClipboardFormat); 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); procedure Clear; virtual; public property Bitmap: TBitmap read GetBitmap write SetBitmap; property Pixmap: TPixmap read GetPixmap write SetPixmap; property PNG: TPortableNetworkGraphic read GetPNG write SetPNG; property PNM: TPortableAnyMapGraphic read GetPNM write SetPNM; property Icon: TIcon read GetIcon write SetIcon; 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; EInvalidGraphic = class(Exception); EInvalidGraphicOperation = class(Exception); { TCanvas } TCanvas = class(TFPCustomCanvas) private 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; FPen: TPen; FFont: TFont; FBrush: TBrush; procedure BrushChanged(ABrush: TObject); procedure FontChanged(AFont: TObject); procedure PenChanged(APen: TObject); procedure RegionChanged(ARegion: TObject); function GetColor: TColor; function GetHandle: HDC; procedure SetAutoRedraw(Value: Boolean); virtual; procedure SetColor(c: TColor); 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 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; protected function GetClipRect: TRect; 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 RealizeAutoRedraw; 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; public constructor Create; destructor Destroy; override; procedure Lock; virtual; procedure Unlock; virtual; procedure Refresh; virtual; procedure Changing; virtual; procedure Changed; virtual; // extra drawing methods (there are more in the ancestor TFPCustomCanvas) procedure Arc(ALeft, ATop, ARight, ABottom, angle1, angle2: Integer); virtual; procedure Arc(ALeft, ATop, ARight, ABottom, SX, SY, EX, EY: Integer); virtual; Procedure BrushCopy(Dest: TRect; InternalImages: TBitmap; Src: TRect; TransparentColor: TColor); virtual; procedure Chord(x1, y1, x2, y2, StartAngle16Deg, EndAngle16Deg: Integer); virtual; procedure Chord(x1, y1, x2, y2, SX, SY, EX, EY: Integer); virtual; Procedure CopyRect(const Dest: TRect; SrcCanvas: TCanvas; const Source: TRect); virtual; Procedure Draw(X,Y: Integer; SrcGraphic: TGraphic); virtual; procedure StretchDraw(const DestRect: TRect; SrcGraphic: TGraphic); virtual; procedure Ellipse(const ARect: TRect); // already in fpcanvas procedure Ellipse(x1, y1, x2, y2: Integer); virtual; // already in fpcanvas Procedure FillRect(const ARect: TRect); virtual; Procedure FillRect(X1,Y1,X2,Y2: Integer); procedure FloodFill(X, Y: Integer; FillColor: TColor; FillStyle: TFillStyle); virtual; procedure Frame3d(var ARect: TRect; const FrameWidth: integer; const Style: TGraphicsBevelCut); virtual; 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 Procedure Line(X1,Y1,X2,Y2: Integer); virtual; // short for MoveTo();LineTo(); // already in fpcanvas Procedure LineTo(X1,Y1: Integer); virtual; // already in fpcanvas Procedure MoveTo(X1,Y1: Integer); virtual; // already in fpcanvas procedure RadialPie(x1, y1, x2, y2, StartAngle16Deg, EndAngle16Deg: Integer); virtual; procedure RadialPie(x1, y1, x2, y2, sx, sy, ex, ey: Integer); virtual; procedure Pie(EllipseX1,EllipseY1,EllipseX2,EllipseY2, StartX,StartY,EndX,EndY: Integer); virtual; procedure PolyBezier(Points: PPoint; NumPts: Integer; Filled: boolean = False; Continuous: boolean = False); virtual; procedure PolyBezier(const Points: array of TPoint; Filled: boolean = False; Continuous: boolean = False); 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); // already in fpcanvas 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); // already in fpcanvas Procedure Rectangle(X1,Y1,X2,Y2: Integer); virtual; // already in fpcanvas Procedure Rectangle(const ARect: TRect); // already in fpcanvas 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; // already in fpcanvas 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; function TextHeight(const Text: string): Integer; virtual; function TextWidth(const Text: string): Integer; virtual; 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 AutoRedraw: Boolean read FAutoRedraw write SetAutoRedraw; property Brush: TBrush read FBrush write SetLazBrush; property CopyMode: TCopyMode read FCopyMode write FCopyMode default cmSrcCopy; property Font: TFont read FFont write SetLazFont; property Pen: TPen read FPen write SetLazPen; property Region: TRegion read FRegion write SetRegion; property Color: TColor read GetColor write SetColor; 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; { TBitmapImage Descendent of TSharedImage for TBitmap. If a TBitmap is assigned to another TBitmap, only the reference count will be increased and both will share the same TBitmapImage } TBitmapNativeType = ( bnNone, // not a TBitmap native type bnWinBitmap, bnXPixmap, bnIcon ); TBitmapNativeTypes = set of TBitmapNativeType; TBitmapHandleType = (bmDIB, bmDDB); { TBitmapImage } TBitmapImage = class(TSharedImage) private FHandle: HBITMAP; // output device dependent handle FMaskHandle: HBITMAP; FPalette: HPALETTE; FDIBHandle: HBITMAP;// output device independent handle FBitmapCanvas: TCanvas; // current canvas selected into FSaveStream: TMemoryStream; FSaveStreamClass: TFPCustomImageWriterClass; FSaveStreamType: TBitmapNativeType; protected procedure FreeHandle; override; procedure FreeMaskHandle; function ReleaseHandle: HBITMAP; function IsEmpty: boolean; function GetPixelFormat: TPixelFormat; public FDIB: TDIBSection; destructor Destroy; override; function HandleAllocated: boolean; override; function GetHandleType: TBitmapHandleType; property BitmapCanvas: TCanvas read FBitmapCanvas write FBitmapCanvas; property SaveStream: TMemoryStream read FSaveStream write FSaveStream; property SaveStreamType: TBitmapNativeType read FSaveStreamType write FSaveStreamType; property SaveStreamClass: TFPCustomImageWriterClass read FSaveStreamClass write FSaveStreamClass; end; { TBitmap } { TBitmap 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 } TBitmapInternalStateFlag = ( bmisCreatingCanvas ); TBitmapInternalState = set of TBitmapInternalStateFlag; { TBitmap } TBitmap = class(TGraphic) private FCanvas: TCanvas; FImage: TBitmapImage; FPalette: HPALETTE; FPixelFormat: TPixelFormat; FTransparentColor: TColor; FTransparentMode: TTransparentMode; FInternalState: TBitmapInternalState; procedure FreeCanvasContext; function GetCanvas: TCanvas; procedure CreateCanvas; function GetMonochrome: Boolean; procedure SetHandle(Value: HBITMAP); procedure SetMaskHandle(NewMaskHandle: HBITMAP); function GetHandleType: TBitmapHandleType; procedure SetHandleType(Value: TBitmapHandleType); virtual; procedure SetMonochrome(const AValue: Boolean); procedure SetPixelFormat(const AValue: TPixelFormat); procedure UpdatePixelFormat; protected procedure Changed(Sender: TObject); override; procedure Changing(Sender: TObject); virtual; procedure Draw(DestCanvas: TCanvas; const DestRect: TRect); override; function GetEmpty: Boolean; override; function GetHeight: Integer; override; function GetPalette: HPALETTE; override; function GetWidth: Integer; override; function GetHandle: HBITMAP; virtual; function GetMaskHandle: HBITMAP; virtual; procedure HandleNeeded; procedure MaskHandleNeeded; procedure PaletteNeeded; procedure UnshareImage(CopyContent: boolean); procedure FreeSaveStream; procedure ReadData(Stream: TStream); override; procedure SetWidthHeight(NewWidth, NewHeight: integer); virtual; procedure SetHeight(NewHeight: Integer); override; procedure SetPalette(Value: HPALETTE); override; procedure SetTransparentMode(Value: TTransparentMode); procedure SetWidth(NewWidth: Integer); override; procedure WriteData(Stream: TStream); override; procedure StoreOriginalStream(Stream: TStream; Size: integer); virtual; procedure WriteStreamWithFPImage(Stream: TStream; WriteSize: boolean; WriterClass: TFPCustomImageWriterClass); virtual; procedure InitFPImageReader(ImgReader: TFPCustomImageReader); virtual; procedure InitFPImageWriter(ImgWriter: TFPCustomImageWriter); virtual; procedure FinalizeFPImageReader(ImgReader: TFPCustomImageReader); virtual; procedure FinalizeFPImageWriter(ImgWriter: TFPCustomImageWriter); virtual; public constructor Create; override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; procedure FreeImage; function HandleAllocated: boolean; function MaskHandleAllocated: boolean; function PaletteAllocated: boolean; procedure CreateFromBitmapHandles(SrcBitmap, SrcMaskBitmap: HBitmap; const SrcRect: TRect); procedure LoadFromDevice(DC: HDC); virtual; function LazarusResourceTypeValid(const ResourceType: string): boolean; virtual; procedure LoadFromStream(Stream: TStream); override; procedure LoadFromLazarusResource(const ResName: String); override; procedure LoadFromResourceName(Instance: THandle; const ResName: String); virtual; procedure LoadFromResourceID(Instance: THandle; ResID: Integer); virtual; procedure LoadFromMimeStream(Stream: TStream; const MimeType: string); override; procedure SaveToFile(const Filename: string); override; procedure GetSupportedSourceMimeTypes(List: TStrings); override; function GetDefaultMimeType: string; override; class function GetFileExtensions: string; override; Procedure LoadFromXPMFile(const Filename: String); procedure Mask(ATransparentColor: TColor); procedure SaveToStream(Stream: TStream); override; procedure ReadStream(Stream: TStream; UseSize: boolean; Size: Longint); virtual; procedure WriteStream(Stream: TStream; WriteSize: Boolean); virtual; Function ReleaseHandle: HBITMAP; function ReleasePalette: HPALETTE; class function GetFPReaderForFileExt( const FileExtension: string): TFPCustomImageReaderClass; override; class function GetFPWriterForFileExt( const FileExtension: string): TFPCustomImageWriterClass; override; class function GetDefaultFPReader: TFPCustomImageReaderClass; override; class function GetDefaultFPWriter: TFPCustomImageWriterClass; override; procedure ReadStreamWithFPImage(Stream: TStream; UseSize: boolean; Size: Longint; ReaderClass: TFPCustomImageReaderClass); virtual; procedure WriteNativeStream(Stream: TStream; WriteSize: Boolean; SaveStreamType: TBitmapNativeType); virtual; function CreateIntfImage: TLazIntfImage; function CanReadGraphicStreams(AClass: TFPCustomImageWriterClass): boolean; virtual; public property Canvas: TCanvas read GetCanvas write FCanvas; property Handle: HBITMAP read GetHandle write SetHandle; property HandleType: TBitmapHandleType read GetHandleType write SetHandleType; property MaskHandle: HBITMAP read GetMaskHandle write SetMaskHandle; property Monochrome: Boolean read GetMonochrome write SetMonochrome; property PixelFormat: TPixelFormat read FPixelFormat write SetPixelFormat default pfDevice; // property ScanLine[Row: Integer]: Pointer; -> Use TLazIntfImage for such things property TransparentColor: TColor read FTransparentColor write FTransparentColor default clDefault; property TransparentMode: TTransparentMode read FTransparentMode write SetTransparentMode default tmAuto; end; { TPixmap } TPixmap = class(TBitmap) public procedure SaveToFile(const Filename: string); override; function LazarusResourceTypeValid(const ResourceType: string): boolean; override; procedure WriteStream(Stream: TStream; WriteSize: Boolean); override; class function GetDefaultFPReader: TFPCustomImageReaderClass; override; class function GetDefaultFPWriter: TFPCustomImageWriterClass; override; end; { TFPImageBitmap } { Use this class to easily create a TBitmap descendent for FPImage reader and writer } TFPImageBitmap = class(TBitmap) public class function GetFileExtensions: string; override; class function IsFileExtensionSupported(const FileExtension: string): boolean; class function GetFPReaderForFileExt( const FileExtension: string): TFPCustomImageReaderClass; override; class function GetFPWriterForFileExt( const FileExtension: string): TFPCustomImageWriterClass; override; class function GetDefaultFPReader: TFPCustomImageReaderClass; override; class function GetDefaultFPWriter: TFPCustomImageWriterClass; override; function LazarusResourceTypeValid(const ResourceType: string): boolean; override; procedure ReadStream(Stream: TStream; UseSize: boolean; Size: Longint); override; procedure WriteStream(Stream: TStream; WriteSize: Boolean); override; function GetDefaultMimeType: string; override; end; { TPortableNetworkGraphic } TPortableNetworkGraphic = class(TFPImageBitmap) public class function GetFileExtensions: string; override; class function GetDefaultFPReader: TFPCustomImageReaderClass; override; class function GetDefaultFPWriter: TFPCustomImageWriterClass; override; end; { TPortableAnyMapGraphic } TPortableAnyMapGraphic = class(TFPImageBitmap) public class function GetFileExtensions: string; override; class function GetDefaultFPReader: TFPCustomImageReaderClass; override; class function GetDefaultFPWriter: TFPCustomImageWriterClass; override; 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 TBitmap 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. } TIcon = class(TBitmap) private FBitmaps: TObjectList; protected procedure ReadData(Stream: TStream); override; procedure InitFPImageReader(ImgReader: TFPCustomImageReader); override; public class function GetFileExtensions: string; override; property Bitmaps: TObjectList read FBitmaps; destructor Destroy; override; procedure AddBitmap(Bitmap: TBitmap); { Note that Ownership passes to TIcon } end; function GraphicFilter(GraphicClass: TGraphicClass): string; function GraphicExtension(GraphicClass: TGraphicClass): string; function GraphicFileMask(GraphicClass: TGraphicClass): string; function GetGraphicClassForFileExtension(const FileExt: string): TGraphicClass; function GetFPImageReaderForFileExtension(const FileExt: string ): TFPCustomImageReaderClass; function GetFPImageWriterForFileExtension(const FileExt: string ): TFPCustomImageWriterClass; type // Color / Identifier mapping TGetColorStringProc = procedure(const s:ansistring) of object; function IdentEntry(Entry: Longint; var MapEntry: TIdentMapEntry): boolean; function ColorToIdent(Color: Longint; var Ident: String): Boolean; function IdentToColor(const Ident: string; var Color: Longint): Boolean; function SysColorToSysColorIndex(Color: TColor): integer; function ColorToRGB(Color: TColor): TColor; function ColorToString(Color: TColor): AnsiString; function StringToColor(const S: shortstring): TColor; procedure GetColorValues(Proc: TGetColorStringProc); Function Blue(rgb: TColor): BYTE; Function Green(rgb: TColor): BYTE; Function Red(rgb: TColor): BYTE; procedure RedGreenBlue(rgb: TColor; out Red, Green, Blue: Byte); function FPColorToTColor(const FPColor: TFPColor): TColor; function TColorToFPColor(const c: TColor): TFPColor; // fonts procedure GetCharsetValues(Proc: TGetStrProc); function CharsetToIdent(Charset: Longint; var Ident: string): Boolean; function IdentToCharset(const Ident: string; var Charset: Longint): Boolean; 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; // graphics type TOnLoadGraphicFromClipboardFormat = procedure(Dest: TGraphic; ClipboardType: TClipboardType; FormatID: TClipboardFormat); TOnSaveGraphicToClipboardFormat = procedure(Src: TGraphic; ClipboardType: TClipboardType; FormatID: TClipboardFormat); var OnLoadSaveClipBrdGraphicValid: boolean = false; OnLoadGraphicFromClipboardFormat: TOnLoadGraphicFromClipboardFormat=nil; OnSaveGraphicToClipboardFormat: TOnSaveGraphicToClipboardFormat=nil; function TestStreamBitmapNativeType(const AStream: TStream): TBitmapNativeType; function TestStreamIsBMP(const AStream: TStream): boolean; function TestStreamIsXPM(const AStream: TStream): boolean; function TestStreamIsIcon(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; 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; procedure Register; implementation 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; procedure Register; begin RegisterClasses([TBitmap,TPixmap,TPortableNetworkGraphic,TPortableAnyMapGraphic,TPicture, TFont,TPen,TBrush,TRegion]); end; const GraphicsFinalized: boolean = false; type TBitmapCanvas = class(TCanvas) private FBitmap: TBitmap; FOldBitmapValid: boolean; FOldBitmap: HBitmap; FOldPaletteValid: boolean; FOldPalette: HPALETTE; procedure FreeDC; // called by TBitmap.FreeCanvasContext protected procedure CreateHandle; override; procedure DeselectHandles; override; public constructor Create(ABitmap: TBitmap); destructor Destroy; override; end; { Color mapping routines } const Colors: array[0..109] of TIdentMapEntry = ( // The following colors match the predefined Delphi 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: clLtGray; Name: 'clLtGray'), (Value: clDkGray; Name: 'clDkGray'), (Value: clWhite; Name: 'clWhite'), (Value: clCream; Name: 'clCream'), (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: clWindow; Name: 'clWindow'), (Value: clWindowFrame; Name: 'clWindowFrame'), (Value: clMenuText; Name: 'clMenuText'), (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'), (Value: clForm; Name: 'clForm'), (Value: clEndColors; Name: 'clEndColors'), (Value: clColorDesktop; Name: 'clColorDesktop'), (Value: cl3DFace; Name: 'cl3DFace'), (Value: cl3DShadow; Name: 'cl3DShadow'), (Value: cl3DHiLight; Name: 'cl3DHiLight'), (Value: clBtnHiLight; Name: 'clBtnHiLight'), // 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') ); function IdentEntry(Entry: Longint; var 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; var Ident: String): Boolean; begin Result := IntToIdent(Color, Ident, Colors); end; function IdentToColor(const Ident: string; var Color: Longint): Boolean; begin Result := IdentToInt(Ident, Color, Colors); end; function SysColorToSysColorIndex(Color: TColor): integer; begin if (Cardinal(Color) and Cardinal(SYS_COLOR_BASE)) <> 0 then begin case Color of clHighlightedText..clForeground: 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 Result:=Color and $FF; end; end else begin Result:=-1; end; end; function ColorToRGB(Color: TColor): TColor; begin if (Cardinal(Color) and Cardinal(SYS_COLOR_BASE)) <> 0 then Result := GetSysColor(SysColorToSysColorIndex(Color)) 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; procedure GetColorValues(Proc: TGetColorStringProc); var I: Integer; begin for I := Low(Colors) to High(Colors) do Proc(Colors[I].Name); end; Function Blue(rgb: TColor): BYTE; begin Result := (rgb shr 16) and $000000ff; end; Function Green(rgb: TColor): BYTE; begin Result := (rgb shr 8) and $000000ff; end; Function Red(rgb: TColor): BYTE; begin Result := rgb and $000000ff; end; procedure RedGreenBlue(rgb: TColor; out Red, Green, Blue: Byte); begin Red := rgb and $000000ff; Green := (rgb shr 8) and $000000ff; Blue := (rgb shr 16) and $000000ff; end; function FPColorToTColor(const FPColor: TFPColor): TColor; begin Result:=((FPColor.Red shr 8) and $ff) or (FPColor.Green and $ff00) or ((FPColor.Blue shl 8) and $ff0000); end; function TColorToFPColor(const c: TColor): 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; {$I graphicsobject.inc} {$I graphic.inc} {$I picture.inc} {$I sharedimage.inc} {$I bitmapimage.inc} {$I bitmap.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} {$I pnm.inc} { TFPImageBitmap } function TFPImageBitmap.GetFileExtensions: string; begin Result:=''; end; function TFPImageBitmap.IsFileExtensionSupported( const FileExtension: string): boolean; var Extensions: String; StartPos: Integer; EndPos: Integer; i: Integer; Ext: String; begin Result:=false; if FileExtension='' then exit; Extensions:=GetFileExtensions; if Extensions='' then exit; Ext:=FileExtension; if Ext[1]='.' then begin Ext:=copy(Ext,2,length(Ext)); if Ext='' then exit; end; StartPos:=1; while StartPos<=length(Extensions) do begin if not (Extensions[StartPos] in [';',' ']) then begin EndPos:=StartPos; while (EndPos<=length(Extensions)) and (Extensions[EndPos]<>';') do inc(EndPos); if EndPos-StartPos=length(Ext) then begin i:=1; while (i<=length(Ext)) and (upcase(Extensions[StartPos+i-1])=upcase(Ext[i])) do inc(i); if i>length(Ext) then begin Result:=true; exit; end; end; StartPos:=EndPos; end else inc(StartPos); end; end; function TFPImageBitmap.GetFPReaderForFileExt(const FileExtension: string ): TFPCustomImageReaderClass; begin if IsFileExtensionSupported(FileExtension) then Result:=GetDefaultFPReader else Result:=nil; end; function TFPImageBitmap.GetFPWriterForFileExt(const FileExtension: string ): TFPCustomImageWriterClass; begin if IsFileExtensionSupported(FileExtension) then Result:=GetDefaultFPWriter else Result:=nil; end; function TFPImageBitmap.GetDefaultFPReader: TFPCustomImageReaderClass; begin Result:=nil; end; function TFPImageBitmap.GetDefaultFPWriter: TFPCustomImageWriterClass; begin Result:=nil; end; function TFPImageBitmap.LazarusResourceTypeValid(const ResourceType: string ): boolean; begin Result:=IsFileExtensionSupported(ResourceType); end; procedure TFPImageBitmap.ReadStream(Stream: TStream; UseSize: boolean; Size: Longint); begin ReadStreamWithFPImage(Stream,UseSize,Size,GetDefaultFPReader); end; procedure TFPImageBitmap.WriteStream(Stream: TStream; WriteSize: Boolean); begin WriteStreamWithFPImage(Stream,WriteSize,GetDefaultFPWriter); end; function TFPImageBitmap.GetDefaultMimeType: string; var DefaultFileExt: String; i: Integer; begin DefaultFileExt:=GetFileExtensions; i:=1; while (i<=length(DefaultFileExt)) and (DefaultFileExt[i]<>';') do inc(i); if i<=length(DefaultFileExt) then DefaultFileExt:=copy(DefaultFileExt,1,i); Result:='image/'+DefaultFileExt; end; { TIcon } const IconSignature: array [0..3] of char = #0#0#1#0; function TestStreamIsIcon(const AStream: TStream): boolean; var Signature: array[0..3] of char; ReadSize: Integer; OldPosition: TStreamSeekType; begin OldPosition:=AStream.Position; ReadSize:=AStream.Read(Signature, SizeOf(Signature)); Result:=(ReadSize=SizeOf(Signature)) and CompareMem(@Signature,@IconSignature,4); AStream.Position:=OldPosition; end; procedure TIcon.ReadData(Stream: TStream); var Size: longint; Position: TStreamSeekType; begin Position := Stream.Position; Stream.Read(Size, 4); // Beware BigEndian and LowEndian sytems if CompareMem(@Size,@IconSignature,4) then begin // Assume Icon - stream without explicit size Stream.Position := Position; ReadStream(Stream, false, Size); end else begin Size := LEtoN(Size); ReadStream(Stream, true, Size); end; end; procedure TIcon.InitFPImageReader(ImgReader: TFPCustomImageReader); begin inherited InitFPImageReader(ImgReader); if ImgReader is TLazReaderIcon then TLazReaderIcon(ImgReader).Icon := self; end; function TIcon.GetFileExtensions: string; begin Result:='ico'; end; destructor TIcon.Destroy; begin inherited Destroy; FreeAndNil(FBitmaps); end; procedure TIcon.AddBitmap(Bitmap: TBitmap); begin if not Assigned(FBitmaps) then FBitmaps := TObjectList.create(True); FBitmaps.Add(Bitmap); end; procedure InterfaceFinal; begin //debugln('Graphics.InterfaceFinal'); FreeAndNil(FontResourceCache); FreeAndNil(PenResourceCache); FreeAndNil(BrushResourceCache); end; initialization FontResourceCache:=TFontHandleCache.Create; PenResourceCache:=TPenHandleCache.Create; BrushResourceCache:=TBrushHandleCache.Create; RegisterIntegerConsts(TypeInfo(TColor), @IdentToColor, @ColorToIdent); RegisterIntegerConsts(TypeInfo(TFontCharset), @IdentToCharset, @CharsetToIdent); RegisterInterfaceFinalizationHandler(@InterfaceFinal); finalization GraphicsFinalized:=true; OnLoadSaveClipBrdGraphicValid:=false; FreeAndNil(PicClipboardFormats); FreeAndNil(PicFileFormats); end.