admin/expertcad
1
0
Fork 0
mirror of http://gitlab.expertsoft.com.ua/git/expertcad synced 2026-01-11 22:45:39 +02:00
Code Issues Packages Projects Releases Wiki Activity
expertcad/POWERCAD30/UNITS/Graphics_.pas
ShevaIV 00e2ad8635 initial commit
2025-05-12 10:07:51 +03:00

7021 lines
196 KiB
ObjectPascal
Raw Blame History

{*******************************************************}
{ }
{ Borland Delphi Visual Component Library }
{ }
{ Copyright (c) 1995-2001 Borland Software Corporation }
{ }
{*******************************************************}
unit Graphics;
{$P+,S-,W-,R-,T-,X+,H+,B-}
{$C PRELOAD}
interface
{$IFDEF MSWINDOWS}
uses Windows,
{$ENDIF}
{$IFDEF LINUX}
uses WinUtils, Libc, Windows,
{$ENDIF}
SysUtils, Classes;
{ Graphics Objects }
type
PColor = ^TColor;
TColor = -$7FFFFFFF-1..$7FFFFFFF;
{$NODEFINE TColor}
(*$HPPEMIT 'namespace Graphics'*)
(*$HPPEMIT '{'*)
(*$HPPEMIT ' enum TColor {clMin=-0x7fffffff-1, clMax=0x7fffffff};'*)
(*$HPPEMIT '}'*)
const
clSystemColor = $FF000000;
clScrollBar = TColor(clSystemColor or COLOR_SCROLLBAR);
clBackground = TColor(clSystemColor or COLOR_BACKGROUND);
clActiveCaption = TColor(clSystemColor or COLOR_ACTIVECAPTION);
clInactiveCaption = TColor(clSystemColor or COLOR_INACTIVECAPTION);
clMenu = TColor(clSystemColor or COLOR_MENU);
clWindow = TColor(clSystemColor or COLOR_WINDOW);
clWindowFrame = TColor(clSystemColor or COLOR_WINDOWFRAME);
clMenuText = TColor(clSystemColor or COLOR_MENUTEXT);
clWindowText = TColor(clSystemColor or COLOR_WINDOWTEXT);
clCaptionText = TColor(clSystemColor or COLOR_CAPTIONTEXT);
clActiveBorder = TColor(clSystemColor or COLOR_ACTIVEBORDER);
clInactiveBorder = TColor(clSystemColor or COLOR_INACTIVEBORDER);
clAppWorkSpace = TColor(clSystemColor or COLOR_APPWORKSPACE);
clHighlight = TColor(clSystemColor or COLOR_HIGHLIGHT);
clHighlightText = TColor(clSystemColor or COLOR_HIGHLIGHTTEXT);
clBtnFace = TColor(clSystemColor or COLOR_BTNFACE);
clBtnShadow = TColor(clSystemColor or COLOR_BTNSHADOW);
clGrayText = TColor(clSystemColor or COLOR_GRAYTEXT);
clBtnText = TColor(clSystemColor or COLOR_BTNTEXT);
clInactiveCaptionText = TColor(clSystemColor or COLOR_INACTIVECAPTIONTEXT);
clBtnHighlight = TColor(clSystemColor or COLOR_BTNHIGHLIGHT);
cl3DDkShadow = TColor(clSystemColor or COLOR_3DDKSHADOW);
cl3DLight = TColor(clSystemColor or COLOR_3DLIGHT);
clInfoText = TColor(clSystemColor or COLOR_INFOTEXT);
clInfoBk = TColor(clSystemColor or COLOR_INFOBK);
clHotLight = TColor(clSystemColor or COLOR_HOTLIGHT);
clGradientActiveCaption = TColor(clSystemColor or COLOR_GRADIENTACTIVECAPTION);
clGradientInactiveCaption = TColor(clSystemColor or COLOR_GRADIENTINACTIVECAPTION);
clMenuHighlight = TColor(clSystemColor or COLOR_MENUHILIGHT);
clMenuBar = TColor(clSystemColor or COLOR_MENUBAR);
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);
StandardColorsCount = 16;
clMoneyGreen = TColor($C0DCC0);
clSkyBlue = TColor($F0CAA6);
clCream = TColor($F0FBFF);
clMedGray = TColor($A4A0A0);
ExtendedColorsCount = 4;
clNone = TColor($1FFFFFFF);
clDefault = TColor($20000000);
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;
{ Icon and cursor types }
rc3_StockIcon = 0;
rc3_Icon = 1;
rc3_Cursor = 2;
type
PCursorOrIcon = ^TCursorOrIcon;
TCursorOrIcon = packed record
Reserved: Word;
wType: Word;
Count: Word;
end;
PIconRec = ^TIconRec;
TIconRec = packed record
Width: Byte;
Height: Byte;
Colors: Word;
Reserved1: Word;
Reserved2: Word;
DIBSize: Longint;
DIBOffset: Longint;
end;
{$EXTERNALSYM HMETAFILE}
HMETAFILE = THandle;
{$EXTERNALSYM HENHMETAFILE}
HENHMETAFILE = THandle;
EInvalidGraphic = class(Exception);
EInvalidGraphicOperation = class(Exception);
TGraphic = class;
TBitmap = class;
TIcon = class;
TMetafile = class;
TResData = record
Handle: THandle;
end;
TFontPitch = (fpDefault, fpVariable, fpFixed);
TFontName = type string;
TFontCharset = 0..255;
{ Changes to the following types should be reflected in the $HPPEMIT directives. }
TFontDataName = string[LF_FACESIZE - 1];
{$NODEFINE TFontDataName}
TFontStyle = (fsBold, fsItalic, fsUnderline, fsStrikeOut);
{$NODEFINE TFontStyle}
TFontStyles = set of TFontStyle;
TFontStylesBase = set of TFontStyle;
{$NODEFINE TFontStylesBase}
(*$HPPEMIT 'namespace Graphics'*)
(*$HPPEMIT '{'*)
(*$HPPEMIT ' enum TFontStyle { fsBold, fsItalic, fsUnderline, fsStrikeOut };'*)
(*$HPPEMIT ' typedef SmallStringBase<31> TFontDataName;'*)
(*$HPPEMIT ' typedef SetBase<TFontStyle, fsBold, fsStrikeOut> TFontStylesBase;'*)
(*$HPPEMIT '}'*)
TFontData = record
Handle: HFont;
Height: Integer;
Pitch: TFontPitch;
Style: TFontStylesBase;
Charset: TFontCharset;
Name: TFontDataName;
end;
TPenStyle = (psSolid, psDash, psDot, psDashDot, psDashDotDot, psClear,
psInsideFrame);
TPenMode = (pmBlack, pmWhite, pmNop, pmNot, pmCopy, pmNotCopy,
pmMergePenNot, pmMaskPenNot, pmMergeNotPen, pmMaskNotPen, pmMerge,
pmNotMerge, pmMask, pmNotMask, pmXor, pmNotXor);
TPenData = record
Handle: HPen;
Color: TColor;
Width: Integer;
Style: TPenStyle;
end;
TBrushStyle = (bsSolid, bsClear, bsHorizontal, bsVertical,
bsFDiagonal, bsBDiagonal, bsCross, bsDiagCross);
TBrushData = record
Handle: HBrush;
Color: TColor;
Bitmap: TBitmap;
Style: TBrushStyle;
end;
PResource = ^TResource;
TResource = record
Next: PResource;
RefCount: Integer;
Handle: THandle;
HashCode: Word;
case Integer of
0: (Data: TResData);
1: (Font: TFontData);
2: (Pen: TPenData);
3: (Brush: TBrushData);
end;
TGraphicsObject = class(TPersistent)
private
FOnChange: TNotifyEvent;
FResource: PResource;
FOwnerLock: PRTLCriticalSection;
protected
procedure Changed; dynamic;
procedure Lock;
procedure Unlock;
public
function HandleAllocated: Boolean;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OwnerCriticalSection: PRTLCriticalSection read FOwnerLock write FOwnerLock;
end;
IChangeNotifier = interface
['{1FB62321-44A7-11D0-9E93-0020AF3D82DA}']
procedure Changed;
end;
TFont = class(TGraphicsObject)
private
FColor: TColor;
FPixelsPerInch: Integer;
FNotify: IChangeNotifier;
procedure GetData(var FontData: TFontData);
procedure SetData(const FontData: TFontData);
protected
procedure Changed; override;
function GetHandle: HFont;
function GetHeight: Integer;
function GetName: TFontName;
function GetPitch: TFontPitch;
function GetSize: Integer;
function GetStyle: TFontStyles;
function GetCharset: TFontCharset;
procedure SetColor(Value: TColor);
procedure SetHandle(Value: HFont);
procedure SetHeight(Value: Integer);
procedure SetName(const Value: TFontName);
procedure SetPitch(Value: TFontPitch);
procedure SetSize(Value: Integer);
procedure SetStyle(Value: TFontStyles);
procedure SetCharset(Value: TFontCharset);
public
constructor Create;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
property FontAdapter: IChangeNotifier read FNotify write FNotify;
property Handle: HFont read GetHandle write SetHandle;
property PixelsPerInch: Integer read FPixelsPerInch write FPixelsPerInch;
published
property Charset: TFontCharset read GetCharset write SetCharset;
property Color: TColor read FColor write SetColor;
property Height: Integer read GetHeight write SetHeight;
property Name: TFontName read GetName write SetName;
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 = class(TGraphicsObject)
private
FMode: TPenMode;
procedure GetData(var PenData: TPenData);
procedure SetData(const PenData: TPenData);
protected
function GetColor: TColor;
procedure SetColor(Value: TColor);
function GetHandle: HPen;
procedure SetHandle(Value: HPen);
procedure SetMode(Value: TPenMode);
function GetStyle: TPenStyle;
procedure SetStyle(Value: TPenStyle);
function GetWidth: Integer;
procedure SetWidth(Value: Integer);
public
constructor Create;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
property Handle: HPen read GetHandle write SetHandle;
published
property Color: TColor read GetColor write SetColor default clBlack;
property Mode: TPenMode read FMode write SetMode default pmCopy;
property Style: TPenStyle read GetStyle write SetStyle default psSolid;
property Width: Integer read GetWidth write SetWidth default 1;
end;
TExtPen = class(TPen)
private
FGeometric:Boolean;
function GetHandle: HPen;
procedure SetHandle(Value: HPen);
procedure SetGeometric(const Value: Boolean);
public
constructor Create;
property Handle: HPen read GetHandle write SetHandle;
Property Geometric:Boolean read FGeometric write SetGeometric;
end;
TBrush = class(TGraphicsObject)
private
procedure GetData(var BrushData: TBrushData);
procedure SetData(const BrushData: TBrushData);
protected
function GetBitmap: TBitmap;
procedure SetBitmap(Value: TBitmap);
function GetColor: TColor;
procedure SetColor(Value: TColor);
function GetHandle: HBrush;
procedure SetHandle(Value: HBrush);
function GetStyle: TBrushStyle;
procedure SetStyle(Value: TBrushStyle);
public
constructor Create;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
property Bitmap: TBitmap read GetBitmap write SetBitmap;
property Handle: HBrush read GetHandle write SetHandle;
published
property Color: TColor read GetColor write SetColor default clWhite;
property Style: TBrushStyle read GetStyle write SetStyle default bsSolid;
end;
TFontRecall = class(TRecall)
public
constructor Create(AFont: TFont);
end;
TPenRecall = class(TRecall)
public
constructor Create(APen: TPen);
end;
TBrushRecall = class(TRecall)
public
constructor Create(ABrush: TBrush);
end;
TFillStyle = (fsSurface, fsBorder);
TFillMode = (fmAlternate, fmWinding);
TCopyMode = Longint;
TCanvasStates = (csHandleValid, csFontValid, csPenValid, csBrushValid);
TCanvasState = set of TCanvasStates;
TCanvasOrientation = (coLeftToRight, coRightToLeft);
TCanvas = class(TPersistent)
private
FHandle: HDC;
State: TCanvasState;
FFont: TFont;
FPen: TPen;
FBrush: TBrush;
FPenPos: TPoint;
FCopyMode: TCopyMode;
FOnChange: TNotifyEvent;
FOnChanging: TNotifyEvent;
FLock: TRTLCriticalSection;
FLockCount: Integer;
FTextFlags: Longint;
procedure CreateBrush;
procedure CreateFont;
procedure CreatePen;
procedure BrushChanged(ABrush: TObject);
procedure DeselectHandles;
function GetCanvasOrientation: TCanvasOrientation;
function GetClipRect: TRect;
function GetHandle: HDC;
function GetPenPos: TPoint;
function GetPixel(X, Y: Integer): TColor;
procedure FontChanged(AFont: TObject);
procedure PenChanged(APen: TObject);
procedure SetBrush(Value: TBrush);
procedure SetFont(Value: TFont);
procedure SetHandle(Value: HDC);
procedure SetPen(Value: TPen);
procedure SetPenPos(Value: TPoint);
procedure SetPixel(X, Y: Integer; Value: TColor);
protected
procedure Changed; virtual;
procedure Changing; virtual;
procedure CreateHandle; virtual;
procedure RequiredState(ReqState: TCanvasState);
public
constructor Create;
destructor Destroy; override;
procedure Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
procedure BrushCopy(const Dest: TRect; Bitmap: TBitmap;
const Source: TRect; Color: TColor);
procedure Chord(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
procedure CopyRect(const Dest: TRect; Canvas: TCanvas;
const Source: TRect);
procedure Draw(X, Y: Integer; Graphic: TGraphic);
procedure DrawFocusRect(const Rect: TRect);
procedure Ellipse(X1, Y1, X2, Y2: Integer); overload;
procedure Ellipse(const Rect: TRect); overload;
procedure FillRect(const Rect: TRect);
procedure FloodFill(X, Y: Integer; Color: TColor; FillStyle: TFillStyle);
procedure FrameRect(const Rect: TRect);
function HandleAllocated: Boolean;
procedure LineTo(X, Y: Integer);
procedure Lock;
procedure MoveTo(X, Y: Integer);
procedure Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
procedure Polygon(const Points: array of TPoint);
procedure Polyline(const Points: array of TPoint);
procedure PolyBezier(const Points: array of TPoint);
procedure PolyBezierTo(const Points: array of TPoint);
procedure Rectangle(X1, Y1, X2, Y2: Integer); overload;
procedure Rectangle(const Rect: TRect); overload;
procedure Refresh;
procedure RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer);
procedure StretchDraw(const Rect: TRect; Graphic: TGraphic);
function TextExtent(const Text: string): TSize;
function TextHeight(const Text: string): Integer;
procedure TextOut(X, Y: Integer; const Text: string);
procedure TextRect(Rect: TRect; X, Y: Integer; const Text: string);
function TextWidth(const Text: string): Integer;
function TryLock: Boolean;
procedure Unlock;
property ClipRect: TRect read GetClipRect;
property Handle: HDC read GetHandle write SetHandle;
property LockCount: Integer read FLockCount;
property CanvasOrientation: TCanvasOrientation read GetCanvasOrientation;
property PenPos: TPoint read GetPenPos write SetPenPos;
property Pixels[X, Y: Integer]: TColor read GetPixel write SetPixel;
property TextFlags: Longint read FTextFlags write FTextFlags;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
published
property Brush: TBrush read FBrush write SetBrush;
property CopyMode: TCopyMode read FCopyMode write FCopyMode default cmSrcCopy;
property Font: TFont read FFont write SetFont;
property Pen: TPen read FPen write SetPen;
end;
{ 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) of object;
{ The TGraphic class is a abstract base class for dealing with graphic images
such as metafile, bitmaps, 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 - Image does not completely cover its rectangular area
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(TInterfacedPersistent, IStreamPersist)
private
FOnChange: TNotifyEvent;
FOnProgress: TProgressEvent;
FModified: Boolean;
FTransparent: Boolean;
FPaletteModified: Boolean;
procedure SetModified(Value: Boolean);
protected
procedure Changed(Sender: TObject); virtual;
procedure DefineProperties(Filer: TFiler); override;
procedure Draw(ACanvas: TCanvas; const Rect: TRect); virtual; abstract;
function Equals(Graphic: TGraphic): Boolean; virtual;
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); 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 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 LoadFromClipboardFormat(AFormat: Word; AData: THandle;
APalette: HPALETTE); virtual; abstract;
procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
var APalette: HPALETTE); virtual; abstract;
property Empty: Boolean read GetEmpty;
property Height: Integer read GetHeight write SetHeight;
property Modified: Boolean read FModified write SetModified;
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;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
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 was 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 - Reads the picture from the handle provided in
the given clipboard format. If the format is not supported, an
exception is generated.
SaveToClipboardFormats - 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.
Icon - Returns an icon. If the contents is not already an icon, the
contents are thrown away and a blank icon is returned.
Metafile - Returns a metafile. If the contents is not already a metafile,
the contents are thrown away and a blank metafile is returned. }
TPicture = class(TInterfacedPersistent, IStreamPersist)
private
FGraphic: TGraphic;
FOnChange: TNotifyEvent;
FNotify: IChangeNotifier;
FOnProgress: TProgressEvent;
procedure ForceType(GraphicType: TGraphicClass);
function GetBitmap: TBitmap;
function GetHeight: Integer;
function GetIcon: TIcon;
function GetMetafile: TMetafile;
function GetWidth: Integer;
procedure ReadData(Stream: TStream);
procedure SetBitmap(Value: TBitmap);
procedure SetGraphic(Value: TGraphic);
procedure SetIcon(Value: TIcon);
procedure SetMetafile(Value: TMetafile);
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); dynamic;
procedure LoadFromStream(Stream: TStream);
procedure SaveToStream(Stream: TStream);
public
constructor Create;
destructor Destroy; override;
procedure LoadFromFile(const Filename: string);
procedure SaveToFile(const Filename: string);
procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
APalette: HPALETTE);
procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
var APalette: HPALETTE);
class function SupportsClipboardFormat(AFormat: Word): Boolean;
procedure Assign(Source: TPersistent); override;
class procedure RegisterFileFormat(const AExtension, ADescription: string;
AGraphicClass: TGraphicClass);
class procedure RegisterFileFormatRes(const AExtension: String;
ADescriptionResID: Integer; AGraphicClass: TGraphicClass);
class procedure RegisterClipboardFormat(AFormat: Word;
AGraphicClass: TGraphicClass);
class procedure UnregisterGraphicClass(AClass: TGraphicClass);
property Bitmap: TBitmap read GetBitmap write SetBitmap;
property Graphic: TGraphic read FGraphic write SetGraphic;
property PictureAdapter: IChangeNotifier read FNotify write FNotify;
property Height: Integer read GetHeight;
property Icon: TIcon read GetIcon write SetIcon;
property Metafile: TMetafile read GetMetafile write SetMetafile;
property Width: Integer read GetWidth;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
end;
{ TMetafile }
{ TMetafile is an encapsulation of the Win32 Enhanced metafile.
Handle - The metafile handle.
Enhanced - determines how the metafile will be stored on disk.
Enhanced = True (default) stores as EMF (Win32 Enhanced Metafile),
Enhanced = False stores as WMF (Windows 3.1 Metafile, with Aldus header).
The in-memory format is always EMF. WMF has very limited capabilities;
storing as WMF will lose information that would be retained by EMF.
This property is set to match the metafile type when loaded from a
stream or file. This maintains form file compatibility with 16 bit
Delphi (If loaded as WMF, then save as WMF).
Inch - The units per inch assumed by a WMF metafile. Used to alter
scale when writing as WMF, but otherwise this property is obsolete.
Enhanced metafiles maintain complete scale information internally.
MMWidth,
MMHeight: Width and Height in 0.01 millimeter units, the native
scale used by enhanced metafiles. The Width and Height properties
are always in screen device pixel units; you can avoid loss of
precision in converting between device pixels and mm by setting
or reading the dimentions in mm with these two properties.
CreatedBy - Optional name of the author or application used to create
the metafile.
Description - Optional text description of the metafile.
You can set the CreatedBy and Description of a new metafile by calling
TMetafileCanvas.CreateWithComment.
TMetafileCanvas
To create a metafile image from scratch, you must draw the image in
a metafile canvas. When the canvas is destroyed, it transfers the
image into the metafile object provided to the canvas constructor.
After the image is drawn on the canvas and the canvas is destroyed,
the image is 'playable' in the metafile object. Like this:
MyMetafile := TMetafile.Create;
MyMetafile.Width := 200;
MyMetafile.Height := 200;
with TMetafileCanvas.Create(MyMetafile, 0) do
try
Brush.Color := clRed;
Ellipse(0,0,100,100);
...
finally
Free;
end;
Form1.Canvas.Draw(0,0,MyMetafile); (* 1 red circle *)
To add to an existing metafile image, create a metafile canvas
and play the source metafile into the metafile canvas. Like this:
(* continued from previous example, so MyMetafile contains an image *)
with TMetafileCanvas.Create(MyMetafile, 0) do
try
Draw(0,0,MyMetafile);
Brush.Color := clBlue;
Ellipse(100,100,200,200);
...
finally
Free;
end;
Form1.Canvas.Draw(0,0,MyMetafile); (* 1 red circle and 1 blue circle *)
}
TMetafileCanvas = class(TCanvas)
private
FMetafile: TMetafile;
public
constructor Create(AMetafile: TMetafile; ReferenceDevice: HDC);
constructor CreateWithComment(AMetafile: TMetafile; ReferenceDevice: HDC;
const CreatedBy, Description: String);
destructor Destroy; override;
end;
TSharedImage = class
private
FRefCount: Integer;
protected
procedure Reference;
procedure Release;
procedure FreeHandle; virtual; abstract;
property RefCount: Integer read FRefCount;
end;
TMetafileImage = class(TSharedImage)
private
FHandle: HENHMETAFILE;
FWidth: Integer; // FWidth and FHeight are in 0.01 mm logical pixels
FHeight: Integer; // These are converted to device pixels in TMetafile
FPalette: HPALETTE;
FInch: Word; // Used only when writing WMF files.
FTempWidth: Integer; // FTempWidth and FTempHeight are in device pixels
FTempHeight: Integer; // Used only when width/height are set when FHandle = 0
protected
procedure FreeHandle; override;
public
destructor Destroy; override;
end;
TMetafile = class(TGraphic)
private
FImage: TMetafileImage;
FEnhanced: Boolean;
function GetAuthor: String;
function GetDesc: String;
function GetHandle: HENHMETAFILE;
function GetInch: Word;
function GetMMHeight: Integer;
function GetMMWidth: Integer;
procedure NewImage;
procedure SetHandle(Value: HENHMETAFILE);
procedure SetInch(Value: Word);
procedure SetMMHeight(Value: Integer);
procedure SetMMWidth(Value: Integer);
procedure UniqueImage;
protected
function GetEmpty: Boolean; override;
function GetHeight: Integer; override;
function GetPalette: HPALETTE; override;
function GetWidth: Integer; override;
procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
procedure ReadData(Stream: TStream); override;
procedure ReadEMFStream(Stream: TStream);
procedure ReadWMFStream(Stream: TStream; Length: Longint);
procedure SetHeight(Value: Integer); override;
procedure SetTransparent(Value: Boolean); override;
procedure SetWidth(Value: Integer); override;
function TestEMF(Stream: TStream): Boolean;
procedure WriteData(Stream: TStream); override;
procedure WriteEMFStream(Stream: TStream);
procedure WriteWMFStream(Stream: TStream);
public
constructor Create; override;
destructor Destroy; override;
procedure Clear;
function HandleAllocated: Boolean;
procedure LoadFromStream(Stream: TStream); override;
procedure SaveToFile(const Filename: String); override;
procedure SaveToStream(Stream: TStream); override;
procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
APalette: HPALETTE); override;
procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
var APalette: HPALETTE); override;
procedure Assign(Source: TPersistent); override;
function ReleaseHandle: HENHMETAFILE;
property CreatedBy: String read GetAuthor;
property Description: String read GetDesc;
property Enhanced: Boolean read FEnhanced write FEnhanced default True;
property Handle: HENHMETAFILE read GetHandle write SetHandle;
property MMWidth: Integer read GetMMWidth write SetMMWidth;
property MMHeight: Integer read GetMMHeight write SetMMHeight;
property Inch: Word read GetInch write SetInch;
end;
{ TBitmap }
{ TBitmap is an encapsulation of a Windows HBITMAP and HPALETTE. It manages
the palette realizing automatically as well as having a Canvas to allow
modifications to the image. Creating copies of a TBitmap is very fast
since the handle is copied not the image. If the image is modified, and
the handle is shared by more than one TBitmap object, the image is copied
before the modification is performed (i.e. copy on write).
Canvas - Allows drawing on the bitmap.
Handle - The HBITMAP encapsulated by the TBitmap. Grabbing the handle
directly should be avoided since it causes the HBITMAP to be copied if
more than one TBitmap share the handle.
Palette - The HPALETTE realized by the TBitmap. Grabbing this handle
directly should be avoided since it causes the HPALETTE to be copied if
more than one TBitmap share the handle.
Monochrome - True if the bitmap is a monochrome bitmap }
TBitmapImage = class(TSharedImage)
private
FHandle: HBITMAP; // DDB or DIB handle, used for drawing
FMaskHandle: HBITMAP; // DDB handle
FPalette: HPALETTE;
FDIBHandle: HBITMAP; // DIB handle corresponding to TDIBSection
FDIB: TDIBSection;
FSaveStream: TMemoryStream; // Save original RLE stream until image is modified
FOS2Format: Boolean; // Write BMP file header, color table in OS/2 format
FHalftone: Boolean; // FPalette is halftone; don't write to file
protected
procedure FreeHandle; override;
public
destructor Destroy; override;
end;
TBitmapHandleType = (bmDIB, bmDDB);
TPixelFormat = (pfDevice, pf1bit, pf4bit, pf8bit, pf15bit, pf16bit, pf24bit, pf32bit, pfCustom);
TTransparentMode = (tmAuto, tmFixed);
TBitmap = class(TGraphic)
private
FImage: TBitmapImage;
FCanvas: TCanvas;
FIgnorePalette: Boolean;
FMaskBitsValid: Boolean;
FMaskValid: Boolean;
FTransparentColor: TColor;
FTransparentMode: TTransparentMode;
procedure Changing(Sender: TObject);
procedure CopyImage(AHandle: HBITMAP; APalette: HPALETTE; DIB: TDIBSection);
procedure DIBNeeded;
procedure FreeContext;
function GetCanvas: TCanvas;
function GetHandle: HBITMAP; virtual;
function GetHandleType: TBitmapHandleType;
function GetMaskHandle: HBITMAP; virtual;
function GetMonochrome: Boolean;
function GetPixelFormat: TPixelFormat;
function GetScanline(Row: Integer): Pointer;
function GetTransparentColor: TColor;
procedure NewImage(NewHandle: HBITMAP; NewPalette: HPALETTE;
const NewDIB: TDIBSection; OS2Format: Boolean; RLEStream: TStream = nil);
procedure ReadStream(Stream: TStream; Size: Longint);
procedure ReadDIB(Stream: TStream; ImageSize: LongWord; bmf: PBitmapFileHeader = nil);
procedure SetHandle(Value: HBITMAP);
procedure SetHandleType(Value: TBitmapHandleType); virtual;
procedure SetMaskHandle(Value: HBITMAP);
procedure SetMonochrome(Value: Boolean);
procedure SetPixelFormat(Value: TPixelFormat);
procedure SetTransparentColor(Value: TColor);
procedure SetTransparentMode(Value: TTransparentMode);
function TransparentColorStored: Boolean;
procedure WriteStream(Stream: TStream; WriteSize: Boolean);
protected
procedure Changed(Sender: TObject); override;
procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
function GetEmpty: Boolean; override;
function GetHeight: Integer; override;
function GetPalette: HPALETTE; override;
function GetWidth: Integer; override;
procedure HandleNeeded;
procedure MaskHandleNeeded;
procedure PaletteNeeded;
procedure ReadData(Stream: TStream); override;
procedure SetHeight(Value: Integer); override;
procedure SetPalette(Value: HPALETTE); override;
procedure SetWidth(Value: Integer); override;
procedure WriteData(Stream: TStream); override;
public
constructor Create; override;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
procedure Dormant;
procedure FreeImage;
function HandleAllocated: Boolean;
procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
APalette: HPALETTE); override;
procedure LoadFromStream(Stream: TStream); override;
procedure LoadFromResourceName(Instance: THandle; const ResName: String);
{$IFDEF MSWINDOWS}
procedure LoadFromResourceID(Instance: THandle; ResID: Integer);
{$ENDIF}
procedure Mask(TransparentColor: TColor);
function ReleaseHandle: HBITMAP;
function ReleaseMaskHandle: HBITMAP;
function ReleasePalette: HPALETTE;
procedure SaveToClipboardFormat(var Format: Word; var Data: THandle;
var APalette: HPALETTE); override;
procedure SaveToStream(Stream: TStream); override;
property Canvas: TCanvas read GetCanvas;
property Handle: HBITMAP read GetHandle write SetHandle;
property HandleType: TBitmapHandleType read GetHandleType write SetHandleType;
property IgnorePalette: Boolean read FIgnorePalette write FIgnorePalette;
property MaskHandle: HBITMAP read GetMaskHandle write SetMaskHandle;
property Monochrome: Boolean read GetMonochrome write SetMonochrome;
property PixelFormat: TPixelFormat read GetPixelFormat write SetPixelFormat;
property ScanLine[Row: Integer]: Pointer read GetScanLine;
property TransparentColor: TColor read GetTransparentColor
write SetTransparentColor stored TransparentColorStored;
property TransparentMode: TTransparentMode read FTransparentMode
write SetTransparentMode default tmAuto;
end;
{ TIcon }
{ TIcon encapsulates window HICON handle. Drawing of an icon does not stretch
so calling stretch draw is not meaningful.
Handle - The HICON used by the TIcon. }
TIconImage = class(TSharedImage)
private
FHandle: HICON;
FMemoryImage: TCustomMemoryStream;
FSize: TPoint;
protected
procedure FreeHandle; override;
public
destructor Destroy; override;
end;
TIcon = class(TGraphic)
private
FImage: TIconImage;
FRequestedSize: TPoint;
function GetHandle: HICON;
procedure HandleNeeded;
procedure ImageNeeded;
procedure NewImage(NewHandle: HICON; NewImage: TMemoryStream);
procedure SetHandle(Value: HICON);
protected
procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
function GetEmpty: Boolean; override;
function GetHeight: Integer; override;
function GetWidth: Integer; override;
procedure SetHeight(Value: Integer); override;
procedure SetTransparent(Value: Boolean); override;
procedure SetWidth(Value: Integer); override;
public
constructor Create; override;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
function HandleAllocated: Boolean;
procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
APalette: HPALETTE); override;
procedure LoadFromStream(Stream: TStream); override;
function ReleaseHandle: HICON;
procedure SaveToClipboardFormat(var Format: Word; var Data: THandle;
var APalette: HPALETTE); override;
procedure SaveToStream(Stream: TStream); override;
property Handle: HICON read GetHandle write SetHandle;
end;
var // New TFont instances are intialized with the values in this structure:
DefFontData: TFontData = (
Handle: 0;
Height: 0;
Pitch: fpDefault;
Style: [];
Charset : DEFAULT_CHARSET;
Name: 'MS Sans Serif');
var
SystemPalette16: HPalette; // 16 color palette that maps to the system palette
var
DDBsOnly: Boolean = False; // True = Load all BMPs as device bitmaps.
// Not recommended.
function GraphicFilter(GraphicClass: TGraphicClass): string;
function GraphicExtension(GraphicClass: TGraphicClass): string;
function GraphicFileMask(GraphicClass: TGraphicClass): string;
function ColorToRGB(Color: TColor): Longint;
function ColorToString(Color: TColor): string;
function StringToColor(const S: string): TColor;
procedure GetColorValues(Proc: TGetStrProc);
function ColorToIdent(Color: Longint; var Ident: string): Boolean;
function IdentToColor(const Ident: string; var Color: Longint): Boolean;
procedure GetCharsetValues(Proc: TGetStrProc);
function CharsetToIdent(Charset: Longint; var Ident: string): Boolean;
function IdentToCharset(const Ident: string; var Charset: Longint): Boolean;
procedure GetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: DWORD;
var ImageSize: DWORD);
function GetDIB(Bitmap: HBITMAP; Palette: HPALETTE; var BitmapInfo; var Bits): Boolean;
function CopyPalette(Palette: HPALETTE): HPALETTE;
procedure PaletteChanged;
procedure FreeMemoryContexts;
function GetDefFontCharSet: TFontCharSet;
function TransparentStretchBlt(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
SrcDC: HDC; SrcX, SrcY, SrcW, SrcH: Integer; MaskDC: HDC; MaskX,
MaskY: Integer): Boolean;
function CreateMappedBmp(Handle: HBITMAP; const OldColors, NewColors: array of TColor): HBITMAP;
function CreateMappedRes(Instance: THandle; ResName: PChar; const OldColors, NewColors: array of TColor): HBITMAP;
function CreateGrayMappedBmp(Handle: HBITMAP): HBITMAP;
function CreateGrayMappedRes(Instance: THandle; ResName: PChar): HBITMAP;
function AllocPatternBitmap(BkColor, FgColor: TColor): TBitmap;
// Alignment must be a power of 2. Color BMPs require DWORD alignment (32).
function BytesPerScanline(PixelsPerScanline, BitsPerPixel, Alignment: Longint): Longint;
var PenRatio: Double =1;
implementation
{ Things left out
---------------
Regions
PatBlt
Tabbed text
Clipping regions
Coordinate transformations
Paths
Beziers }
uses Consts;
const
csAllValid = [csHandleValid..csBrushValid];
var
ScreenLogPixels: Integer;
StockPen: HPEN;
StockBrush: HBRUSH;
StockFont: HFONT;
StockIcon: HICON;
BitmapImageLock: TRTLCriticalSection;
CounterLock: TRTLCriticalSection;
procedure InternalDeletePalette(Pal: HPalette);
begin
if (Pal <> 0) and (Pal <> SystemPalette16) then
DeleteObject(Pal);
end;
{ Resource managers }
const
ResInfoSize = SizeOf(TResource) - SizeOf(TFontData);
type
TResourceManager = class(TMyObject)
ResList: PResource;
FLock: TRTLCriticalSection;
ResDataSize: Word;
constructor Create(AResDataSize: Word);
destructor Destroy; override;
function AllocResource(const ResData): PResource;
procedure FreeResource(Resource: PResource);
procedure ChangeResource(GraphicsObject: TGraphicsObject; const ResData);
procedure AssignResource(GraphicsObject: TGraphicsObject;
AResource: PResource);
procedure Lock;
procedure Unlock;
end;
var
FontManager: TResourceManager;
PenManager: TResourceManager;
BrushManager: TResourceManager;
function GetHashCode(const Buffer; Count: Integer): Word; assembler;
asm
MOV ECX,EDX
MOV EDX,EAX
XOR EAX,EAX
@@1: ROL AX,5
XOR AL,[EDX]
INC EDX
DEC ECX
JNE @@1
end;
constructor TResourceManager.Create(AResDataSize: Word);
begin
ResDataSize := AResDataSize;
InitializeCriticalSection(FLock);
end;
destructor TResourceManager.Destroy;
begin
DeleteCriticalSection(FLock);
end;
procedure TResourceManager.Lock;
begin
EnterCriticalSection(FLock);
end;
procedure TResourceManager.Unlock;
begin
LeaveCriticalSection(FLock);
end;
function TResourceManager.AllocResource(const ResData): PResource;
var
ResHash: Word;
begin
ResHash := GetHashCode(ResData, ResDataSize);
Lock;
try
Result := ResList;
while (Result <> nil) and ((Result^.HashCode <> ResHash) or
not CompareMem(@Result^.Data, @ResData, ResDataSize)) do
Result := Result^.Next;
if Result = nil then
begin
GetMem(Result, ResDataSize + ResInfoSize);
with Result^ do
begin
Next := ResList;
RefCount := 0;
Handle := TResData(ResData).Handle;
HashCode := ResHash;
Move(ResData, Data, ResDataSize);
end;
ResList := Result;
end;
Inc(Result^.RefCount);
finally
Unlock;
end;
end;
procedure TResourceManager.FreeResource(Resource: PResource);
var
P: PResource;
DeleteIt: Boolean;
begin
if Resource <> nil then
with Resource^ do
begin
Lock;
try
Dec(RefCount);
DeleteIt := RefCount = 0;
if DeleteIt then
begin
if Resource = ResList then
ResList := Resource^.Next
else
begin
P := ResList;
while P^.Next <> Resource do P := P^.Next;
P^.Next := Resource^.Next;
end;
end;
finally
Unlock;
end;
if DeleteIt then
begin // this is outside the critsect to minimize lock time
if Handle <> 0 then DeleteObject(Handle);
FreeMem(Resource);
end;
end;
end;
procedure TResourceManager.ChangeResource(GraphicsObject: TGraphicsObject;
const ResData);
var
P: PResource;
begin
Lock;
try // prevent changes to GraphicsObject.FResource pointer between steps
P := GraphicsObject.FResource;
GraphicsObject.FResource := AllocResource(ResData);
if GraphicsObject.FResource <> P then GraphicsObject.Changed;
FreeResource(P);
finally
Unlock;
end;
end;
procedure TResourceManager.AssignResource(GraphicsObject: TGraphicsObject;
AResource: PResource);
var
P: PResource;
begin
Lock;
try
P := GraphicsObject.FResource;
if P <> AResource then
begin
Inc(AResource^.RefCount);
GraphicsObject.FResource := AResource;
GraphicsObject.Changed;
FreeResource(P);
end;
finally
Unlock;
end;
end;
var
CanvasList: TThreadList;
procedure PaletteChanged;
procedure ClearColor(ResMan: TResourceManager);
var
Resource: PResource;
begin
ResMan.Lock;
try
Resource := ResMan.ResList;
while Resource <> nil do
begin
with Resource^ do
{ Assumes Pen.Color and Brush.Color share the same location }
if (Handle <> 0) and (Pen.Color < 0) then
begin
DeleteObject(Handle);
Handle := 0;
end;
Resource := Resource^.Next;
end;
finally
ResMan.Unlock;
end;
end;
var
I,J: Integer;
begin
{ Called when the system palette has changed (WM_SYSCOLORCHANGE) }
I := 0;
with CanvasList.LockList do
try
while I < Count do
begin
with TCanvas(Items[I]) do
begin
Lock;
Inc(I);
DeselectHandles;
end;
end;
ClearColor(PenManager);
ClearColor(BrushManager);
finally
for J := 0 to I-1 do // Only unlock the canvases we actually locked
TCanvas(Items[J]).Unlock;
CanvasList.UnlockList;
end;
end;
{ Color mapping routines }
const
Colors: array[0..51] of TIdentMapEntry = (
(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'),
(Value: clMoneyGreen; Name: 'clMoneyGreen'),
(Value: clSkyBlue; Name: 'clSkyBlue'),
(Value: clCream; Name: 'clCream'),
(Value: clMedGray; Name: 'clMedGray'),
(Value: clActiveBorder; Name: 'clActiveBorder'),
(Value: clActiveCaption; Name: 'clActiveCaption'),
(Value: clAppWorkSpace; Name: 'clAppWorkSpace'),
(Value: clBackground; Name: 'clBackground'),
(Value: clBtnFace; Name: 'clBtnFace'),
(Value: clBtnHighlight; Name: 'clBtnHighlight'),
(Value: clBtnShadow; Name: 'clBtnShadow'),
(Value: clBtnText; Name: 'clBtnText'),
(Value: clCaptionText; Name: 'clCaptionText'),
(Value: clDefault; Name: 'clDefault'),
(Value: clGradientActiveCaption; Name: 'clGradientActiveCaption'),
(Value: clGradientInactiveCaption; Name: 'clGradientInactiveCaption'),
(Value: clGrayText; Name: 'clGrayText'),
(Value: clHighlight; Name: 'clHighlight'),
(Value: clHighlightText; Name: 'clHighlightText'),
(Value: clHotLight; Name: 'clHotLight'),
(Value: clInactiveBorder; Name: 'clInactiveBorder'),
(Value: clInactiveCaption; Name: 'clInactiveCaption'),
(Value: clInactiveCaptionText; Name: 'clInactiveCaptionText'),
(Value: clInfoBk; Name: 'clInfoBk'),
(Value: clInfoText; Name: 'clInfoText'),
(Value: clMenu; Name: 'clMenu'),
(Value: clMenuBar; Name: 'clMenuBar'),
(Value: clMenuHighlight; Name: 'clMenuHighlight'),
(Value: clMenuText; Name: 'clMenuText'),
(Value: clNone; Name: 'clNone'),
(Value: clScrollBar; Name: 'clScrollBar'),
(Value: cl3DDkShadow; Name: 'cl3DDkShadow'),
(Value: cl3DLight; Name: 'cl3DLight'),
(Value: clWindow; Name: 'clWindow'),
(Value: clWindowFrame; Name: 'clWindowFrame'),
(Value: clWindowText; Name: 'clWindowText'));
function ColorToRGB(Color: TColor): Longint;
begin
if Color < 0 then
Result := GetSysColor(Color and $000000FF) else
Result := Color;
end;
function ColorToString(Color: TColor): string;
begin
if not ColorToIdent(Color, Result) then
FmtStr(Result, '%s%.8x', [HexDisplayPrefix, Color]);
end;
function StringToColor(const S: string): TColor;
begin
if not IdentToColor(S, Longint(Result)) then
Result := TColor(StrToInt(S));
end;
procedure GetColorValues(Proc: TGetStrProc);
var
I: Integer;
begin
for I := Low(Colors) to High(Colors) do Proc(Colors[I].Name);
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;
{ TGraphicsObject }
procedure TGraphicsObject.Changed;
begin
if Assigned(FOnChange) then FOnChange(Self);
end;
procedure TGraphicsObject.Lock;
begin
if Assigned(FOwnerLock) then EnterCriticalSection(FOwnerLock^);
end;
procedure TGraphicsObject.Unlock;
begin
if Assigned(FOwnerLock) then LeaveCriticalSection(FOwnerLock^);
end;
function TGraphicsObject.HandleAllocated: Boolean;
begin
Result := (FResource <> nil) and (FResource^.Handle <> 0);
end;
{ TFont }
const
FontCharsets: array[0..17] of TIdentMapEntry = (
(Value: 0; Name: 'ANSI_CHARSET'),
(Value: 1; Name: 'DEFAULT_CHARSET'),
(Value: 2; Name: 'SYMBOL_CHARSET'),
(Value: 77; Name: 'MAC_CHARSET'),
(Value: 128; Name: 'SHIFTJIS_CHARSET'),
(Value: 129; Name: 'HANGEUL_CHARSET'),
(Value: 130; Name: 'JOHAB_CHARSET'),
(Value: 134; Name: 'GB2312_CHARSET'),
(Value: 136; Name: 'CHINESEBIG5_CHARSET'),
(Value: 161; Name: 'GREEK_CHARSET'),
(Value: 162; Name: 'TURKISH_CHARSET'),
(Value: 177; Name: 'HEBREW_CHARSET'),
(Value: 178; Name: 'ARABIC_CHARSET'),
(Value: 186; Name: 'BALTIC_CHARSET'),
(Value: 204; Name: 'RUSSIAN_CHARSET'),
(Value: 222; Name: 'THAI_CHARSET'),
(Value: 238; Name: 'EASTEUROPE_CHARSET'),
(Value: 255; Name: 'OEM_CHARSET'));
procedure GetCharsetValues(Proc: TGetStrProc);
var
I: Integer;
begin
for I := Low(FontCharsets) to High(FontCharsets) do Proc(FontCharsets[I].Name);
end;
function CharsetToIdent(Charset: Longint; var Ident: string): Boolean;
begin
Result := IntToIdent(Charset, Ident, FontCharsets);
end;
function IdentToCharset(const Ident: string; var Charset: Longint): Boolean;
begin
Result := IdentToInt(Ident, CharSet, FontCharsets);
end;
function GetFontData(Font: HFont): TFontData;
var
LogFont: TLogFont;
begin
Result := DefFontData;
if Font <> 0 then
begin
if GetObject(Font, SizeOf(LogFont), @LogFont) <> 0 then
with Result, LogFont do
begin
Height := lfHeight;
if lfWeight >= FW_BOLD then
Include(Style, fsBold);
if lfItalic = 1 then
Include(Style, fsItalic);
if lfUnderline = 1 then
Include(Style, fsUnderline);
if lfStrikeOut = 1 then
Include(Style, fsStrikeOut);
Charset := TFontCharset(lfCharSet);
Name := lfFaceName;
case lfPitchAndFamily and $F of
VARIABLE_PITCH: Pitch := fpVariable;
FIXED_PITCH: Pitch := fpFixed;
else
Pitch := fpDefault;
end;
Handle := Font;
end;
end;
end;
constructor TFont.Create;
begin
DefFontData.Handle := 0;
FResource := FontManager.AllocResource(DefFontData);
FColor := clWindowText;
FPixelsPerInch := ScreenLogPixels;
end;
destructor TFont.Destroy;
begin
FontManager.FreeResource(FResource);
end;
procedure TFont.Changed;
begin
inherited Changed;
if FNotify <> nil then FNotify.Changed;
end;
procedure TFont.Assign(Source: TPersistent);
begin
if Source is TFont then
begin
Lock;
try
TFont(Source).Lock;
try
FontManager.AssignResource(Self, TFont(Source).FResource);
Color := TFont(Source).Color;
if PixelsPerInch <> TFont(Source).PixelsPerInch then
Size := TFont(Source).Size;
finally
TFont(Source).Unlock;
end;
finally
Unlock;
end;
Exit;
end;
inherited Assign(Source);
end;
procedure TFont.GetData(var FontData: TFontData);
begin
FontData := FResource^.Font;
FontData.Handle := 0;
end;
procedure TFont.SetData(const FontData: TFontData);
begin
Lock;
try
FontManager.ChangeResource(Self, FontData);
finally
Unlock;
end;
end;
procedure TFont.SetColor(Value: TColor);
begin
if FColor <> Value then
begin
FColor := Value;
Changed;
end;
end;
function TFont.GetHandle: HFont;
var
LogFont: TLogFont;
begin
with FResource^ do
begin
if Handle = 0 then
begin
FontManager.Lock;
with LogFont do
try
if Handle = 0 then
begin
lfHeight := Font.Height;
lfWidth := 0; { have font mapper choose }
lfEscapement := 0; { only straight fonts }
lfOrientation := 0; { no rotation }
if fsBold in Font.Style then
lfWeight := FW_BOLD
else
lfWeight := FW_NORMAL;
lfItalic := Byte(fsItalic in Font.Style);
lfUnderline := Byte(fsUnderline in Font.Style);
lfStrikeOut := Byte(fsStrikeOut in Font.Style);
lfCharSet := Byte(Font.Charset);
if AnsiCompareText(Font.Name, 'Default') = 0 then // do not localize
StrPCopy(lfFaceName, DefFontData.Name)
else
StrPCopy(lfFaceName, Font.Name);
lfQuality := DEFAULT_QUALITY;
{ Everything else as default }
lfOutPrecision := OUT_DEFAULT_PRECIS;
lfClipPrecision := CLIP_DEFAULT_PRECIS;
case Pitch of
fpVariable: lfPitchAndFamily := VARIABLE_PITCH;
fpFixed: lfPitchAndFamily := FIXED_PITCH;
else
lfPitchAndFamily := DEFAULT_PITCH;
end;
Handle := CreateFontIndirect(LogFont);
end;
finally
FontManager.Unlock;
end;
end;
Result := Handle;
end;
end;
procedure TFont.SetHandle(Value: HFont);
begin
SetData(GetFontData(Value));
end;
function TFont.GetHeight: Integer;
begin
Result := FResource^.Font.Height;
end;
procedure TFont.SetHeight(Value: Integer);
var
FontData: TFontData;
begin
GetData(FontData);
FontData.Height := Value;
SetData(FontData);
end;
function TFont.GetName: TFontName;
begin
Result := FResource^.Font.Name;
end;
procedure TFont.SetName(const Value: TFontName);
var
FontData: TFontData;
begin
if Value <> '' then
begin
GetData(FontData);
FillChar(FontData.Name, SizeOf(FontData.Name), 0);
FontData.Name := Value;
SetData(FontData);
end;
end;
function TFont.GetSize: Integer;
begin
Result := -MulDiv(Height, 72, FPixelsPerInch);
end;
procedure TFont.SetSize(Value: Integer);
begin
Height := -MulDiv(Value, FPixelsPerInch, 72);
end;
function TFont.GetStyle: TFontStyles;
begin
Result := FResource^.Font.Style;
end;
procedure TFont.SetStyle(Value: TFontStyles);
var
FontData: TFontData;
begin
GetData(FontData);
FontData.Style := Value;
SetData(FontData);
end;
function TFont.GetPitch: TFontPitch;
begin
Result := FResource^.Font.Pitch;
end;
procedure TFont.SetPitch(Value: TFontPitch);
var
FontData: TFontData;
begin
GetData(FontData);
FontData.Pitch := Value;
SetData(FontData);
end;
function TFont.GetCharset: TFontCharset;
begin
Result := FResource^.Font.Charset;
end;
procedure TFont.SetCharset(Value: TFontCharset);
var
FontData: TFontData;
begin
GetData(FontData);
FontData.Charset := Value;
SetData(FontData);
end;
{ TPen }
const
DefPenData: TPenData = (
Handle: 0;
Color: clBlack;
Width: 1;
Style: psSolid);
constructor TPen.Create;
begin
FResource := PenManager.AllocResource(DefPenData);
FMode := pmCopy;
//FRatio := 1;
end;
destructor TPen.Destroy;
begin
PenManager.FreeResource(FResource);
end;
procedure TPen.Assign(Source: TPersistent);
begin
if Source is TPen then
begin
Lock;
try
TPen(Source).Lock;
try
PenManager.AssignResource(Self, TPen(Source).FResource);
SetMode(TPen(Source).FMode);
finally
TPen(Source).Unlock;
end;
finally
Unlock;
end;
Exit;
end;
inherited Assign(Source);
end;
procedure TPen.GetData(var PenData: TPenData);
begin
PenData := FResource^.Pen;
PenData.Handle := 0;
end;
procedure TPen.SetData(const PenData: TPenData);
begin
Lock;
try
PenManager.ChangeResource(Self, PenData);
finally
Unlock;
end;
end;
function TPen.GetColor: TColor;
begin
Result := FResource^.Pen.Color;
end;
procedure TPen.SetColor(Value: TColor);
var
PenData: TPenData;
begin
GetData(PenData);
PenData.Color := Value;
SetData(PenData);
end;
function TPen.GetHandle: HPen;
const
PenStyles: array[TPenStyle] of Word =
(PS_SOLID, PS_DASH, PS_DOT, PS_DASHDOT, PS_DASHDOTDOT, PS_NULL,
PS_INSIDEFRAME);
var
LogPen: TLogPen;
begin
with FResource^ do
begin
if Handle = 0 then
begin
PenManager.Lock;
with LogPen do
try
if Handle = 0 then
begin
lopnStyle := PenStyles[Pen.Style];
lopnWidth.X := Pen.Width;
lopnColor := ColorToRGB(Pen.Color);
Handle := CreatePenIndirect(LogPen);
end;
finally
PenManager.Unlock;
end;
end;
Result := Handle;
end;
end;
procedure TPen.SetHandle(Value: HPen);
var
PenData: TPenData;
begin
PenData := DefPenData;
PenData.Handle := Value;
SetData(PenData);
end;
procedure TPen.SetMode(Value: TPenMode);
begin
if FMode <> Value then
begin
FMode := Value;
Changed;
end;
end;
function TPen.GetStyle: TPenStyle;
begin
Result := FResource^.Pen.Style;
end;
procedure TPen.SetStyle(Value: TPenStyle);
var
PenData: TPenData;
begin
GetData(PenData);
PenData.Style := Value;
SetData(PenData);
end;
function TPen.GetWidth: Integer;
begin
Result := FResource^.Pen.Width;
end;
procedure TPen.SetWidth(Value: Integer);
var
PenData: TPenData;
begin
if Value >= 0 then
begin
GetData(PenData);
PenData.Width := Value;
if (PenRatio > 1) then
begin
PenData.Width := Round(Value*PenRatio);
end else if PenRatio > 1 then begin
PenData.Width := Round(Value*(PenRatio/2));
end;
SetData(PenData);
end;
end;
constructor TExtPen.Create;
begin
inherited Create;
FGeometric := False;
end;
function TExtPen.GetHandle: HPen;
const
PenStyles: array[TPenStyle] of Word =
(PS_SOLID, PS_DASH, PS_DOT, PS_DASHDOT, PS_DASHDOTDOT, PS_NULL,
PS_INSIDEFRAME);
var
LogPen: TLogPen;
lb: TLogBrush;
begin
with FResource^ do
begin
if Handle = 0 then
begin
PenManager.Lock;
with LogPen do
try
if Handle = 0 then
begin
lopnStyle := PenStyles[Pen.Style];
lopnWidth.X := Pen.Width;
lopnColor := ColorToRGB(Pen.Color);
if FGeometric and (Self.Mode <> pmXor) and (pen.width>1) and (pen.Style <> psSOlid) then begin
lb.lbStyle := BS_SOLID;
lb.lbColor := ColorToRGB(Pen.Color);
lb.lbHatch := 0;
Handle := ExtCreatePen(PS_GEOMETRIC or lopnStyle or
PS_ENDCAP_SQUARE or PS_JOIN_BEVEL,pen.width,lb,0,nil);
end else begin
Handle := CreatePenIndirect(LogPen);
end;
end;
finally
PenManager.Unlock;
end;
end;
Result := Handle;
end;
end;
procedure TExtPen.SetGeometric(const Value: Boolean);
begin
FGeometric := Value;
Changed;
end;
procedure TExtPen.SetHandle(Value: HPen);
var
PenData: TPenData;
begin
PenData := DefPenData;
PenData.Handle := Value;
SetData(PenData);
end;
{ TBrush }
const
DefBrushData: TBrushData = (
Handle: 0;
Color: clWhite;
Bitmap: nil;
Style: bsSolid);
constructor TBrush.Create;
begin
FResource := BrushManager.AllocResource(DefBrushData);
end;
destructor TBrush.Destroy;
begin
BrushManager.FreeResource(FResource);
end;
procedure TBrush.Assign(Source: TPersistent);
begin
if Source is TBrush then
begin
Lock;
try
TBrush(Source).Lock;
try
BrushManager.AssignResource(Self, TBrush(Source).FResource);
finally
TBrush(Source).Unlock;
end;
finally
Unlock;
end;
Exit;
end;
inherited Assign(Source);
end;
procedure TBrush.GetData(var BrushData: TBrushData);
begin
BrushData := FResource^.Brush;
BrushData.Handle := 0;
BrushData.Bitmap := nil;
end;
procedure TBrush.SetData(const BrushData: TBrushData);
begin
Lock;
try
BrushManager.ChangeResource(Self, BrushData);
finally
Unlock;
end;
end;
function TBrush.GetBitmap: TBitmap;
begin
Result := FResource^.Brush.Bitmap;
end;
procedure TBrush.SetBitmap(Value: TBitmap);
var
BrushData: TBrushData;
begin
BrushData := DefBrushData;
BrushData.Bitmap := Value;
SetData(BrushData);
end;
function TBrush.GetColor: TColor;
begin
Result := FResource^.Brush.Color;
end;
procedure TBrush.SetColor(Value: TColor);
var
BrushData: TBrushData;
begin
GetData(BrushData);
BrushData.Color := Value;
if BrushData.Style = bsClear then BrushData.Style := bsSolid;
SetData(BrushData);
end;
function TBrush.GetHandle: HBrush;
var
LogBrush: TLogBrush;
begin
with FResource^ do
begin
if Handle = 0 then
begin
BrushManager.Lock;
try
if Handle = 0 then
begin
with LogBrush do
begin
if Brush.Bitmap <> nil then
begin
lbStyle := BS_PATTERN;
Brush.Bitmap.HandleType := bmDDB;
lbHatch := Brush.Bitmap.Handle;
end else
begin
lbHatch := 0;
case Brush.Style of
bsSolid: lbStyle := BS_SOLID;
bsClear: lbStyle := BS_HOLLOW;
else
lbStyle := BS_HATCHED;
lbHatch := Ord(Brush.Style) - Ord(bsHorizontal);
end;
end;
lbColor := ColorToRGB(Brush.Color);
end;
Handle := CreateBrushIndirect(LogBrush);
end;
finally
BrushManager.Unlock;
end;
end;
Result := Handle;
end;
end;
procedure TBrush.SetHandle(Value: HBrush);
var
BrushData: TBrushData;
begin
BrushData := DefBrushData;
BrushData.Handle := Value;
SetData(BrushData);
end;
function TBrush.GetStyle: TBrushStyle;
begin
Result := FResource^.Brush.Style;
end;
procedure TBrush.SetStyle(Value: TBrushStyle);
var
BrushData: TBrushData;
begin
GetData(BrushData);
BrushData.Style := Value;
if BrushData.Style = bsClear then BrushData.Color := clWhite;
SetData(BrushData);
end;
{ TFontRecall }
constructor TFontRecall.Create(AFont: TFont);
begin
inherited Create(TFont.Create, AFont);
end;
{ TPenRecall }
constructor TPenRecall.Create(APen: TPen);
begin
inherited Create(TPen.Create, APen);
end;
{ TBrushRecall }
constructor TBrushRecall.Create(ABrush: TBrush);
begin
inherited Create(TBrush.Create, ABrush);
end;
{ TCanvas }
constructor TCanvas.Create;
begin
inherited Create;
InitializeCriticalSection(FLock);
FFont := TFont.Create;
FFont.OnChange := FontChanged;
FFont.OwnerCriticalSection := @FLock;
FPen := TExtPen.Create;
FPen.OnChange := PenChanged;
FPen.OwnerCriticalSection := @FLock;
FBrush := TBrush.Create;
FBrush.OnChange := BrushChanged;
FBrush.OwnerCriticalSection := @FLock;
FCopyMode := cmSrcCopy;
State := [];
CanvasList.Add(Self);
end;
destructor TCanvas.Destroy;
begin
CanvasList.Remove(Self);
SetHandle(0);
FFont.Free;
FPen.Free;
FBrush.Free;
DeleteCriticalSection(FLock);
inherited Destroy;
end;
procedure TCanvas.Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
begin
Changing;
RequiredState([csHandleValid, csPenValid, csBrushValid]);
Windows.Arc(FHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4);
Changed;
end;
procedure TCanvas.BrushCopy(const Dest: TRect; Bitmap: TBitmap;
const Source: TRect; Color: TColor);
const
ROP_DSPDxax = $00E20746;
var
SrcW, SrcH, DstW, DstH: Integer;
crBack, crText: TColorRef;
MaskDC: HDC;
Mask: TBitmap;
MaskHandle: HBITMAP;
begin
if Bitmap = nil then Exit;
Lock;
try
Changing;
RequiredState([csHandleValid, csBrushValid]);
Bitmap.Canvas.Lock;
try
DstW := Dest.Right - Dest.Left;
DstH := Dest.Bottom - Dest.Top;
SrcW := Source.Right - Source.Left;
SrcH := Source.Bottom - Source.Top;
if Bitmap.TransparentColor = Color then
begin
Mask := nil;
MaskHandle := Bitmap.MaskHandle;
MaskDC := CreateCompatibleDC(0);
MaskHandle := SelectObject(MaskDC, MaskHandle);
end
else
begin
Mask := TBitmap.Create;
Mask.Assign(Bitmap);
{ Replace Color with black and all other colors with white }
Mask.Mask(Color);
Mask.Canvas.RequiredState([csHandleValid]);
MaskDC := Mask.Canvas.FHandle;
MaskHandle := 0;
end;
try
Bitmap.Canvas.RequiredState([csHandleValid]);
{ Draw transparently or use brush color to fill background }
if Brush.Style = bsClear then
begin
TransparentStretchBlt(FHandle, Dest.Left, Dest.Top, DstW, DstH,
Bitmap.Canvas.FHandle, Source.Left, Source.Top, SrcW, SrcH,
MaskDC, Source.Left, Source.Top);
end
else
begin
StretchBlt(FHandle, Dest.Left, Dest.Top, DstW, DstH,
Bitmap.Canvas.FHandle, Source.Left, Source.Top, SrcW, SrcH, SrcCopy);
crText := SetTextColor(Self.FHandle, 0);
crBack := SetBkColor(Self.FHandle, $FFFFFF);
StretchBlt(Self.FHandle, Dest.Left, Dest.Top, DstW, DstH,
MaskDC, Source.Left, Source.Top, SrcW, SrcH, ROP_DSPDxax);
SetTextColor(Self.FHandle, crText);
SetBkColor(Self.FHandle, crBack);
end;
finally
if Assigned(Mask) then Mask.Free
else
begin
if MaskHandle <> 0 then SelectObject(MaskDC, MaskHandle);
DeleteDC(MaskDC);
end;
end;
finally
Bitmap.Canvas.Unlock;
end;
Changed;
finally
Unlock;
end;
end;
procedure TCanvas.Chord(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
begin
Changing;
RequiredState([csHandleValid, csPenValid, csBrushValid]);
Windows.Chord(FHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4);
Changed;
end;
procedure TCanvas.CopyRect(const Dest: TRect; Canvas: TCanvas;
const Source: TRect);
begin
Changing;
RequiredState([csHandleValid, csFontValid, csBrushValid]);
Canvas.RequiredState([csHandleValid, csBrushValid]);
StretchBlt(FHandle, Dest.Left, Dest.Top, Dest.Right - Dest.Left,
Dest.Bottom - Dest.Top, Canvas.FHandle, Source.Left, Source.Top,
Source.Right - Source.Left, Source.Bottom - Source.Top, CopyMode);
Changed;
end;
procedure TCanvas.Draw(X, Y: Integer; Graphic: TGraphic);
begin
if (Graphic <> nil) and not Graphic.Empty then
begin
Changing;
RequiredState([csHandleValid]);
SetBkColor(FHandle, ColorToRGB(FBrush.Color));
SetTextColor(FHandle, ColorToRGB(FFont.Color));
Graphic.Draw(Self, Rect(X, Y, X + Graphic.Width, Y + Graphic.Height));
Changed;
end;
end;
procedure TCanvas.DrawFocusRect(const Rect: TRect);
begin
Changing;
RequiredState([csHandleValid, csBrushValid]);
Windows.DrawFocusRect(FHandle, Rect);
Changed;
end;
procedure TCanvas.Ellipse(X1, Y1, X2, Y2: Integer);
begin
Changing;
RequiredState([csHandleValid, csPenValid, csBrushValid]);
Windows.Ellipse(FHandle, X1, Y1, X2, Y2);
Changed;
end;
procedure TCanvas.Ellipse(const Rect: TRect);
begin
Ellipse(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);
end;
procedure TCanvas.FillRect(const Rect: TRect);
begin
Changing;
RequiredState([csHandleValid, csBrushValid]);
Windows.FillRect(FHandle, Rect, Brush.GetHandle);
Changed;
end;
procedure TCanvas.FloodFill(X, Y: Integer; Color: TColor;
FillStyle: TFillStyle);
const
FillStyles: array[TFillStyle] of Word =
(FLOODFILLSURFACE, FLOODFILLBORDER);
begin
Changing;
RequiredState([csHandleValid, csBrushValid]);
Windows.ExtFloodFill(FHandle, X, Y, Color, FillStyles[FillStyle]);
Changed;
end;
procedure TCanvas.FrameRect(const Rect: TRect);
begin
Changing;
RequiredState([csHandleValid, csBrushValid]);
Windows.FrameRect(FHandle, Rect, Brush.GetHandle);
Changed;
end;
function TCanvas.HandleAllocated: Boolean;
begin
Result := FHandle <> 0;
end;
procedure TCanvas.LineTo(X, Y: Integer);
begin
Changing;
RequiredState([csHandleValid, csPenValid, csBrushValid]);
Windows.LineTo(FHandle, X, Y);
Changed;
end;
procedure TCanvas.Lock;
begin
EnterCriticalSection(CounterLock);
Inc(FLockCount);
LeaveCriticalSection(CounterLock);
EnterCriticalSection(FLock);
end;
procedure TCanvas.MoveTo(X, Y: Integer);
begin
RequiredState([csHandleValid]);
Windows.MoveToEx(FHandle, X, Y, nil);
end;
procedure TCanvas.Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
begin
Changing;
RequiredState([csHandleValid, csPenValid, csBrushValid]);
Windows.Pie(FHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4);
Changed;
end;
type
PPoints = ^TPoints;
TPoints = array[0..0] of TPoint;
procedure TCanvas.Polygon(const Points: array of TPoint);
begin
Changing;
RequiredState([csHandleValid, csPenValid, csBrushValid]);
Windows.Polygon(FHandle, PPoints(@Points)^, High(Points) + 1);
Changed;
end;
procedure TCanvas.Polyline(const Points: array of TPoint);
begin
Changing;
RequiredState([csHandleValid, csPenValid, csBrushValid]);
Windows.Polyline(FHandle, PPoints(@Points)^, High(Points) + 1);
Changed;
end;
procedure TCanvas.PolyBezier(const Points: array of TPoint);
begin
Changing;
RequiredState([csHandleValid, csPenValid, csBrushValid]);
Windows.PolyBezier(FHandle, PPoints(@Points)^, High(Points) + 1);
Changed;
end;
procedure TCanvas.PolyBezierTo(const Points: array of TPoint);
begin
Changing;
RequiredState([csHandleValid, csPenValid, csBrushValid]);
Windows.PolyBezierTo(FHandle, PPoints(@Points)^, High(Points) + 1);
Changed;
end;
procedure TCanvas.Rectangle(X1, Y1, X2, Y2: Integer);
begin
Changing;
RequiredState([csHandleValid, csBrushValid, csPenValid]);
Windows.Rectangle(FHandle, X1, Y1, X2, Y2);
Changed;
end;
procedure TCanvas.Rectangle(const Rect: TRect);
begin
Rectangle(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);
end;
procedure TCanvas.Refresh;
begin
DeselectHandles;
end;
procedure TCanvas.RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer);
begin
Changing;
RequiredState([csHandleValid, csBrushValid, csPenValid]);
Windows.RoundRect(FHandle, X1, Y1, X2, Y2, X3, Y3);
Changed;
end;
procedure TCanvas.StretchDraw(const Rect: TRect; Graphic: TGraphic);
begin
if Graphic <> nil then
begin
Changing;
RequiredState(csAllValid);
Graphic.Draw(Self, Rect);
Changed;
end;
end;
function TCanvas.GetCanvasOrientation: TCanvasOrientation;
var
Point: TPoint;
begin
Result := coLeftToRight;
if (FTextFlags and ETO_RTLREADING) <> 0 then
begin
GetWindowOrgEx(Handle, Point);
if Point.X <> 0 then Result := coRightToLeft
end;
end;
procedure TCanvas.TextOut(X, Y: Integer; const Text: String);
begin
Changing;
RequiredState([csHandleValid, csFontValid, csBrushValid]);
if CanvasOrientation = coRightToLeft then Inc(X, TextWidth(Text) + 1);
Windows.ExtTextOut(FHandle, X, Y, FTextFlags, nil, PChar(Text),
Length(Text), nil);
MoveTo(X + TextWidth(Text), Y);
Changed;
end;
procedure TCanvas.TextRect(Rect: TRect; X, Y: Integer; const Text: string);
var
Options: Longint;
begin
Changing;
RequiredState([csHandleValid, csFontValid, csBrushValid]);
Options := ETO_CLIPPED or FTextFlags;
if Brush.Style <> bsClear then
Options := Options or ETO_OPAQUE;
if ((FTextFlags and ETO_RTLREADING) <> 0) and
(CanvasOrientation = coRightToLeft) then Inc(X, TextWidth(Text) + 1);
Windows.ExtTextOut(FHandle, X, Y, Options, @Rect, PChar(Text),
Length(Text), nil);
Changed;
end;
function TCanvas.TextExtent(const Text: string): TSize;
begin
RequiredState([csHandleValid, csFontValid]);
Result.cX := 0;
Result.cY := 0;
Windows.GetTextExtentPoint32(FHandle, PChar(Text), Length(Text), Result);
end;
function TCanvas.TextWidth(const Text: string): Integer;
begin
Result := TextExtent(Text).cX;
end;
function TCanvas.TextHeight(const Text: string): Integer;
begin
Result := TextExtent(Text).cY;
end;
function TCanvas.TryLock: Boolean;
begin
EnterCriticalSection(CounterLock);
try
Result := FLockCount = 0;
if Result then Lock;
finally
LeaveCriticalSection(CounterLock);
end;
end;
procedure TCanvas.Unlock;
begin
LeaveCriticalSection(FLock);
EnterCriticalSection(CounterLock);
Dec(FLockCount);
LeaveCriticalSection(CounterLock);
end;
procedure TCanvas.SetFont(Value: TFont);
begin
FFont.Assign(Value);
end;
procedure TCanvas.SetPen(Value: TPen);
begin
FPen.Assign(Value);
end;
procedure TCanvas.SetBrush(Value: TBrush);
begin
FBrush.Assign(Value);
end;
function TCanvas.GetPenPos: TPoint;
begin
RequiredState([csHandleValid]);
Windows.GetCurrentPositionEx(FHandle, @Result);
end;
procedure TCanvas.SetPenPos(Value: TPoint);
begin
MoveTo(Value.X, Value.Y);
end;
function TCanvas.GetPixel(X, Y: Integer): TColor;
begin
RequiredState([csHandleValid]);
GetPixel := Windows.GetPixel(FHandle, X, Y);
end;
procedure TCanvas.SetPixel(X, Y: Integer; Value: TColor);
begin
Changing;
RequiredState([csHandleValid, csPenValid]);
Windows.SetPixel(FHandle, X, Y, ColorToRGB(Value));
Changed;
end;
function TCanvas.GetClipRect: TRect;
begin
RequiredState([csHandleValid]);
GetClipBox(FHandle, Result);
end;
function TCanvas.GetHandle: HDC;
begin
Changing;
RequiredState(csAllValid);
Result := FHandle;
end;
procedure TCanvas.DeselectHandles;
begin
if (FHandle <> 0) and (State - [csPenValid, csBrushValid, csFontValid] <> State) then
begin
SelectObject(FHandle, StockPen);
SelectObject(FHandle, StockBrush);
SelectObject(FHandle, StockFont);
State := State - [csPenValid, csBrushValid, csFontValid];
end;
end;
procedure TCanvas.CreateHandle;
begin
end;
procedure TCanvas.SetHandle(Value: HDC);
begin
if FHandle <> Value then
begin
if FHandle <> 0 then
begin
DeselectHandles;
FPenPos := GetPenPos;
FHandle := 0;
Exclude(State, csHandleValid);
end;
if Value <> 0 then
begin
Include(State, csHandleValid);
FHandle := Value;
SetPenPos(FPenPos);
end;
end;
end;
procedure TCanvas.RequiredState(ReqState: TCanvasState);
var
NeededState: TCanvasState;
begin
NeededState := ReqState - State;
if NeededState <> [] then
begin
if csHandleValid in NeededState then
begin
CreateHandle;
if FHandle = 0 then
raise EInvalidOperation.CreateRes(@SNoCanvasHandle);
end;
if csFontValid in NeededState then CreateFont;
if csPenValid in NeededState then CreatePen;
if csBrushValid in NeededState then CreateBrush;
State := State + NeededState;
end;
end;
procedure TCanvas.Changing;
begin
if Assigned(FOnChanging) then FOnChanging(Self);
end;
procedure TCanvas.Changed;
begin
if Assigned(FOnChange) then FOnChange(Self);
end;
procedure TCanvas.CreateFont;
begin
SelectObject(FHandle, Font.GetHandle);
SetTextColor(FHandle, ColorToRGB(Font.Color));
end;
procedure TCanvas.CreatePen;
const
PenModes: array[TPenMode] of Word =
(R2_BLACK, R2_WHITE, R2_NOP, R2_NOT, R2_COPYPEN, R2_NOTCOPYPEN, R2_MERGEPENNOT,
R2_MASKPENNOT, R2_MERGENOTPEN, R2_MASKNOTPEN, R2_MERGEPEN, R2_NOTMERGEPEN,
R2_MASKPEN, R2_NOTMASKPEN, R2_XORPEN, R2_NOTXORPEN);
begin
SelectObject(FHandle, TExtPen(Pen).GetHandle);
SetROP2(FHandle, PenModes[Pen.Mode]);
end;
procedure TCanvas.CreateBrush;
begin
UnrealizeObject(Brush.Handle);
SelectObject(FHandle, Brush.Handle);
if Brush.Style = bsSolid then
begin
SetBkColor(FHandle, ColorToRGB(Brush.Color));
SetBkMode(FHandle, OPAQUE);
end
else
begin
{ Win95 doesn't draw brush hatches if bkcolor = brush color }
{ Since bkmode is transparent, nothing should use bkcolor anyway }
SetBkColor(FHandle, not ColorToRGB(Brush.Color));
SetBkMode(FHandle, TRANSPARENT);
end;
end;
procedure TCanvas.FontChanged(AFont: TObject);
begin
if csFontValid in State then
begin
Exclude(State, csFontValid);
SelectObject(FHandle, StockFont);
end;
end;
procedure TCanvas.PenChanged(APen: TObject);
begin
if csPenValid in State then
begin
Exclude(State, csPenValid);
SelectObject(FHandle, StockPen);
end;
end;
procedure TCanvas.BrushChanged(ABrush: TObject);
begin
if csBrushValid in State then
begin
Exclude(State, csBrushValid);
SelectObject(FHandle, StockBrush);
end;
end;
{ Picture support }
{ Metafile types }
const
WMFKey = Integer($9AC6CDD7);
WMFWord = $CDD7;
type
PMetafileHeader = ^TMetafileHeader;
TMetafileHeader = packed record
Key: Longint;
Handle: SmallInt;
Box: TSmallRect;
Inch: Word;
Reserved: Longint;
CheckSum: Word;
end;
{ Exception routines }
procedure InvalidOperation(Str: PResStringRec);
begin
raise EInvalidGraphicOperation.CreateRes(Str);
end;
procedure InvalidGraphic(Str: PResStringRec);
begin
raise EInvalidGraphic.CreateRes(Str);
end;
procedure InvalidBitmap;
begin
InvalidGraphic(@SInvalidBitmap);
end;
procedure InvalidIcon;
begin
InvalidGraphic(@SInvalidIcon);
end;
procedure InvalidMetafile;
begin
InvalidGraphic(@SInvalidMetafile);
end;
procedure OutOfResources;
begin
raise EOutOfResources.Create(SOutOfResources);
end;
procedure GDIError;
var
ErrorCode: Integer;
Buf: array [Byte] of Char;
begin
ErrorCode := GetLastError;
if (ErrorCode <> 0) and (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil,
ErrorCode, LOCALE_USER_DEFAULT, Buf, sizeof(Buf), nil) <> 0) then
raise EOutOfResources.Create(Buf)
else
OutOfResources;
end;
function GDICheck(Value: Integer): Integer;
begin
if Value = 0 then GDIError;
Result := Value;
end;
function DupBits(Src: HBITMAP; Size: TPoint; Mono: Boolean): HBITMAP;
var
DC, Mem1, Mem2: HDC;
Old1, Old2: HBITMAP;
Bitmap: Windows.TBitmap;
begin
Mem1 := CreateCompatibleDC(0);
Mem2 := CreateCompatibleDC(0);
try
GetObject(Src, SizeOf(Bitmap), @Bitmap);
if Mono then
Result := CreateBitmap(Size.X, Size.Y, 1, 1, nil)
else
begin
DC := GetDC(0);
if DC = 0 then GDIError;
try
Result := CreateCompatibleBitmap(DC, Size.X, Size.Y);
if Result = 0 then GDIError;
finally
ReleaseDC(0, DC);
end;
end;
if Result <> 0 then
begin
Old1 := SelectObject(Mem1, Src);
Old2 := SelectObject(Mem2, Result);
StretchBlt(Mem2, 0, 0, Size.X, Size.Y, Mem1, 0, 0, Bitmap.bmWidth,
Bitmap.bmHeight, SrcCopy);
if Old1 <> 0 then SelectObject(Mem1, Old1);
if Old2 <> 0 then SelectObject(Mem2, Old2);
end;
finally
DeleteDC(Mem1);
DeleteDC(Mem2);
end;
end;
function GetDInColors(BitCount: Word): Integer;
begin
case BitCount of
1, 4, 8: Result := 1 shl BitCount;
else
Result := 0;
end;
end;
function BytesPerScanline(PixelsPerScanline, BitsPerPixel, Alignment: Longint): Longint;
begin
Dec(Alignment);
Result := ((PixelsPerScanline * BitsPerPixel) + Alignment) and not Alignment;
Result := Result div 8;
end;
function TransparentStretchBlt(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
SrcDC: HDC; SrcX, SrcY, SrcW, SrcH: Integer; MaskDC: HDC; MaskX,
MaskY: Integer): Boolean;
const
ROP_DstCopy = $00AA0029;
var
MemDC: HDC;
MemBmp: HBITMAP;
Save: THandle;
crText, crBack: TColorRef;
SavePal: HPALETTE;
begin
Result := True;
if (Win32Platform = VER_PLATFORM_WIN32_NT) and (SrcW = DstW) and (SrcH = DstH) then
begin
MemBmp := GDICheck(CreateCompatibleBitmap(SrcDC, 1, 1));
MemBmp := SelectObject(MaskDC, MemBmp);
try
MaskBlt(DstDC, DstX, DstY, DstW, DstH, SrcDC, SrcX, SrcY, MemBmp, MaskX,
MaskY, MakeRop4(ROP_DstCopy, SrcCopy));
finally
MemBmp := SelectObject(MaskDC, MemBmp);
DeleteObject(MemBmp);
end;
Exit;
end;
SavePal := 0;
MemDC := GDICheck(CreateCompatibleDC(0));
try
MemBmp := GDICheck(CreateCompatibleBitmap(SrcDC, SrcW, SrcH));
Save := SelectObject(MemDC, MemBmp);
SavePal := SelectPalette(SrcDC, SystemPalette16, False);
SelectPalette(SrcDC, SavePal, False);
if SavePal <> 0 then
SavePal := SelectPalette(MemDC, SavePal, True)
else
SavePal := SelectPalette(MemDC, SystemPalette16, True);
RealizePalette(MemDC);
StretchBlt(MemDC, 0, 0, SrcW, SrcH, MaskDC, MaskX, MaskY, SrcW, SrcH, SrcCopy);
StretchBlt(MemDC, 0, 0, SrcW, SrcH, SrcDC, SrcX, SrcY, SrcW, SrcH, SrcErase);
crText := SetTextColor(DstDC, $0);
crBack := SetBkColor(DstDC, $FFFFFF);
StretchBlt(DstDC, DstX, DstY, DstW, DstH, MaskDC, MaskX, MaskY, SrcW, SrcH, SrcAnd);
StretchBlt(DstDC, DstX, DstY, DstW, DstH, MemDC, 0, 0, SrcW, SrcH, SrcInvert);
SetTextColor(DstDC, crText);
SetBkColor(DstDC, crBack);
if Save <> 0 then SelectObject(MemDC, Save);
DeleteObject(MemBmp);
finally
if SavePal <> 0 then SelectPalette(MemDC, SavePal, False);
DeleteDC(MemDC);
end;
end;
type
PRGBTripleArray = ^TRGBTripleArray;
TRGBTripleArray = array [Byte] of TRGBTriple;
PRGBQuadArray = ^TRGBQuadArray;
TRGBQuadArray = array [Byte] of TRGBQuad;
{ RGBTripleToQuad performs in-place conversion of an OS2 color
table into a DIB color table. }
procedure RGBTripleToQuad(var ColorTable);
var
I: Integer;
P3: PRGBTripleArray;
P4: PRGBQuadArray;
begin
P3 := PRGBTripleArray(@ColorTable);
P4 := Pointer(P3);
for I := 255 downto 1 do // don't move zeroth item
with P4^[I], P3^[I] do
begin // order is significant for last item moved
rgbRed := rgbtRed;
rgbGreen := rgbtGreen;
rgbBlue := rgbtBlue;
rgbReserved := 0;
end;
P4^[0].rgbReserved := 0;
end;
{ RGBQuadToTriple performs the inverse of RGBTripleToQuad. }
procedure RGBQuadToTriple(var ColorTable; var ColorCount: Integer);
var
I: Integer;
P3: PRGBTripleArray;
P4: PRGBQuadArray;
begin
P3 := PRGBTripleArray(@ColorTable);
P4 := Pointer(P3);
for I := 1 to ColorCount-1 do // don't move zeroth item
with P4^[I], P3^[I] do
begin
rgbtRed := rgbRed;
rgbtGreen := rgbGreen;
rgbtBlue := rgbBlue;
end;
if ColorCount < 256 then
begin
FillChar(P3^[ColorCount], (256 - ColorCount) * sizeof(TRGBTriple), 0);
ColorCount := 256; // OS2 color tables always have 256 entries
end;
end;
procedure ByteSwapColors(var Colors; Count: Integer);
var // convert RGB to BGR and vice-versa. TRGBQuad <-> TPaletteEntry
SysInfo: TSystemInfo;
begin
GetSystemInfo(SysInfo);
asm
MOV EDX, Colors
MOV ECX, Count
DEC ECX
JS @@END
LEA EAX, SysInfo
CMP [EAX].TSystemInfo.wProcessorLevel, 3
JE @@386
@@1: MOV EAX, [EDX+ECX*4]
BSWAP EAX
SHR EAX,8
MOV [EDX+ECX*4],EAX
DEC ECX
JNS @@1
JMP @@END
@@386:
PUSH EBX
@@2: XOR EBX,EBX
MOV EAX, [EDX+ECX*4]
MOV BH, AL
MOV BL, AH
SHR EAX,16
SHL EBX,8
MOV BL, AL
MOV [EDX+ECX*4],EBX
DEC ECX
JNS @@2
POP EBX
@@END:
end;
end;
function CreateSystemPalette(const Entries: array of TColor): HPALETTE;
var
DC: HDC;
SysPalSize: Integer;
Pal: TMaxLogPalette;
begin
Pal.palVersion := $300;
Pal.palNumEntries := 16;
Move(Entries, Pal.palPalEntry, 16 * SizeOf(TColor));
DC := GetDC(0);
try
SysPalSize := GetDeviceCaps(DC, SIZEPALETTE);
{ Ignore the disk image of the palette for 16 color bitmaps.
Replace with the first and last 8 colors of the system palette }
if SysPalSize >= 16 then
begin
GetSystemPaletteEntries(DC, 0, 8, Pal.palPalEntry);
{ Is light and dark gray swapped? }
if TColor(Pal.palPalEntry[7]) = clSilver then
begin
GetSystemPaletteEntries(DC, SysPalSize - 8, 1, Pal.palPalEntry[7]);
GetSystemPaletteEntries(DC, SysPalSize - 7, 7, Pal.palPalEntry[Pal.palNumEntries - 7]);
GetSystemPaletteEntries(DC, 7, 1, Pal.palPalEntry[8]);
end
else
GetSystemPaletteEntries(DC, SysPalSize - 8, 8, Pal.palPalEntry[Pal.palNumEntries - 8]);
end
else
begin
end;
finally
ReleaseDC(0,DC);
end;
Result := CreatePalette(PLogPalette(@Pal)^);
end;
function SystemPaletteOverride(var Pal: TMaxLogPalette): Boolean;
var
DC: HDC;
SysPalSize: Integer;
begin
Result := False;
if SystemPalette16 <> 0 then
begin
DC := GetDC(0);
try
SysPalSize := GetDeviceCaps(DC, SIZEPALETTE);
if SysPalSize >= 16 then
begin
{ Ignore the disk image of the palette for 16 color bitmaps.
Replace with the first and last 8 colors of the system palette }
GetPaletteEntries(SystemPalette16, 0, 8, Pal.palPalEntry);
GetPaletteEntries(SystemPalette16, 8, 8, Pal.palPalEntry[Pal.palNumEntries - 8]);
Result := True;
end
finally
ReleaseDC(0,DC);
end;
end;
end;
function PaletteFromDIBColorTable(DIBHandle: THandle; ColorTable: Pointer;
ColorCount: Integer): HPalette;
var
DC: HDC;
Save: THandle;
Pal: TMaxLogPalette;
begin
Result := 0;
Pal.palVersion := $300;
if DIBHandle <> 0 then
begin
DC := CreateCompatibleDC(0);
Save := SelectObject(DC, DIBHandle);
Pal.palNumEntries := GetDIBColorTable(DC, 0, 256, Pal.palPalEntry);
SelectObject(DC, Save);
DeleteDC(DC);
end
else
begin
Pal.palNumEntries := ColorCount;
Move(ColorTable^, Pal.palPalEntry, ColorCount * 4);
end;
if Pal.palNumEntries = 0 then Exit;
if (Pal.palNumEntries <> 16) or not SystemPaletteOverride(Pal) then
ByteSwapColors(Pal.palPalEntry, Pal.palNumEntries);
Result := CreatePalette(PLogPalette(@Pal)^);
end;
function PaletteToDIBColorTable(Pal: HPalette;
var ColorTable: array of TRGBQuad): Integer;
begin
Result := 0;
if (Pal = 0) or
(GetObject(Pal, sizeof(Result), @Result) = 0) or
(Result = 0) then Exit;
if Result > High(ColorTable)+1 then Result := High(ColorTable)+1;
GetPaletteEntries(Pal, 0, Result, ColorTable);
ByteSwapColors(ColorTable, Result);
end;
procedure TwoBitsFromDIB(var BI: TBitmapInfoHeader; var XorBits, AndBits: HBITMAP;
const IconSize: TPoint);
type
PLongArray = ^TLongArray;
TLongArray = array[0..1] of Longint;
var
Temp: HBITMAP;
NumColors: Integer;
DC: HDC;
Bits: Pointer;
Colors: PLongArray;
begin
with BI do
begin
biHeight := biHeight shr 1; { Size in record is doubled }
biSizeImage := BytesPerScanline(biWidth, biBitCount, 32) * biHeight;
NumColors := GetDInColors(biBitCount);
end;
DC := GetDC(0);
if DC = 0 then OutOfResources;
try
Bits := Pointer(Longint(@BI) + SizeOf(BI) + NumColors * SizeOf(TRGBQuad));
Temp := GDICheck(CreateDIBitmap(DC, BI, CBM_INIT, Bits, PBitmapInfo(@BI)^, DIB_RGB_COLORS));
try
XorBits := DupBits(Temp, IconSize, False);
finally
DeleteObject(Temp);
end;
with BI do
begin
Inc(Longint(Bits), biSizeImage);
biBitCount := 1;
biSizeImage := BytesPerScanline(biWidth, biBitCount, 32) * biHeight;
biClrUsed := 2;
biClrImportant := 2;
end;
Colors := Pointer(Longint(@BI) + SizeOf(BI));
Colors^[0] := 0;
Colors^[1] := $FFFFFF;
Temp := GDICheck(CreateDIBitmap(DC, BI, CBM_INIT, Bits, PBitmapInfo(@BI)^, DIB_RGB_COLORS));
try
AndBits := DupBits(Temp, IconSize, True);
finally
DeleteObject(Temp);
end;
finally
ReleaseDC(0, DC);
end;
end;
procedure ReadIcon(Stream: TStream; var Icon: HICON; ImageCount: Integer;
StartOffset: Integer; const RequestedSize: TPoint; var IconSize: TPoint);
type
PIconRecArray = ^TIconRecArray;
TIconRecArray = array[0..300] of TIconRec;
var
List: PIconRecArray;
HeaderLen, Length: Integer;
BitsPerPixel: Word;
Colors, BestColor, C1, N, Index: Integer;
DC: HDC;
BI: PBitmapInfoHeader;
ResData: Pointer;
XorBits, AndBits: HBITMAP;
XorInfo, AndInfo: Windows.TBitmap;
XorMem, AndMem: Pointer;
XorLen, AndLen: Integer;
(*
var
P: PChar;
begin
P := Pointer(Integer((Stream as TCustomMemoryStream).Memory) + Stream.Position);
// N := LookupIconIdFromDirectoryEx(Pointer(P), True, 0, 0, LR_DEFAULTCOLOR);
Icon := GDICheck(CreateIconFromResourceEx(
Pointer(P + PIconRec(P)^.DIBOffset - StartOffset),
PIconRec(P)^.DIBSize, True, $00030000, 0, 0, LR_DEFAULTCOLOR));
end;
*)
function AdjustColor(I: Integer): Integer;
begin
if I = 0 then
Result := MaxInt
else
Result := I;
end;
function BetterSize(const Old, New: TIconRec): Boolean;
var
NewX, NewY, OldX, OldY: Integer;
begin
NewX := New.Width - IconSize.X;
NewY := New.Height - IconSize.Y;
OldX := Old.Width - IconSize.X;
OldY := Old.Height - IconSize.Y;
Result := (Abs(NewX) <= Abs(OldX)) and ((NewX <= 0) or (NewX <= OldX)) and
(Abs(NewY) <= Abs(OldY)) and ((NewY <= 0) or (NewY <= OldY));
end;
begin
HeaderLen := SizeOf(TIconRec) * ImageCount;
List := AllocMem(HeaderLen);
try
Stream.Read(List^, HeaderLen);
if (RequestedSize.X or RequestedSize.Y) = 0 then
begin
IconSize.X := GetSystemMetrics(SM_CXICON);
IconSize.Y := GetSystemMetrics(SM_CYICON);
end
else
IconSize := RequestedSize;
DC := GetDC(0);
if DC = 0 then OutOfResources;
try
BitsPerPixel := GetDeviceCaps(DC, PLANES) * GetDeviceCaps(DC, BITSPIXEL);
if BitsPerPixel > 8 then
Colors := MaxInt
else
Colors := 1 shl BitsPerPixel;
finally
ReleaseDC(0, DC);
end;
{ Find the image that most closely matches (<=) the current screen color
depth and the requested image size. }
Index := 0;
BestColor := AdjustColor(List^[0].Colors);
for N := 1 to ImageCount-1 do
begin
C1 := AdjustColor(List^[N].Colors);
if (C1 <= Colors) and (C1 >= BestColor) and
BetterSize(List^[Index], List^[N]) then
begin
Index := N;
BestColor := C1;
end;
end;
{ the following code determines which image most closely matches the
current device. It is not meant to absolutely match Windows
(known broken) algorithm }
(* C2 := 0;
for N := 0 to ImageCount - 1 do
begin
C1 := List^[N].Colors;
if C1 = Colors then
begin
Index := N;
if (IconSize.X = List^[N].Width) and (IconSize.Y = List^[N].Height) then
Break; // exact match on size and color
end
else if Index = -1 then
begin // take the first icon with fewer colors than screen
if C1 <= Colors then
begin
Index := N;
C2 := C1;
end;
end
else if C1 > C2 then // take icon with more colors than first match
Index := N;
end;
if Index = -1 then Index := 0;
*)
with List^[Index] do
begin
IconSize.X := Width;
IconSize.Y := Height;
BI := AllocMem(DIBSize);
try
Stream.Seek(DIBOffset - (HeaderLen + StartOffset), 1);
Stream.Read(BI^, DIBSize);
TwoBitsFromDIB(BI^, XorBits, AndBits, IconSize);
GetObject(AndBits, SizeOf(Windows.TBitmap), @AndInfo);
GetObject(XorBits, SizeOf(Windows.TBitmap), @XorInfo);
with AndInfo do
AndLen := bmWidthBytes * bmHeight * bmPlanes;
with XorInfo do
XorLen := bmWidthBytes * bmHeight * bmPlanes;
Length := AndLen + XorLen;
ResData := AllocMem(Length);
try
AndMem := ResData;
with AndInfo do
XorMem := Pointer(Longint(ResData) + AndLen);
GetBitmapBits(AndBits, AndLen, AndMem);
GetBitmapBits(XorBits, XorLen, XorMem);
DeleteObject(XorBits);
DeleteObject(AndBits);
Icon := CreateIcon(HInstance, IconSize.X, IconSize.Y,
XorInfo.bmPlanes, XorInfo.bmBitsPixel, AndMem, XorMem);
if Icon = 0 then GDIError;
finally
FreeMem(ResData, Length);
end;
finally
FreeMem(BI, DIBSize);
end;
end;
finally
FreeMem(List, HeaderLen);
end;
end;
function ComputeAldusChecksum(var WMF: TMetafileHeader): Word;
type
PWord = ^Word;
var
pW: PWord;
pEnd: PWord;
begin
Result := 0;
pW := @WMF;
pEnd := @WMF.CheckSum;
while Longint(pW) < Longint(pEnd) do
begin
Result := Result xor pW^;
Inc(Longint(pW), SizeOf(Word));
end;
end;
procedure InitializeBitmapInfoHeader(Bitmap: HBITMAP; var BI: TBitmapInfoHeader;
Colors: Integer);
var
DS: TDIBSection;
Bytes: Integer;
begin
DS.dsbmih.biSize := 0;
Bytes := GetObject(Bitmap, SizeOf(DS), @DS);
if Bytes = 0 then InvalidBitmap
else if (Bytes >= (sizeof(DS.dsbm) + sizeof(DS.dsbmih))) and
(DS.dsbmih.biSize >= DWORD(sizeof(DS.dsbmih))) then
BI := DS.dsbmih
else
begin
FillChar(BI, sizeof(BI), 0);
with BI, DS.dsbm do
begin
biSize := SizeOf(BI);
biWidth := bmWidth;
biHeight := bmHeight;
end;
end;
case Colors of
2: BI.biBitCount := 1;
3..16:
begin
BI.biBitCount := 4;
BI.biClrUsed := Colors;
end;
17..256:
begin
BI.biBitCount := 8;
BI.biClrUsed := Colors;
end;
else
BI.biBitCount := DS.dsbm.bmBitsPixel * DS.dsbm.bmPlanes;
end;
BI.biPlanes := 1;
if BI.biClrImportant > BI.biClrUsed then
BI.biClrImportant := BI.biClrUsed;
if BI.biSizeImage = 0 then
BI.biSizeImage := BytesPerScanLine(BI.biWidth, BI.biBitCount, 32) * Abs(BI.biHeight);
end;
procedure InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: DWORD;
var ImageSize: DWORD; Colors: Integer);
var
BI: TBitmapInfoHeader;
begin
InitializeBitmapInfoHeader(Bitmap, BI, Colors);
if BI.biBitCount > 8 then
begin
InfoHeaderSize := SizeOf(TBitmapInfoHeader);
if (BI.biCompression and BI_BITFIELDS) <> 0 then
Inc(InfoHeaderSize, 12);
end
else
if BI.biClrUsed = 0 then
InfoHeaderSize := SizeOf(TBitmapInfoHeader) +
SizeOf(TRGBQuad) * (1 shl BI.biBitCount)
else
InfoHeaderSize := SizeOf(TBitmapInfoHeader) +
SizeOf(TRGBQuad) * BI.biClrUsed;
ImageSize := BI.biSizeImage;
end;
procedure GetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: DWORD;
var ImageSize: DWORD);
begin
InternalGetDIBSizes(Bitmap, InfoHeaderSize, ImageSize, 0);
end;
function InternalGetDIB(Bitmap: HBITMAP; Palette: HPALETTE;
var BitmapInfo; var Bits; Colors: Integer): Boolean;
var
OldPal: HPALETTE;
DC: HDC;
begin
InitializeBitmapInfoHeader(Bitmap, TBitmapInfoHeader(BitmapInfo), Colors);
OldPal := 0;
DC := CreateCompatibleDC(0);
try
if Palette <> 0 then
begin
OldPal := SelectPalette(DC, Palette, False);
RealizePalette(DC);
end;
Result := GetDIBits(DC, Bitmap, 0, TBitmapInfoHeader(BitmapInfo).biHeight, @Bits,
TBitmapInfo(BitmapInfo), DIB_RGB_COLORS) <> 0;
finally
if OldPal <> 0 then SelectPalette(DC, OldPal, False);
DeleteDC(DC);
end;
end;
function GetDIB(Bitmap: HBITMAP; Palette: HPALETTE; var BitmapInfo; var Bits): Boolean;
begin
Result := InternalGetDIB(Bitmap, Palette, BitmapInfo, Bits, 0);
end;
procedure WinError;
begin
end;
procedure CheckBool(Result: Bool);
begin
if not Result then WinError;
end;
procedure WriteIcon(Stream: TStream; Icon: HICON; WriteLength: Boolean);
var
IconInfo: TIconInfo;
MonoInfoSize, ColorInfoSize: DWORD;
MonoBitsSize, ColorBitsSize: DWORD;
MonoInfo, MonoBits, ColorInfo, ColorBits: Pointer;
CI: TCursorOrIcon;
List: TIconRec;
Length: Longint;
begin
FillChar(CI, SizeOf(CI), 0);
FillChar(List, SizeOf(List), 0);
CheckBool(GetIconInfo(Icon, IconInfo));
try
InternalGetDIBSizes(IconInfo.hbmMask, MonoInfoSize, MonoBitsSize, 2);
InternalGetDIBSizes(IconInfo.hbmColor, ColorInfoSize, ColorBitsSize, 16);
MonoInfo := nil;
MonoBits := nil;
ColorInfo := nil;
ColorBits := nil;
try
MonoInfo := AllocMem(MonoInfoSize);
MonoBits := AllocMem(MonoBitsSize);
ColorInfo := AllocMem(ColorInfoSize);
ColorBits := AllocMem(ColorBitsSize);
InternalGetDIB(IconInfo.hbmMask, 0, MonoInfo^, MonoBits^, 2);
InternalGetDIB(IconInfo.hbmColor, 0, ColorInfo^, ColorBits^, 16);
if WriteLength then
begin
Length := SizeOf(CI) + SizeOf(List) + ColorInfoSize +
ColorBitsSize + MonoBitsSize;
Stream.Write(Length, SizeOf(Length));
end;
with CI do
begin
CI.wType := RC3_ICON;
CI.Count := 1;
end;
Stream.Write(CI, SizeOf(CI));
with List, PBitmapInfoHeader(ColorInfo)^ do
begin
Width := biWidth;
Height := biHeight;
Colors := biPlanes * biBitCount;
DIBSize := ColorInfoSize + ColorBitsSize + MonoBitsSize;
DIBOffset := SizeOf(CI) + SizeOf(List);
end;
Stream.Write(List, SizeOf(List));
with PBitmapInfoHeader(ColorInfo)^ do
Inc(biHeight, biHeight); { color height includes mono bits }
Stream.Write(ColorInfo^, ColorInfoSize);
Stream.Write(ColorBits^, ColorBitsSize);
Stream.Write(MonoBits^, MonoBitsSize);
finally
FreeMem(ColorInfo, ColorInfoSize);
FreeMem(ColorBits, ColorBitsSize);
FreeMem(MonoInfo, MonoInfoSize);
FreeMem(MonoBits, MonoBitsSize);
end;
finally
DeleteObject(IconInfo.hbmColor);
DeleteObject(IconInfo.hbmMask);
end;
end;
{ TGraphic }
constructor TGraphic.Create;
begin // This stub is required for C++ compatibility.
inherited Create; // C++ doesn't support abstract virtual constructors.
end;
procedure TGraphic.Changed(Sender: TObject);
begin
FModified := True;
if Assigned(FOnChange) then FOnChange(Self);
end;
procedure TGraphic.DefineProperties(Filer: TFiler);
function DoWrite: Boolean;
begin
if Filer.Ancestor <> nil then
Result := not (Filer.Ancestor is TGraphic) or
not Equals(TGraphic(Filer.Ancestor))
else
Result := not Empty;
end;
begin
Filer.DefineBinaryProperty('Data', ReadData, WriteData, DoWrite);
end;
function TGraphic.Equals(Graphic: TGraphic): Boolean;
var
MyImage, GraphicsImage: TMemoryStream;
begin
Result := (Graphic <> nil) and (ClassType = Graphic.ClassType);
if Empty or Graphic.Empty then
begin
Result := Empty and Graphic.Empty;
Exit;
end;
if Result then
begin
MyImage := TMemoryStream.Create;
try
WriteData(MyImage);
GraphicsImage := TMemoryStream.Create;
try
Graphic.WriteData(GraphicsImage);
Result := (MyImage.Size = GraphicsImage.Size) and
CompareMem(MyImage.Memory, GraphicsImage.Memory, MyImage.Size);
finally
GraphicsImage.Free;
end;
finally
MyImage.Free;
end;
end;
end;
function TGraphic.GetPalette: HPALETTE;
begin
Result := 0;
end;
function TGraphic.GetTransparent: Boolean;
begin
Result := FTransparent;
end;
procedure TGraphic.LoadFromFile(const Filename: string);
var
Stream: TStream;
begin
Stream := TFileStream.Create(Filename, fmOpenRead or fmShareDenyWrite);
try
LoadFromStream(Stream);
finally
Stream.Free;
end;
end;
procedure TGraphic.Progress(Sender: TObject; Stage: TProgressStage;
PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);
begin
if Assigned(FOnProgress) then
FOnProgress(Sender, Stage, PercentDone, RedrawNow, R, Msg);
end;
procedure TGraphic.ReadData(Stream: TStream);
begin
LoadFromStream(Stream);
end;
procedure TGraphic.SaveToFile(const Filename: string);
var
Stream: TStream;
begin
Stream := TFileStream.Create(Filename, fmCreate);
try
SaveToStream(Stream);
finally
Stream.Free;
end;
end;
procedure TGraphic.SetPalette(Value: HPalette);
begin
end;
procedure TGraphic.SetModified(Value: Boolean);
begin
if Value then
Changed(Self) else
FModified := False;
end;
procedure TGraphic.SetTransparent(Value: Boolean);
begin
if Value <> FTransparent then
begin
FTransparent := Value;
Changed(Self);
end;
end;
procedure TGraphic.WriteData(Stream: TStream);
begin
SaveToStream(Stream);
end;
{ TPicture }
type
PFileFormat = ^TFileFormat;
TFileFormat = record
GraphicClass: TGraphicClass;
Extension: string;
Description: string;
DescResID: Integer;
end;
TFileFormatsList = class(TList)
public
constructor Create;
destructor Destroy; override;
procedure Add(const Ext, Desc: String; DescID: Integer; AClass: TGraphicClass);
function FindExt(Ext: string): TGraphicClass;
function FindClassName(const Classname: string): TGraphicClass;
procedure Remove(AClass: TGraphicClass);
procedure BuildFilterStrings(GraphicClass: TGraphicClass;
var Descriptions, Filters: string);
end;
constructor TFileFormatsList.Create;
begin
inherited Create;
Add('wmf', SVMetafiles, 0, TMetafile);
Add('emf', SVEnhMetafiles, 0, TMetafile);
Add('ico', SVIcons, 0, TIcon);
Add('bmp', SVBitmaps, 0, TBitmap);
end;
destructor TFileFormatsList.Destroy;
var
I: Integer;
begin
for I := 0 to Count-1 do
Dispose(PFileFormat(Items[I]));
inherited Destroy;
end;
procedure TFileFormatsList.Add(const Ext, Desc: String; DescID: Integer;
AClass: TGraphicClass);
var
NewRec: PFileFormat;
begin
New(NewRec);
with NewRec^ do
begin
Extension := AnsiLowerCase(Ext);
GraphicClass := AClass;
Description := Desc;
DescResID := DescID;
end;
inherited Add(NewRec);
end;
function TFileFormatsList.FindExt(Ext: string): TGraphicClass;
var
I: Integer;
begin
Ext := AnsiLowerCase(Ext);
for I := Count-1 downto 0 do
with PFileFormat(Items[I])^ do
if Extension = Ext then
begin
Result := GraphicClass;
Exit;
end;
Result := nil;
end;
function TFileFormatsList.FindClassName(const ClassName: string): TGraphicClass;
var
I: Integer;
begin
for I := Count-1 downto 0 do
begin
Result := PFileFormat(Items[I])^.GraphicClass;
if Result.ClassName = Classname then Exit;
end;
Result := nil;
end;
procedure TFileFormatsList.Remove(AClass: TGraphicClass);
var
I: Integer;
P: PFileFormat;
begin
for I := Count-1 downto 0 do
begin
P := PFileFormat(Items[I]);
if P^.GraphicClass.InheritsFrom(AClass) then
begin
Dispose(P);
Delete(I);
end;
end;
end;
procedure TFileFormatsList.BuildFilterStrings(GraphicClass: TGraphicClass;
var Descriptions, Filters: string);
var
C, I: Integer;
P: PFileFormat;
begin
Descriptions := '';
Filters := '';
C := 0;
for I := Count-1 downto 0 do
begin
P := PFileFormat(Items[I]);
if P^.GraphicClass.InheritsFrom(GraphicClass) and (P^.Extension <> '') then
with P^ do
begin
if C <> 0 then
begin
Descriptions := Descriptions + '|';
Filters := Filters + ';';
end;
if (Description = '') and (DescResID <> 0) then
Description := LoadStr(DescResID);
FmtStr(Descriptions, '%s%s (*.%s)|*.%2:s', [Descriptions, Description, Extension]);
FmtStr(Filters, '%s*.%s', [Filters, Extension]);
Inc(C);
end;
end;
if C > 1 then
FmtStr(Descriptions, '%s (%s)|%1:s|%s', [sAllFilter, Filters, Descriptions]);
end;
type
TClipboardFormats = class
private
FClasses: TList;
FFormats: TList;
public
constructor Create;
destructor Destroy; override;
procedure Add(Fmt: Word; AClass: TGraphicClass);
function FindFormat(Fmt: Word): TGraphicClass;
procedure Remove(AClass: TGraphicClass);
end;
constructor TClipboardFormats.Create;
begin
FClasses := TList.Create;
FFormats := TList.Create;
Add(CF_METAFILEPICT, TMetafile);
Add(CF_ENHMETAFILE, TMetafile);
Add(CF_BITMAP, TBitmap);
end;
destructor TClipboardFormats.Destroy;
begin
FClasses.Free;
FFormats.Free;
end;
procedure TClipboardFormats.Add(Fmt: Word; AClass: TGraphicClass);
var
I: Integer;
begin
I := FClasses.Add(AClass);
try
FFormats.Add(Pointer(Integer(Fmt)));
except
FClasses.Delete(I);
raise;
end;
end;
function TClipboardFormats.FindFormat(Fmt: Word): TGraphicClass;
var
I: Integer;
begin
for I := FFormats.Count-1 downto 0 do
if Word(FFormats[I]) = Fmt then
begin
Result := FClasses[I];
Exit;
end;
Result := nil;
end;
procedure TClipboardFormats.Remove(AClass: TGraphicClass);
var
I: Integer;
begin
for I := FClasses.Count-1 downto 0 do
if TGraphicClass(FClasses[I]).InheritsFrom(AClass) then
begin
FClasses.Delete(I);
FFormats.Delete(I);
end;
end;
var
ClipboardFormats: TClipboardFormats = nil;
FileFormats: TFileFormatsList = nil;
function GetFileFormats: TFileFormatsList;
begin
if FileFormats = nil then FileFormats := TFileFormatsList.Create;
Result := FileFormats;
end;
function GetClipboardFormats: TClipboardFormats;
begin
if ClipboardFormats = nil then ClipboardFormats := TClipboardFormats.Create;
Result := ClipboardFormats;
end;
constructor TPicture.Create;
begin
inherited Create;
GetFileFormats;
GetClipboardFormats;
end;
destructor TPicture.Destroy;
begin
FGraphic.Free;
inherited Destroy;
end;
procedure TPicture.AssignTo(Dest: TPersistent);
begin
if Graphic is Dest.ClassType then
Dest.Assign(Graphic)
else
inherited AssignTo(Dest);
end;
procedure TPicture.ForceType(GraphicType: TGraphicClass);
begin
if not (Graphic is GraphicType) then
begin
FGraphic.Free;
FGraphic := nil;
FGraphic := GraphicType.Create;
FGraphic.OnChange := Changed;
FGraphic.OnProgress := Progress;
Changed(Self);
end;
end;
function TPicture.GetBitmap: TBitmap;
begin
ForceType(TBitmap);
Result := TBitmap(Graphic);
end;
function TPicture.GetIcon: TIcon;
begin
ForceType(TIcon);
Result := TIcon(Graphic);
end;
function TPicture.GetMetafile: TMetafile;
begin
ForceType(TMetafile);
Result := TMetafile(Graphic);
end;
procedure TPicture.SetBitmap(Value: TBitmap);
begin
SetGraphic(Value);
end;
procedure TPicture.SetIcon(Value: TIcon);
begin
SetGraphic(Value);
end;
procedure TPicture.SetMetafile(Value: TMetafile);
begin
SetGraphic(Value);
end;
procedure TPicture.SetGraphic(Value: TGraphic);
var
NewGraphic: TGraphic;
begin
NewGraphic := nil;
if Value <> nil then
begin
NewGraphic := TGraphicClass(Value.ClassType).Create;
NewGraphic.Assign(Value);
NewGraphic.OnChange := Changed;
NewGraphic.OnProgress := Progress;
end;
try
FGraphic.Free;
FGraphic := NewGraphic;
Changed(Self);
except
NewGraphic.Free;
raise;
end;
end;
{ Based on the extension of Filename, create the cooresponding TGraphic class
and call its LoadFromFile method. }
procedure TPicture.LoadFromFile(const Filename: string);
var
Ext: string;
NewGraphic: TGraphic;
GraphicClass: TGraphicClass;
begin
Ext := ExtractFileExt(Filename);
Delete(Ext, 1, 1);
GraphicClass := FileFormats.FindExt(Ext);
if GraphicClass = nil then
raise EInvalidGraphic.CreateFmt(SUnknownExtension, [Ext]);
NewGraphic := GraphicClass.Create;
try
NewGraphic.OnProgress := Progress;
NewGraphic.LoadFromFile(Filename);
except
NewGraphic.Free;
raise;
end;
FGraphic.Free;
FGraphic := NewGraphic;
FGraphic.OnChange := Changed;
Changed(Self);
end;
procedure TPicture.SaveToFile(const Filename: string);
begin
if FGraphic <> nil then FGraphic.SaveToFile(Filename);
end;
procedure TPicture.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
APalette: HPALETTE);
var
NewGraphic: TGraphic;
GraphicClass: TGraphicClass;
begin
GraphicClass := ClipboardFormats.FindFormat(AFormat);
if GraphicClass = nil then
InvalidGraphic(@SUnknownClipboardFormat);
NewGraphic := GraphicClass.Create;
try
NewGraphic.OnProgress := Progress;
NewGraphic.LoadFromClipboardFormat(AFormat, AData, APalette);
except
NewGraphic.Free;
raise;
end;
FGraphic.Free;
FGraphic := NewGraphic;
FGraphic.OnChange := Changed;
Changed(Self);
end;
procedure TPicture.SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
var APalette: HPALETTE);
begin
if FGraphic <> nil then
FGraphic.SaveToClipboardFormat(AFormat, AData, APalette);
end;
class function TPicture.SupportsClipboardFormat(AFormat: Word): Boolean;
begin
Result := GetClipboardFormats.FindFormat(AFormat) <> nil;
end;
procedure TPicture.LoadFromStream(Stream: TStream);
begin
Bitmap.LoadFromStream(Stream);
end;
procedure TPicture.SaveToStream(Stream: TStream);
begin
Bitmap.SaveToStream(Stream);
end;
procedure TPicture.Assign(Source: TPersistent);
begin
if Source = nil then
SetGraphic(nil)
else if Source is TPicture then
SetGraphic(TPicture(Source).Graphic)
else if Source is TGraphic then
SetGraphic(TGraphic(Source))
else
inherited Assign(Source);
end;
class procedure TPicture.RegisterFileFormat(const AExtension,
ADescription: string; AGraphicClass: TGraphicClass);
begin
GetFileFormats.Add(AExtension, ADescription, 0, AGraphicClass);
end;
class procedure TPicture.RegisterFileFormatRes(const AExtension: String;
ADescriptionResID: Integer; AGraphicClass: TGraphicClass);
begin
GetFileFormats.Add(AExtension, '', ADescriptionResID, AGraphicClass);
end;
class procedure TPicture.RegisterClipboardFormat(AFormat: Word;
AGraphicClass: TGraphicClass);
begin
GetClipboardFormats.Add(AFormat, AGraphicClass);
end;
class procedure TPicture.UnRegisterGraphicClass(AClass: TGraphicClass);
begin
if FileFormats <> nil then FileFormats.Remove(AClass);
if ClipboardFormats <> nil then ClipboardFormats.Remove(AClass);
end;
procedure TPicture.Changed(Sender: TObject);
begin
if Assigned(FOnChange) then FOnChange(Self);
if FNotify <> nil then FNotify.Changed;
end;
procedure TPicture.Progress(Sender: TObject; Stage: TProgressStage;
PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);
begin
if Assigned(FOnProgress) then FOnProgress(Sender, Stage, PercentDone, RedrawNow, R, Msg);
end;
procedure TPicture.ReadData(Stream: TStream);
var
CName: string[63];
NewGraphic: TGraphic;
GraphicClass: TGraphicClass;
begin
Stream.Read(CName[0], 1);
Stream.Read(CName[1], Integer(CName[0]));
GraphicClass := FileFormats.FindClassName(CName);
NewGraphic := nil;
if GraphicClass <> nil then
begin
NewGraphic := GraphicClass.Create;
try
NewGraphic.ReadData(Stream);
except
NewGraphic.Free;
raise;
end;
end;
FGraphic.Free;
FGraphic := NewGraphic;
if NewGraphic <> nil then
begin
NewGraphic.OnChange := Changed;
NewGraphic.OnProgress := Progress;
end;
Changed(Self);
end;
procedure TPicture.WriteData(Stream: TStream);
var
CName: string[63];
begin
with Stream do
begin
if Graphic <> nil then
CName := Graphic.ClassName else
CName := '';
Write(CName, Length(CName) + 1);
if Graphic <> nil then
Graphic.WriteData(Stream);
end;
end;
procedure TPicture.DefineProperties(Filer: TFiler);
function DoWrite: Boolean;
var
Ancestor: TPicture;
begin
if Filer.Ancestor <> nil then
begin
Result := True;
if Filer.Ancestor is TPicture then
begin
Ancestor := TPicture(Filer.Ancestor);
Result := not ((Graphic = Ancestor.Graphic) or
((Graphic <> nil) and (Ancestor.Graphic <> nil) and
Graphic.Equals(Ancestor.Graphic)));
end;
end
else Result := Graphic <> nil;
end;
begin
Filer.DefineBinaryProperty('Data', ReadData, WriteData, DoWrite);
end;
function TPicture.GetWidth: Integer;
begin
Result := 0;
if FGraphic <> nil then Result := FGraphic.Width;
end;
function TPicture.GetHeight: Integer;
begin
Result := 0;
if FGraphic <> nil then Result := FGraphic.Height;
end;
{ TMetafileImage }
destructor TMetafileImage.Destroy;
begin
if FHandle <> 0 then DeleteEnhMetafile(FHandle);
InternalDeletePalette(FPalette);
inherited Destroy;
end;
procedure TMetafileImage.FreeHandle;
begin
end;
{ TMetafileCanvas }
constructor TMetafileCanvas.Create(AMetafile: TMetafile; ReferenceDevice: HDC);
begin
CreateWithComment(AMetafile, ReferenceDevice, AMetafile.CreatedBy,
AMetafile.Description);
end;
constructor TMetafileCanvas.CreateWithComment(AMetafile : TMetafile;
ReferenceDevice: HDC; const CreatedBy, Description: String);
var
RefDC: HDC;
R: TRect;
Temp: HDC;
P: PChar;
begin
inherited Create;
FMetafile := AMetafile;
RefDC := ReferenceDevice;
if ReferenceDevice = 0 then RefDC := GetDC(0);
try
if FMetafile.MMWidth = 0 then
if FMetafile.Width = 0 then
FMetafile.MMWidth := GetDeviceCaps(RefDC, HORZSIZE)*100
else
FMetafile.MMWidth := MulDiv(FMetafile.Width,
GetDeviceCaps(RefDC, HORZSIZE)*100, GetDeviceCaps(RefDC, HORZRES));
if FMetafile.MMHeight = 0 then
if FMetafile.Height = 0 then
FMetafile.MMHeight := GetDeviceCaps(RefDC, VERTSIZE)*100
else
FMetafile.MMHeight := MulDiv(FMetafile.Height,
GetDeviceCaps(RefDC, VERTSIZE)*100, GetDeviceCaps(RefDC, VERTRES));
R := Rect(0,0,FMetafile.MMWidth,FMetafile.MMHeight);
if (Length(CreatedBy) > 0) or (Length(Description) > 0) then
P := PChar(CreatedBy+#0+Description+#0#0)
else
P := nil;
Temp := CreateEnhMetafile(RefDC, nil, @R, P);
if Temp = 0 then GDIError;
Handle := Temp;
finally
if ReferenceDevice = 0 then ReleaseDC(0, RefDC);
end;
end;
destructor TMetafileCanvas.Destroy;
var
Temp: HDC;
begin
Temp := Handle;
Handle := 0;
FMetafile.Handle := CloseEnhMetafile(Temp);
inherited Destroy;
end;
{ TMetafile }
constructor TMetafile.Create;
begin
inherited Create;
FEnhanced := True;
FTransparent := True;
Assign(nil);
end;
destructor TMetafile.Destroy;
begin
FImage.Release;
inherited Destroy;
end;
procedure TMetafile.Assign(Source: TPersistent);
var
Pal: HPalette;
begin
if (Source = nil) or (Source is TMetafile) then
begin
Pal := 0;
if FImage <> nil then
begin
Pal := FImage.FPalette;
FImage.Release;
end;
if Assigned(Source) then
begin
FImage := TMetafile(Source).FImage;
FEnhanced := TMetafile(Source).Enhanced;
end
else
begin
FImage := TMetafileImage.Create;
FEnhanced := True;
end;
FImage.Reference;
PaletteModified := (Pal <> Palette) and (Palette <> 0);
Changed(Self);
end
else
inherited Assign(Source);
end;
procedure TMetafile.Clear;
begin
NewImage;
end;
procedure TMetafile.Draw(ACanvas: TCanvas; const Rect: TRect);
var
MetaPal, OldPal: HPALETTE;
R: TRect;
begin
if FImage = nil then Exit;
MetaPal := Palette;
OldPal := 0;
if MetaPal <> 0 then
begin
OldPal := SelectPalette(ACanvas.Handle, MetaPal, True);
RealizePalette(ACanvas.Handle);
end;
R := Rect;
Dec(R.Right); // Metafile rect includes right and bottom coords
Dec(R.Bottom);
PlayEnhMetaFile(ACanvas.Handle, FImage.FHandle, R);
if MetaPal <> 0 then
SelectPalette(ACanvas.Handle, OldPal, True);
end;
function TMetafile.GetAuthor: String;
var
Temp: Integer;
begin
Result := '';
if (FImage = nil) or (FImage.FHandle = 0) then Exit;
Temp := GetEnhMetafileDescription(FImage.FHandle, 0, nil);
if Temp <= 0 then Exit;
SetLength(Result, Temp);
GetEnhMetafileDescription(FImage.FHandle, Temp, PChar(Result));
SetLength(Result, StrLen(PChar(Result)));
end;
function TMetafile.GetDesc: String;
var
Temp: Integer;
begin
Result := '';
if (FImage = nil) or (FImage.FHandle = 0) then Exit;
Temp := GetEnhMetafileDescription(FImage.FHandle, 0, nil);
if Temp <= 0 then Exit;
SetLength(Result, Temp);
GetEnhMetafileDescription(FImage.FHandle, Temp, PChar(Result));
Delete(Result, 1, StrLen(PChar(Result))+1);
SetLength(Result, StrLen(PChar(Result)));
end;
function TMetafile.GetEmpty;
begin
Result := FImage = nil;
end;
function TMetafile.GetHandle: HENHMETAFILE;
begin
if Assigned(FImage) then
Result := FImage.FHandle
else
Result := 0;
end;
function TMetaFile.HandleAllocated: Boolean;
begin
Result := Assigned(FImage) and (FImage.FHandle <> 0);
end;
const
HundredthMMPerInch = 2540;
function TMetafile.GetHeight: Integer;
var
EMFHeader: TEnhMetaHeader;
begin
if FImage = nil then NewImage;
with FImage do
if FInch = 0 then
if FHandle = 0 then
Result := FTempHeight
else
begin { convert 0.01mm units to referenceDC device pixels }
GetEnhMetaFileHeader(FHandle, Sizeof(EMFHeader), @EMFHeader);
Result := MulDiv(FHeight, { metafile height in 0.01mm }
EMFHeader.szlDevice.cy, { device height in pixels }
EMFHeader.szlMillimeters.cy*100); { device height in mm }
end
else { for WMF files, convert to font dpi based device pixels }
Result := MulDiv(FHeight, ScreenLogPixels, HundredthMMPerInch);
end;
function TMetafile.GetInch: Word;
begin
Result := 0;
if FImage <> nil then Result := FImage.FInch;
end;
function TMetafile.GetMMHeight: Integer;
begin
if FImage = nil then NewImage;
Result := FImage.FHeight;
end;
function TMetafile.GetMMWidth: Integer;
begin
if FImage = nil then NewImage;
Result := FImage.FWidth;
end;
function TMetafile.GetPalette: HPALETTE;
var
LogPal: TMaxLogPalette;
Count: Integer;
begin
Result := 0;
if (FImage = nil) or (FImage.FHandle = 0) then Exit;
if FImage.FPalette = 0 then
begin
Count := GetEnhMetaFilePaletteEntries(FImage.FHandle, 0, nil);
if Count = 0 then
Exit
else if Count > 256 then
Count := Count and $FF;
InternalDeletePalette(FImage.FPalette);
LogPal.palVersion := $300;
LogPal.palNumEntries := Count;
GetEnhMetaFilePaletteEntries(FImage.FHandle, Count, @LogPal.palPalEntry);
FImage.FPalette := CreatePalette(PLogPalette(@LogPal)^);
end;
Result := FImage.FPalette;
end;
function TMetafile.GetWidth: Integer;
var
EMFHeader: TEnhMetaHeader;
begin
if FImage = nil then NewImage;
with FImage do
if FInch = 0 then
if FHandle = 0 then
Result := FTempWidth
else
begin { convert 0.01mm units to referenceDC device pixels }
GetEnhMetaFileHeader(FHandle, Sizeof(EMFHeader), @EMFHeader);
Result := MulDiv(FWidth, { metafile width in 0.01mm }
EMFHeader.szlDevice.cx, { device width in pixels }
EMFHeader.szlMillimeters.cx*100); { device width in 0.01mm }
end
else { for WMF files, convert to font dpi based device pixels }
Result := MulDiv(FWidth, ScreenLogPixels, HundredthMMPerInch);
end;
procedure TMetafile.LoadFromStream(Stream: TStream);
begin
if TestEMF(Stream) then
ReadEMFStream(Stream)
else
ReadWMFStream(Stream, Stream.Size - Stream.Position);
PaletteModified := Palette <> 0;
Changed(Self);
end;
procedure TMetafile.NewImage;
begin
FImage.Release;
FImage := TMetafileImage.Create;
FImage.Reference;
end;
procedure TMetafile.ReadData(Stream: TStream);
var
Length: Longint;
begin
Stream.Read(Length, SizeOf(Longint));
if Length <= 4 then
Assign(nil)
else
if TestEMF(Stream) then
ReadEMFStream(Stream)
else
ReadWMFStream(Stream, Length - Sizeof(Length));
PaletteModified := Palette <> 0;
Changed(Self);
end;
procedure TMetafile.ReadEMFStream(Stream: TStream);
var
EnhHeader: TEnhMetaheader;
Buf: PChar;
begin
NewImage;
Stream.ReadBuffer(EnhHeader, Sizeof(EnhHeader));
if EnhHeader.dSignature <> ENHMETA_SIGNATURE then InvalidMetafile;
GetMem(Buf, EnhHeader.nBytes);
with FImage do
try
Move(EnhHeader, Buf^, Sizeof(EnhHeader));
Stream.ReadBuffer(PChar(Buf + Sizeof(EnhHeader))^,
EnhHeader.nBytes - Sizeof(EnhHeader));
FHandle := SetEnhMetafileBits(EnhHeader.nBytes, Buf);
if FHandle = 0 then InvalidMetafile;
FInch := 0;
with EnhHeader.rclFrame do
begin
FWidth := Right - Left; { in 0.01 mm units }
FHeight := Bottom - Top;
end;
Enhanced := True;
finally
FreeMem(Buf, EnhHeader.nBytes);
end;
end;
procedure TMetafile.ReadWMFStream(Stream: TStream; Length: Longint);
var
WMF: TMetafileHeader;
BitMem: Pointer;
MFP: TMetaFilePict;
EMFHeader: TEnhMetaheader;
begin
NewImage;
Stream.Read(WMF, SizeOf(WMF));
if (WMF.Key <> WMFKEY) or (ComputeAldusChecksum(WMF) <> WMF.CheckSum) then
InvalidMetafile;
Dec(Length, SizeOf(WMF));
GetMem(Bitmem, Length);
with FImage do
try
Stream.Read(BitMem^, Length);
FImage.FInch := WMF.Inch;
if WMF.Inch = 0 then WMF.Inch := 96;
FWidth := MulDiv(WMF.Box.Right - WMF.Box.Left,HundredthMMPerInch,WMF.Inch);
FHeight := MulDiv(WMF.Box.Bottom - WMF.Box.Top,HundredthMMPerInch,WMF.Inch);
with MFP do
begin
MM := MM_ANISOTROPIC;
xExt := 0;
yExt := 0;
hmf := 0;
end;
FHandle := SetWinMetaFileBits(Length, BitMem, 0, MFP);
if FHandle = 0 then InvalidMetafile;
// Get the maximum extent actually used by the metafile output
// and re-convert the wmf data using the new extents.
// This helps preserve whitespace margins in WMFs
GetEnhMetaFileHeader(FHandle, Sizeof(EMFHeader), @EMFHeader);
with MFP, EMFHeader.rclFrame do
begin
MM := MM_ANISOTROPIC;
xExt := Right;
yExt := Bottom;
hmf := 0;
end;
DeleteEnhMetafile(FHandle);
FHandle := SetWinMetaFileBits(Length, BitMem, 0, MFP);
if FHandle = 0 then InvalidMetafile;
Enhanced := False;
finally
Freemem(BitMem, Length);
end;
end;
procedure TMetafile.SaveToFile(const Filename: String);
var
SaveEnh: Boolean;
begin
SaveEnh := Enhanced;
try
if AnsiLowerCaseFileName(ExtractFileExt(Filename)) = '.wmf' then
Enhanced := False; { For 16 bit compatibility }
inherited SaveToFile(Filename);
finally
Enhanced := SaveEnh;
end;
end;
procedure TMetafile.SaveToStream(Stream: TStream);
begin
if FImage <> nil then
if Enhanced then
WriteEMFStream(Stream)
else
WriteWMFStream(Stream);
end;
procedure TMetafile.SetHandle(Value: HENHMETAFILE);
var
EnhHeader: TEnhMetaHeader;
begin
if (Value <> 0) and
(GetEnhMetafileHeader(Value, sizeof(EnhHeader), @EnhHeader) = 0) then
InvalidMetafile;
UniqueImage;
if FImage.FHandle <> 0 then DeleteEnhMetafile(FImage.FHandle);
InternalDeletePalette(FImage.FPalette);
FImage.FPalette := 0;
FImage.FHandle := Value;
FImage.FTempWidth := 0;
FImage.FTempHeight := 0;
if Value <> 0 then
with EnhHeader.rclFrame do
begin
FImage.FWidth := Right - Left;
FImage.FHeight := Bottom - Top;
end;
PaletteModified := Palette <> 0;
Changed(Self);
end;
procedure TMetafile.SetHeight(Value: Integer);
var
EMFHeader: TEnhMetaHeader;
begin
if FImage = nil then NewImage;
with FImage do
if FInch = 0 then
if FHandle = 0 then
FTempHeight := Value
else
begin { convert device pixels to 0.01mm units }
GetEnhMetaFileHeader(FHandle, Sizeof(EMFHeader), @EMFHeader);
MMHeight := MulDiv(Value, { metafile height in pixels }
EMFHeader.szlMillimeters.cy*100, { device height in 0.01mm }
EMFHeader.szlDevice.cy); { device height in pixels }
end
else
MMHeight := MulDiv(Value, HundredthMMPerInch, ScreenLogPixels);
end;
procedure TMetafile.SetInch(Value: Word);
begin
if FImage = nil then NewImage;
if FImage.FInch <> Value then
begin
UniqueImage;
FImage.FInch := Value;
Changed(Self);
end;
end;
procedure TMetafile.SetMMHeight(Value: Integer);
begin
if FImage = nil then NewImage;
FImage.FTempHeight := 0;
if FImage.FHeight <> Value then
begin
UniqueImage;
FImage.FHeight := Value;
Changed(Self);
end;
end;
procedure TMetafile.SetMMWidth(Value: Integer);
begin
if FImage = nil then NewImage;
FImage.FTempWidth := 0;
if FImage.FWidth <> Value then
begin
UniqueImage;
FImage.FWidth := Value;
Changed(Self);
end;
end;
procedure TMetafile.SetTransparent(Value: Boolean);
begin
// Ignore assignments to this property.
// Metafiles must always be considered transparent.
end;
procedure TMetafile.SetWidth(Value: Integer);
var
EMFHeader: TEnhMetaHeader;
begin
if FImage = nil then NewImage;
with FImage do
if FInch = 0 then
if FHandle = 0 then
FTempWidth := Value
else
begin { convert device pixels to 0.01mm units }
GetEnhMetaFileHeader(FHandle, Sizeof(EMFHeader), @EMFHeader);
MMWidth := MulDiv(Value, { metafile width in pixels }
EMFHeader.szlMillimeters.cx*100, { device width in mm }
EMFHeader.szlDevice.cx); { device width in pixels }
end
else
MMWidth := MulDiv(Value, HundredthMMPerInch, ScreenLogPixels);
end;
function TMetafile.TestEMF(Stream: TStream): Boolean;
var
Size: Longint;
Header: TEnhMetaHeader;
begin
Size := Stream.Size - Stream.Position;
if Size > Sizeof(Header) then
begin
Stream.Read(Header, Sizeof(Header));
Stream.Seek(-Sizeof(Header), soFromCurrent);
end;
Result := (Size > Sizeof(Header)) and
(Header.iType = EMR_HEADER) and (Header.dSignature = ENHMETA_SIGNATURE);
end;
procedure TMetafile.UniqueImage;
var
NewImage: TMetafileImage;
begin
if FImage = nil then
Self.NewImage
else
if FImage.FRefCount > 1 then
begin
NewImage:= TMetafileImage.Create;
if FImage.FHandle <> 0 then
NewImage.FHandle := CopyEnhMetafile(FImage.FHandle, nil);
NewImage.FHeight := FImage.FHeight;
NewImage.FWidth := FImage.FWidth;
NewImage.FInch := FImage.FInch;
NewImage.FTempWidth := FImage.FTempWidth;
NewImage.FTempHeight := FImage.FTempHeight;
FImage.Release;
FImage := NewImage;
FImage.Reference;
end;
end;
procedure TMetafile.WriteData(Stream: TStream);
var
SavePos: Longint;
begin
if FImage <> nil then
begin
SavePos := 0;
Stream.Write(SavePos, Sizeof(SavePos));
SavePos := Stream.Position - Sizeof(SavePos);
if Enhanced then
WriteEMFStream(Stream)
else
WriteWMFStream(Stream);
Stream.Seek(SavePos, soFromBeginning);
SavePos := Stream.Size - SavePos;
Stream.Write(SavePos, Sizeof(SavePos));
Stream.Seek(0, soFromEnd);
end;
end;
procedure TMetafile.WriteEMFStream(Stream: TStream);
var
Buf: Pointer;
Length: Longint;
begin
if FImage = nil then Exit;
Length := GetEnhMetaFileBits(FImage.FHandle, 0, nil);
if Length = 0 then Exit;
GetMem(Buf, Length);
try
GetEnhMetaFileBits(FImage.FHandle, Length, Buf);
Stream.WriteBuffer(Buf^, Length);
finally
FreeMem(Buf, Length);
end;
end;
procedure TMetafile.WriteWMFStream(Stream: TStream);
var
WMF: TMetafileHeader;
Bits: Pointer;
Length: UINT;
RefDC: HDC;
begin
if FImage = nil then Exit;
FillChar(WMF, SizeOf(WMF), 0);
with FImage do
begin
with WMF do
begin
Key := WMFKEY;
if FInch = 0 then
Inch := 96 { WMF defaults to 96 units per inch }
else
Inch := FInch;
with Box do
begin
Right := MulDiv(FWidth, WMF.Inch, HundredthMMPerInch);
Bottom := MulDiv(FHeight, WMF.Inch, HundredthMMPerInch);
end;
CheckSum := ComputeAldusChecksum(WMF);
end;
RefDC := GetDC(0);
try
Length := GetWinMetaFileBits(FHandle, 0, nil, MM_ANISOTROPIC, RefDC);
GetMem(Bits, Length);
try
if GetWinMetaFileBits(FHandle, Length, Bits, MM_ANISOTROPIC,
RefDC) < Length then GDIError;
Stream.WriteBuffer(WMF, SizeOf(WMF));
Stream.WriteBuffer(Bits^, Length);
finally
FreeMem(Bits, Length);
end;
finally
ReleaseDC(0, RefDC);
end;
end;
end;
procedure TMetafile.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
APalette: HPALETTE);
var
EnhHeader: TEnhMetaHeader;
begin
AData := GetClipboardData(CF_ENHMETAFILE); // OS will convert WMF to EMF
if AData = 0 then InvalidGraphic(@SUnknownClipboardFormat);
NewImage;
with FImage do
begin
FHandle := CopyEnhMetafile(AData, nil);
GetEnhMetaFileHeader(FHandle, sizeof(EnhHeader), @EnhHeader);
with EnhHeader.rclFrame do
begin
FWidth := Right - Left;
FHeight := Bottom - Top;
end;
FInch := 0;
end;
Enhanced := True;
PaletteModified := Palette <> 0;
Changed(Self);
end;
procedure TMetafile.SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
var APalette: HPALETTE);
begin
if FImage = nil then Exit;
AFormat := CF_ENHMETAFILE;
APalette := 0;
AData := CopyEnhMetaFile(FImage.FHandle, nil);
end;
function TMetafile.ReleaseHandle: HENHMETAFILE;
begin
UniqueImage;
Result := FImage.FHandle;
FImage.FHandle := 0;
end;
var
BitmapCanvasList: TThreadList = nil;
{ TBitmapCanvas }
{ Create a canvas that gets its DC from the memory DC cache }
type
TBitmapCanvas = class(TCanvas)
private
FBitmap: TBitmap;
FOldBitmap: HBITMAP;
FOldPalette: HPALETTE;
procedure FreeContext;
protected
procedure CreateHandle; override;
public
constructor Create(ABitmap: TBitmap);
destructor Destroy; override;
end;
{ FreeMemoryContexts is called by the VCL main winproc to release
memory DCs after every message is processed (garbage collection).
Only memory DCs not locked by other threads will be freed.
}
procedure FreeMemoryContexts;
var
I: Integer;
begin
with BitmapCanvasList.LockList do
try
for I := Count-1 downto 0 do
with TBitmapCanvas(Items[I]) do
if TryLock then
try
FreeContext;
finally
Unlock;
end;
finally
BitmapCanvasList.UnlockList;
end;
end;
{ DeselectBitmap is called to ensure that a bitmap handle is not
selected into any memory DC anywhere in the system. If the bitmap
handle is in use by a locked canvas, DeselectBitmap must wait for
the canvas to unlock. }
procedure DeselectBitmap(AHandle: HBITMAP);
var
I: Integer;
begin
if AHandle = 0 then Exit;
with BitmapCanvasList.LockList do
try
for I := Count - 1 downto 0 do
with TBitmapCanvas(Items[I]) do
if (FBitmap <> nil) and (FBitmap.FImage.FHandle = AHandle) then
FreeContext;
finally
BitmapCanvasList.UnlockList;
end;
end;
constructor TBitmapCanvas.Create(ABitmap: TBitmap);
begin
inherited Create;
FBitmap := ABitmap;
end;
destructor TBitmapCanvas.Destroy;
begin
FreeContext;
inherited Destroy;
end;
procedure TBitmapCanvas.FreeContext;
var
H: HBITMAP;
begin
if FHandle <> 0 then
begin
Lock;
try
if FOldBitmap <> 0 then SelectObject(FHandle, FOldBitmap);
if FOldPalette <> 0 then SelectPalette(FHandle, FOldPalette, True);
H := FHandle;
Handle := 0;
DeleteDC(H);
BitmapCanvasList.Remove(Self);
finally
Unlock;
end;
end;
end;
procedure TBitmapCanvas.CreateHandle;
var
H: HBITMAP;
begin
if FBitmap <> nil then
begin
Lock;
try
FBitmap.HandleNeeded;
DeselectBitmap(FBitmap.FImage.FHandle);
//!! DeselectBitmap(FBitmap.FImage.FMaskHandle);
FBitmap.PaletteNeeded;
H := CreateCompatibleDC(0);
if FBitmap.FImage.FHandle <> 0 then
FOldBitmap := SelectObject(H, FBitmap.FImage.FHandle) else
FOldBitmap := 0;
if FBitmap.FImage.FPalette <> 0 then
begin
FOldPalette := SelectPalette(H, FBitmap.FImage.FPalette, True);
RealizePalette(H);
end
else
FOldPalette := 0;
Handle := H;
BitmapCanvasList.Add(Self);
finally
Unlock;
end;
end;
end;
{ TSharedImage }
procedure TSharedImage.Reference;
begin
Inc(FRefCount);
end;
procedure TSharedImage.Release;
begin
if Pointer(Self) <> nil then
begin
Dec(FRefCount);
if FRefCount = 0 then
begin
FreeHandle;
Free;
end;
end;
end;
{ TBitmapImage }
destructor TBitmapImage.Destroy;
begin
if FDIBHandle <> 0 then
begin
DeselectBitmap(FDIBHandle);
DeleteObject(FDIBHandle);
FDIBHandle := 0;
end;
FreeHandle;
if FDIB.dshSection <> 0 then CloseHandle(FDIB.dshSection);
FreeAndNil(FSaveStream);
inherited Destroy;
end;
procedure TBitmapImage.FreeHandle;
begin
if (FHandle <> 0) and (FHandle <> FDIBHandle) then
begin
DeselectBitmap(FHandle);
DeleteObject(FHandle);
end;
if FMaskHandle <> 0 then
begin
DeselectBitmap(FMaskHandle);
DeleteObject(FMaskHandle);
FMaskHandle := 0;
end;
InternalDeletePalette(FPalette);
FHandle := 0;
FPalette := 0;
end;
{ TBitmap }
const
{ Mapping from color in DIB to system color }
Grays: array[0..3] of TColor = (clWhite, clSilver, clGray, clBlack);
SysGrays: array[0..3] of TColor = (clBtnHighlight, clBtnFace, clBtnShadow,
clBtnText);
{ This function will replace OldColors in Handle's colortable with NewColors and
return a new DDB which uses that color table. For bitmap's with more than
256 colors (8bpp) this function returns the original bitmap. }
function CreateMappedBmp(Handle: HBITMAP; const OldColors, NewColors: array of TColor): HBITMAP;
var
Bitmap: PBitmapInfoHeader;
ColorCount: Integer;
BitmapInfoSize: DWORD;
BitmapBitsSize: DWORD;
Bits: Pointer;
Colors: PRGBQuadArray;
I, J: Integer;
OldColor, NewColor: Integer;
ScreenDC, DC: HDC;
Save: HBITMAP;
begin
Result := Handle;
if Handle = 0 then Exit;
InternalGetDIBSizes(Handle, BitmapInfoSize, BitmapBitsSize, 0);
Bitmap := AllocMem(DWORD(BitmapInfoSize) + BitmapBitsSize);
try
Bits := Pointer(DWORD(Bitmap) + BitmapInfoSize);
InternalGetDIB(Handle, 0, Bitmap^, Bits^, 0);
if Bitmap^.biBitCount <= 8 then
begin
ColorCount := 1 shl (Bitmap^.biBitCount);
Colors := Pointer(DWORD(Bitmap) + Bitmap^.biSize);
ByteSwapColors(Colors^, ColorCount);
for I := 0 to ColorCount - 1 do
for J := Low(OldColors) to High(OldColors) do
begin
OldColor := ColorToRGB(OldColors[J]);
if Integer(Colors[I]) = OldColor then
begin
NewColor := ColorToRGB(NewColors[J]);
Integer(Colors[I]) := NewColor;
end;
end;
ByteSwapColors(Colors^, ColorCount);
ScreenDC := GetDC(0);
try
DC := CreateCompatibleDC(ScreenDC);
if DC <> 0 then
with Bitmap^ do
begin
Result := CreateCompatibleBitmap(ScreenDC, biWidth, biHeight);
if Result <> 0 then
begin
Save := SelectObject(DC, Result);
StretchDIBits(DC, 0, 0, biWidth, biHeight, 0, 0, biWidth, biHeight,
Bits, PBitmapInfo(Bitmap)^, DIB_RGB_COLORS, SrcCopy);
SelectObject(DC, Save);
end;
end;
DeleteDC(DC);
finally
ReleaseDC(0, ScreenDC);
end;
end;
finally
FreeMem(Bitmap, BitmapInfoSize + BitmapBitsSize);
end;
end;
{ This function will create a new DDB from the bitmap resource, replacing
OldColors in the colortable with NewColors. If the bitmap resource has more
than 256 colors (8bpp) this function returns the new DDB without color
modifications. }
function CreateMappedRes(Instance: THandle; ResName: PChar;
const OldColors, NewColors: array of TColor): HBITMAP;
var
Rsrc: HRSRC;
Res: THandle;
ColorCount: DWORD;
BitmapInfoSize: Integer;
Bitmap: PBitmapInfoHeader;
BitmapInfo: PBitmapInfoHeader;
Colors: PRGBQuadArray;
I, J: Integer;
OldColor, NewColor: Integer;
Bits: Pointer;
ScreenDC, DC: HDC;
Save: HBITMAP;
Temp: TBitmap;
begin
Result := 0;
Rsrc := FindResource(Instance, ResName, RT_BITMAP);
if Rsrc = 0 then Exit;
Res := LoadResource(Instance, Rsrc);
try
{ Lock the bitmap and get a pointer to the color table. }
Bitmap := LockResource(Res);
if Bitmap <> nil then
try
if (Bitmap^.biBitCount * Bitmap^.biPlanes) <= 8 then
begin
ColorCount := 1 shl (Bitmap^.biBitCount);
BitmapInfoSize := Bitmap^.biSize + ColorCount * SizeOf(TRGBQuad);
GetMem(BitmapInfo, BitmapInfoSize);
try
Move(Bitmap^, BitmapInfo^, BitmapInfoSize);
if Bitmap^.biBitCount <= 8 then
begin
Colors := Pointer(DWORD(BitmapInfo) + BitmapInfo^.biSize);
ByteSwapColors(Colors^, ColorCount);
for I := 0 to ColorCount - 1 do
for J := Low(OldColors) to High(OldColors) do
begin
OldColor := ColorToRGB(OldColors[J]);
if Integer(Colors[I]) = OldColor then
begin
NewColor := ColorToRGB(NewColors[J]);
Integer(Colors[I]) := NewColor;
end;
end;
ByteSwapColors(Colors^, ColorCount);
end;
{ First skip over the header structure and color table entries, if any. }
Bits := Pointer(Longint(Bitmap) + BitmapInfoSize);
{ Create a color bitmap compatible with the display device. }
ScreenDC := GetDC(0);
try
DC := CreateCompatibleDC(ScreenDC);
if DC <> 0 then
with BitmapInfo^ do
begin
Result := CreateCompatibleBitmap(ScreenDC, biWidth, biHeight);
if Result <> 0 then
begin
Save := SelectObject(DC, Result);
StretchDIBits(DC, 0, 0, biWidth, biHeight, 0, 0, biWidth, biHeight,
Bits, PBitmapInfo(BitmapInfo)^, DIB_RGB_COLORS, SrcCopy);
SelectObject(DC, Save);
end;
end;
DeleteDC(DC);
finally
ReleaseDC(0, ScreenDC);
end;
finally
FreeMem(BitmapInfo, BitmapInfoSize);
end;
end
else
begin
Temp := TBitmap.Create;
try
{$IFDEF MSWINDOWS}
Temp.LoadFromResourceID(Instance, Integer(ResName));
{$ELSE}
Temp.LoadFromResourceName(Instance, ResName);
{$ENDIF}
Result := Temp.ReleaseHandle;
finally
Temp.Free;
end;
end;
finally
UnlockResource(Res);
end;
finally
FreeResource(Res);
end;
end;
{ This function replaces the standard gray colors in a bitmap with the system
grays (Grays, SysGrays). }
function CreateGrayMappedBmp(Handle: HBITMAP): HBITMAP;
begin
Result := CreateMappedBmp(Handle, Grays, SysGrays);
end;
{ This function replaces the standard gray colors in a bitmap resource with the
system grays (Grays, SysGrays). }
function CreateGrayMappedRes(Instance: THandle; ResName: PChar): HBITMAP;
begin
Result := CreateMappedRes(Instance, ResName, Grays, SysGrays);
end;
procedure UpdateDIBColorTable(DIBHandle: HBITMAP; Pal: HPalette;
const DIB: TDIBSection);
var
ScreenDC, DC: HDC;
OldBM: HBitmap;
ColorCount: Integer;
Colors: array [Byte] of TRGBQuad;
begin
if (DIBHandle <> 0) and (DIB.dsbmih.biBitCount <= 8) then
begin
ColorCount := PaletteToDIBColorTable(Pal, Colors);
if ColorCount = 0 then Exit;
ScreenDC := GetDC(0);
DC := CreateCompatibleDC(ScreenDC);
OldBM := SelectObject(DC, DIBHandle);
try
SetDIBColorTable(DC, 0, ColorCount, Colors);
finally
SelectObject(DC, OldBM);
DeleteDC(DC);
ReleaseDC(0, ScreenDC);
end;
end;
end;
procedure FixupBitFields(var DIB: TDIBSection);
begin
if (DIB.dsbmih.biCompression and BI_BITFIELDS <> 0) and
(DIB.dsBitFields[0] = 0) then
if DIB.dsbmih.biBitCount = 16 then
begin
// fix buggy 16 bit color drivers
DIB.dsBitFields[0] := $F800;
DIB.dsBitFields[1] := $07E0;
DIB.dsBitFields[2] := $001F;
end else if DIB.dsbmih.biBitCount = 32 then
begin
// fix buggy 32 bit color drivers
DIB.dsBitFields[0] := $00FF0000;
DIB.dsBitFields[1] := $0000FF00;
DIB.dsBitFields[2] := $000000FF;
end;
end;
function CopyBitmap(Handle: HBITMAP; OldPalette, NewPalette: HPALETTE;
var DIB: TDIBSection; Canvas: TCanvas): HBITMAP;
var
OldScr, NewScr: HBITMAP;
ScreenDC, NewImageDC, OldImageDC: HDC;
BI: PBitmapInfo;
BitsMem: Pointer;
SrcDIB: TDIBSection;
MonoColors: array [0..1] of Integer;
Pal1, Pal2: HPalette;
begin
Result := 0;
with DIB, dsbm, dsbmih do
begin
if (biSize <> 0) and ((biWidth = 0) or (biHeight = 0)) then Exit;
if (biSize = 0) and ((bmWidth = 0) or (bmHeight = 0)) then Exit;
end;
DeselectBitmap(Handle);
SrcDIB.dsbmih.biSize := 0;
if Handle <> 0 then
if GetObject(Handle, sizeof(SrcDIB), @SrcDIB) < sizeof(SrcDIB.dsbm) then
InvalidBitmap;
ScreenDC := GDICheck(GetDC(0));
NewImageDC := GDICheck(CreateCompatibleDC(ScreenDC));
with DIB.dsbm do
try
if DIB.dsbmih.biSize < DWORD(sizeof(DIB.dsbmih)) then
if (bmPlanes or bmBitsPixel) = 1 then // monochrome
Result := GDICheck(CreateBitmap(bmWidth, bmHeight, 1, 1, nil))
else // Create DDB
Result := GDICheck(CreateCompatibleBitmap(ScreenDC, bmWidth, bmHeight))
else // Create DIB
begin
GetMem(BI, sizeof(TBitmapInfo) + 256 * sizeof(TRGBQuad));
with DIB.dsbmih do
try
biSize := sizeof(BI.bmiHeader);
biPlanes := 1;
if biBitCount = 0 then
biBitCount := GetDeviceCaps(ScreenDC, BITSPIXEL) * GetDeviceCaps(ScreenDC, PLANES);
BI.bmiHeader := DIB.dsbmih;
bmWidth := biWidth;
bmHeight := biHeight;
if (biBitCount <= 8) then
begin
if (biBitCount = 1) and ((Handle = 0) or (SrcDIB.dsbm.bmBits = nil)) then
begin // set mono DIB to white/black when converting from DDB.
Integer(BI^.bmiColors[0]) := 0;
PInteger(Integer(@BI^.bmiColors) + sizeof(Integer))^ := $FFFFFF;
end
else if (NewPalette <> 0) then
PaletteToDIBColorTable(NewPalette, PRGBQuadArray(@BI.bmiColors)^)
else if Handle <> 0 then
begin
NewScr := SelectObject(NewImageDC, Handle);
if (SrcDIB.dsbmih.biSize > 0) and (SrcDIB.dsbm.bmBits <> nil) then
biClrUsed := GetDIBColorTable(NewImageDC, 0, 256, BI^.bmiColors)
else
GetDIBits(NewImageDC, Handle, 0, Abs(biHeight), nil, BI^, DIB_RGB_COLORS);
SelectObject(NewImageDC, NewScr);
end;
end
else if ((biBitCount = 16) or (biBitCount = 32)) and
((biCompression and BI_BITFIELDS) <> 0) then
begin
FixupBitFields(DIB);
Move(DIB.dsBitFields, BI.bmiColors, sizeof(DIB.dsBitFields));
end;
Result := GDICheck(CreateDIBSection(ScreenDC, BI^, DIB_RGB_COLORS, BitsMem, 0, 0));
if (BitsMem = nil) then GDIError;
if (Handle <> 0) and (SrcDIB.dsbm.bmWidth = biWidth) and
(SrcDIB.dsbm.bmHeight = biHeight) and (biBitCount > 8) then
begin // shortcut bitblt steps
GetDIBits(NewImageDC, Handle, 0, Abs(biHeight), BitsMem, BI^, DIB_RGB_COLORS);
Exit;
end;
finally
FreeMem(BI);
end;
end;
GDICheck(Result);
NewScr := GDICheck(SelectObject(NewImageDC, Result));
try
try
Pal1 := 0;
Pal2 := 0;
if NewPalette <> 0 then
begin
Pal1 := SelectPalette(NewImageDC, NewPalette, False);
RealizePalette(NewImageDC);
end;
try
if Canvas <> nil then
begin
FillRect(NewImageDC, Rect(0, 0, bmWidth, bmHeight),
Canvas.Brush.Handle);
SetTextColor(NewImageDC, ColorToRGB(Canvas.Font.Color));
SetBkColor(NewImageDC, ColorToRGB(Canvas.Brush.Color));
if (DIB.dsbmih.biBitCount = 1) and (DIB.dsbm.bmBits <> nil) then
begin
MonoColors[0] := ColorToRGB(Canvas.Font.Color);
MonoColors[1] := ColorToRGB(Canvas.Brush.Color);
SetDIBColorTable(NewImageDC, 0, 2, MonoColors);
end;
end
else
PatBlt(NewImageDC, 0, 0, bmWidth, bmHeight, WHITENESS);
if Handle <> 0 then
begin
OldImageDC := GDICheck(CreateCompatibleDC(ScreenDC));
try
OldScr := GDICheck(SelectObject(OldImageDC, Handle));
if OldPalette <> 0 then
begin
Pal2 := SelectPalette(OldImageDC, OldPalette, False);
RealizePalette(OldImageDC);
end;
if Canvas <> nil then
begin
SetTextColor(OldImageDC, ColorToRGB(Canvas.Font.Color));
SetBkColor(OldImageDC, ColorToRGB(Canvas.Brush.Color));
end;
BitBlt(NewImageDC, 0, 0, bmWidth, bmHeight, OldImageDC, 0, 0, SRCCOPY);
if OldPalette <> 0 then
SelectPalette(OldImageDC, Pal2, True);
GDICheck(SelectObject(OldImageDC, OldScr));
finally
DeleteDC(OldImageDC);
end;
end;
finally
if NewPalette <> 0 then
SelectPalette(NewImageDC, Pal1, True);
end;
finally
SelectObject(NewImageDC, NewScr);
end;
except
DeleteObject(Result);
raise;
end;
finally
DeleteDC(NewImageDC);
ReleaseDC(0, ScreenDC);
if (Result <> 0) then GetObject(Result, sizeof(DIB), @DIB);
end;
end;
function CopyPalette(Palette: HPALETTE): HPALETTE;
var
PaletteSize: Integer;
LogPal: TMaxLogPalette;
begin
Result := 0;
if Palette = 0 then Exit;
PaletteSize := 0;
if GetObject(Palette, SizeOf(PaletteSize), @PaletteSize) = 0 then Exit;
if PaletteSize = 0 then Exit;
with LogPal do
begin
palVersion := $0300;
palNumEntries := PaletteSize;
GetPaletteEntries(Palette, 0, PaletteSize, palPalEntry);
end;
Result := CreatePalette(PLogPalette(@LogPal)^);
end;
function CopyBitmapAsMask(Handle: HBITMAP; Palette: HPALETTE;
TransparentColor: TColorRef): HBITMAP;
var
DIB: TDIBSection;
ScreenDC, BitmapDC, MonoDC: HDC;
BkColor: TColorRef;
Remove: Boolean;
SaveBitmap, SaveMono: HBITMAP;
begin
Result := 0;
if (Handle <> 0) and (GetObject(Handle, SizeOf(DIB), @DIB) <> 0) then
begin
DeselectBitmap(Handle);
ScreenDC := 0;
MonoDC := 0;
try
ScreenDC := GDICheck(GetDC(0));
MonoDC := GDICheck(CreateCompatibleDC(ScreenDC));
with DIB, dsBm do
begin
Result := CreateBitmap(bmWidth, bmHeight, 1, 1, nil);
if Result <> 0 then
begin
SaveMono := SelectObject(MonoDC, Result);
if TransparentColor = TColorRef(clNone) then
PatBlt(MonoDC, 0, 0, bmWidth, bmHeight, Blackness)
else
begin
BitmapDC := GDICheck(CreateCompatibleDC(ScreenDC));
try
{ Convert DIB to DDB }
if bmBits <> nil then
begin
Remove := True;
DIB.dsbmih.biSize := 0;
Handle := CopyBitmap(Handle, Palette, Palette, DIB, nil);
end
else Remove := False;
SaveBitmap := SelectObject(BitmapDC, Handle);
if Palette <> 0 then
begin
SelectPalette(BitmapDC, Palette, False);
RealizePalette(BitmapDC);
SelectPalette(MonoDC, Palette, False);
RealizePalette(MonoDC);
end;
BkColor := SetBkColor(BitmapDC, TransparentColor);
BitBlt(MonoDC, 0, 0, bmWidth, bmHeight, BitmapDC, 0, 0, SrcCopy);
SetBkColor(BitmapDC, BkColor);
if SaveBitmap <> 0 then SelectObject(BitmapDC, SaveBitmap);
if Remove then DeleteObject(Handle);
finally
DeleteDC(BitmapDC);
end;
end;
if SaveMono <> 0 then SelectObject(MonoDC, SaveMono);
end;
end;
finally
if MonoDC <> 0 then DeleteDC(MonoDC);
if ScreenDC <> 0 then ReleaseDC(0, ScreenDC);
end;
end;
end;
constructor TBitmap.Create;
begin
inherited Create;
FTransparentColor := clDefault;
FImage := TBitmapImage.Create;
FImage.Reference;
if DDBsOnly then HandleType := bmDDB;
end;
destructor TBitmap.Destroy;
begin
FreeContext;
FImage.Release;
FCanvas.Free;
inherited Destroy;
end;
procedure TBitmap.Assign(Source: TPersistent);
var
DIB: TDIBSection;
begin
if (Source = nil) or (Source is TBitmap) then
begin
EnterCriticalSection(BitmapImageLock);
try
if Source <> nil then
begin
TBitmap(Source).FImage.Reference;
FImage.Release;
FImage := TBitmap(Source).FImage;
FTransparent := TBitmap(Source).FTransparent;
FTransparentColor := TBitmap(Source).FTransparentColor;
FTransparentMode := TBitmap(Source).FTransparentMode;
end
else
begin
FillChar(DIB, Sizeof(DIB), 0);
NewImage(0, 0, DIB, False);
end;
finally
LeaveCriticalSection(BitmapImageLock);
end;
PaletteModified := Palette <> 0;
Changed(Self);
end
else inherited Assign(Source);
end;
procedure TBitmap.CopyImage(AHandle: HBITMAP; APalette: HPALETTE; DIB: TDIBSection);
var
NewHandle, NewPalette: THandle;
begin
FreeContext;
NewHandle := 0;
NewPalette := 0;
try
if APalette = SystemPalette16 then
NewPalette := APalette
else
NewPalette := CopyPalette(APalette);
NewHandle := CopyBitmap(AHandle, APalette, NewPalette, DIB, FCanvas);
NewImage(NewHandle, NewPalette, DIB, FImage.FOS2Format);
except
InternalDeletePalette(NewPalette);
if NewHandle <> 0 then DeleteObject(NewHandle);
raise;
end;
end;
{ Called by the FCanvas whenever an operation is going to be performed on the
bitmap that would modify it. Since modifications should only affect this
TBitmap, the handle needs to be 'cloned' if it is being refered to by more
than one TBitmap }
procedure TBitmap.Changing(Sender: TObject);
begin
FreeImage;
FImage.FDIB.dsbmih.biClrUsed := 0;
FImage.FDIB.dsbmih.biClrImportant := 0;
FreeAndNil(FImage.FSaveStream);
end;
procedure TBitmap.Changed(Sender: TObject);
begin
FMaskBitsValid := False;
inherited Changed(Sender);
end;
procedure TBitmap.Dormant;
var
s: TMemoryStream;
DIB: TDIBSection;
begin
s := TMemoryStream.Create;
SaveToStream(s);
S.Size := S.Size; // compact to minimum buffer
DIB := FImage.FDIB;
DIB.dsbm.bmBits := nil;
FreeContext; // InternalDeletePalette requires this
FreeAndNil(FCanvas);
NewImage(0, 0, DIB, FImage.FOS2Format, s);
end;
procedure TBitmap.Draw(ACanvas: TCanvas; const Rect: TRect);
var
OldPalette: HPalette;
RestorePalette: Boolean;
DoHalftone: Boolean;
Pt: TPoint;
BPP: Integer;
MaskDC: HDC;
Save: THandle;
begin
with Rect, FImage do
begin
ACanvas.RequiredState(csAllValid);
PaletteNeeded;
OldPalette := 0;
RestorePalette := False;
if FPalette <> 0 then
begin
OldPalette := SelectPalette(ACanvas.FHandle, FPalette, True);
RealizePalette(ACanvas.FHandle);
RestorePalette := True;
end;
BPP := GetDeviceCaps(ACanvas.FHandle, BITSPIXEL) *
GetDeviceCaps(ACanvas.FHandle, PLANES);
DoHalftone := (BPP <= 8) and (BPP < (FDIB.dsbm.bmBitsPixel * FDIB.dsbm.bmPlanes));
if DoHalftone then
begin
GetBrushOrgEx(ACanvas.FHandle, pt);
SetStretchBltMode(ACanvas.FHandle, HALFTONE);
SetBrushOrgEx(ACanvas.FHandle, pt.x, pt.y, @pt);
end else if not Monochrome then
SetStretchBltMode(ACanvas.Handle, STRETCH_DELETESCANS);
try
{ Call MaskHandleNeeded prior to creating the canvas handle since
it causes FreeContext to be called. }
if Transparent then MaskHandleNeeded;
Canvas.RequiredState(csAllValid);
if Transparent then
begin
Save := 0;
MaskDC := 0;
try
MaskDC := GDICheck(CreateCompatibleDC(0));
Save := SelectObject(MaskDC, FMaskHandle);
TransparentStretchBlt(ACanvas.FHandle, Left, Top, Right - Left,
Bottom - Top, Canvas.FHandle, 0, 0, FDIB.dsbm.bmWidth,
FDIB.dsbm.bmHeight, MaskDC, 0, 0);
finally
if Save <> 0 then SelectObject(MaskDC, Save);
if MaskDC <> 0 then DeleteDC(MaskDC);
end;
end
else
StretchBlt(ACanvas.FHandle, Left, Top, Right - Left, Bottom - Top,
Canvas.FHandle, 0, 0, FDIB.dsbm.bmWidth,
FDIB.dsbm.bmHeight, ACanvas.CopyMode);
finally
if RestorePalette then
SelectPalette(ACanvas.FHandle, OldPalette, True);
end;
end;
end;
{ FreeImage:
If there are multiple references to the image, create a unique copy of the image.
If FHandle = FDIBHandle, the DIB memory will be updated when the drawing
handle is drawn upon, so no changes are needed to maintain image integrity.
If FHandle <> FDIBHandle, the DIB will not track with changes made to
the DDB, so destroy the DIB handle (but keep the DIB pixel format info). }
procedure TBitmap.FreeImage;
var
P: HPalette;
begin
with FImage do
if FRefCount > 1 then
begin
HandleNeeded;
if FHalftone then
P := 0
else
P := FPalette;
CopyImage(FHandle, P, FDIB)
end
else if (FHandle <> 0) and (FHandle <> FDIBHandle) then
begin
if FDIBHandle <> 0 then
if not DeleteObject(FDIBHandle) then GDIError;
FDIBHandle := 0;
FDIB.dsbm.bmBits := nil;
end;
end;
function TBitmap.GetEmpty;
begin
with FImage do
Result := (FHandle = 0) and (FDIBHandle = 0) and (FSaveStream = nil);
end;
function TBitmap.GetCanvas: TCanvas;
begin
if FCanvas = nil then
begin
HandleNeeded;
if FCanvas = nil then // possible recursion
begin
FCanvas := TBitmapCanvas.Create(Self);
FCanvas.OnChange := Changed;
FCanvas.OnChanging := Changing;
end;
end;
Result := FCanvas;
end;
{ Since the user might modify the contents of the HBITMAP it must not be
shared by another TBitmap when given to the user nor should it be selected
into a DC. }
function TBitmap.GetHandle: HBITMAP;
begin
FreeContext;
HandleNeeded;
Changing(Self);
Result := FImage.FHandle;
end;
function TBitmap.HandleAllocated: Boolean;
begin
Result := Assigned(FImage) and (FImage.FHandle <> 0);
end;
function TBitmap.GetHandleType: TBitmapHandleType;
begin
with FImage do
begin
if (FHandle = 0) or (FHandle = FDIBHandle) then
if FDIBHandle = 0 then
if FDIB.dsbmih.biSize = 0 then
Result := bmDDB
else
Result := bmDIB
else
Result := bmDIB
else
Result := bmDDB;
end;
end;
function TBitmap.GetHeight: Integer;
begin
Result := Abs(FImage.FDIB.dsbm.bmHeight);
end;
function TBitmap.GetMaskHandle: HBITMAP;
begin
MaskHandleNeeded;
Result := FImage.FMaskHandle;
end;
function TBitmap.GetMonochrome: Boolean;
begin
with FImage.FDIB.dsbm do
Result := (bmPlanes = 1) and (bmBitsPixel = 1);
end;
function TBitmap.GetPalette: HPALETTE;
begin
PaletteNeeded;
Result := FImage.FPalette;
end;
function TBitmap.GetPixelFormat: TPixelFormat;
begin
Result := pfCustom;
if HandleType = bmDDB then
Result := pfDevice
else
with FImage.FDIB, dsbmih do
case biBitCount of
1: Result := pf1Bit;
4: Result := pf4Bit;
8: Result := pf8Bit;
16: case biCompression of
BI_RGB : Result := pf15Bit;
BI_BITFIELDS: if dsBitFields[1] = $7E0 then Result := pf16Bit;
end;
24: Result := pf24Bit;
32: if biCompression = BI_RGB then Result := pf32Bit;
end;
end;
function TBitmap.GetScanLine(Row: Integer): Pointer;
begin
Changing(Self);
with FImage.FDIB, dsbm, dsbmih do
begin
if (Row < 0) or (Row >= bmHeight) then
InvalidOperation(@SScanLine);
DIBNeeded;
GDIFlush;
if biHeight > 0 then // bottom-up DIB
Row := biHeight - Row - 1;
Integer(Result) := Integer(bmBits) +
Row * BytesPerScanline(biWidth, biBitCount, 32);
end;
end;
function TBitmap.GetTransparentColor: TColor;
begin
if FTransparentColor = clDefault then
begin
if Monochrome then
Result := clWhite
else
Result := Canvas.Pixels[0, Height - 1];
end
else Result := ColorToRGB(FTransparentColor);
Result := Result or $02000000;
end;
function TBitmap.GetWidth: Integer;
begin
Result := FImage.FDIB.dsbm.bmWidth;
end;
procedure TBitmap.DIBNeeded;
begin
with FImage do
begin
if (FHandle = 0) or (FDIBHandle <> 0) then Exit;
PaletteNeeded;
if FDIB.dsbmih.biSize = 0 then
begin
GetObject(FHandle, sizeof(FDIB), @FDIB);
with FDIB, dsbm, dsbmih do
begin
biSize := sizeof(dsbmih);
biWidth := bmWidth;
biHeight := bmHeight;
biPlanes := 1;
biBitCount := bmPlanes * bmBitsPixel;
end;
end;
FDIBHandle := CopyBitmap(FHandle, FPalette, FPalette, FDIB, nil);
end;
end;
procedure TBitmap.FreeContext;
begin
if (FCanvas <> nil) then TBitmapCanvas(FCanvas).FreeContext;
end;
procedure TBitmap.HandleNeeded;
var
vChange: TNotifyEvent;
begin
if (FImage.FHandle = 0) and (FImage.FDIBHandle = 0) and (FImage.FSaveStream <> nil) then
begin
FImage.FSaveStream.Position := 0;
vChange := OnChange;
try
OnChange := nil;
LoadFromStream(FImage.FSaveStream); // Current FImage may be destroyed here
finally
OnChange := vChange;
end;
end;
with FImage do
if FHandle = 0 then
FHandle := FDIBHandle;
end;
procedure TBitmap.Mask(TransparentColor: TColor);
var
NewHandle, NewPalette: THandle;
DIB: TDIBSection;
begin
NewHandle := 0;
NewPalette := 0;
try
FreeContext;
HandleNeeded;
NewHandle := CopyBitmapAsMask(FImage.FHandle, FImage.FPalette,
ColorToRGB(TransparentColor));
FillChar(DIB, SizeOf(DIB), 0);
GetObject(NewHandle, SizeOf(DIB), @DIB);
if FImage.FPalette = SystemPalette16 then
NewPalette := FImage.FPalette
else
NewPalette := CopyPalette(FImage.FPalette);
NewImage(NewHandle, NewPalette, DIB, FImage.FOS2Format);
except
InternalDeletePalette(NewPalette);
if NewHandle <> 0 then DeleteObject(NewHandle);
raise;
end;
Changed(Self);
end;
procedure TBitmap.MaskHandleNeeded;
begin
if FMaskValid and FMaskBitsValid then Exit;
with FImage do
begin
{ Delete existing mask if any }
if FMaskHandle <> 0 then
begin
DeselectBitmap(FMaskHandle);
DeleteObject(FMaskHandle);
FMaskHandle := 0;
end;
FreeContext;
HandleNeeded; // may change FImage instance pointer
end;
with FImage do // use new FImage from here on
begin
FMaskHandle := CopyBitmapAsMask(FHandle, FPalette, GetTransparentColor);
FMaskValid := True;
FMaskBitsValid := True;
end;
end;
procedure TBitmap.PaletteNeeded;
var
DC: HDC;
begin
with FImage do
begin
if FIgnorePalette or (FPalette <> 0) or (FDIBHandle = 0) then Exit;
if FHandle = FDIBHandle then DeselectBitmap(FDIBHandle);
FPalette := PaletteFromDIBColorTable(FDIBHandle, nil, 1 shl FDIB.dsbmih.biBitCount);
if FPalette <> 0 then Exit;
DC := GDICheck(GetDC(0));
FHalftone := FHalftone or
((GetDeviceCaps(DC, BITSPIXEL) * GetDeviceCaps(DC, PLANES)) <
(FDIB.dsbm.bmBitsPixel * FDIB.dsbm.bmPlanes));
if FHalftone then FPalette := CreateHalftonePalette(DC);
ReleaseDC(0, DC);
if FPalette = 0 then IgnorePalette := True;
end;
end;
procedure TBitmap.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
APalette: HPALETTE);
var
DIB: TDIBSection;
begin
if (AFormat <> CF_BITMAP) or (AData = 0) then
InvalidGraphic(@SUnknownClipboardFormat);
FreeContext;
FillChar(DIB, sizeof(DIB), 0);
GetObject(AData, sizeof(DIB), @DIB);
if DIB.dsbm.bmBits = nil then DIB.dsbmih.biSize := 0;
CopyImage(AData, APalette, DIB);
FImage.FOS2Format := False;
PaletteModified := Palette <> 0;
Changed(Self);
end;
procedure TBitmap.LoadFromStream(Stream: TStream);
begin
ReadStream(Stream, Stream.Size - Stream.Position);
end;
procedure TBitmap.LoadFromResourceName(Instance: THandle; const ResName: string);
var
Stream: TCustomMemoryStream;
begin
Stream := TResourceStream.Create(Instance, ResName, RT_BITMAP);
try
ReadDIB(Stream, Stream.Size);
finally
Stream.Free;
end;
end;
{$IFDEF MSWINDOWS}
procedure TBitmap.LoadFromResourceID(Instance: THandle; ResID: Integer);
var
Stream: TCustomMemoryStream;
begin
Stream := TResourceStream.CreateFromID(Instance, ResID, RT_BITMAP);
try
ReadDIB(Stream, Stream.Size);
finally
Stream.Free;
end;
end;
{$ENDIF}
procedure TBitmap.NewImage(NewHandle: HBITMAP; NewPalette: HPALETTE;
const NewDIB: TDIBSection; OS2Format: Boolean; RLEStream: TStream = nil);
var
Image: TBitmapImage;
begin
Image := TBitmapImage.Create;
with Image do
try
FHandle := NewHandle;
FPalette := NewPalette;
FDIB := NewDIB;
FOS2Format := OS2Format;
if FDIB.dsbm.bmBits <> nil then FDIBHandle := FHandle;
FSaveStream := RLEStream as TMemoryStream;
except
Image.Free;
raise;
end;
//!! replace with InterlockedExchange()
EnterCriticalSection(BitmapImageLock);
try
FImage.Release;
FImage := Image;
FImage.Reference;
finally
LeaveCriticalSection(BitmapImageLock);
end;
FMaskValid := False;
end;
procedure TBitmap.ReadData(Stream: TStream);
var
Size: Longint;
begin
Stream.Read(Size, SizeOf(Size));
ReadStream(Stream, Size);
end;
procedure TBitmap.ReadDIB(Stream: TStream; ImageSize: LongWord; bmf: PBitmapFileHeader);
const
DIBPalSizes: array [Boolean] of Byte = (sizeof(TRGBQuad), sizeof(TRGBTriple));
var
DC, MemDC: HDC;
BitsMem: Pointer;
OS2Header: TBitmapCoreHeader;
BitmapInfo: PBitmapInfo;
ColorTable: Pointer;
HeaderSize: Integer;
OS2Format: Boolean;
BMHandle, OldBMP: HBITMAP;
DIB: TDIBSection;
Pal, OldPal: HPalette;
RLEStream: TStream;
vbmf: TBitmapFileHeader;
{$IFDEF LINUX}
I: Integer;
{$ENDIF}
begin
Pal := 0;
BMHandle := 0;
RLEStream := nil;
Stream.Read(HeaderSize, sizeof(HeaderSize));
OS2Format := HeaderSize = sizeof(OS2Header);
if OS2Format then HeaderSize := sizeof(TBitmapInfoHeader);
GetMem(BitmapInfo, HeaderSize + 12 + 256 * sizeof(TRGBQuad));
with BitmapInfo^ do
try
try
if OS2Format then // convert OS2 DIB to Win DIB
begin
Stream.Read(Pointer(Longint(@OS2Header) + sizeof(HeaderSize))^,
sizeof(OS2Header) - sizeof(HeaderSize));
FillChar(bmiHeader, sizeof(bmiHeader), 0);
with bmiHeader, OS2Header do
begin
biWidth := bcWidth;
biHeight := bcHeight;
biPlanes := bcPlanes;
biBitCount := bcBitCount;
end;
Dec(ImageSize, sizeof(OS2Header));
end
else
begin // support bitmap headers larger than TBitmapInfoHeader
Stream.Read(Pointer(Longint(BitmapInfo) + sizeof(HeaderSize))^,
HeaderSize - sizeof(HeaderSize));
Dec(ImageSize, HeaderSize);
if (bmiHeader.biCompression <> BI_BITFIELDS) and
(bmiHeader.biCompression <> BI_RGB) then
begin // Preserve funky non-DIB data (like RLE) until modified
RLEStream := TMemoryStream.Create;
// source stream could be unidirectional. don't reverse seek
if bmf = nil then
begin
FillChar(vbmf, sizeof(vbmf), 0);
vbmf.bfType := $4D42;
vbmf.bfSize := ImageSize + Cardinal(HeaderSize);
bmf := @vbmf;
end;
RLEStream.Write(bmf^, sizeof(bmf^));
RLEStream.Write(HeaderSize, sizeof(HeaderSize));
RLEStream.Write(Pointer(Longint(BitmapInfo) + sizeof(HeaderSize))^,
HeaderSize - sizeof(HeaderSize));
RLEStream.CopyFrom(Stream, ImageSize);
{ Cast ImageSize (long word) to integer to avoid integer overflow when negating. }
RLEStream.Seek(-Integer(ImageSize), soFromEnd);
Stream := RLEStream; // the rest of the proc reads from RLEStream
end;
end;
with bmiHeader do
begin
biSize := HeaderSize;
ColorTable := Pointer(Longint(BitmapInfo) + HeaderSize);
{ check number of planes. DIBs must be 1 color plane (packed pixels) }
if biPlanes <> 1 then InvalidBitmap;
// 3 DWORD color element bit masks (ie 888 or 565) can precede colors
// TBitmapInfoHeader sucessors include these masks in the headersize
if (HeaderSize = sizeof(TBitmapInfoHeader)) and
((biBitCount = 16) or (biBitCount = 32)) and
(biCompression = BI_BITFIELDS) then
begin
Stream.ReadBuffer(ColorTable^, 3 * sizeof(DWORD));
Inc(Longint(ColorTable), 3 * sizeof(DWORD));
Dec(ImageSize, 3 * sizeof(DWORD));
end;
// Read the color palette
if biClrUsed = 0 then
biClrUsed := GetDInColors(biBitCount);
Stream.ReadBuffer(ColorTable^, biClrUsed * DIBPalSizes[OS2Format]);
Dec(ImageSize, biClrUsed * DIBPalSizes[OS2Format]);
// biSizeImage can be zero. If zero, compute the size.
if biSizeImage = 0 then // top-down DIBs have negative height
biSizeImage := BytesPerScanLine(biWidth, biBitCount, 32) * Abs(biHeight);
if biSizeImage < ImageSize then ImageSize := biSizeImage;
end;
{ convert OS2 color table to DIB color table }
if OS2Format then RGBTripleToQuad(ColorTable^);
DC := GDICheck(GetDC(0));
try
if ((bmiHeader.biCompression <> BI_RGB) and
(bmiHeader.biCompression <> BI_BITFIELDS)) or DDBsOnly then
begin
MemDC := 0;
GetMem(BitsMem, ImageSize);
try
Stream.ReadBuffer(BitsMem^, ImageSize);
MemDC := GDICheck(CreateCompatibleDC(DC));
OldBMP := SelectObject(MemDC, CreateCompatibleBitmap(DC, 1, 1));
OldPal := 0;
if bmiHeader.biClrUsed > 0 then
begin
Pal := PaletteFromDIBColorTable(0, ColorTable, bmiHeader.biClrUsed);
OldPal := SelectPalette(MemDC, Pal, False);
RealizePalette(MemDC);
end;
try
BMHandle := CreateDIBitmap(MemDC, BitmapInfo^.bmiHeader, CBM_INIT, BitsMem,
BitmapInfo^, DIB_RGB_COLORS);
if (BMHandle = 0) then
if GetLastError = 0 then InvalidBitmap else RaiseLastOSError;
finally
if OldPal <> 0 then
SelectPalette(MemDC, OldPal, True);
DeleteObject(SelectObject(MemDC, OldBMP));
end;
finally
if MemDC <> 0 then DeleteDC(MemDC);
FreeMem(BitsMem);
end;
end
else
begin
BMHandle := CreateDIBSection(DC, BitmapInfo^, DIB_RGB_COLORS, BitsMem, 0, 0);
if (BMHandle = 0) or (BitsMem = nil) then
if GetLastError = 0 then InvalidBitmap else RaiseLastOSError;
try
{$IFDEF LINUX}
// I need to pre-touch the memory in 4096 byte increments to ensure
// the read will succeed. WINE marks this memory as not present to
// catch when we make changes to it. If we read directly into it
// Linux will (correctly) terminate the read with a failure since an
// exception occured during the read. We need to make sure these
// exceptions are triggered in user space instead of kernel.
for I := 1 to (ImageSize + 4095) div 4096 do
PByteArray(BitsMem)^[(I - 1) * 4096] := 0;
{$ENDIF}
Stream.ReadBuffer(BitsMem^, ImageSize);
except
DeleteObject(BMHandle);
raise;
end;
end;
finally
ReleaseDC(0, DC);
end;
// Hi-color DIBs don't preserve color table, so create palette now
if (bmiHeader.biBitCount > 8) and (bmiHeader.biClrUsed > 0) and (Pal = 0)then
Pal := PaletteFromDIBColorTable(0, ColorTable, bmiHeader.biClrUsed);
FillChar(DIB, sizeof(DIB), 0);
GetObject(BMHandle, Sizeof(DIB), @DIB);
// GetObject / CreateDIBSection don't preserve these info values
DIB.dsBmih.biXPelsPerMeter := bmiHeader.biXPelsPerMeter;
DIB.dsBmih.biYPelsPerMeter := bmiHeader.biYPelsPerMeter;
DIB.dsBmih.biClrUsed := bmiHeader.biClrUsed;
DIB.dsBmih.biClrImportant := bmiHeader.biClrImportant;
except
RLEStream.Free;
raise;
end;
finally
FreeMem(BitmapInfo);
end;
NewImage(BMHandle, Pal, DIB, OS2Format, RLEStream);
PaletteModified := Palette <> 0;
Changed(Self);
end;
procedure TBitmap.ReadStream(Stream: TStream; Size: Longint);
var
Bmf: TBitmapFileHeader;
DIB: TDIBSection;
begin
FreeContext;
if Size = 0 then
begin
FillChar(DIB, sizeof(DIB), 0);
NewImage(0, 0, DIB, False);
end
else
begin
Stream.ReadBuffer(Bmf, sizeof(Bmf));
if Bmf.bfType <> $4D42 then InvalidBitmap;
ReadDIB(Stream, Size - sizeof(Bmf), @Bmf);
end;
end;
procedure TBitmap.SetHandle(Value: HBITMAP);
var
DIB: TDIBSection;
APalette: HPALETTE;
begin
with FImage do
if FHandle <> Value then
begin
FreeContext;
FillChar(DIB, sizeof(DIB), 0);
if Value <> 0 then
GetObject(Value, SizeOf(DIB), @DIB);
if FRefCount = 1 then
begin
APalette := FPalette;
FPalette := 0;
end
else
if FPalette = SystemPalette16 then
APalette := SystemPalette16
else
APalette := CopyPalette(FPalette);
try
NewImage(Value, APalette, DIB, False);
except
InternalDeletePalette(APalette);
raise;
end;
Changed(Self);
end;
end;
procedure TBitmap.SetHandleType(Value: TBitmapHandleType);
var
DIB: TDIBSection;
AHandle: HBITMAP;
NewPalette: HPALETTE;
DoCopy: Boolean;
begin
if Value = GetHandleType then Exit;
with FImage do
begin
if (FHandle = 0) and (FDIBHandle = 0) then
if Value = bmDDB then
FDIB.dsbmih.biSize := 0
else
FDIB.dsbmih.biSize := sizeof(FDIB.dsbmih)
else
begin
if Value = bmDIB then
begin
if (FDIBHandle <> 0) and (FDIBHandle = FHandle) then Exit;
FreeContext;
PaletteNeeded;
DIBNeeded;
if FRefCount = 1 then
begin
AHandle := FDIBHandle;
FDIBHandle := 0;
NewPalette := FPalette;
FPalette := 0;
NewImage(AHandle, NewPalette, FDIB, FOS2Format);
end
else
CopyImage(FDIBHandle, FPalette, FDIB);
end
else
begin
if (FHandle <> 0) and (FHandle <> FDIBHandle) then Exit;
FreeContext;
PaletteNeeded;
DIB := FDIB;
DIB.dsbmih.biSize := 0; // flag to tell CopyBitmap to create a DDB
DoCopy := FRefCount = 1;
if DoCopy then
NewPalette := FPalette
else
NewPalette := CopyPalette(FPalette);
AHandle := CopyBitmap(FDIBHandle, FPalette, NewPalette, DIB, nil);
if DoCopy then
FHandle := AHandle
else
NewImage(AHandle, NewPalette, DIB, FOS2Format);
end;
Changed(Self);
end;
end;
end;
procedure TBitmap.SetHeight(Value: Integer);
var
DIB: TDIBSection;
begin
with FImage do
if FDIB.dsbm.bmHeight <> Value then
begin
HandleNeeded;
DIB := FDIB;
DIB.dsbm.bmHeight := Value;
DIB.dsbmih.biHeight := Value;
CopyImage(FHandle, FPalette, DIB);
Changed(Self);
end;
end;
procedure TBitmap.SetMaskHandle(Value: HBITMAP);
begin
with FImage do
if FMaskHandle <> Value then
begin
FMaskHandle := Value;
FMaskValid := True;
FMaskBitsValid := True;
end;
end;
procedure TBitmap.SetMonochrome(Value: Boolean);
var
DIB: TDIBSection;
begin
with FImage, FDIB.dsbmih do
if Value <> ((biPlanes = 1) and (biBitCount = 1)) then
begin
HandleNeeded;
DIB := FDIB;
with DIB.dsbmih, DIB.dsbm do
begin
biSize := 0; // request DDB handle
biPlanes := Byte(Value); // 0 = request screen BMP format
biBitCount := Byte(Value);
bmPlanes := Byte(Value);
bmBitsPixel := Byte(Value);
end;
CopyImage(FHandle, FPalette, DIB);
Changed(Self);
end;
end;
procedure TBitmap.SetPalette(Value: HPALETTE);
var
AHandle: HBITMAP;
DIB: TDIBSection;
begin
if FImage.FPalette <> Value then
begin
with FImage do
if (Value = 0) and (FRefCount = 1) then
begin
InternalDeletePalette(FPalette);
FPalette := 0;
end
else
begin
FreeContext;
HandleNeeded;
DIB := FDIB;
AHandle := CopyBitmap(FHandle, FPalette, Value, DIB, nil);
try
NewImage(AHandle, Value, DIB, FOS2Format);
except
DeleteObject(AHandle);
raise;
end;
end;
UpdateDIBColorTable(FImage.FDIBHandle, Value, FImage.FDIB);
PaletteModified := True;
Changed(Self);
end;
end;
procedure TBitmap.SetPixelFormat(Value: TPixelFormat);
const
BitCounts: array [pf1Bit..pf32Bit] of Byte = (1,4,8,16,16,24,32);
var
DIB: TDIBSection;
Pal: HPalette;
DC: HDC;
KillPal: Boolean;
begin
if Value = GetPixelFormat then Exit;
case Value of
pfDevice:
begin
HandleType := bmDDB;
Exit;
end;
pfCustom: InvalidGraphic(@SInvalidPixelFormat);
else
FillChar(DIB, sizeof(DIB), 0);
DIB.dsbm := FImage.FDIB.dsbm;
KillPal := False;
with DIB, dsbm, dsbmih do
begin
bmBits := nil;
biSize := sizeof(DIB.dsbmih);
biWidth := bmWidth;
biHeight := bmHeight;
biPlanes := 1;
biBitCount := BitCounts[Value];
Pal := FImage.FPalette;
case Value of
pf4Bit: Pal := SystemPalette16;
pf8Bit:
begin
DC := GDICheck(GetDC(0));
Pal := CreateHalftonePalette(DC);
KillPal := True;
ReleaseDC(0, DC);
end;
pf16Bit:
begin
biCompression := BI_BITFIELDS;
dsBitFields[0] := $F800;
dsBitFields[1] := $07E0;
dsBitFields[2] := $001F;
end;
end;
try
CopyImage(Handle, Pal, DIB);
PaletteModified := Pal <> 0;
finally
if KillPal then DeleteObject(Pal);
end;
Changed(Self);
end;
end;
end;
procedure TBitmap.SetTransparentColor(Value: TColor);
begin
if Value <> FTransparentColor then
begin
if Value = clDefault then
FTransparentMode := tmAuto else
FTransparentMode := tmFixed;
FTransparentColor := Value;
if FImage.FRefCount > 1 then
with FImage do
begin
HandleNeeded;
CopyImage(FHandle, FPalette, FDIB);
end;
Changed(Self);
end;
end;
procedure TBitmap.SetTransparentMode(Value: TTransparentMode);
begin
if Value <> FTransparentMode then
begin
if Value = tmAuto then
SetTransparentColor(clDefault) else
SetTransparentColor(GetTransparentColor);
end;
end;
procedure TBitmap.SetWidth(Value: Integer);
var
DIB: TDIBSection;
begin
with FImage do
if FDIB.dsbm.bmWidth <> Value then
begin
HandleNeeded;
DIB := FDIB;
DIB.dsbm.bmWidth := Value;
DIB.dsbmih.biWidth := Value;
CopyImage(FHandle, FPalette, DIB);
Changed(Self);
end;
end;
procedure TBitmap.WriteData(Stream: TStream);
begin
WriteStream(Stream, True);
end;
procedure TBitmap.WriteStream(Stream: TStream; WriteSize: Boolean);
const
PalSize: array [Boolean] of Byte = (sizeof(TRGBQuad), sizeof(TRGBTriple));
var
Size, ColorCount: DWORD;
HeaderSize: DWORD;
BMF: TBitmapFileHeader;
Save: THandle;
BC: TBitmapCoreHeader;
Colors: array [Byte] of TRGBQuad;
begin
FillChar(BMF, sizeof(BMF), 0);
BMF.bfType := $4D42;
if FImage.FSaveStream <> nil then
begin
Size := FImage.FSaveStream.Size;
if WriteSize then
Stream.WriteBuffer(Size, sizeof(Size));
Stream.Write(FImage.FSaveStream.Memory^, FImage.FSaveStream.Size);
Exit;
end;
DIBNeeded;
with FImage do
begin
Size := 0;
if FDIBHandle <> 0 then
begin
InternalGetDIBSizes(FDIBHandle, HeaderSize, Size, FDIB.dsbmih.biClrUsed);
if FOS2Format then
begin // OS2 format cannot have partial palette
HeaderSize := sizeof(BC);
if FDIB.dsbmih.biBitCount <= 8 then
Inc(HeaderSize, sizeof(TRGBTriple) * (1 shl FDIB.dsbmih.biBitCount));
end;
Inc(Size, HeaderSize + sizeof(BMF));
FillChar(BMF, sizeof(BMF), 0);
BMF.bfType := $4D42;
Canvas.RequiredState([csHandleValid]);
Save := GDICheck(SelectObject(FCanvas.FHandle, FDIBHandle));
ColorCount := GetDIBColorTable(FCanvas.FHandle, 0, 256, Colors);
SelectObject(FCanvas.FHandle, Save);
// GetDIBColorTable always reports the full palette; trim it back for partial palettes
if (0 < FDIB.dsbmih.biClrUsed) and (FDIB.dsbmih.biClrUsed < ColorCount) then
ColorCount := FDIB.dsbmih.biClrUsed;
if (not FOS2Format) and (ColorCount = 0) and (FPalette <> 0) and not FHalftone then
begin
ColorCount := PaletteToDIBColorTable(FPalette, Colors);
if FDIB.dsbmih.biBitCount > 8 then
begin // optional color palette for hicolor images (non OS2)
Inc(Size, ColorCount * sizeof(TRGBQuad));
Inc(HeaderSize, ColorCount * sizeof(TRGBQuad));
end;
end;
BMF.bfSize := Size;
BMF.bfOffBits := sizeof(BMF) + HeaderSize;
end;
if WriteSize then Stream.WriteBuffer(Size, SizeOf(Size));
if Size <> 0 then
begin
FixupBitFields(FDIB);
if (ColorCount <> 0) then
begin
if (FDIB.dsbmih.biClrUsed = 0) or (FDIB.dsbmih.biClrUsed <> ColorCount) then
FDIB.dsbmih.biClrUsed := ColorCount;
if FOS2Format then RGBQuadToTriple(Colors, Integer(ColorCount));
end;
if FOS2Format then
begin
with BC, FDIB.dsbmih do
begin
bcSize := sizeof(BC);
bcWidth := biWidth;
bcHeight := biHeight;
bcPlanes := 1;
bcBitCount := biBitCount;
end;
Stream.WriteBuffer(BMF, sizeof(BMF));
Stream.WriteBuffer(BC, sizeof(BC));
end
else
begin
Stream.WriteBuffer(BMF, Sizeof(BMF));
Stream.WriteBuffer(FDIB.dsbmih, Sizeof(FDIB.dsbmih));
if (FDIB.dsbmih.biBitCount > 8) and
((FDIB.dsbmih.biCompression and BI_BITFIELDS) <> 0) then
Stream.WriteBuffer(FDIB.dsBitfields, 12);
end;
Stream.WriteBuffer(Colors, ColorCount * PalSize[FOS2Format]);
Stream.WriteBuffer(FDIB.dsbm.bmBits^, FDIB.dsbmih.biSizeImage);
end;
end;
end;
{ ReleaseHandle gives up ownership of the bitmap handle the TBitmap contains. }
function TBitmap.ReleaseHandle: HBITMAP;
begin
HandleNeeded;
Changing(Self);
with FImage do
begin
Result := FHandle;
if FHandle = FDIBHandle then
begin
FDIBHandle := 0;
FDIB.dsbm.bmBits := nil;
end;
FHandle := 0;
end;
end;
function TBitmap.ReleaseMaskHandle: HBITMAP;
begin
Result := GetMaskHandle;
FImage.FMaskHandle := 0;
end;
function TBitmap.ReleasePalette: HPALETTE;
begin
HandleNeeded;
Changing(Self);
Result := FImage.FPalette;
FImage.FPalette := 0;
end;
procedure TBitmap.SaveToStream(Stream: TStream);
begin
WriteStream(Stream, False);
end;
procedure TBitmap.SaveToClipboardFormat(var Format: Word; var Data: THandle;
var APalette: HPALETTE);
var
DIB: TDIBSection;
begin
Format := CF_BITMAP;
HandleNeeded;
with FImage do
begin
DIB := FDIB;
DIB.dsbmih.biSize := 0; // copy to device bitmap
DIB.dsbm.bmBits := nil;
Data := CopyBitmap(FHandle, FPalette, FPalette, DIB, FCanvas);
end;
try
APalette := CopyPalette(FImage.FPalette);
except
DeleteObject(Data);
raise;
end;
end;
function TBitmap.TransparentColorStored: Boolean;
begin
Result := FTransparentMode = tmFixed;
end;
{ TIconImage }
destructor TIconImage.Destroy;
begin
FMemoryImage.Free;
inherited Destroy;
end;
procedure TIconImage.FreeHandle;
begin
if FHandle <> 0 then DestroyIcon(FHandle);
FHandle := 0;
end;
{ TIcon }
constructor TIcon.Create;
begin
inherited Create;
FTransparent := True;
FImage := TIconImage.Create;
FImage.Reference;
end;
destructor TIcon.Destroy;
begin
FImage.Release;
inherited Destroy;
end;
procedure TIcon.Assign(Source: TPersistent);
begin
if (Source = nil) or (Source is TIcon) then
begin
if Source <> nil then
begin
TIcon(Source).FImage.Reference;
FImage.Release;
FImage := TIcon(Source).FImage;
end else
NewImage(0, nil);
Changed(Self);
Exit;
end;
inherited Assign(Source);
end;
procedure TIcon.Draw(ACanvas: TCanvas; const Rect: TRect);
begin
with Rect.TopLeft do
begin
ACanvas.RequiredState([csHandleValid]);
DrawIconEx(ACanvas.FHandle, X, Y, Handle, 0, 0, 0, 0, DI_NORMAL);
end;
end;
function TIcon.GetEmpty: Boolean;
begin
with FImage do
Result := (FHandle = 0) and (FMemoryImage = nil);
end;
function TIcon.GetHandle: HICON;
begin
HandleNeeded;
Result := FImage.FHandle;
end;
function TIcon.HandleAllocated: Boolean;
begin
Result := Assigned(FImage) and (FImage.FHandle <> 0);
end;
function TIcon.GetHeight: Integer;
begin
Result := FImage.FSize.y;
if Result = 0 then
Result := GetSystemMetrics(SM_CYICON)
end;
function TIcon.GetWidth: Integer;
begin
Result := FImage.FSize.X;
if Result = 0 then
Result := GetSystemMetrics(SM_CXICON);
end;
procedure TIcon.HandleNeeded;
var
CI: TCursorOrIcon;
NewHandle: HICON;
begin
with FImage do
begin
if FHandle <> 0 then Exit;
if FMemoryImage = nil then Exit;
FMemoryImage.Position := 0;
FMemoryImage.ReadBuffer(CI, SizeOf(CI));
case CI.wType of
RC3_STOCKICON: NewHandle := StockIcon;
RC3_ICON: ReadIcon(FMemoryImage, NewHandle, CI.Count, SizeOf(CI),
FRequestedSize, FSize);
else
InvalidIcon;
end;
FHandle := NewHandle;
end;
end;
procedure TIcon.ImageNeeded;
var
Image: TMemoryStream;
CI: TCursorOrIcon;
begin
with FImage do
begin
if FMemoryImage <> nil then Exit;
if FHandle = 0 then InvalidIcon;
Image := TMemoryStream.Create;
try
if GetHandle = StockIcon then
begin
FillChar(CI, SizeOf(CI), 0);
Image.WriteBuffer(CI, SizeOf(CI));
end
else
WriteIcon(Image, Handle, False);
except
Image.Free;
raise;
end;
FMemoryImage := Image;
end;
end;
procedure TIcon.LoadFromStream(Stream: TStream);
var
Image: TMemoryStream;
CI: TCursorOrIcon;
begin
Image := TMemoryStream.Create;
try
Image.SetSize(Stream.Size - Stream.Position);
Stream.ReadBuffer(Image.Memory^, Image.Size);
Image.ReadBuffer(CI, SizeOf(CI));
if not (CI.wType in [RC3_STOCKICON, RC3_ICON]) then InvalidIcon;
NewImage(0, Image);
except
Image.Free;
raise;
end;
Changed(Self);
end;
procedure TIcon.NewImage(NewHandle: HICON; NewImage: TMemoryStream);
var
Image: TIconImage;
begin
Image := TIconImage.Create;
try
Image.FHandle := NewHandle;
Image.FMemoryImage := NewImage;
except
Image.Free;
raise;
end;
Image.Reference;
FImage.Release;
FImage := Image;
end;
function TIcon.ReleaseHandle: HICON;
begin
with FImage do
begin
if FRefCount > 1 then NewImage(CopyIcon(FHandle), nil);
Result := FHandle;
FHandle := 0;
end;
Changed(Self);
end;
procedure TIcon.SetHandle(Value: HICON);
begin
NewImage(Value, nil);
Changed(Self);
end;
procedure TIcon.SetHeight(Value: Integer);
begin
if FImage.FHandle = 0 then
FRequestedSize.Y := Value
else
InvalidOperation(@SChangeIconSize);
end;
procedure TIcon.SetTransparent(Value: Boolean);
begin
// Ignore assignments to this property.
// Icons are always transparent.
end;
procedure TIcon.SetWidth(Value: Integer);
begin
if FImage.FHandle = 0 then
FRequestedSize.X := Value
else
InvalidOperation(@SChangeIconSize);
end;
procedure TIcon.SaveToStream(Stream: TStream);
begin
ImageNeeded;
with FImage.FMemoryImage do Stream.WriteBuffer(Memory^, Size);
end;
procedure TIcon.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
APalette: HPALETTE);
begin
InvalidOperation(@SIconToClipboard);
end;
procedure TIcon.SaveToClipboardFormat(var Format: Word; var Data: THandle;
var APalette: HPALETTE);
begin
InvalidOperation(@SIconToClipboard);
end;
function GraphicFilter(GraphicClass: TGraphicClass): string;
var
Filters: string;
begin
GetFileFormats.BuildFilterStrings(GraphicClass, Result, Filters);
end;
function GraphicExtension(GraphicClass: TGraphicClass): string;
var
I: Integer;
begin
for I := GetFileFormats.Count-1 downto 0 do
if PFileFormat(FileFormats[I])^.GraphicClass.ClassName = GraphicClass.ClassName then
begin
Result := PFileFormat(FileFormats[I])^.Extension;
Exit;
end;
Result := '';
end;
function GraphicFileMask(GraphicClass: TGraphicClass): string;
var
Descriptions: string;
begin
GetFileFormats.BuildFilterStrings(GraphicClass, Descriptions, Result);
end;
procedure InitScreenLogPixels;
const
Pal16: array [0..15] of TColor =
(clBlack, clMaroon, clGreen, clOlive, clNavy, clPurple, clTeal, clDkGray,
clLtGray, clRed, clLime, clYellow, clBlue, clFuchsia, clAqua, clWhite);
var
DC: HDC;
begin
DC := GetDC(0);
ScreenLogPixels := GetDeviceCaps(DC, LOGPIXELSY);
ReleaseDC(0,DC);
//!! SystemPalette16 := GetStockObject(DEFAULT_PALETTE);
SystemPalette16 := CreateSystemPalette(Pal16);
end;
function GetDefFontCharSet: TFontCharSet;
var
DisplayDC: HDC;
TxtMetric: TTEXTMETRIC;
begin
Result := DEFAULT_CHARSET;
DisplayDC := GetDC(0);
if (DisplayDC <> 0) then
begin
if (SelectObject(DisplayDC, StockFont) <> 0) then
if (GetTextMetrics(DisplayDC, TxtMetric)) then
Result := TxtMetric.tmCharSet;
ReleaseDC(0, DisplayDC);
end;
end;
procedure InitDefFontData;
var
Charset: TFontCharset;
begin
DefFontData.Height := -MulDiv(8, ScreenLogPixels, 72);
if not SysLocale.FarEast then Exit;
Charset := GetDefFontCharset;
case Charset of
SHIFTJIS_CHARSET:
begin
DefFontData.Name := '<27>l<EFBFBD>r <20>o<EFBFBD>S<EFBFBD>V<EFBFBD>b<EFBFBD>N';
DefFontData.Height := -MulDiv(9, ScreenLogPixels, 72);
DefFontData.CharSet := CharSet;
end;
end;
end;
type
PPattern = ^TPattern;
TPattern = record
Next: PPattern;
Bitmap: TBitmap;
BkColorRef: TColorRef;
FgColorRef: TColorRef;
end;
TPatternManager = class(TMyObject)
private
List: PPattern;
FLock: TRTLCriticalSection;
function CreateBitmap(BkColor, FgColor: TColor): TBitmap;
public
constructor Create;
destructor Destroy; override;
function AllocPattern(BkColor, FgColor: TColorRef): PPattern;
procedure FreePatterns;
procedure Lock;
procedure Unlock;
end;
constructor TPatternManager.Create;
begin
InitializeCriticalSection(FLock);
end;
destructor TPatternManager.Destroy;
begin
FreePatterns;
DeleteCriticalSection(FLock);
end;
procedure TPatternManager.Lock;
begin
EnterCriticalSection(FLock);
end;
procedure TPatternManager.Unlock;
begin
LeaveCriticalSection(FLock);
end;
function TPatternManager.AllocPattern(BkColor, FgColor: TColorRef): PPattern;
begin
Lock;
try
Result := List;
while (Result <> nil) and ((Result^.BkColorRef <> BkColor) or
(Result^.FgColorRef <> FgColor)) do
Result := Result^.Next;
if Result = nil then
begin
GetMem(Result, SizeOf(TPattern));
with Result^ do
begin
Next := List;
Bitmap := CreateBitmap(BkColor, FgColor);
BkColorRef := BkColor;
FgColorRef := FgColor;
end;
List := Result;
end;
finally
Unlock;
end;
end;
function TPatternManager.CreateBitmap(BkColor, FgColor: TColor): TBitmap;
var
X, Y: Integer;
begin
Result := TBitmap.Create;
try
with Result do
begin
Width := 8;
Height := 8;
with Canvas do
begin
Brush.Style := bsSolid;
Brush.Color := BkColor;
FillRect(Rect(0, 0, Width, Height));
for Y := 0 to 8 do
for X := 0 to 8 do
if (Y mod 2) = (X mod 2) then { toggles between even/odd pixles }
Pixels[X, Y] := FgColor; { on even/odd rows }
end;
Dormant;
end;
except
Result.Free;
raise;
end;
end;
procedure TPatternManager.FreePatterns;
var
P: PPattern;
begin
while List <> nil do
begin
P := List;
with P^ do
begin
Lock;
try
List := Next
finally
Unlock;
end;
if Bitmap <> nil then Bitmap.Free;
end;
FreeMem(P);
end;
end;
var
PatternManager: TPatternManager;
function AllocPatternBitmap(BkColor, FgColor: TColor): TBitmap;
begin
if PatternManager <> nil then
Result := PatternManager.AllocPattern(ColorToRGB(BkColor),
ColorToRGB(FgColor)).Bitmap
else
Result := nil;
end;
initialization
InitScreenLogPixels;
InitializeCriticalSection(BitmapImageLock);
InitializeCriticalSection(CounterLock);
StockPen := GetStockObject(BLACK_PEN);
StockBrush := GetStockObject(HOLLOW_BRUSH);
StockFont := GetStockObject(SYSTEM_FONT);
StockIcon := LoadIcon(0, IDI_APPLICATION);
InitDefFontData;
FontManager := TResourceManager.Create(SizeOf(TFontData));
PenManager := TResourceManager.Create(SizeOf(TPenData));
BrushManager := TResourceManager.Create(SizeOf(TBrushData));
PatternManager := TPatternManager.Create;
BitmapCanvasList := TThreadList.Create;
CanvasList := TThreadList.Create;
RegisterIntegerConsts(TypeInfo(TColor), IdentToColor, ColorToIdent);
RegisterIntegerConsts(TypeInfo(TFontCharset), IdentToCharset, CharsetToIdent);
finalization
PatternManager.Free;
FileFormats.Free;
ClipboardFormats.Free;
FreeMemoryContexts;
BitmapCanvasList.Free;
CanvasList.Free;
FontManager.Free;
PenManager.Free;
BrushManager.Free;
DeleteObject(SystemPalette16);
DeleteCriticalSection(BitmapImageLock);
DeleteCriticalSection(CounterLock);
end.
Reference in New Issue View Git Blame Copy Permalink