home *** CD-ROM | disk | FTP | other *** search
/ QBasic & Borland Pascal & C / Delphi5.iso / Runimage / Delphi50 / Source / Vcl / GRAPHICS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1999-08-11  |  188.3 KB  |  6,753 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Borland Delphi Visual Component Library         }
  5. {                                                       }
  6. {       Copyright (c) 1995,99 Inprise Corporation       }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit Graphics;
  11.  
  12. {$P+,S-,W-,R-,T-,X+,H+}
  13. {$C PRELOAD}
  14.  
  15. interface
  16.  
  17. uses Windows, SysUtils, Classes;
  18.  
  19. { Graphics Objects }
  20.  
  21. type
  22.   PColor = ^TColor;
  23.   TColor = -$7FFFFFFF-1..$7FFFFFFF;
  24.   {$NODEFINE TColor}
  25.  
  26.   (*$HPPEMIT 'namespace Graphics'*)
  27.   (*$HPPEMIT '{'*)
  28.   (*$HPPEMIT '  enum TColor {clMin=-0x7fffffff-1, clMax=0x7fffffff};'*)
  29.   (*$HPPEMIT '}'*)
  30.  
  31.  
  32. const
  33.   clScrollBar = TColor(COLOR_SCROLLBAR or $80000000);
  34.   clBackground = TColor(COLOR_BACKGROUND or $80000000);
  35.   clActiveCaption = TColor(COLOR_ACTIVECAPTION or $80000000);
  36.   clInactiveCaption = TColor(COLOR_INACTIVECAPTION or $80000000);
  37.   clMenu = TColor(COLOR_MENU or $80000000);
  38.   clWindow = TColor(COLOR_WINDOW or $80000000);
  39.   clWindowFrame = TColor(COLOR_WINDOWFRAME or $80000000);
  40.   clMenuText = TColor(COLOR_MENUTEXT or $80000000);
  41.   clWindowText = TColor(COLOR_WINDOWTEXT or $80000000);
  42.   clCaptionText = TColor(COLOR_CAPTIONTEXT or $80000000);
  43.   clActiveBorder = TColor(COLOR_ACTIVEBORDER or $80000000);
  44.   clInactiveBorder = TColor(COLOR_INACTIVEBORDER or $80000000);
  45.   clAppWorkSpace = TColor(COLOR_APPWORKSPACE or $80000000);
  46.   clHighlight = TColor(COLOR_HIGHLIGHT or $80000000);
  47.   clHighlightText = TColor(COLOR_HIGHLIGHTTEXT or $80000000);
  48.   clBtnFace = TColor(COLOR_BTNFACE or $80000000);
  49.   clBtnShadow = TColor(COLOR_BTNSHADOW or $80000000);
  50.   clGrayText = TColor(COLOR_GRAYTEXT or $80000000);
  51.   clBtnText = TColor(COLOR_BTNTEXT or $80000000);
  52.   clInactiveCaptionText = TColor(COLOR_INACTIVECAPTIONTEXT or $80000000);
  53.   clBtnHighlight = TColor(COLOR_BTNHIGHLIGHT or $80000000);
  54.   cl3DDkShadow = TColor(COLOR_3DDKSHADOW or $80000000);
  55.   cl3DLight = TColor(COLOR_3DLIGHT or $80000000);
  56.   clInfoText = TColor(COLOR_INFOTEXT or $80000000);
  57.   clInfoBk = TColor(COLOR_INFOBK or $80000000);
  58.  
  59.   clBlack = TColor($000000);
  60.   clMaroon = TColor($000080);
  61.   clGreen = TColor($008000);
  62.   clOlive = TColor($008080);
  63.   clNavy = TColor($800000);
  64.   clPurple = TColor($800080);
  65.   clTeal = TColor($808000);
  66.   clGray = TColor($808080);
  67.   clSilver = TColor($C0C0C0);
  68.   clRed = TColor($0000FF);
  69.   clLime = TColor($00FF00);
  70.   clYellow = TColor($00FFFF);
  71.   clBlue = TColor($FF0000);
  72.   clFuchsia = TColor($FF00FF);
  73.   clAqua = TColor($FFFF00);
  74.   clLtGray = TColor($C0C0C0);
  75.   clDkGray = TColor($808080);
  76.   clWhite = TColor($FFFFFF);
  77.   clNone = TColor($1FFFFFFF);
  78.   clDefault = TColor($20000000);
  79.  
  80. const
  81.   cmBlackness = BLACKNESS;
  82.   cmDstInvert = DSTINVERT;
  83.   cmMergeCopy = MERGECOPY;
  84.   cmMergePaint = MERGEPAINT;
  85.   cmNotSrcCopy = NOTSRCCOPY;
  86.   cmNotSrcErase = NOTSRCERASE;
  87.   cmPatCopy = PATCOPY;
  88.   cmPatInvert = PATINVERT;
  89.   cmPatPaint = PATPAINT;
  90.   cmSrcAnd = SRCAND;
  91.   cmSrcCopy = SRCCOPY;
  92.   cmSrcErase = SRCERASE;
  93.   cmSrcInvert = SRCINVERT;
  94.   cmSrcPaint = SRCPAINT;
  95.   cmWhiteness = WHITENESS;
  96.  
  97. type
  98.   {$EXTERNALSYM HMETAFILE}
  99.   HMETAFILE = THandle;
  100.   {$EXTERNALSYM HENHMETAFILE}
  101.   HENHMETAFILE = THandle;
  102.  
  103.   EInvalidGraphic = class(Exception);
  104.   EInvalidGraphicOperation = class(Exception);
  105.  
  106.   TGraphic = class;
  107.   TBitmap = class;
  108.   TIcon = class;
  109.   TMetafile = class;
  110.  
  111.   TResData = record
  112.     Handle: THandle;
  113.   end;
  114.  
  115.   TFontPitch = (fpDefault, fpVariable, fpFixed);
  116.   TFontName = type string;
  117.   TFontCharset = 0..255;
  118.  
  119.   { Changes to the following types should be reflected in the $HPPEMIT directives. }
  120.  
  121.   TFontDataName = string[LF_FACESIZE - 1];
  122.   {$NODEFINE TFontDataName}
  123.   TFontStyle = (fsBold, fsItalic, fsUnderline, fsStrikeOut);
  124.   {$NODEFINE TFontStyle}
  125.   TFontStyles = set of TFontStyle;
  126.   TFontStylesBase = set of TFontStyle;
  127.   {$NODEFINE TFontStylesBase}
  128.  
  129.   (*$HPPEMIT 'namespace Graphics'*)
  130.   (*$HPPEMIT '{'*)
  131.   (*$HPPEMIT '  enum TFontStyle { fsBold, fsItalic, fsUnderline, fsStrikeOut };'*)
  132.   (*$HPPEMIT '  typedef SmallStringBase<31> TFontDataName;'*)
  133.   (*$HPPEMIT '  typedef SetBase<TFontStyle, fsBold, fsStrikeOut> TFontStylesBase;'*)
  134.   (*$HPPEMIT '}'*)
  135.  
  136.   TFontData = record
  137.     Handle: HFont;
  138.     Height: Integer;
  139.     Pitch: TFontPitch;
  140.     Style: TFontStylesBase;
  141.     Charset: TFontCharset;
  142.     Name: TFontDataName;
  143.   end;
  144.  
  145.   TPenStyle = (psSolid, psDash, psDot, psDashDot, psDashDotDot, psClear,
  146.     psInsideFrame);
  147.   TPenMode = (pmBlack, pmWhite, pmNop, pmNot, pmCopy, pmNotCopy,
  148.     pmMergePenNot, pmMaskPenNot, pmMergeNotPen, pmMaskNotPen, pmMerge,
  149.     pmNotMerge, pmMask, pmNotMask, pmXor, pmNotXor);
  150.  
  151.   TPenData = record
  152.     Handle: HPen;
  153.     Color: TColor;
  154.     Width: Integer;
  155.     Style: TPenStyle;
  156.   end;
  157.  
  158.   TBrushStyle = (bsSolid, bsClear, bsHorizontal, bsVertical,
  159.     bsFDiagonal, bsBDiagonal, bsCross, bsDiagCross);
  160.  
  161.   TBrushData = record
  162.     Handle: HBrush;
  163.     Color: TColor;
  164.     Bitmap: TBitmap;
  165.     Style: TBrushStyle;
  166.   end;
  167.  
  168.   PResource = ^TResource;
  169.   TResource = record
  170.     Next: PResource;
  171.     RefCount: Integer;
  172.     Handle: THandle;
  173.     HashCode: Word;
  174.     case Integer of
  175.       0: (Data: TResData);
  176.       1: (Font: TFontData);
  177.       2: (Pen: TPenData);
  178.       3: (Brush: TBrushData);
  179.   end;
  180.  
  181.   TGraphicsObject = class(TPersistent)
  182.   private
  183.     FOnChange: TNotifyEvent;
  184.     FResource: PResource;
  185.     FOwnerLock: PRTLCriticalSection;
  186.   protected
  187.     procedure Changed; dynamic;
  188.     procedure Lock;
  189.     procedure Unlock;
  190.   public
  191.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  192.     property OwnerCriticalSection: PRTLCriticalSection read FOwnerLock write FOwnerLock;
  193.   end;
  194.  
  195.   IChangeNotifier = interface
  196.     ['{1FB62321-44A7-11D0-9E93-0020AF3D82DA}']
  197.     procedure Changed;
  198.   end;
  199.  
  200.   TFont = class(TGraphicsObject)
  201.   private
  202.     FColor: TColor;
  203.     FPixelsPerInch: Integer;
  204.     FNotify: IChangeNotifier;
  205.     procedure GetData(var FontData: TFontData);
  206.     procedure SetData(const FontData: TFontData);
  207.   protected
  208.     procedure Changed; override;
  209.     function GetHandle: HFont;
  210.     function GetHeight: Integer;
  211.     function GetName: TFontName;
  212.     function GetPitch: TFontPitch;
  213.     function GetSize: Integer;
  214.     function GetStyle: TFontStyles;
  215.     function GetCharset: TFontCharset;
  216.     procedure SetColor(Value: TColor);
  217.     procedure SetHandle(Value: HFont);
  218.     procedure SetHeight(Value: Integer);
  219.     procedure SetName(const Value: TFontName);
  220.     procedure SetPitch(Value: TFontPitch);
  221.     procedure SetSize(Value: Integer);
  222.     procedure SetStyle(Value: TFontStyles);
  223.     procedure SetCharset(Value: TFontCharset);
  224.   public
  225.     constructor Create;
  226.     destructor Destroy; override;
  227.     procedure Assign(Source: TPersistent); override;
  228.     property FontAdapter: IChangeNotifier read FNotify write FNotify;
  229.     property Handle: HFont read GetHandle write SetHandle;
  230.     property PixelsPerInch: Integer read FPixelsPerInch write FPixelsPerInch;
  231.   published
  232.     property Charset: TFontCharset read GetCharset write SetCharset;
  233.     property Color: TColor read FColor write SetColor;
  234.     property Height: Integer read GetHeight write SetHeight;
  235.     property Name: TFontName read GetName write SetName;
  236.     property Pitch: TFontPitch read GetPitch write SetPitch default fpDefault;
  237.     property Size: Integer read GetSize write SetSize stored False;
  238.     property Style: TFontStyles read GetStyle write SetStyle;
  239.   end;
  240.  
  241.   TPen = class(TGraphicsObject)
  242.   private
  243.     FMode: TPenMode;
  244.     procedure GetData(var PenData: TPenData);
  245.     procedure SetData(const PenData: TPenData);
  246.   protected
  247.     function GetColor: TColor;
  248.     procedure SetColor(Value: TColor);
  249.     function GetHandle: HPen;
  250.     procedure SetHandle(Value: HPen);
  251.     procedure SetMode(Value: TPenMode);
  252.     function GetStyle: TPenStyle;
  253.     procedure SetStyle(Value: TPenStyle);
  254.     function GetWidth: Integer;
  255.     procedure SetWidth(Value: Integer);
  256.   public
  257.     constructor Create;
  258.     destructor Destroy; override;
  259.     procedure Assign(Source: TPersistent); override;
  260.     property Handle: HPen read GetHandle write SetHandle;
  261.   published
  262.     property Color: TColor read GetColor write SetColor default clBlack;
  263.     property Mode: TPenMode read FMode write SetMode default pmCopy;
  264.     property Style: TPenStyle read GetStyle write SetStyle default psSolid;
  265.     property Width: Integer read GetWidth write SetWidth default 1;
  266.   end;
  267.  
  268.   TBrush = class(TGraphicsObject)
  269.   private
  270.     procedure GetData(var BrushData: TBrushData);
  271.     procedure SetData(const BrushData: TBrushData);
  272.   protected
  273.     function GetBitmap: TBitmap;
  274.     procedure SetBitmap(Value: TBitmap);
  275.     function GetColor: TColor;
  276.     procedure SetColor(Value: TColor);
  277.     function GetHandle: HBrush;
  278.     procedure SetHandle(Value: HBrush);
  279.     function GetStyle: TBrushStyle;
  280.     procedure SetStyle(Value: TBrushStyle);
  281.   public
  282.     constructor Create;
  283.     destructor Destroy; override;
  284.     procedure Assign(Source: TPersistent); override;
  285.     property Bitmap: TBitmap read GetBitmap write SetBitmap;
  286.     property Handle: HBrush read GetHandle write SetHandle;
  287.   published
  288.     property Color: TColor read GetColor write SetColor default clWhite;
  289.     property Style: TBrushStyle read GetStyle write SetStyle default bsSolid;
  290.   end;
  291.  
  292.   TFillStyle = (fsSurface, fsBorder);
  293.   TFillMode = (fmAlternate, fmWinding);
  294.  
  295.   TCopyMode = Longint;
  296.  
  297.   TCanvasStates = (csHandleValid, csFontValid, csPenValid, csBrushValid);
  298.   TCanvasState = set of TCanvasStates;
  299.   TCanvasOrientation = (coLeftToRight, coRightToLeft);
  300.  
  301.   TCanvas = class(TPersistent)
  302.   private
  303.     FHandle: HDC;
  304.     State: TCanvasState;
  305.     FFont: TFont;
  306.     FPen: TPen;
  307.     FBrush: TBrush;
  308.     FPenPos: TPoint;
  309.     FCopyMode: TCopyMode;
  310.     FOnChange: TNotifyEvent;
  311.     FOnChanging: TNotifyEvent;
  312.     FLock: TRTLCriticalSection;
  313.     FLockCount: Integer;
  314.     FTextFlags: Longint;
  315.     procedure CreateBrush;
  316.     procedure CreateFont;
  317.     procedure CreatePen;
  318.     procedure BrushChanged(ABrush: TObject);
  319.     procedure DeselectHandles;
  320.     function GetCanvasOrientation: TCanvasOrientation;
  321.     function GetClipRect: TRect;
  322.     function GetHandle: HDC;
  323.     function GetPenPos: TPoint;
  324.     function GetPixel(X, Y: Integer): TColor;
  325.     procedure FontChanged(AFont: TObject);
  326.     procedure PenChanged(APen: TObject);
  327.     procedure SetBrush(Value: TBrush);
  328.     procedure SetFont(Value: TFont);
  329.     procedure SetHandle(Value: HDC);
  330.     procedure SetPen(Value: TPen);
  331.     procedure SetPenPos(Value: TPoint);
  332.     procedure SetPixel(X, Y: Integer; Value: TColor);
  333.   protected
  334.     procedure Changed; virtual;
  335.     procedure Changing; virtual;
  336.     procedure CreateHandle; virtual;
  337.     procedure RequiredState(ReqState: TCanvasState);
  338.   public
  339.     constructor Create;
  340.     destructor Destroy; override;
  341.     procedure Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
  342.     procedure BrushCopy(const Dest: TRect; Bitmap: TBitmap;
  343.       const Source: TRect; Color: TColor);
  344.     procedure Chord(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
  345.     procedure CopyRect(const Dest: TRect; Canvas: TCanvas;
  346.       const Source: TRect);
  347.     procedure Draw(X, Y: Integer; Graphic: TGraphic);
  348.     procedure DrawFocusRect(const Rect: TRect);
  349.     procedure Ellipse(X1, Y1, X2, Y2: Integer); overload;
  350.     procedure Ellipse(const Rect: TRect); overload;
  351.     procedure FillRect(const Rect: TRect);
  352.     procedure FloodFill(X, Y: Integer; Color: TColor; FillStyle: TFillStyle);
  353.     procedure FrameRect(const Rect: TRect);
  354.     procedure LineTo(X, Y: Integer);
  355.     procedure Lock;
  356.     procedure MoveTo(X, Y: Integer);
  357.     procedure Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
  358.     procedure Polygon(const Points: array of TPoint);
  359.     procedure Polyline(const Points: array of TPoint);
  360.     procedure PolyBezier(const Points: array of TPoint);
  361.     procedure PolyBezierTo(const Points: array of TPoint);
  362.     procedure Rectangle(X1, Y1, X2, Y2: Integer); overload;
  363.     procedure Rectangle(const Rect: TRect); overload;
  364.     procedure Refresh;
  365.     procedure RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer);
  366.     procedure StretchDraw(const Rect: TRect; Graphic: TGraphic);
  367.     function TextExtent(const Text: string): TSize;
  368.     function TextHeight(const Text: string): Integer;
  369.     procedure TextOut(X, Y: Integer; const Text: string);
  370.     procedure TextRect(Rect: TRect; X, Y: Integer; const Text: string);
  371.     function TextWidth(const Text: string): Integer;
  372.     function TryLock: Boolean;
  373.     procedure Unlock;
  374.     property ClipRect: TRect read GetClipRect;
  375.     property Handle: HDC read GetHandle write SetHandle;
  376.     property LockCount: Integer read FLockCount;
  377.     property CanvasOrientation: TCanvasOrientation read GetCanvasOrientation;
  378.     property PenPos: TPoint read GetPenPos write SetPenPos;
  379.     property Pixels[X, Y: Integer]: TColor read GetPixel write SetPixel;
  380.     property TextFlags: Longint read FTextFlags write FTextFlags;
  381.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  382.     property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
  383.   published
  384.     property Brush: TBrush read FBrush write SetBrush;
  385.     property CopyMode: TCopyMode read FCopyMode write FCopyMode default cmSrcCopy;
  386.     property Font: TFont read FFont write SetFont;
  387.     property Pen: TPen read FPen write SetPen;
  388.   end;
  389.  
  390.   { TProgressEvent is a generic progress notification event which may be
  391.         used by TGraphic classes with computationally intensive (slow)
  392.         operations, such as loading, storing, or transforming image data.
  393.     Event params:
  394.       Stage - Indicates whether this call to the OnProgress event is to
  395.         prepare for, process, or clean up after a graphic operation.  If
  396.         OnProgress is called at all, the first call for a graphic operation
  397.         will be with Stage = psStarting, to allow the OnProgress event handler
  398.         to allocate whatever resources it needs to process subsequent progress
  399.         notifications.  After Stage = psStarting, you are guaranteed that
  400.         OnProgress will be called again with Stage = psEnding to allow you
  401.         to free those resources, even if the graphic operation is aborted by
  402.         an exception.  Zero or more calls to OnProgress with Stage = psRunning
  403.         may occur between the psStarting and psEnding calls.
  404.       PercentDone - The ratio of work done to work remaining, on a scale of
  405.         0 to 100.  Values may repeat or even regress (get smaller) in
  406.         successive calls.  PercentDone is usually only a guess, and the
  407.         guess may be dramatically altered as new information is discovered
  408.         in decoding the image.
  409.       RedrawNow - Indicates whether the graphic can be/should be redrawn
  410.         immediately.  Useful for showing successive approximations of
  411.         an image as data is available instead of waiting for all the data
  412.         to arrive before drawing anything.  Since there is no message loop
  413.         activity during graphic operations, you should call Update to force
  414.         a control to be redrawn immediately in the OnProgress event handler.
  415.         Redrawing a graphic when RedrawNow = False could corrupt the image
  416.         and/or cause exceptions.
  417.       Rect - Area of image that has changed and needs to be redrawn.
  418.       Msg - Optional text describing in one or two words what the graphic
  419.         class is currently working on.  Ex:  "Loading" "Storing"
  420.         "Reducing colors".  The Msg string can also be empty.
  421.         Msg strings should be resourced for translation,  should not
  422.         contain trailing periods, and should be used only for
  423.         display purposes.  (do not: if Msg = 'Loading' then...)
  424.   }
  425.  
  426.   TProgressStage = (psStarting, psRunning, psEnding);
  427.   TProgressEvent = procedure (Sender: TObject; Stage: TProgressStage;
  428.     PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string) of object;
  429.  
  430.   { The TGraphic class is a abstract base class for dealing with graphic images
  431.     such as metafile, bitmaps, icons, and other image formats.
  432.       LoadFromFile - Read the graphic from the file system.  The old contents of
  433.         the graphic are lost.  If the file is not of the right format, an
  434.         exception will be generated.
  435.       SaveToFile - Writes the graphic to disk in the file provided.
  436.       LoadFromStream - Like LoadFromFile except source is a stream (e.g.
  437.         TBlobStream).
  438.       SaveToStream - stream analogue of SaveToFile.
  439.       LoadFromClipboardFormat - Replaces the current image with the data
  440.         provided.  If the TGraphic does not support that format it will generate
  441.         an exception.
  442.       SaveToClipboardFormats - Converts the image to a clipboard format.  If the
  443.         image does not support being translated into a clipboard format it
  444.         will generate an exception.
  445.       Height - The native, unstretched, height of the graphic.
  446.       Palette - Color palette of image.  Zero if graphic doesn't need/use palettes.
  447.       Transparent - Image does not completely cover its rectangular area
  448.       Width - The native, unstretched, width of the graphic.
  449.       OnChange - Called whenever the graphic changes
  450.       PaletteModified - Indicates in OnChange whether color palette has changed.
  451.         Stays true until whoever's responsible for realizing this new palette
  452.         (ex: TImage) sets it to False.
  453.       OnProgress - Generic progress indicator event. Propagates out to TPicture
  454.         and TImage OnProgress events.}
  455.  
  456.   TGraphic = class(TPersistent)
  457.   private
  458.     FOnChange: TNotifyEvent;
  459.     FOnProgress: TProgressEvent;
  460.     FModified: Boolean;
  461.     FTransparent: Boolean;
  462.     FPaletteModified: Boolean;
  463.     procedure SetModified(Value: Boolean);
  464.   protected
  465.     constructor Create; virtual;
  466.     procedure Changed(Sender: TObject); virtual;
  467.     procedure DefineProperties(Filer: TFiler); override;
  468.     procedure Draw(ACanvas: TCanvas; const Rect: TRect); virtual; abstract;
  469.     function Equals(Graphic: TGraphic): Boolean; virtual;
  470.     function GetEmpty: Boolean; virtual; abstract;
  471.     function GetHeight: Integer; virtual; abstract;
  472.     function GetPalette: HPALETTE; virtual;
  473.     function GetTransparent: Boolean; virtual;
  474.     function GetWidth: Integer; virtual; abstract;
  475.     procedure Progress(Sender: TObject; Stage: TProgressStage;
  476.       PercentDone: Byte;  RedrawNow: Boolean; const R: TRect; const Msg: string); dynamic;
  477.     procedure ReadData(Stream: TStream); virtual;
  478.     procedure SetHeight(Value: Integer); virtual; abstract;
  479.     procedure SetPalette(Value: HPALETTE); virtual;
  480.     procedure SetTransparent(Value: Boolean); virtual;
  481.     procedure SetWidth(Value: Integer); virtual; abstract;
  482.     procedure WriteData(Stream: TStream); virtual;
  483.   public
  484.     procedure LoadFromFile(const Filename: string); virtual;
  485.     procedure SaveToFile(const Filename: string); virtual;
  486.     procedure LoadFromStream(Stream: TStream); virtual; abstract;
  487.     procedure SaveToStream(Stream: TStream); virtual; abstract;
  488.     procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  489.       APalette: HPALETTE); virtual; abstract;
  490.     procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  491.       var APalette: HPALETTE); virtual; abstract;
  492.     property Empty: Boolean read GetEmpty;
  493.     property Height: Integer read GetHeight write SetHeight;
  494.     property Modified: Boolean read FModified write SetModified;
  495.     property Palette: HPALETTE read GetPalette write SetPalette;
  496.     property PaletteModified: Boolean read FPaletteModified write FPaletteModified;
  497.     property Transparent: Boolean read GetTransparent write SetTransparent;
  498.     property Width: Integer read GetWidth write SetWidth;
  499.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  500.     property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
  501.   end;
  502.  
  503.   TGraphicClass = class of TGraphic;
  504.  
  505.   { TPicture }
  506.   { TPicture is a TGraphic container.  It is used in place of a TGraphic if the
  507.     graphic can be of any TGraphic class.  LoadFromFile and SaveToFile are
  508.     polymorphic. For example, if the TPicture is holding an Icon, you can
  509.     LoadFromFile a bitmap file, where if the class was TIcon you could only read
  510.     .ICO files.
  511.       LoadFromFile - Reads a picture from disk.  The TGraphic class created
  512.         determined by the file extension of the file.  If the file extension is
  513.         not recognized an exception is generated.
  514.       SaveToFile - Writes the picture to disk.
  515.       LoadFromClipboardFormat - Reads the picture from the handle provided in
  516.         the given clipboard format.  If the format is not supported, an
  517.         exception is generated.
  518.       SaveToClipboardFormats - Allocates a global handle and writes the picture
  519.         in its native clipboard format (CF_BITMAP for bitmaps, CF_METAFILE
  520.         for metafiles, etc.).  Formats will contain the formats written.
  521.         Returns the number of clipboard items written to the array pointed to
  522.         by Formats and Datas or would be written if either Formats or Datas are
  523.         nil.
  524.       SupportsClipboardFormat - Returns true if the given clipboard format
  525.         is supported by LoadFromClipboardFormat.
  526.       Assign - Copys the contents of the given TPicture.  Used most often in
  527.         the implementation of TPicture properties.
  528.       RegisterFileFormat - Register a new TGraphic class for use in
  529.         LoadFromFile.
  530.       RegisterClipboardFormat - Registers a new TGraphic class for use in
  531.         LoadFromClipboardFormat.
  532.       UnRegisterGraphicClass - Removes all references to the specified TGraphic
  533.         class and all its descendents from the file format and clipboard format
  534.         internal lists.
  535.       Height - The native, unstretched, height of the picture.
  536.       Width - The native, unstretched, width of the picture.
  537.       Graphic - The TGraphic object contained by the TPicture
  538.       Bitmap - Returns a bitmap.  If the contents is not already a bitmap, the
  539.         contents are thrown away and a blank bitmap is returned.
  540.       Icon - Returns an icon.  If the contents is not already an icon, the
  541.         contents are thrown away and a blank icon is returned.
  542.       Metafile - Returns a metafile.  If the contents is not already a metafile,
  543.         the contents are thrown away and a blank metafile is returned. }
  544.   TPicture = class(TPersistent)
  545.   private
  546.     FGraphic: TGraphic;
  547.     FOnChange: TNotifyEvent;
  548.     FNotify: IChangeNotifier;
  549.     FOnProgress: TProgressEvent;
  550.     procedure ForceType(GraphicType: TGraphicClass);
  551.     function GetBitmap: TBitmap;
  552.     function GetHeight: Integer;
  553.     function GetIcon: TIcon;
  554.     function GetMetafile: TMetafile;
  555.     function GetWidth: Integer;
  556.     procedure ReadData(Stream: TStream);
  557.     procedure SetBitmap(Value: TBitmap);
  558.     procedure SetGraphic(Value: TGraphic);
  559.     procedure SetIcon(Value: TIcon);
  560.     procedure SetMetafile(Value: TMetafile);
  561.     procedure WriteData(Stream: TStream);
  562.   protected
  563.     procedure AssignTo(Dest: TPersistent); override;
  564.     procedure Changed(Sender: TObject); dynamic;
  565.     procedure Progress(Sender: TObject; Stage: TProgressStage;
  566.       PercentDone: Byte;  RedrawNow: Boolean; const R: TRect; const Msg: string); dynamic;
  567.     procedure DefineProperties(Filer: TFiler); override;
  568.   public
  569.     constructor Create;
  570.     destructor Destroy; override;
  571.     procedure LoadFromFile(const Filename: string);
  572.     procedure SaveToFile(const Filename: string);
  573.     procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  574.       APalette: HPALETTE);
  575.     procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  576.       var APalette: HPALETTE);
  577.     class function SupportsClipboardFormat(AFormat: Word): Boolean;
  578.     procedure Assign(Source: TPersistent); override;
  579.     class procedure RegisterFileFormat(const AExtension, ADescription: string;
  580.       AGraphicClass: TGraphicClass);
  581.     class procedure RegisterFileFormatRes(const AExtension: String;
  582.       ADescriptionResID: Integer; AGraphicClass: TGraphicClass);
  583.     class procedure RegisterClipboardFormat(AFormat: Word;
  584.       AGraphicClass: TGraphicClass);
  585.     class procedure UnregisterGraphicClass(AClass: TGraphicClass);
  586.     property Bitmap: TBitmap read GetBitmap write SetBitmap;
  587.     property Graphic: TGraphic read FGraphic write SetGraphic;
  588.     property PictureAdapter: IChangeNotifier read FNotify write FNotify;
  589.     property Height: Integer read GetHeight;
  590.     property Icon: TIcon read GetIcon write SetIcon;
  591.     property Metafile: TMetafile read GetMetafile write SetMetafile;
  592.     property Width: Integer read GetWidth;
  593.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  594.     property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
  595.   end;
  596.  
  597.   { TMetafile }
  598.   { TMetafile is an encapsulation of the Win32 Enhanced metafile.
  599.       Handle - The metafile handle.
  600.       Enhanced - determines how the metafile will be stored on disk.
  601.         Enhanced = True (default) stores as EMF (Win32 Enhanced Metafile),
  602.         Enhanced = False stores as WMF (Windows 3.1 Metafile, with Aldus header).
  603.         The in-memory format is always EMF.  WMF has very limited capabilities;
  604.         storing as WMF will lose information that would be retained by EMF.
  605.         This property is set to match the metafile type when loaded from a
  606.         stream or file.  This maintains form file compatibility with 16 bit
  607.         Delphi (If loaded as WMF, then save as WMF).
  608.       Inch - The units per inch assumed by a WMF metafile.  Used to alter
  609.         scale when writing as WMF, but otherwise this property is obsolete.
  610.         Enhanced metafiles maintain complete scale information internally.
  611.       MMWidth,
  612.       MMHeight: Width and Height in 0.01 millimeter units, the native
  613.         scale used by enhanced metafiles.  The Width and Height properties
  614.         are always in screen device pixel units; you can avoid loss of
  615.         precision in converting between device pixels and mm by setting
  616.         or reading the dimentions in mm with these two properties.
  617.       CreatedBy - Optional name of the author or application used to create
  618.         the metafile.
  619.       Description - Optional text description of the metafile.
  620.       You can set the CreatedBy and Description of a new metafile by calling
  621.       TMetafileCanvas.CreateWithComment.
  622.  
  623.     TMetafileCanvas
  624.       To create a metafile image from scratch, you must draw the image in
  625.       a metafile canvas.  When the canvas is destroyed, it transfers the
  626.       image into the metafile object provided to the canvas constructor.
  627.       After the image is drawn on the canvas and the canvas is destroyed,
  628.       the image is 'playable' in the metafile object.  Like this:
  629.  
  630.       MyMetafile := TMetafile.Create;
  631.       MyMetafile.Width := 200;
  632.       MyMetafile.Height := 200;
  633.       with TMetafileCanvas.Create(MyMetafile, 0) do
  634.       try
  635.         Brush.Color := clRed;
  636.         Ellipse(0,0,100,100);
  637.         ...
  638.       finally
  639.         Free;
  640.       end;
  641.       Form1.Canvas.Draw(0,0,MyMetafile);  (* 1 red circle  *)
  642.  
  643.       To add to an existing metafile image, create a metafile canvas
  644.       and play the source metafile into the metafile canvas.  Like this:
  645.  
  646.       (* continued from previous example, so MyMetafile contains an image *)
  647.       with TMetafileCanvas.Create(MyMetafile, 0) do
  648.       try
  649.         Draw(0,0,MyMetafile);
  650.         Brush.Color := clBlue;
  651.         Ellipse(100,100,200,200);
  652.         ...
  653.       finally
  654.         Free;
  655.       end;
  656.       Form1.Canvas.Draw(0,0,MyMetafile);  (* 1 red circle and 1 blue circle *)
  657.   }
  658.  
  659.   TMetafileCanvas = class(TCanvas)
  660.   private
  661.     FMetafile: TMetafile;
  662.   public
  663.     constructor Create(AMetafile: TMetafile; ReferenceDevice: HDC);
  664.     constructor CreateWithComment(AMetafile: TMetafile; ReferenceDevice: HDC;
  665.       const CreatedBy, Description: String);
  666.     destructor Destroy; override;
  667.   end;
  668.  
  669.   TSharedImage = class
  670.   private
  671.     FRefCount: Integer;
  672.   protected
  673.     procedure Reference;
  674.     procedure Release;
  675.     procedure FreeHandle; virtual; abstract;
  676.     property RefCount: Integer read FRefCount;
  677.   end;
  678.  
  679.   TMetafileImage = class(TSharedImage)
  680.   private
  681.     FHandle: HENHMETAFILE;
  682.     FWidth: Integer;      // FWidth and FHeight are in 0.01 mm logical pixels
  683.     FHeight: Integer;     // These are converted to device pixels in TMetafile
  684.     FPalette: HPALETTE;
  685.     FInch: Word;          // Used only when writing WMF files.
  686.     FTempWidth: Integer;  // FTempWidth and FTempHeight are in device pixels
  687.     FTempHeight: Integer; // Used only when width/height are set when FHandle = 0
  688.   protected
  689.     procedure FreeHandle; override;
  690.   public
  691.     destructor Destroy; override;
  692.   end;
  693.  
  694.   TMetafile = class(TGraphic)
  695.   private
  696.     FImage: TMetafileImage;
  697.     FEnhanced: Boolean;
  698.     function GetAuthor: String;
  699.     function GetDesc: String;
  700.     function GetHandle: HENHMETAFILE;
  701.     function GetInch: Word;
  702.     function GetMMHeight: Integer;
  703.     function GetMMWidth: Integer;
  704.     procedure NewImage;
  705.     procedure SetHandle(Value: HENHMETAFILE);
  706.     procedure SetInch(Value: Word);
  707.     procedure SetMMHeight(Value: Integer);
  708.     procedure SetMMWidth(Value: Integer);
  709.     procedure UniqueImage;
  710.   protected
  711.     function GetEmpty: Boolean; override;
  712.     function GetHeight: Integer; override;
  713.     function GetPalette: HPALETTE; override;
  714.     function GetWidth: Integer; override;
  715.     procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
  716.     procedure ReadData(Stream: TStream); override;
  717.     procedure ReadEMFStream(Stream: TStream);
  718.     procedure ReadWMFStream(Stream: TStream; Length: Longint);
  719.     procedure SetHeight(Value: Integer); override;
  720.     procedure SetTransparent(Value: Boolean); override;
  721.     procedure SetWidth(Value: Integer); override;
  722.     function  TestEMF(Stream: TStream): Boolean;
  723.     procedure WriteData(Stream: TStream); override;
  724.     procedure WriteEMFStream(Stream: TStream);
  725.     procedure WriteWMFStream(Stream: TStream);
  726.   public
  727.     constructor Create; override;
  728.     destructor Destroy; override;
  729.     procedure Clear;
  730.     procedure LoadFromStream(Stream: TStream); override;
  731.     procedure SaveToFile(const Filename: String); override;
  732.     procedure SaveToStream(Stream: TStream); override;
  733.     procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  734.       APalette: HPALETTE); override;
  735.     procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  736.       var APalette: HPALETTE); override;
  737.     procedure Assign(Source: TPersistent); override;
  738.     function ReleaseHandle: HENHMETAFILE;
  739.     property CreatedBy: String read GetAuthor;
  740.     property Description: String read GetDesc;
  741.     property Enhanced: Boolean read FEnhanced write FEnhanced default True;
  742.     property Handle: HENHMETAFILE read GetHandle write SetHandle;
  743.     property MMWidth: Integer read GetMMWidth write SetMMWidth;
  744.     property MMHeight: Integer read GetMMHeight write SetMMHeight;
  745.     property Inch: Word read GetInch write SetInch;
  746.   end;
  747.  
  748.   { TBitmap }
  749.   { TBitmap is an encapsulation of a Windows HBITMAP and HPALETTE.  It manages
  750.     the palette realizing automatically as well as having a Canvas to allow
  751.     modifications to the image.  Creating copies of a TBitmap is very fast
  752.     since the handle is copied not the image.  If the image is modified, and
  753.     the handle is shared by more than one TBitmap object, the image is copied
  754.     before the modification is performed (i.e. copy on write).
  755.       Canvas - Allows drawing on the bitmap.
  756.       Handle - The HBITMAP encapsulated by the TBitmap.  Grabbing the handle
  757.         directly should be avoided since it causes the HBITMAP to be copied if
  758.         more than one TBitmap share the handle.
  759.       Palette - The HPALETTE realized by the TBitmap.  Grabbing this handle
  760.         directly should be avoided since it causes the HPALETTE to be copied if
  761.         more than one TBitmap share the handle.
  762.       Monochrome - True if the bitmap is a monochrome bitmap }
  763.  
  764.   TBitmapImage = class(TSharedImage)
  765.   private
  766.     FHandle: HBITMAP;     // DDB or DIB handle, used for drawing
  767.     FMaskHandle: HBITMAP; // DDB handle
  768.     FPalette: HPALETTE;
  769.     FDIBHandle: HBITMAP;  // DIB handle corresponding to TDIBSection
  770.     FDIB: TDIBSection;
  771.     FSaveStream: TMemoryStream; // Save original RLE stream until image is modified
  772.     FOS2Format: Boolean;  // Write BMP file header, color table in OS/2 format
  773.     FHalftone: Boolean;   // FPalette is halftone; don't write to file
  774.   protected
  775.     procedure FreeHandle; override;
  776.   public
  777.     destructor Destroy; override;
  778.   end;
  779.  
  780.   TBitmapHandleType = (bmDIB, bmDDB);
  781.   TPixelFormat = (pfDevice, pf1bit, pf4bit, pf8bit, pf15bit, pf16bit, pf24bit, pf32bit, pfCustom);
  782.   TTransparentMode = (tmAuto, tmFixed);
  783.  
  784.   TBitmap = class(TGraphic)
  785.   private
  786.     FImage: TBitmapImage;
  787.     FCanvas: TCanvas;
  788.     FIgnorePalette: Boolean;
  789.     FMaskBitsValid: Boolean;
  790.     FMaskValid: Boolean;
  791.     FTransparentColor: TColor;
  792.     FTransparentMode: TTransparentMode;
  793.     procedure Changing(Sender: TObject);
  794.     procedure CopyImage(AHandle: HBITMAP; APalette: HPALETTE; DIB: TDIBSection);
  795.     procedure DIBNeeded;
  796.     procedure FreeContext;
  797.     function GetCanvas: TCanvas;
  798.     function GetHandle: HBITMAP; virtual;
  799.     function GetHandleType: TBitmapHandleType;
  800.     function GetMaskHandle: HBITMAP; virtual;
  801.     function GetMonochrome: Boolean;
  802.     function GetPixelFormat: TPixelFormat;
  803.     function GetScanline(Row: Integer): Pointer;
  804.     function GetTransparentColor: TColor;
  805.     procedure NewImage(NewHandle: HBITMAP; NewPalette: HPALETTE;
  806.       const NewDIB: TDIBSection; OS2Format: Boolean; RLEStream: TStream = nil);
  807.     procedure ReadStream(Stream: TStream; Size: Longint);
  808.     procedure ReadDIB(Stream: TStream; ImageSize: LongWord);
  809.     procedure SetHandle(Value: HBITMAP);
  810.     procedure SetHandleType(Value: TBitmapHandleType); virtual;
  811.     procedure SetMaskHandle(Value: HBITMAP);
  812.     procedure SetMonochrome(Value: Boolean);
  813.     procedure SetPixelFormat(Value: TPixelFormat);
  814.     procedure SetTransparentColor(Value: TColor);
  815.     procedure SetTransparentMode(Value: TTransparentMode);
  816.     function TransparentColorStored: Boolean;
  817.     procedure WriteStream(Stream: TStream; WriteSize: Boolean);
  818.   protected
  819.     procedure Changed(Sender: TObject); override;
  820.     procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
  821.     function GetEmpty: Boolean; override;
  822.     function GetHeight: Integer; override;
  823.     function GetPalette: HPALETTE; override;
  824.     function GetWidth: Integer; override;
  825.     procedure HandleNeeded;
  826.     procedure MaskHandleNeeded;
  827.     procedure PaletteNeeded;
  828.     procedure ReadData(Stream: TStream); override;
  829.     procedure SetHeight(Value: Integer); override;
  830.     procedure SetPalette(Value: HPALETTE); override;
  831.     procedure SetWidth(Value: Integer); override;
  832.     procedure WriteData(Stream: TStream); override;
  833.   public
  834.     constructor Create; override;
  835.     destructor Destroy; override;
  836.     procedure Assign(Source: TPersistent); override;
  837.     procedure Dormant;
  838.     procedure FreeImage;
  839.     procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  840.       APalette: HPALETTE); override;
  841.     procedure LoadFromStream(Stream: TStream); override;
  842.     procedure LoadFromResourceName(Instance: THandle; const ResName: String);
  843.     procedure LoadFromResourceID(Instance: THandle; ResID: Integer);
  844.     procedure Mask(TransparentColor: TColor);
  845.     function ReleaseHandle: HBITMAP;
  846.     function ReleaseMaskHandle: HBITMAP;
  847.     function ReleasePalette: HPALETTE;
  848.     procedure SaveToClipboardFormat(var Format: Word; var Data: THandle;
  849.       var APalette: HPALETTE); override;
  850.     procedure SaveToStream(Stream: TStream); override;
  851.     property Canvas: TCanvas read GetCanvas;
  852.     property Handle: HBITMAP read GetHandle write SetHandle;
  853.     property HandleType: TBitmapHandleType read GetHandleType write SetHandleType;
  854.     property IgnorePalette: Boolean read FIgnorePalette write FIgnorePalette;
  855.     property MaskHandle: HBITMAP read GetMaskHandle write SetMaskHandle;
  856.     property Monochrome: Boolean read GetMonochrome write SetMonochrome;
  857.     property PixelFormat: TPixelFormat read GetPixelFormat write SetPixelFormat;
  858.     property ScanLine[Row: Integer]: Pointer read GetScanLine;
  859.     property TransparentColor: TColor read GetTransparentColor
  860.       write SetTransparentColor stored TransparentColorStored;
  861.     property TransparentMode: TTransparentMode read FTransparentMode
  862.       write SetTransparentMode default tmAuto;
  863.   end;
  864.  
  865.   { TIcon }
  866.   { TIcon encapsulates window HICON handle. Drawing of an icon does not stretch
  867.     so calling stretch draw is not meaningful.
  868.       Handle - The HICON used by the TIcon. }
  869.  
  870.   TIconImage = class(TSharedImage)
  871.   private
  872.     FHandle: HICON;
  873.     FMemoryImage: TCustomMemoryStream;
  874.     FSize: TPoint;
  875.   protected
  876.     procedure FreeHandle; override;
  877.   public
  878.     destructor Destroy; override;
  879.   end;
  880.  
  881.   TIcon = class(TGraphic)
  882.   private
  883.     FImage: TIconImage;
  884.     FRequestedSize: TPoint;
  885.     function GetHandle: HICON;
  886.     procedure HandleNeeded;
  887.     procedure ImageNeeded;
  888.     procedure NewImage(NewHandle: HICON; NewImage: TMemoryStream);
  889.     procedure SetHandle(Value: HICON);
  890.   protected
  891.     procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
  892.     function GetEmpty: Boolean; override;
  893.     function GetHeight: Integer; override;
  894.     function GetWidth: Integer; override;
  895.     procedure SetHeight(Value: Integer); override;
  896.     procedure SetTransparent(Value: Boolean); override;
  897.     procedure SetWidth(Value: Integer); override;
  898.   public
  899.     constructor Create; override;
  900.     destructor Destroy; override;
  901.     procedure Assign(Source: TPersistent); override;
  902.     procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  903.       APalette: HPALETTE); override;
  904.     procedure LoadFromStream(Stream: TStream); override;
  905.     function ReleaseHandle: HICON;
  906.     procedure SaveToClipboardFormat(var Format: Word; var Data: THandle;
  907.       var APalette: HPALETTE); override;
  908.     procedure SaveToStream(Stream: TStream); override;
  909.     property Handle: HICON read GetHandle write SetHandle;
  910.   end;
  911.  
  912. var    // New TFont instances are intialized with the values in this structure:
  913.   DefFontData: TFontData = (
  914.     Handle: 0;
  915.     Height: 0;
  916.     Pitch: fpDefault;
  917.     Style: [];
  918.     Charset : DEFAULT_CHARSET;
  919.     Name: 'MS Sans Serif');
  920.  
  921.  
  922. var
  923.   SystemPalette16: HPalette; // 16 color palette that maps to the system palette
  924.  
  925. var
  926.   DDBsOnly: Boolean = False; // True = Load all BMPs as device bitmaps.
  927.                              // Not recommended.
  928.  
  929. function GraphicFilter(GraphicClass: TGraphicClass): string;
  930. function GraphicExtension(GraphicClass: TGraphicClass): string;
  931. function GraphicFileMask(GraphicClass: TGraphicClass): string;
  932.  
  933. function ColorToRGB(Color: TColor): Longint;
  934. function ColorToString(Color: TColor): string;
  935. function StringToColor(const S: string): TColor;
  936. procedure GetColorValues(Proc: TGetStrProc);
  937. function ColorToIdent(Color: Longint; var Ident: string): Boolean;
  938. function IdentToColor(const Ident: string; var Color: Longint): Boolean;
  939. procedure GetCharsetValues(Proc: TGetStrProc);
  940. function CharsetToIdent(Charset: Longint; var Ident: string): Boolean;
  941. function IdentToCharset(const Ident: string; var Charset: Longint): Boolean;
  942.  
  943. procedure GetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: DWORD;
  944.   var ImageSize: DWORD);
  945. function GetDIB(Bitmap: HBITMAP; Palette: HPALETTE; var BitmapInfo; var Bits): Boolean;
  946.  
  947. function CopyPalette(Palette: HPALETTE): HPALETTE;
  948.  
  949. procedure PaletteChanged;
  950. procedure FreeMemoryContexts;
  951.  
  952. function GetDefFontCharSet: TFontCharSet;
  953.  
  954. function TransparentStretchBlt(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
  955.   SrcDC: HDC; SrcX, SrcY, SrcW, SrcH: Integer; MaskDC: HDC; MaskX,
  956.   MaskY: Integer): Boolean;
  957.  
  958. function CreateMappedBmp(Handle: HBITMAP; const OldColors, NewColors: array of TColor): HBITMAP;
  959. function CreateMappedRes(Instance: THandle; ResName: PChar; const OldColors, NewColors: array of TColor): HBITMAP;
  960. function CreateGrayMappedBmp(Handle: HBITMAP): HBITMAP;
  961. function CreateGrayMappedRes(Instance: THandle; ResName: PChar): HBITMAP;
  962.  
  963. function AllocPatternBitmap(BkColor, FgColor: TColor): TBitmap;
  964.  
  965. // Alignment must be a power of 2.  Color BMPs require DWORD alignment (32).
  966. function BytesPerScanline(PixelsPerScanline, BitsPerPixel, Alignment: Longint): Longint;
  967.  
  968. implementation
  969.  
  970. { Things left out
  971.   ---------------
  972.   Regions
  973.   PatBlt
  974.   Tabbed text
  975.   Clipping regions
  976.   Coordinate transformations
  977.   Paths
  978.   Beziers }
  979.  
  980. uses Consts;
  981.  
  982. const
  983.   csAllValid = [csHandleValid..csBrushValid];
  984.  
  985. var
  986.   ScreenLogPixels: Integer;
  987.   StockPen: HPEN;
  988.   StockBrush: HBRUSH;
  989.   StockFont: HFONT;
  990.   StockIcon: HICON;
  991.   BitmapImageLock: TRTLCriticalSection;
  992.   CounterLock: TRTLCriticalSection;
  993.  
  994. procedure InternalDeletePalette(Pal: HPalette);
  995. begin
  996.   if (Pal <> 0) and (Pal <> SystemPalette16) then
  997.     DeleteObject(Pal);
  998. end;
  999.  
  1000. { Resource managers }
  1001.  
  1002. const
  1003.   ResInfoSize = SizeOf(TResource) - SizeOf(TFontData);
  1004.  
  1005. type
  1006.   TResourceManager = class(TObject)
  1007.     ResList: PResource;
  1008.     FLock: TRTLCriticalSection;
  1009.     ResDataSize: Word;
  1010.     constructor Create(AResDataSize: Word);
  1011.     destructor Destroy; override;
  1012.     function AllocResource(const ResData): PResource;
  1013.     procedure FreeResource(Resource: PResource);
  1014.     procedure ChangeResource(GraphicsObject: TGraphicsObject; const ResData);
  1015.     procedure AssignResource(GraphicsObject: TGraphicsObject;
  1016.       AResource: PResource);
  1017.     procedure Lock;
  1018.     procedure Unlock;
  1019.   end;
  1020.  
  1021. var
  1022.   FontManager: TResourceManager;
  1023.   PenManager: TResourceManager;
  1024.   BrushManager: TResourceManager;
  1025.  
  1026. function GetHashCode(const Buffer; Count: Integer): Word; assembler;
  1027. asm
  1028.         MOV     ECX,EDX
  1029.         MOV     EDX,EAX
  1030.         XOR     EAX,EAX
  1031. @@1:    ROL     AX,5
  1032.         XOR     AL,[EDX]
  1033.         INC     EDX
  1034.         DEC     ECX
  1035.         JNE     @@1
  1036. end;
  1037.  
  1038. constructor TResourceManager.Create(AResDataSize: Word);
  1039. begin
  1040.   ResDataSize := AResDataSize;
  1041.   InitializeCriticalSection(FLock);
  1042. end;
  1043.  
  1044. destructor TResourceManager.Destroy;
  1045. begin
  1046.   DeleteCriticalSection(FLock);
  1047. end;
  1048.  
  1049. procedure TResourceManager.Lock;
  1050. begin
  1051.   EnterCriticalSection(FLock);
  1052. end;
  1053.  
  1054. procedure TResourceManager.Unlock;
  1055. begin
  1056.   LeaveCriticalSection(FLock);
  1057. end;
  1058.  
  1059. function TResourceManager.AllocResource(const ResData): PResource;
  1060. var
  1061.   ResHash: Word;
  1062. begin
  1063.   ResHash := GetHashCode(ResData, ResDataSize);
  1064.   Lock;
  1065.   try
  1066.     Result := ResList;
  1067.     while (Result <> nil) and ((Result^.HashCode <> ResHash) or
  1068.       not CompareMem(@Result^.Data, @ResData, ResDataSize)) do
  1069.       Result := Result^.Next;
  1070.     if Result = nil then
  1071.     begin
  1072.       GetMem(Result, ResDataSize + ResInfoSize);
  1073.       with Result^ do
  1074.       begin
  1075.         Next := ResList;
  1076.         RefCount := 0;
  1077.         Handle := TResData(ResData).Handle;
  1078.         HashCode := ResHash;
  1079.         Move(ResData, Data, ResDataSize);
  1080.       end;
  1081.       ResList := Result;
  1082.     end;
  1083.     Inc(Result^.RefCount);
  1084.   finally
  1085.     Unlock;
  1086.   end;
  1087. end;
  1088.  
  1089. procedure TResourceManager.FreeResource(Resource: PResource);
  1090. var
  1091.   P: PResource;
  1092.   DeleteIt: Boolean;
  1093. begin
  1094.   if Resource <> nil then
  1095.     with Resource^ do
  1096.     begin
  1097.       Lock;
  1098.       try
  1099.         Dec(RefCount);
  1100.         DeleteIt := RefCount = 0;
  1101.         if DeleteIt then
  1102.         begin
  1103.           if Resource = ResList then
  1104.             ResList := Resource^.Next
  1105.           else
  1106.           begin
  1107.             P := ResList;
  1108.             while P^.Next <> Resource do P := P^.Next;
  1109.             P^.Next := Resource^.Next;
  1110.           end;
  1111.         end;
  1112.       finally
  1113.         Unlock;
  1114.       end;
  1115.       if DeleteIt then
  1116.       begin  // this is outside the critsect to minimize lock time
  1117.         if Handle <> 0 then DeleteObject(Handle);
  1118.         FreeMem(Resource);
  1119.       end;
  1120.     end;
  1121. end;
  1122.  
  1123. procedure TResourceManager.ChangeResource(GraphicsObject: TGraphicsObject;
  1124.   const ResData);
  1125. var
  1126.   P: PResource;
  1127. begin
  1128.   Lock;
  1129.   try  // prevent changes to GraphicsObject.FResource pointer between steps
  1130.     P := GraphicsObject.FResource;
  1131.     GraphicsObject.FResource := AllocResource(ResData);
  1132.     if GraphicsObject.FResource <> P then GraphicsObject.Changed;
  1133.     FreeResource(P);
  1134.   finally
  1135.     Unlock;
  1136.   end;
  1137. end;
  1138.  
  1139. procedure TResourceManager.AssignResource(GraphicsObject: TGraphicsObject;
  1140.   AResource: PResource);
  1141. var
  1142.   P: PResource;
  1143. begin
  1144.   Lock;
  1145.   try
  1146.     P := GraphicsObject.FResource;
  1147.     if P <> AResource then
  1148.     begin
  1149.       Inc(AResource^.RefCount);
  1150.       GraphicsObject.FResource := AResource;
  1151.       GraphicsObject.Changed;
  1152.       FreeResource(P);
  1153.     end;
  1154.   finally
  1155.     Unlock;
  1156.   end;
  1157. end;
  1158.  
  1159. var
  1160.   CanvasList: TThreadList;
  1161.  
  1162. procedure PaletteChanged;
  1163.  
  1164.   procedure ClearColor(ResMan: TResourceManager);
  1165.   var
  1166.     Resource: PResource;
  1167.   begin
  1168.     ResMan.Lock;
  1169.     try
  1170.       Resource := ResMan.ResList;
  1171.       while Resource <> nil do
  1172.       begin
  1173.         with Resource^ do
  1174.         { Assumes Pen.Color and Brush.Color share the same location }
  1175.           if (Handle <> 0) and (Pen.Color < 0) then
  1176.           begin
  1177.             DeleteObject(Handle);
  1178.             Handle := 0;
  1179.           end;
  1180.         Resource := Resource^.Next;
  1181.       end;
  1182.     finally
  1183.       ResMan.Unlock;
  1184.     end;
  1185.   end;
  1186.  
  1187. var
  1188.   I,J: Integer;
  1189. begin
  1190.   { Called when the system palette has changed (WM_SYSCOLORCHANGE) }
  1191.   I := 0;
  1192.   with CanvasList.LockList do
  1193.   try
  1194.     while I < Count do
  1195.     begin
  1196.       with TCanvas(Items[I]) do
  1197.       begin
  1198.         Lock;
  1199.         Inc(I);
  1200.         DeselectHandles;
  1201.       end;
  1202.     end;
  1203.     ClearColor(PenManager);
  1204.     ClearColor(BrushManager);
  1205.   finally
  1206.     for J := 0 to I-1 do  // Only unlock the canvases we actually locked
  1207.       TCanvas(Items[J]).Unlock;
  1208.     CanvasList.UnlockList;
  1209.   end;
  1210. end;
  1211.  
  1212. { Color mapping routines }
  1213.  
  1214. const
  1215.   Colors: array[0..41] of TIdentMapEntry = (
  1216.     (Value: clBlack; Name: 'clBlack'),
  1217.     (Value: clMaroon; Name: 'clMaroon'),
  1218.     (Value: clGreen; Name: 'clGreen'),
  1219.     (Value: clOlive; Name: 'clOlive'),
  1220.     (Value: clNavy; Name: 'clNavy'),
  1221.     (Value: clPurple; Name: 'clPurple'),
  1222.     (Value: clTeal; Name: 'clTeal'),
  1223.     (Value: clGray; Name: 'clGray'),
  1224.     (Value: clSilver; Name: 'clSilver'),
  1225.     (Value: clRed; Name: 'clRed'),
  1226.     (Value: clLime; Name: 'clLime'),
  1227.     (Value: clYellow; Name: 'clYellow'),
  1228.     (Value: clBlue; Name: 'clBlue'),
  1229.     (Value: clFuchsia; Name: 'clFuchsia'),
  1230.     (Value: clAqua; Name: 'clAqua'),
  1231.     (Value: clWhite; Name: 'clWhite'),
  1232.     (Value: clScrollBar; Name: 'clScrollBar'),
  1233.     (Value: clBackground; Name: 'clBackground'),
  1234.     (Value: clActiveCaption; Name: 'clActiveCaption'),
  1235.     (Value: clInactiveCaption; Name: 'clInactiveCaption'),
  1236.     (Value: clMenu; Name: 'clMenu'),
  1237.     (Value: clWindow; Name: 'clWindow'),
  1238.     (Value: clWindowFrame; Name: 'clWindowFrame'),
  1239.     (Value: clMenuText; Name: 'clMenuText'),
  1240.     (Value: clWindowText; Name: 'clWindowText'),
  1241.     (Value: clCaptionText; Name: 'clCaptionText'),
  1242.     (Value: clActiveBorder; Name: 'clActiveBorder'),
  1243.     (Value: clInactiveBorder; Name: 'clInactiveBorder'),
  1244.     (Value: clAppWorkSpace; Name: 'clAppWorkSpace'),
  1245.     (Value: clHighlight; Name: 'clHighlight'),
  1246.     (Value: clHighlightText; Name: 'clHighlightText'),
  1247.     (Value: clBtnFace; Name: 'clBtnFace'),
  1248.     (Value: clBtnShadow; Name: 'clBtnShadow'),
  1249.     (Value: clGrayText; Name: 'clGrayText'),
  1250.     (Value: clBtnText; Name: 'clBtnText'),
  1251.     (Value: clInactiveCaptionText; Name: 'clInactiveCaptionText'),
  1252.     (Value: clBtnHighlight; Name: 'clBtnHighlight'),
  1253.     (Value: cl3DDkShadow; Name: 'cl3DDkShadow'),
  1254.     (Value: cl3DLight; Name: 'cl3DLight'),
  1255.     (Value: clInfoText; Name: 'clInfoText'),
  1256.     (Value: clInfoBk; Name: 'clInfoBk'),
  1257.     (Value: clNone; Name: 'clNone'));
  1258.  
  1259. function ColorToRGB(Color: TColor): Longint;
  1260. begin
  1261.   if Color < 0 then
  1262.     Result := GetSysColor(Color and $000000FF) else
  1263.     Result := Color;
  1264. end;
  1265.  
  1266. function ColorToString(Color: TColor): string;
  1267. begin
  1268.   if not ColorToIdent(Color, Result) then
  1269.     FmtStr(Result, '%s%.8x', [HexDisplayPrefix, Color]);
  1270. end;
  1271.  
  1272. function StringToColor(const S: string): TColor;
  1273. begin
  1274.   if not IdentToColor(S, Longint(Result)) then
  1275.     Result := TColor(StrToInt(S));
  1276. end;
  1277.  
  1278. procedure GetColorValues(Proc: TGetStrProc);
  1279. var
  1280.   I: Integer;
  1281. begin
  1282.   for I := Low(Colors) to High(Colors) do Proc(Colors[I].Name);
  1283. end;
  1284.  
  1285. function ColorToIdent(Color: Longint; var Ident: string): Boolean;
  1286. begin
  1287.   Result := IntToIdent(Color, Ident, Colors);
  1288. end;
  1289.  
  1290. function IdentToColor(const Ident: string; var Color: Longint): Boolean;
  1291. begin
  1292.   Result := IdentToInt(Ident, Color, Colors);
  1293. end;
  1294.  
  1295. { TGraphicsObject }
  1296.  
  1297. procedure TGraphicsObject.Changed;
  1298. begin
  1299.   if Assigned(FOnChange) then FOnChange(Self);
  1300. end;
  1301.  
  1302. procedure TGraphicsObject.Lock;
  1303. begin
  1304.   if Assigned(FOwnerLock) then EnterCriticalSection(FOwnerLock^);
  1305. end;
  1306.  
  1307. procedure TGraphicsObject.Unlock;
  1308. begin
  1309.   if Assigned(FOwnerLock) then LeaveCriticalSection(FOwnerLock^);
  1310. end;
  1311.  
  1312. { TFont }
  1313.  
  1314. const
  1315.   FontCharsets: array[0..17] of TIdentMapEntry = (
  1316.     (Value: 0; Name: 'ANSI_CHARSET'),
  1317.     (Value: 1; Name: 'DEFAULT_CHARSET'),
  1318.     (Value: 2; Name: 'SYMBOL_CHARSET'),
  1319.     (Value: 77; Name: 'MAC_CHARSET'),
  1320.     (Value: 128; Name: 'SHIFTJIS_CHARSET'),
  1321.     (Value: 129; Name: 'HANGEUL_CHARSET'),
  1322.     (Value: 130; Name: 'JOHAB_CHARSET'),
  1323.     (Value: 134; Name: 'GB2312_CHARSET'),
  1324.     (Value: 136; Name: 'CHINESEBIG5_CHARSET'),
  1325.     (Value: 161; Name: 'GREEK_CHARSET'),
  1326.     (Value: 162; Name: 'TURKISH_CHARSET'),
  1327.     (Value: 177; Name: 'HEBREW_CHARSET'),
  1328.     (Value: 178; Name: 'ARABIC_CHARSET'),
  1329.     (Value: 186; Name: 'BALTIC_CHARSET'),
  1330.     (Value: 204; Name: 'RUSSIAN_CHARSET'),
  1331.     (Value: 222; Name: 'THAI_CHARSET'),
  1332.     (Value: 238; Name: 'EASTEUROPE_CHARSET'),
  1333.     (Value: 255; Name: 'OEM_CHARSET'));
  1334.  
  1335. procedure GetCharsetValues(Proc: TGetStrProc);
  1336. var
  1337.   I: Integer;
  1338. begin
  1339.   for I := Low(FontCharsets) to High(FontCharsets) do Proc(FontCharsets[I].Name);
  1340. end;
  1341.  
  1342. function CharsetToIdent(Charset: Longint; var Ident: string): Boolean;
  1343. begin
  1344.   Result := IntToIdent(Charset, Ident, FontCharsets);
  1345. end;
  1346.  
  1347. function IdentToCharset(const Ident: string; var Charset: Longint): Boolean;
  1348. begin
  1349.   Result := IdentToInt(Ident, CharSet, FontCharsets);
  1350. end;
  1351.  
  1352. function GetFontData(Font: HFont): TFontData;
  1353. var
  1354.   LogFont: TLogFont;
  1355. begin
  1356.   Result := DefFontData;
  1357.   if Font <> 0 then
  1358.   begin
  1359.     if GetObject(Font, SizeOf(LogFont), @LogFont) <> 0 then
  1360.     with Result, LogFont do
  1361.     begin
  1362.       Height := lfHeight;
  1363.       if lfWeight >= FW_BOLD then
  1364.         Include(Style, fsBold);
  1365.       if lfItalic = 1 then
  1366.         Include(Style, fsItalic);
  1367.       if lfUnderline = 1 then
  1368.         Include(Style, fsUnderline);
  1369.       if lfStrikeOut = 1 then
  1370.         Include(Style, fsStrikeOut);
  1371.       Charset := TFontCharset(lfCharSet);
  1372.       Name := lfFaceName;
  1373.       case lfPitchAndFamily and $F of
  1374.         VARIABLE_PITCH: Pitch := fpVariable;
  1375.         FIXED_PITCH: Pitch := fpFixed;
  1376.       else
  1377.         Pitch := fpDefault;
  1378.       end;
  1379.       Handle := Font;
  1380.     end;
  1381.   end;
  1382. end;
  1383.  
  1384. constructor TFont.Create;
  1385. begin
  1386.   DefFontData.Handle := 0;
  1387.   FResource := FontManager.AllocResource(DefFontData);
  1388.   FColor := clWindowText;
  1389.   FPixelsPerInch := ScreenLogPixels;
  1390. end;
  1391.  
  1392. destructor TFont.Destroy;
  1393. begin
  1394.   FontManager.FreeResource(FResource);
  1395. end;
  1396.  
  1397. procedure TFont.Changed;
  1398. begin
  1399.   inherited Changed;
  1400.   if FNotify <> nil then FNotify.Changed;
  1401. end;
  1402.  
  1403. procedure TFont.Assign(Source: TPersistent);
  1404. begin
  1405.   if Source is TFont then
  1406.   begin
  1407.     Lock;
  1408.     try
  1409.       TFont(Source).Lock;
  1410.       try
  1411.         FontManager.AssignResource(Self, TFont(Source).FResource);
  1412.         Color := TFont(Source).Color;
  1413.         if PixelsPerInch <> TFont(Source).PixelsPerInch then
  1414.           Size := TFont(Source).Size;
  1415.       finally
  1416.         TFont(Source).Unlock;
  1417.       end;
  1418.     finally
  1419.       Unlock;
  1420.     end;
  1421.     Exit;
  1422.   end;
  1423.   inherited Assign(Source);
  1424. end;
  1425.  
  1426. procedure TFont.GetData(var FontData: TFontData);
  1427. begin
  1428.   FontData := FResource^.Font;
  1429.   FontData.Handle := 0;
  1430. end;
  1431.  
  1432. procedure TFont.SetData(const FontData: TFontData);
  1433. begin
  1434.   Lock;
  1435.   try
  1436.     FontManager.ChangeResource(Self, FontData);
  1437.   finally
  1438.     Unlock;
  1439.   end;
  1440. end;
  1441.  
  1442. procedure TFont.SetColor(Value: TColor);
  1443. begin
  1444.   if FColor <> Value then
  1445.   begin
  1446.     FColor := Value;
  1447.     Changed;
  1448.   end;
  1449. end;
  1450.  
  1451. function TFont.GetHandle: HFont;
  1452. var
  1453.   LogFont: TLogFont;
  1454. begin
  1455.   with FResource^ do
  1456.   begin
  1457.     if Handle = 0 then
  1458.     begin
  1459.       FontManager.Lock;
  1460.       with LogFont do
  1461.       try
  1462.         if Handle = 0 then
  1463.         begin
  1464.           lfHeight := Font.Height;
  1465.           lfWidth := 0; { have font mapper choose }
  1466.           lfEscapement := 0; { only straight fonts }
  1467.           lfOrientation := 0; { no rotation }
  1468.           if fsBold in Font.Style then
  1469.             lfWeight := FW_BOLD
  1470.           else
  1471.             lfWeight := FW_NORMAL;
  1472.           lfItalic := Byte(fsItalic in Font.Style);
  1473.           lfUnderline := Byte(fsUnderline in Font.Style);
  1474.           lfStrikeOut := Byte(fsStrikeOut in Font.Style);
  1475.           lfCharSet := Byte(Font.Charset);
  1476.           if AnsiCompareText(Font.Name, 'Default') = 0 then  // do not localize
  1477.             StrPCopy(lfFaceName, DefFontData.Name)
  1478.           else
  1479.             StrPCopy(lfFaceName, Font.Name);
  1480.           lfQuality := DEFAULT_QUALITY;
  1481.           { Everything else as default }
  1482.           lfOutPrecision := OUT_DEFAULT_PRECIS;
  1483.           lfClipPrecision := CLIP_DEFAULT_PRECIS;
  1484.           case Pitch of
  1485.             fpVariable: lfPitchAndFamily := VARIABLE_PITCH;
  1486.             fpFixed: lfPitchAndFamily := FIXED_PITCH;
  1487.           else
  1488.             lfPitchAndFamily := DEFAULT_PITCH;
  1489.           end;
  1490.           Handle := CreateFontIndirect(LogFont);
  1491.         end;
  1492.       finally
  1493.         FontManager.Unlock;
  1494.       end;
  1495.     end;
  1496.     Result := Handle;
  1497.   end;
  1498. end;
  1499.  
  1500. procedure TFont.SetHandle(Value: HFont);
  1501. begin
  1502.   SetData(GetFontData(Value));
  1503. end;
  1504.  
  1505. function TFont.GetHeight: Integer;
  1506. begin
  1507.   Result := FResource^.Font.Height;
  1508. end;
  1509.  
  1510. procedure TFont.SetHeight(Value: Integer);
  1511. var
  1512.   FontData: TFontData;
  1513. begin
  1514.   GetData(FontData);
  1515.   FontData.Height := Value;
  1516.   SetData(FontData);
  1517. end;
  1518.  
  1519. function TFont.GetName: TFontName;
  1520. begin
  1521.   Result := FResource^.Font.Name;
  1522. end;
  1523.  
  1524. procedure TFont.SetName(const Value: TFontName);
  1525. var
  1526.   FontData: TFontData;
  1527. begin
  1528.   if Value <> '' then
  1529.   begin
  1530.     GetData(FontData);
  1531.     FillChar(FontData.Name, SizeOf(FontData.Name), 0);
  1532.     FontData.Name := Value;
  1533.     SetData(FontData);
  1534.   end;
  1535. end;
  1536.  
  1537. function TFont.GetSize: Integer;
  1538. begin
  1539.   Result := -MulDiv(Height, 72, FPixelsPerInch);
  1540. end;
  1541.  
  1542. procedure TFont.SetSize(Value: Integer);
  1543. begin
  1544.   Height := -MulDiv(Value, FPixelsPerInch, 72);
  1545. end;
  1546.  
  1547. function TFont.GetStyle: TFontStyles;
  1548. begin
  1549.   Result := FResource^.Font.Style;
  1550. end;
  1551.  
  1552. procedure TFont.SetStyle(Value: TFontStyles);
  1553. var
  1554.   FontData: TFontData;
  1555. begin
  1556.   GetData(FontData);
  1557.   FontData.Style := Value;
  1558.   SetData(FontData);
  1559. end;
  1560.  
  1561. function TFont.GetPitch: TFontPitch;
  1562. begin
  1563.   Result := FResource^.Font.Pitch;
  1564. end;
  1565.  
  1566. procedure TFont.SetPitch(Value: TFontPitch);
  1567. var
  1568.   FontData: TFontData;
  1569. begin
  1570.   GetData(FontData);
  1571.   FontData.Pitch := Value;
  1572.   SetData(FontData);
  1573. end;
  1574.  
  1575. function TFont.GetCharset: TFontCharset;
  1576. begin
  1577.   Result := FResource^.Font.Charset;
  1578. end;
  1579.  
  1580. procedure TFont.SetCharset(Value: TFontCharset);
  1581. var
  1582.   FontData: TFontData;
  1583. begin
  1584.   GetData(FontData);
  1585.   FontData.Charset := Value;
  1586.   SetData(FontData);
  1587. end;
  1588.  
  1589. { TPen }
  1590.  
  1591. const
  1592.   DefPenData: TPenData = (
  1593.     Handle: 0;
  1594.     Color: clBlack;
  1595.     Width: 1;
  1596.     Style: psSolid);
  1597.  
  1598. constructor TPen.Create;
  1599. begin
  1600.   FResource := PenManager.AllocResource(DefPenData);
  1601.   FMode := pmCopy;
  1602. end;
  1603.  
  1604. destructor TPen.Destroy;
  1605. begin
  1606.   PenManager.FreeResource(FResource);
  1607. end;
  1608.  
  1609. procedure TPen.Assign(Source: TPersistent);
  1610. begin
  1611.   if Source is TPen then
  1612.   begin
  1613.     Lock;
  1614.     try
  1615.       TPen(Source).Lock;
  1616.       try
  1617.         PenManager.AssignResource(Self, TPen(Source).FResource);
  1618.         SetMode(TPen(Source).FMode);
  1619.       finally
  1620.         TPen(Source).Unlock;
  1621.       end;
  1622.     finally
  1623.       Unlock;
  1624.     end;
  1625.     Exit;
  1626.   end;
  1627.   inherited Assign(Source);
  1628. end;
  1629.  
  1630. procedure TPen.GetData(var PenData: TPenData);
  1631. begin
  1632.   PenData := FResource^.Pen;
  1633.   PenData.Handle := 0;
  1634. end;
  1635.  
  1636. procedure TPen.SetData(const PenData: TPenData);
  1637. begin
  1638.   Lock;
  1639.   try
  1640.     PenManager.ChangeResource(Self, PenData);
  1641.   finally
  1642.     Unlock;
  1643.   end;
  1644. end;
  1645.  
  1646. function TPen.GetColor: TColor;
  1647. begin
  1648.   Result := FResource^.Pen.Color;
  1649. end;
  1650.  
  1651. procedure TPen.SetColor(Value: TColor);
  1652. var
  1653.   PenData: TPenData;
  1654. begin
  1655.   GetData(PenData);
  1656.   PenData.Color := Value;
  1657.   SetData(PenData);
  1658. end;
  1659.  
  1660. function TPen.GetHandle: HPen;
  1661. const
  1662.   PenStyles: array[TPenStyle] of Word =
  1663.     (PS_SOLID, PS_DASH, PS_DOT, PS_DASHDOT, PS_DASHDOTDOT, PS_NULL,
  1664.      PS_INSIDEFRAME);
  1665. var
  1666.   LogPen: TLogPen;
  1667. begin
  1668.   with FResource^ do
  1669.   begin
  1670.     if Handle = 0 then
  1671.     begin
  1672.       PenManager.Lock;
  1673.       with LogPen do
  1674.       try
  1675.         if Handle = 0 then
  1676.         begin
  1677.           lopnStyle := PenStyles[Pen.Style];
  1678.           lopnWidth.X := Pen.Width;
  1679.           lopnColor := ColorToRGB(Pen.Color);
  1680.           Handle := CreatePenIndirect(LogPen);
  1681.         end;
  1682.       finally
  1683.         PenManager.Unlock;
  1684.       end;
  1685.     end;
  1686.     Result := Handle;
  1687.   end;
  1688. end;
  1689.  
  1690. procedure TPen.SetHandle(Value: HPen);
  1691. var
  1692.   PenData: TPenData;
  1693. begin
  1694.   PenData := DefPenData;
  1695.   PenData.Handle := Value;
  1696.   SetData(PenData);
  1697. end;
  1698.  
  1699. procedure TPen.SetMode(Value: TPenMode);
  1700. begin
  1701.   if FMode <> Value then
  1702.   begin
  1703.     FMode := Value;
  1704.     Changed;
  1705.   end;
  1706. end;
  1707.  
  1708. function TPen.GetStyle: TPenStyle;
  1709. begin
  1710.   Result := FResource^.Pen.Style;
  1711. end;
  1712.  
  1713. procedure TPen.SetStyle(Value: TPenStyle);
  1714. var
  1715.   PenData: TPenData;
  1716. begin
  1717.   GetData(PenData);
  1718.   PenData.Style := Value;
  1719.   SetData(PenData);
  1720. end;
  1721.  
  1722. function TPen.GetWidth: Integer;
  1723. begin
  1724.   Result := FResource^.Pen.Width;
  1725. end;
  1726.  
  1727. procedure TPen.SetWidth(Value: Integer);
  1728. var
  1729.   PenData: TPenData;
  1730. begin
  1731.   if Value >= 0 then
  1732.   begin
  1733.     GetData(PenData);
  1734.     PenData.Width := Value;
  1735.     SetData(PenData);
  1736.   end;
  1737. end;
  1738.  
  1739. { TBrush }
  1740.  
  1741. const
  1742.   DefBrushData: TBrushData = (
  1743.     Handle: 0;
  1744.     Color: clWhite;
  1745.     Bitmap: nil;
  1746.     Style: bsSolid);
  1747.  
  1748. constructor TBrush.Create;
  1749. begin
  1750.   FResource := BrushManager.AllocResource(DefBrushData);
  1751. end;
  1752.  
  1753. destructor TBrush.Destroy;
  1754. begin
  1755.   BrushManager.FreeResource(FResource);
  1756. end;
  1757.  
  1758. procedure TBrush.Assign(Source: TPersistent);
  1759. begin
  1760.   if Source is TBrush then
  1761.   begin
  1762.     Lock;
  1763.     try
  1764.       TBrush(Source).Lock;
  1765.       try
  1766.         BrushManager.AssignResource(Self, TBrush(Source).FResource);
  1767.       finally
  1768.         TBrush(Source).Unlock;
  1769.       end;
  1770.     finally
  1771.       Unlock;
  1772.     end;
  1773.     Exit;
  1774.   end;
  1775.   inherited Assign(Source);
  1776. end;
  1777.  
  1778. procedure TBrush.GetData(var BrushData: TBrushData);
  1779. begin
  1780.   BrushData := FResource^.Brush;
  1781.   BrushData.Handle := 0;
  1782.   BrushData.Bitmap := nil;
  1783. end;
  1784.  
  1785. procedure TBrush.SetData(const BrushData: TBrushData);
  1786. begin
  1787.   Lock;
  1788.   try
  1789.     BrushManager.ChangeResource(Self, BrushData);
  1790.   finally
  1791.     Unlock;
  1792.   end;
  1793. end;
  1794.  
  1795. function TBrush.GetBitmap: TBitmap;
  1796. begin
  1797.   Result := FResource^.Brush.Bitmap;
  1798. end;
  1799.  
  1800. procedure TBrush.SetBitmap(Value: TBitmap);
  1801. var
  1802.   BrushData: TBrushData;
  1803. begin
  1804.   BrushData := DefBrushData;
  1805.   BrushData.Bitmap := Value;
  1806.   SetData(BrushData);
  1807. end;
  1808.  
  1809. function TBrush.GetColor: TColor;
  1810. begin
  1811.   Result := FResource^.Brush.Color;
  1812. end;
  1813.  
  1814. procedure TBrush.SetColor(Value: TColor);
  1815. var
  1816.   BrushData: TBrushData;
  1817. begin
  1818.   GetData(BrushData);
  1819.   BrushData.Color := Value;
  1820.   if BrushData.Style = bsClear then BrushData.Style := bsSolid;
  1821.   SetData(BrushData);
  1822. end;
  1823.  
  1824. function TBrush.GetHandle: HBrush;
  1825. var
  1826.   LogBrush: TLogBrush;
  1827. begin
  1828.   with FResource^ do
  1829.   begin
  1830.     if Handle = 0 then
  1831.     begin
  1832.       BrushManager.Lock;
  1833.       try
  1834.         if Handle = 0 then
  1835.         begin
  1836.           with LogBrush do
  1837.           begin
  1838.             if Brush.Bitmap <> nil then
  1839.             begin
  1840.               lbStyle := BS_PATTERN;
  1841.               Brush.Bitmap.HandleType := bmDDB;
  1842.               lbHatch := Brush.Bitmap.Handle;
  1843.             end else
  1844.             begin
  1845.               lbHatch := 0;
  1846.               case Brush.Style of
  1847.                 bsSolid: lbStyle := BS_SOLID;
  1848.                 bsClear: lbStyle := BS_HOLLOW;
  1849.               else
  1850.                 lbStyle := BS_HATCHED;
  1851.                 lbHatch := Ord(Brush.Style) - Ord(bsHorizontal);
  1852.               end;
  1853.             end;
  1854.             lbColor := ColorToRGB(Brush.Color);
  1855.           end;
  1856.           Handle := CreateBrushIndirect(LogBrush);
  1857.         end;
  1858.       finally
  1859.         BrushManager.Unlock;
  1860.       end;
  1861.     end;
  1862.     Result := Handle;
  1863.   end;
  1864. end;
  1865.  
  1866. procedure TBrush.SetHandle(Value: HBrush);
  1867. var
  1868.   BrushData: TBrushData;
  1869. begin
  1870.   BrushData := DefBrushData;
  1871.   BrushData.Handle := Value;
  1872.   SetData(BrushData);
  1873. end;
  1874.  
  1875. function TBrush.GetStyle: TBrushStyle;
  1876. begin
  1877.   Result := FResource^.Brush.Style;
  1878. end;
  1879.  
  1880. procedure TBrush.SetStyle(Value: TBrushStyle);
  1881. var
  1882.   BrushData: TBrushData;
  1883. begin
  1884.   GetData(BrushData);
  1885.   BrushData.Style := Value;
  1886.   if BrushData.Style = bsClear then BrushData.Color := clWhite;
  1887.   SetData(BrushData);
  1888. end;
  1889.  
  1890. { TCanvas }
  1891.  
  1892. constructor TCanvas.Create;
  1893. begin
  1894.   inherited Create;
  1895.   InitializeCriticalSection(FLock);
  1896.   FFont := TFont.Create;
  1897.   FFont.OnChange := FontChanged;
  1898.   FFont.OwnerCriticalSection := @FLock;
  1899.   FPen := TPen.Create;
  1900.   FPen.OnChange := PenChanged;
  1901.   FPen.OwnerCriticalSection := @FLock;
  1902.   FBrush := TBrush.Create;
  1903.   FBrush.OnChange := BrushChanged;
  1904.   FBrush.OwnerCriticalSection := @FLock;
  1905.   FCopyMode := cmSrcCopy;
  1906.   State := [];
  1907.   CanvasList.Add(Self);
  1908. end;
  1909.  
  1910. destructor TCanvas.Destroy;
  1911. begin
  1912.   CanvasList.Remove(Self);
  1913.   SetHandle(0);
  1914.   FFont.Free;
  1915.   FPen.Free;
  1916.   FBrush.Free;
  1917.   DeleteCriticalSection(FLock);
  1918.   inherited Destroy;
  1919. end;
  1920.  
  1921. procedure TCanvas.Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
  1922. begin
  1923.   Changing;
  1924.   RequiredState([csHandleValid, csPenValid, csBrushValid]);
  1925.   Windows.Arc(FHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4);
  1926.   Changed;
  1927. end;
  1928.  
  1929. procedure TCanvas.BrushCopy(const Dest: TRect; Bitmap: TBitmap;
  1930.   const Source: TRect; Color: TColor);
  1931. const
  1932.   ROP_DSPDxax = $00E20746;
  1933. var
  1934.   SrcW, SrcH, DstW, DstH: Integer;
  1935.   crBack, crText: TColorRef;
  1936.   MaskDC: HDC;
  1937.   Mask: TBitmap;
  1938.   MaskHandle: HBITMAP;
  1939. begin
  1940.   if Bitmap = nil then Exit;
  1941.   Lock;
  1942.   try
  1943.     Changing;
  1944.     RequiredState([csHandleValid, csBrushValid]);
  1945.     Bitmap.Canvas.Lock;
  1946.     try
  1947.       DstW := Dest.Right - Dest.Left;
  1948.       DstH := Dest.Bottom - Dest.Top;
  1949.       SrcW := Source.Right - Source.Left;
  1950.       SrcH := Source.Bottom - Source.Top;
  1951.  
  1952.       if Bitmap.TransparentColor = Color then
  1953.       begin
  1954.         Mask := nil;
  1955.         MaskHandle := Bitmap.MaskHandle;
  1956.         MaskDC := CreateCompatibleDC(0);
  1957.         MaskHandle := SelectObject(MaskDC, MaskHandle);
  1958.       end
  1959.       else
  1960.       begin
  1961.         Mask := TBitmap.Create;
  1962.         Mask.Assign(Bitmap);
  1963.         { Replace Color with black and all other colors with white }
  1964.         Mask.Mask(Color);
  1965.         Mask.Canvas.RequiredState([csHandleValid]);
  1966.         MaskDC := Mask.Canvas.FHandle;
  1967.         MaskHandle := 0;
  1968.       end;
  1969.  
  1970.       try
  1971.         Bitmap.Canvas.RequiredState([csHandleValid]);
  1972.         { Draw transparently or use brush color to fill background }
  1973.         if Brush.Style = bsClear then
  1974.         begin
  1975.           TransparentStretchBlt(FHandle, Dest.Left, Dest.Top, DstW, DstH,
  1976.             Bitmap.Canvas.FHandle, Source.Left, Source.Top, SrcW, SrcH,
  1977.             MaskDC, Source.Left, Source.Top);
  1978.         end
  1979.         else
  1980.         begin
  1981.           StretchBlt(FHandle, Dest.Left, Dest.Top, DstW, DstH,
  1982.             Bitmap.Canvas.FHandle, Source.Left, Source.Top, SrcW, SrcH, SrcCopy);
  1983.           crText := SetTextColor(Self.FHandle, 0);
  1984.           crBack := SetBkColor(Self.FHandle, $FFFFFF);
  1985.           StretchBlt(Self.FHandle, Dest.Left, Dest.Top, DstW, DstH,
  1986.             MaskDC, Source.Left, Source.Top, SrcW, SrcH, ROP_DSPDxax);
  1987.           SetTextColor(Self.FHandle, crText);
  1988.           SetBkColor(Self.FHandle, crBack);
  1989.         end;
  1990.       finally
  1991.         if Assigned(Mask) then Mask.Free
  1992.         else
  1993.         begin
  1994.           if MaskHandle <> 0 then SelectObject(MaskDC, MaskHandle);
  1995.           DeleteDC(MaskDC);
  1996.         end;
  1997.       end;
  1998.     finally
  1999.       Bitmap.Canvas.Unlock;
  2000.     end;
  2001.     Changed;
  2002.   finally
  2003.     Unlock;
  2004.   end;
  2005. end;
  2006.  
  2007. procedure TCanvas.Chord(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
  2008. begin
  2009.   Changing;
  2010.   RequiredState([csHandleValid, csPenValid, csBrushValid]);
  2011.   Windows.Chord(FHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4);
  2012.   Changed;
  2013. end;
  2014.  
  2015. procedure TCanvas.CopyRect(const Dest: TRect; Canvas: TCanvas;
  2016.   const Source: TRect);
  2017. begin
  2018.   Changing;
  2019.   RequiredState([csHandleValid, csFontValid, csBrushValid]);
  2020.   Canvas.RequiredState([csHandleValid, csBrushValid]);
  2021.   StretchBlt(FHandle, Dest.Left, Dest.Top, Dest.Right - Dest.Left,
  2022.     Dest.Bottom - Dest.Top, Canvas.FHandle, Source.Left, Source.Top,
  2023.     Source.Right - Source.Left, Source.Bottom - Source.Top, CopyMode);
  2024.   Changed;
  2025. end;
  2026.  
  2027. procedure TCanvas.Draw(X, Y: Integer; Graphic: TGraphic);
  2028. begin
  2029.   if (Graphic <> nil) and not Graphic.Empty then
  2030.   begin
  2031.     Changing;
  2032.     RequiredState([csHandleValid]);
  2033.     SetBkColor(FHandle, ColorToRGB(FBrush.Color));
  2034.     SetTextColor(FHandle, ColorToRGB(FFont.Color));
  2035.     Graphic.Draw(Self, Rect(X, Y, X + Graphic.Width, Y + Graphic.Height));
  2036.     Changed;
  2037.   end;
  2038. end;
  2039.  
  2040. procedure TCanvas.DrawFocusRect(const Rect: TRect);
  2041. begin
  2042.   Changing;
  2043.   RequiredState([csHandleValid, csBrushValid]);
  2044.   Windows.DrawFocusRect(FHandle, Rect);
  2045.   Changed;
  2046. end;
  2047.  
  2048. procedure TCanvas.Ellipse(X1, Y1, X2, Y2: Integer);
  2049. begin
  2050.   Changing;
  2051.   RequiredState([csHandleValid, csPenValid, csBrushValid]);
  2052.   Windows.Ellipse(FHandle, X1, Y1, X2, Y2);
  2053.   Changed;
  2054. end;
  2055.  
  2056. procedure TCanvas.Ellipse(const Rect: TRect);
  2057. begin
  2058.   Ellipse(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);
  2059. end;
  2060.  
  2061. procedure TCanvas.FillRect(const Rect: TRect);
  2062. begin
  2063.   Changing;
  2064.   RequiredState([csHandleValid, csBrushValid]);
  2065.   Windows.FillRect(FHandle, Rect, Brush.GetHandle);
  2066.   Changed;
  2067. end;
  2068.  
  2069. procedure TCanvas.FloodFill(X, Y: Integer; Color: TColor;
  2070.   FillStyle: TFillStyle);
  2071. const
  2072.   FillStyles: array[TFillStyle] of Word =
  2073.     (FLOODFILLSURFACE, FLOODFILLBORDER);
  2074. begin
  2075.   Changing;
  2076.   RequiredState([csHandleValid, csBrushValid]);
  2077.   Windows.ExtFloodFill(FHandle, X, Y, Color, FillStyles[FillStyle]);
  2078.   Changed;
  2079. end;
  2080.  
  2081. procedure TCanvas.FrameRect(const Rect: TRect);
  2082. begin
  2083.   Changing;
  2084.   RequiredState([csHandleValid, csBrushValid]);
  2085.   Windows.FrameRect(FHandle, Rect, Brush.GetHandle);
  2086.   Changed;
  2087. end;
  2088.  
  2089. procedure TCanvas.LineTo(X, Y: Integer);
  2090. begin
  2091.   Changing;
  2092.   RequiredState([csHandleValid, csPenValid, csBrushValid]);
  2093.   Windows.LineTo(FHandle, X, Y);
  2094.   Changed;
  2095. end;
  2096.  
  2097. procedure TCanvas.Lock;
  2098. begin
  2099.   EnterCriticalSection(CounterLock);
  2100.   Inc(FLockCount);
  2101.   LeaveCriticalSection(CounterLock);
  2102.   EnterCriticalSection(FLock);
  2103. end;
  2104.  
  2105. procedure TCanvas.MoveTo(X, Y: Integer);
  2106. begin
  2107.   RequiredState([csHandleValid]);
  2108.   Windows.MoveToEx(FHandle, X, Y, nil);
  2109. end;
  2110.  
  2111. procedure TCanvas.Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
  2112. begin
  2113.   Changing;
  2114.   RequiredState([csHandleValid, csPenValid, csBrushValid]);
  2115.   Windows.Pie(FHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4);
  2116.   Changed;
  2117. end;
  2118.  
  2119. type
  2120.   PPoints = ^TPoints;
  2121.   TPoints = array[0..0] of TPoint;
  2122.  
  2123. procedure TCanvas.Polygon(const Points: array of TPoint);
  2124. begin
  2125.   Changing;
  2126.   RequiredState([csHandleValid, csPenValid, csBrushValid]);
  2127.   Windows.Polygon(FHandle, PPoints(@Points)^, High(Points) + 1);
  2128.   Changed;
  2129. end;
  2130.  
  2131. procedure TCanvas.Polyline(const Points: array of TPoint);
  2132. begin
  2133.   Changing;
  2134.   RequiredState([csHandleValid, csPenValid, csBrushValid]);
  2135.   Windows.Polyline(FHandle, PPoints(@Points)^, High(Points) + 1);
  2136.   Changed;
  2137. end;
  2138.  
  2139. procedure TCanvas.PolyBezier(const Points: array of TPoint);
  2140. begin
  2141.   Changing;
  2142.   RequiredState([csHandleValid, csPenValid, csBrushValid]);
  2143.   Windows.PolyBezier(FHandle, PPoints(@Points)^, High(Points) + 1);
  2144.   Changed;
  2145. end;
  2146.  
  2147. procedure TCanvas.PolyBezierTo(const Points: array of TPoint);
  2148. begin
  2149.   Changing;
  2150.   RequiredState([csHandleValid, csPenValid, csBrushValid]);
  2151.   Windows.PolyBezierTo(FHandle, PPoints(@Points)^, High(Points) + 1);
  2152.   Changed;
  2153. end;
  2154.  
  2155. procedure TCanvas.Rectangle(X1, Y1, X2, Y2: Integer);
  2156. begin
  2157.   Changing;
  2158.   RequiredState([csHandleValid, csBrushValid, csPenValid]);
  2159.   Windows.Rectangle(FHandle, X1, Y1, X2, Y2);
  2160.   Changed;
  2161. end;
  2162.  
  2163. procedure TCanvas.Rectangle(const Rect: TRect);
  2164. begin
  2165.   Rectangle(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);
  2166. end;
  2167.  
  2168. procedure TCanvas.Refresh;
  2169. begin
  2170.   DeselectHandles;
  2171. end;
  2172.  
  2173. procedure TCanvas.RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer);
  2174. begin
  2175.   Changing;
  2176.   RequiredState([csHandleValid, csBrushValid, csPenValid]);
  2177.   Windows.RoundRect(FHandle, X1, Y1, X2, Y2, X3, Y3);
  2178.   Changed;
  2179. end;
  2180.  
  2181. procedure TCanvas.StretchDraw(const Rect: TRect; Graphic: TGraphic);
  2182. begin
  2183.   if Graphic <> nil then
  2184.   begin
  2185.     Changing;
  2186.     RequiredState(csAllValid);
  2187.     Graphic.Draw(Self, Rect);
  2188.     Changed;
  2189.   end;
  2190. end;
  2191.  
  2192. function TCanvas.GetCanvasOrientation: TCanvasOrientation;
  2193. var
  2194.   Point: TPoint;
  2195. begin
  2196.   Result := coLeftToRight;
  2197.   if (FTextFlags and ETO_RTLREADING) <> 0 then
  2198.   begin
  2199.     GetWindowOrgEx(Handle, Point);
  2200.     if Point.X <> 0 then Result := coRightToLeft
  2201.   end;
  2202. end;
  2203.  
  2204. procedure TCanvas.TextOut(X, Y: Integer; const Text: String);
  2205. begin
  2206.   Changing;
  2207.   RequiredState([csHandleValid, csFontValid, csBrushValid]);
  2208.   if CanvasOrientation = coRightToLeft then Inc(X, TextWidth(Text) + 1);
  2209.   Windows.ExtTextOut(FHandle, X, Y, FTextFlags, nil, PChar(Text),
  2210.    Length(Text), nil);
  2211.   MoveTo(X + TextWidth(Text), Y);
  2212.   Changed;
  2213. end;
  2214.  
  2215. procedure TCanvas.TextRect(Rect: TRect; X, Y: Integer; const Text: string);
  2216. var
  2217.   Options: Longint;
  2218. begin
  2219.   Changing;
  2220.   RequiredState([csHandleValid, csFontValid, csBrushValid]);
  2221.   Options := ETO_CLIPPED or FTextFlags;
  2222.   if Brush.Style <> bsClear then Inc(Options, ETO_OPAQUE);
  2223.   if ((FTextFlags and ETO_RTLREADING) <> 0) and
  2224.      (CanvasOrientation = coRightToLeft) then Inc(X, TextWidth(Text) + 1);
  2225.   Windows.ExtTextOut(FHandle, X, Y, Options, @Rect, PChar(Text),
  2226.     Length(Text), nil);
  2227.   Changed;
  2228. end;
  2229.  
  2230. function TCanvas.TextExtent(const Text: string): TSize;
  2231. begin
  2232.   RequiredState([csHandleValid, csFontValid]);
  2233.   Result.cX := 0;
  2234.   Result.cY := 0;
  2235.   Windows.GetTextExtentPoint32(FHandle, PChar(Text), Length(Text), Result);
  2236. end;
  2237.  
  2238. function TCanvas.TextWidth(const Text: string): Integer;
  2239. begin
  2240.   Result := TextExtent(Text).cX;
  2241. end;
  2242.  
  2243. function TCanvas.TextHeight(const Text: string): Integer;
  2244. begin
  2245.   Result := TextExtent(Text).cY;
  2246. end;
  2247.  
  2248. function TCanvas.TryLock: Boolean;
  2249. begin
  2250.   EnterCriticalSection(CounterLock);
  2251.   try
  2252.     Result := FLockCount = 0;
  2253.     if Result then Lock;
  2254.   finally
  2255.     LeaveCriticalSection(CounterLock);
  2256.   end;
  2257. end;
  2258.  
  2259. procedure TCanvas.Unlock;
  2260. begin
  2261.   LeaveCriticalSection(FLock);
  2262.   EnterCriticalSection(CounterLock);
  2263.   Dec(FLockCount);
  2264.   LeaveCriticalSection(CounterLock);
  2265. end;
  2266.  
  2267. procedure TCanvas.SetFont(Value: TFont);
  2268. begin
  2269.   FFont.Assign(Value);
  2270. end;
  2271.  
  2272. procedure TCanvas.SetPen(Value: TPen);
  2273. begin
  2274.   FPen.Assign(Value);
  2275. end;
  2276.  
  2277. procedure TCanvas.SetBrush(Value: TBrush);
  2278. begin
  2279.   FBrush.Assign(Value);
  2280. end;
  2281.  
  2282. function TCanvas.GetPenPos: TPoint;
  2283. begin
  2284.   RequiredState([csHandleValid]);
  2285.   Windows.GetCurrentPositionEx(FHandle, @Result);
  2286. end;
  2287.  
  2288. procedure TCanvas.SetPenPos(Value: TPoint);
  2289. begin
  2290.   MoveTo(Value.X, Value.Y);
  2291. end;
  2292.  
  2293. function TCanvas.GetPixel(X, Y: Integer): TColor;
  2294. begin
  2295.   RequiredState([csHandleValid]);
  2296.   GetPixel := Windows.GetPixel(FHandle, X, Y);
  2297. end;
  2298.  
  2299. procedure TCanvas.SetPixel(X, Y: Integer; Value: TColor);
  2300. begin
  2301.   Changing;
  2302.   RequiredState([csHandleValid, csPenValid]);
  2303.   Windows.SetPixel(FHandle, X, Y, ColorToRGB(Value));
  2304.   Changed;
  2305. end;
  2306.  
  2307. function TCanvas.GetClipRect: TRect;
  2308. begin
  2309.   RequiredState([csHandleValid]);
  2310.   GetClipBox(FHandle, Result);
  2311. end;
  2312.  
  2313. function TCanvas.GetHandle: HDC;
  2314. begin
  2315.   Changing;
  2316.   RequiredState(csAllValid);
  2317.   Result := FHandle;
  2318. end;
  2319.  
  2320. procedure TCanvas.DeselectHandles;
  2321. begin
  2322.   if (FHandle <> 0) and (State - [csPenValid, csBrushValid, csFontValid] <> State) then
  2323.   begin
  2324.     SelectObject(FHandle, StockPen);
  2325.     SelectObject(FHandle, StockBrush);
  2326.     SelectObject(FHandle, StockFont);
  2327.     State := State - [csPenValid, csBrushValid, csFontValid];
  2328.   end;
  2329. end;
  2330.  
  2331. procedure TCanvas.CreateHandle;
  2332. begin
  2333. end;
  2334.  
  2335. procedure TCanvas.SetHandle(Value: HDC);
  2336. begin
  2337.   if FHandle <> Value then
  2338.   begin
  2339.     if FHandle <> 0 then
  2340.     begin
  2341.       DeselectHandles;
  2342.       FPenPos := GetPenPos;
  2343.       FHandle := 0;
  2344.       Exclude(State, csHandleValid);
  2345.     end;
  2346.     if Value <> 0 then
  2347.     begin
  2348.       Include(State, csHandleValid);
  2349.       FHandle := Value;
  2350.       SetPenPos(FPenPos);
  2351.     end;
  2352.   end;
  2353. end;
  2354.  
  2355. procedure TCanvas.RequiredState(ReqState: TCanvasState);
  2356. var
  2357.   NeededState: TCanvasState;
  2358. begin
  2359.   NeededState := ReqState - State;
  2360.   if NeededState <> [] then
  2361.   begin
  2362.     if csHandleValid in NeededState then
  2363.     begin
  2364.       CreateHandle;
  2365.       if FHandle = 0 then
  2366.         raise EInvalidOperation.CreateRes(@SNoCanvasHandle);
  2367.     end;
  2368.     if csFontValid in NeededState then CreateFont;
  2369.     if csPenValid in NeededState then CreatePen;
  2370.     if csBrushValid in NeededState then CreateBrush;
  2371.     State := State + NeededState;
  2372.   end;
  2373. end;
  2374.  
  2375. procedure TCanvas.Changing;
  2376. begin
  2377.   if Assigned(FOnChanging) then FOnChanging(Self);
  2378. end;
  2379.  
  2380. procedure TCanvas.Changed;
  2381. begin
  2382.   if Assigned(FOnChange) then FOnChange(Self);
  2383. end;
  2384.  
  2385. procedure TCanvas.CreateFont;
  2386. begin
  2387.   SelectObject(FHandle, Font.GetHandle);
  2388.   SetTextColor(FHandle, ColorToRGB(Font.Color));
  2389. end;
  2390.  
  2391. procedure TCanvas.CreatePen;
  2392. const
  2393.   PenModes: array[TPenMode] of Word =
  2394.     (R2_BLACK, R2_WHITE, R2_NOP, R2_NOT, R2_COPYPEN, R2_NOTCOPYPEN, R2_MERGEPENNOT,
  2395.      R2_MASKPENNOT, R2_MERGENOTPEN, R2_MASKNOTPEN, R2_MERGEPEN, R2_NOTMERGEPEN,
  2396.      R2_MASKPEN, R2_NOTMASKPEN, R2_XORPEN, R2_NOTXORPEN);
  2397. begin
  2398.   SelectObject(FHandle, Pen.GetHandle);
  2399.   SetROP2(FHandle, PenModes[Pen.Mode]);
  2400. end;
  2401.  
  2402. procedure TCanvas.CreateBrush;
  2403. begin
  2404.   UnrealizeObject(Brush.Handle);
  2405.   SelectObject(FHandle, Brush.Handle);
  2406.   if Brush.Style = bsSolid then
  2407.   begin
  2408.     SetBkColor(FHandle, ColorToRGB(Brush.Color));
  2409.     SetBkMode(FHandle, OPAQUE);
  2410.   end
  2411.   else
  2412.   begin
  2413.     { Win95 doesn't draw brush hatches if bkcolor = brush color }
  2414.     { Since bkmode is transparent, nothing should use bkcolor anyway }
  2415.     SetBkColor(FHandle, not ColorToRGB(Brush.Color));
  2416.     SetBkMode(FHandle, TRANSPARENT);
  2417.   end;
  2418. end;
  2419.  
  2420. procedure TCanvas.FontChanged(AFont: TObject);
  2421. begin
  2422.   if csFontValid in State then
  2423.   begin
  2424.     Exclude(State, csFontValid);
  2425.     SelectObject(FHandle, StockFont);
  2426.   end;
  2427. end;
  2428.  
  2429. procedure TCanvas.PenChanged(APen: TObject);
  2430. begin
  2431.   if csPenValid in State then
  2432.   begin
  2433.     Exclude(State, csPenValid);
  2434.     SelectObject(FHandle, StockPen);
  2435.   end;
  2436. end;
  2437.  
  2438. procedure TCanvas.BrushChanged(ABrush: TObject);
  2439. begin
  2440.   if csBrushValid in State then
  2441.   begin
  2442.     Exclude(State, csBrushValid);
  2443.     SelectObject(FHandle, StockBrush);
  2444.   end;
  2445. end;
  2446.  
  2447. { Picture support }
  2448.  
  2449. { Icon and cursor types }
  2450.  
  2451. const
  2452.   rc3_StockIcon = 0;
  2453.   rc3_Icon = 1;
  2454.   rc3_Cursor = 2;
  2455.  
  2456. type
  2457.   PCursorOrIcon = ^TCursorOrIcon;
  2458.   TCursorOrIcon = packed record
  2459.     Reserved: Word;
  2460.     wType: Word;
  2461.     Count: Word;
  2462.   end;
  2463.  
  2464.   PIconRec = ^TIconRec;
  2465.   TIconRec = packed record
  2466.     Width: Byte;
  2467.     Height: Byte;
  2468.     Colors: Word;
  2469.     Reserved1: Word;
  2470.     Reserved2: Word;
  2471.     DIBSize: Longint;
  2472.     DIBOffset: Longint;
  2473.   end;
  2474.  
  2475.  
  2476. { Metafile types }
  2477.  
  2478. const
  2479.   WMFKey = Integer($9AC6CDD7);
  2480.   WMFWord = $CDD7;
  2481.  
  2482. type
  2483.   PMetafileHeader = ^TMetafileHeader;
  2484.   TMetafileHeader = packed record
  2485.     Key: Longint;
  2486.     Handle: SmallInt;
  2487.     Box: TSmallRect;
  2488.     Inch: Word;
  2489.     Reserved: Longint;
  2490.     CheckSum: Word;
  2491.   end;
  2492.  
  2493. { Exception routines }
  2494.  
  2495. procedure InvalidOperation(Str: PResStringRec); 
  2496. begin
  2497.   raise EInvalidGraphicOperation.CreateRes(Str);
  2498. end;
  2499.  
  2500. procedure InvalidGraphic(Str: PResStringRec);
  2501. begin
  2502.   raise EInvalidGraphic.CreateRes(Str);
  2503. end;
  2504.  
  2505. procedure InvalidBitmap; 
  2506. begin
  2507.   InvalidGraphic(@SInvalidBitmap);
  2508. end;
  2509.  
  2510. procedure InvalidIcon;
  2511. begin
  2512.   InvalidGraphic(@SInvalidIcon);
  2513. end;
  2514.  
  2515. procedure InvalidMetafile;
  2516. begin
  2517.   InvalidGraphic(@SInvalidMetafile);
  2518. end;
  2519.  
  2520. procedure OutOfResources;
  2521. begin
  2522.   raise EOutOfResources.Create(SOutOfResources);
  2523. end;
  2524.  
  2525. procedure GDIError;
  2526. var
  2527.   ErrorCode: Integer;
  2528.   Buf: array [Byte] of Char;
  2529. begin
  2530.   ErrorCode := GetLastError;
  2531.   if (ErrorCode <> 0) and (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil,
  2532.     ErrorCode, LOCALE_USER_DEFAULT, Buf, sizeof(Buf), nil) <> 0) then
  2533.     raise EOutOfResources.Create(Buf)
  2534.   else
  2535.     OutOfResources;
  2536. end;
  2537.  
  2538. function GDICheck(Value: Integer): Integer;
  2539. begin
  2540.   if Value = 0 then GDIError;
  2541.   Result := Value;
  2542. end;
  2543.  
  2544. function DupBits(Src: HBITMAP; Size: TPoint; Mono: Boolean): HBITMAP;
  2545. var
  2546.   DC, Mem1, Mem2: HDC;
  2547.   Old1, Old2: HBITMAP;
  2548.   Bitmap: Windows.TBitmap;
  2549. begin
  2550.   Mem1 := CreateCompatibleDC(0);
  2551.   Mem2 := CreateCompatibleDC(0);
  2552.  
  2553.   try
  2554.     GetObject(Src, SizeOf(Bitmap), @Bitmap);
  2555.     if Mono then
  2556.       Result := CreateBitmap(Size.X, Size.Y, 1, 1, nil)
  2557.     else
  2558.     begin
  2559.       DC := GetDC(0);
  2560.       if DC = 0 then GDIError;
  2561.       try
  2562.         Result := CreateCompatibleBitmap(DC, Size.X, Size.Y);
  2563.         if Result = 0 then GDIError;
  2564.       finally
  2565.         ReleaseDC(0, DC);
  2566.       end;
  2567.     end;
  2568.  
  2569.     if Result <> 0 then
  2570.     begin
  2571.       Old1 := SelectObject(Mem1, Src);
  2572.       Old2 := SelectObject(Mem2, Result);
  2573.  
  2574.       StretchBlt(Mem2, 0, 0, Size.X, Size.Y, Mem1, 0, 0, Bitmap.bmWidth,
  2575.         Bitmap.bmHeight, SrcCopy);
  2576.       if Old1 <> 0 then SelectObject(Mem1, Old1);
  2577.       if Old2 <> 0 then SelectObject(Mem2, Old2);
  2578.     end;
  2579.   finally
  2580.     DeleteDC(Mem1);
  2581.     DeleteDC(Mem2);
  2582.   end;
  2583. end;
  2584.  
  2585. function GetDInColors(BitCount: Word): Integer;
  2586. begin
  2587.   case BitCount of
  2588.     1, 4, 8: Result := 1 shl BitCount;
  2589.   else
  2590.     Result := 0;
  2591.   end;
  2592. end;
  2593.  
  2594. function BytesPerScanline(PixelsPerScanline, BitsPerPixel, Alignment: Longint): Longint;
  2595. begin
  2596.   Dec(Alignment);
  2597.   Result := ((PixelsPerScanline * BitsPerPixel) + Alignment) and not Alignment;
  2598.   Result := Result div 8;
  2599. end;
  2600.  
  2601. function TransparentStretchBlt(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
  2602.   SrcDC: HDC; SrcX, SrcY, SrcW, SrcH: Integer; MaskDC: HDC; MaskX,
  2603.   MaskY: Integer): Boolean;
  2604. const
  2605.   ROP_DstCopy = $00AA0029;
  2606. var
  2607.   MemDC: HDC;
  2608.   MemBmp: HBITMAP;
  2609.   Save: THandle;
  2610.   crText, crBack: TColorRef;
  2611.   SavePal: HPALETTE;
  2612. begin
  2613.   Result := True;
  2614.   if (Win32Platform = VER_PLATFORM_WIN32_NT) and (SrcW = DstW) and (SrcH = DstH) then
  2615.   begin
  2616.     MemBmp := GDICheck(CreateCompatibleBitmap(SrcDC, 1, 1));
  2617.     MemBmp := SelectObject(MaskDC, MemBmp);
  2618.     try
  2619.       MaskBlt(DstDC, DstX, DstY, DstW, DstH, SrcDC, SrcX, SrcY, MemBmp, MaskX,
  2620.         MaskY, MakeRop4(ROP_DstCopy, SrcCopy));
  2621.     finally
  2622.       MemBmp := SelectObject(MaskDC, MemBmp);
  2623.       DeleteObject(MemBmp);
  2624.     end;
  2625.     Exit;
  2626.   end;
  2627.   SavePal := 0;
  2628.   MemDC := GDICheck(CreateCompatibleDC(0));
  2629.   try
  2630.     MemBmp := GDICheck(CreateCompatibleBitmap(SrcDC, SrcW, SrcH));
  2631.     Save := SelectObject(MemDC, MemBmp);
  2632.     SavePal := SelectPalette(SrcDC, SystemPalette16, False);
  2633.     SelectPalette(SrcDC, SavePal, False);
  2634.     if SavePal <> 0 then
  2635.       SavePal := SelectPalette(MemDC, SavePal, True)
  2636.     else
  2637.       SavePal := SelectPalette(MemDC, SystemPalette16, True);
  2638.     RealizePalette(MemDC);
  2639.  
  2640.     StretchBlt(MemDC, 0, 0, SrcW, SrcH, MaskDC, MaskX, MaskY, SrcW, SrcH, SrcCopy);
  2641.     StretchBlt(MemDC, 0, 0, SrcW, SrcH, SrcDC, SrcX, SrcY, SrcW, SrcH, SrcErase);
  2642.     crText := SetTextColor(DstDC, $0);
  2643.     crBack := SetBkColor(DstDC, $FFFFFF);
  2644.     StretchBlt(DstDC, DstX, DstY, DstW, DstH, MaskDC, MaskX, MaskY, SrcW, SrcH, SrcAnd);
  2645.     StretchBlt(DstDC, DstX, DstY, DstW, DstH, MemDC, 0, 0, SrcW, SrcH, SrcInvert);
  2646.     SetTextColor(DstDC, crText);
  2647.     SetBkColor(DstDC, crBack);
  2648.  
  2649.     if Save <> 0 then SelectObject(MemDC, Save);
  2650.     DeleteObject(MemBmp);
  2651.   finally
  2652.     if SavePal <> 0 then SelectPalette(MemDC, SavePal, False);
  2653.     DeleteDC(MemDC);
  2654.   end;
  2655. end;
  2656.  
  2657. type
  2658.   PRGBTripleArray = ^TRGBTripleArray;
  2659.   TRGBTripleArray = array [Byte] of TRGBTriple;
  2660.   PRGBQuadArray = ^TRGBQuadArray;
  2661.   TRGBQuadArray = array [Byte] of TRGBQuad;
  2662.  
  2663. { RGBTripleToQuad performs in-place conversion of an OS2 color
  2664.   table into a DIB color table.   }
  2665. procedure RGBTripleToQuad(var ColorTable);
  2666. var
  2667.   I: Integer;
  2668.   P3: PRGBTripleArray;
  2669.   P4: PRGBQuadArray;
  2670. begin
  2671.   P3 := PRGBTripleArray(@ColorTable);
  2672.   P4 := Pointer(P3);
  2673.   for I := 255 downto 1 do  // don't move zeroth item
  2674.     with P4^[I], P3^[I] do
  2675.     begin                     // order is significant for last item moved
  2676.       rgbRed := rgbtRed;
  2677.       rgbGreen := rgbtGreen;
  2678.       rgbBlue := rgbtBlue;
  2679.       rgbReserved := 0;
  2680.     end;
  2681.   P4^[0].rgbReserved := 0;
  2682. end;
  2683.  
  2684. { RGBQuadToTriple performs the inverse of RGBTripleToQuad. }
  2685. procedure RGBQuadToTriple(var ColorTable; var ColorCount: Integer);
  2686. var
  2687.   I: Integer;
  2688.   P3: PRGBTripleArray;
  2689.   P4: PRGBQuadArray;
  2690. begin
  2691.   P3 := PRGBTripleArray(@ColorTable);
  2692.   P4 := Pointer(P3);
  2693.   for I := 1 to ColorCount-1 do  // don't move zeroth item
  2694.     with P4^[I], P3^[I] do
  2695.     begin
  2696.       rgbtRed := rgbRed;
  2697.       rgbtGreen := rgbGreen;
  2698.       rgbtBlue := rgbBlue;
  2699.     end;
  2700.   if ColorCount < 256 then
  2701.   begin
  2702.     FillChar(P3^[ColorCount], (256 - ColorCount) * sizeof(TRGBTriple), 0);
  2703.     ColorCount := 256;   // OS2 color tables always have 256 entries
  2704.   end;
  2705. end;
  2706.  
  2707. procedure ByteSwapColors(var Colors; Count: Integer);
  2708. var   // convert RGB to BGR and vice-versa.  TRGBQuad <-> TPaletteEntry
  2709.   SysInfo: TSystemInfo;
  2710. begin
  2711.   GetSystemInfo(SysInfo);
  2712.   asm
  2713.         MOV   EDX, Colors
  2714.         MOV   ECX, Count
  2715.         DEC   ECX
  2716.         JS    @@END
  2717.         LEA   EAX, SysInfo
  2718.         CMP   [EAX].TSystemInfo.wProcessorLevel, 3
  2719.         JE    @@386
  2720.   @@1:  MOV   EAX, [EDX+ECX*4]
  2721.         BSWAP EAX
  2722.         SHR   EAX,8
  2723.         MOV   [EDX+ECX*4],EAX
  2724.         DEC   ECX
  2725.         JNS   @@1
  2726.         JMP   @@END
  2727.   @@386:
  2728.         PUSH  EBX
  2729.   @@2:  XOR   EBX,EBX
  2730.         MOV   EAX, [EDX+ECX*4]
  2731.         MOV   BH, AL
  2732.         MOV   BL, AH
  2733.         SHR   EAX,16
  2734.         SHL   EBX,8
  2735.         MOV   BL, AL
  2736.         MOV   [EDX+ECX*4],EBX
  2737.         DEC   ECX
  2738.         JNS   @@2
  2739.         POP   EBX
  2740.     @@END:
  2741.   end;
  2742. end;
  2743.  
  2744. function CreateSystemPalette(const Entries: array of TColor): HPALETTE;
  2745. var
  2746.   DC: HDC;
  2747.   SysPalSize: Integer;
  2748.   Pal: TMaxLogPalette;
  2749. begin
  2750.   Pal.palVersion := $300;
  2751.   Pal.palNumEntries := 16;
  2752.   Move(Entries, Pal.palPalEntry, 16 * SizeOf(TColor));
  2753.   DC := GetDC(0);
  2754.   try
  2755.     SysPalSize := GetDeviceCaps(DC, SIZEPALETTE);
  2756.     { Ignore the disk image of the palette for 16 color bitmaps.
  2757.       Replace with the first and last 8 colors of the system palette }
  2758.     if SysPalSize >= 16 then
  2759.     begin
  2760.       GetSystemPaletteEntries(DC, 0, 8, Pal.palPalEntry);
  2761.       { Is light and dark gray swapped? }
  2762.       if TColor(Pal.palPalEntry[7]) = clSilver then
  2763.       begin
  2764.         GetSystemPaletteEntries(DC, SysPalSize - 8, 1, Pal.palPalEntry[7]);
  2765.         GetSystemPaletteEntries(DC, SysPalSize - 7, 7, Pal.palPalEntry[Pal.palNumEntries - 7]);
  2766.         GetSystemPaletteEntries(DC, 7, 1, Pal.palPalEntry[8]);
  2767.       end
  2768.       else
  2769.         GetSystemPaletteEntries(DC, SysPalSize - 8, 8, Pal.palPalEntry[Pal.palNumEntries - 8]);
  2770.     end
  2771.     else
  2772.     begin
  2773.     end;
  2774.   finally
  2775.     ReleaseDC(0,DC);
  2776.   end;
  2777.   Result := CreatePalette(PLogPalette(@Pal)^);
  2778. end;
  2779.  
  2780. function SystemPaletteOverride(var Pal: TMaxLogPalette): Boolean;
  2781. var
  2782.   DC: HDC;
  2783.   SysPalSize: Integer;
  2784. begin
  2785.   Result := False;
  2786.   if SystemPalette16 <> 0 then
  2787.   begin
  2788.     DC := GetDC(0);
  2789.     try
  2790.       SysPalSize := GetDeviceCaps(DC, SIZEPALETTE);
  2791.       if SysPalSize >= 16 then
  2792.       begin
  2793.         { Ignore the disk image of the palette for 16 color bitmaps.
  2794.           Replace with the first and last 8 colors of the system palette }
  2795.         GetPaletteEntries(SystemPalette16, 0, 8, Pal.palPalEntry);
  2796.         GetPaletteEntries(SystemPalette16, 8, 8, Pal.palPalEntry[Pal.palNumEntries - 8]);
  2797.         Result := True;
  2798.       end
  2799.     finally
  2800.       ReleaseDC(0,DC);
  2801.     end;
  2802.   end;
  2803. end;
  2804.  
  2805. function PaletteFromDIBColorTable(DIBHandle: THandle; ColorTable: Pointer;
  2806.   ColorCount: Integer): HPalette;
  2807. var
  2808.   DC: HDC;
  2809.   Save: THandle;
  2810.   Pal: TMaxLogPalette;
  2811. begin
  2812.   Result := 0;
  2813.   Pal.palVersion := $300;
  2814.   if DIBHandle <> 0 then
  2815.   begin
  2816.     DC := CreateCompatibleDC(0);
  2817.     Save := SelectObject(DC, DIBHandle);
  2818.     Pal.palNumEntries := GetDIBColorTable(DC, 0, 256, Pal.palPalEntry);
  2819.     SelectObject(DC, Save);
  2820.     DeleteDC(DC);
  2821.   end
  2822.   else
  2823.   begin
  2824.     Pal.palNumEntries := ColorCount;
  2825.     Move(ColorTable^, Pal.palPalEntry, ColorCount * 4);
  2826.   end;
  2827.   if Pal.palNumEntries = 0 then Exit;
  2828.   if (Pal.palNumEntries <> 16) or not SystemPaletteOverride(Pal) then
  2829.     ByteSwapColors(Pal.palPalEntry, Pal.palNumEntries);
  2830.   Result := CreatePalette(PLogPalette(@Pal)^);
  2831. end;
  2832.  
  2833. function PaletteToDIBColorTable(Pal: HPalette;
  2834.   var ColorTable: array of TRGBQuad): Integer;
  2835. begin
  2836.   Result := 0;
  2837.   if (Pal = 0) or
  2838.      (GetObject(Pal, sizeof(Result), @Result) = 0) or
  2839.      (Result = 0) then Exit;
  2840.   if Result > High(ColorTable)+1 then Result := High(ColorTable)+1;
  2841.   GetPaletteEntries(Pal, 0, Result, ColorTable);
  2842.   ByteSwapColors(ColorTable, Result);
  2843. end;
  2844.  
  2845. procedure TwoBitsFromDIB(var BI: TBitmapInfoHeader; var XorBits, AndBits: HBITMAP;
  2846.   const IconSize: TPoint);
  2847. type
  2848.   PLongArray = ^TLongArray;
  2849.   TLongArray = array[0..1] of Longint;
  2850. var
  2851.   Temp: HBITMAP;
  2852.   NumColors: Integer;
  2853.   DC: HDC;
  2854.   Bits: Pointer;
  2855.   Colors: PLongArray;
  2856. begin
  2857.   with BI do
  2858.   begin
  2859.     biHeight := biHeight shr 1; { Size in record is doubled }
  2860.     biSizeImage := BytesPerScanline(biWidth, biBitCount, 32) * biHeight;
  2861.     NumColors := GetDInColors(biBitCount);
  2862.   end;
  2863.   DC := GetDC(0);
  2864.   if DC = 0 then OutOfResources;
  2865.   try
  2866.     Bits := Pointer(Longint(@BI) + SizeOf(BI) + NumColors * SizeOf(TRGBQuad));
  2867.     Temp := GDICheck(CreateDIBitmap(DC, BI, CBM_INIT, Bits, PBitmapInfo(@BI)^, DIB_RGB_COLORS));
  2868.     try
  2869.       XorBits := DupBits(Temp, IconSize, False);
  2870.     finally
  2871.       DeleteObject(Temp);
  2872.     end;
  2873.     with BI do
  2874.     begin
  2875.       Inc(Longint(Bits), biSizeImage);
  2876.       biBitCount := 1;
  2877.       biSizeImage := BytesPerScanline(biWidth, biBitCount, 32) * biHeight;
  2878.       biClrUsed := 2;
  2879.       biClrImportant := 2;
  2880.     end;
  2881.     Colors := Pointer(Longint(@BI) + SizeOf(BI));
  2882.     Colors^[0] := 0;
  2883.     Colors^[1] := $FFFFFF;
  2884.     Temp := GDICheck(CreateDIBitmap(DC, BI, CBM_INIT, Bits, PBitmapInfo(@BI)^, DIB_RGB_COLORS));
  2885.     try
  2886.       AndBits := DupBits(Temp, IconSize, True);
  2887.     finally
  2888.       DeleteObject(Temp);
  2889.     end;
  2890.   finally
  2891.     ReleaseDC(0, DC);
  2892.   end;
  2893. end;
  2894.  
  2895. procedure ReadIcon(Stream: TStream; var Icon: HICON; ImageCount: Integer;
  2896.   StartOffset: Integer; const RequestedSize: TPoint; var IconSize: TPoint);
  2897. type
  2898.   PIconRecArray = ^TIconRecArray;
  2899.   TIconRecArray = array[0..300] of TIconRec;
  2900. var
  2901.   List: PIconRecArray;
  2902.   HeaderLen, Length: Integer;
  2903.   BitsPerPixel: Word;
  2904.   Colors, BestColor, C1, N, Index: Integer;
  2905.   DC: HDC;
  2906.   BI: PBitmapInfoHeader;
  2907.   ResData: Pointer;
  2908.   XorBits, AndBits: HBITMAP;
  2909.   XorInfo, AndInfo: Windows.TBitmap;
  2910.   XorMem, AndMem: Pointer;
  2911.   XorLen, AndLen: Integer;
  2912. (*
  2913. var
  2914.   P: PChar;
  2915. begin
  2916.   P := Pointer(Integer((Stream as TCustomMemoryStream).Memory) + Stream.Position);
  2917. //  N := LookupIconIdFromDirectoryEx(Pointer(P), True, 0, 0, LR_DEFAULTCOLOR);
  2918.   Icon := GDICheck(CreateIconFromResourceEx(
  2919.     Pointer(P + PIconRec(P)^.DIBOffset - StartOffset),
  2920.     PIconRec(P)^.DIBSize, True, $00030000, 0, 0, LR_DEFAULTCOLOR));
  2921. end;
  2922. *)
  2923.  
  2924.   function AdjustColor(I: Integer): Integer;
  2925.   begin
  2926.     if I = 0 then
  2927.       Result := MaxInt
  2928.     else
  2929.       Result := I;
  2930.   end;
  2931.  
  2932.   function BetterSize(const Old, New: TIconRec): Boolean;
  2933.   var
  2934.     NewX, NewY, OldX, OldY: Integer;
  2935.   begin
  2936.     NewX := New.Width - IconSize.X;
  2937.     NewY := New.Height - IconSize.Y;
  2938.     OldX := Old.Width - IconSize.X;
  2939.     OldY := Old.Height - IconSize.Y;
  2940.     Result := (Abs(NewX) <= Abs(OldX)) and ((NewX <= 0) or (NewX <= OldX)) and
  2941.        (Abs(NewY) <= Abs(OldY)) and ((NewY <= 0) or (NewY <= OldY));
  2942.   end;
  2943.  
  2944. begin
  2945.   HeaderLen := SizeOf(TIconRec) * ImageCount;
  2946.   List := AllocMem(HeaderLen);
  2947.   try
  2948.     Stream.Read(List^, HeaderLen);
  2949.     if (RequestedSize.X or RequestedSize.Y) = 0 then
  2950.     begin
  2951.       IconSize.X := GetSystemMetrics(SM_CXICON);
  2952.       IconSize.Y := GetSystemMetrics(SM_CYICON);
  2953.     end
  2954.     else
  2955.       IconSize := RequestedSize;
  2956.     DC := GetDC(0);
  2957.     if DC = 0 then OutOfResources;
  2958.     try
  2959.       BitsPerPixel := GetDeviceCaps(DC, PLANES) * GetDeviceCaps(DC, BITSPIXEL);
  2960.       if BitsPerPixel > 8 then
  2961.         Colors := MaxInt
  2962.       else
  2963.         Colors := 1 shl BitsPerPixel;
  2964.     finally
  2965.       ReleaseDC(0, DC);
  2966.     end;
  2967.  
  2968.     { Find the image that most closely matches (<=) the current screen color
  2969.       depth and the requested image size.  }
  2970.     Index := 0;
  2971.     BestColor := AdjustColor(List^[0].Colors);
  2972.     for N := 1 to ImageCount-1 do
  2973.     begin
  2974.       C1 := AdjustColor(List^[N].Colors);
  2975.       if (C1 <= Colors) and (C1 >= BestColor) and
  2976.         BetterSize(List^[Index], List^[N]) then
  2977.       begin
  2978.         Index := N;
  2979.         BestColor := C1;
  2980.       end;
  2981.     end;
  2982.  
  2983.     { the following code determines which image most closely matches the
  2984.       current device. It is not meant to absolutely match Windows
  2985.       (known broken) algorithm }
  2986. (*    C2 := 0;
  2987.     for N := 0 to ImageCount - 1 do
  2988.     begin
  2989.       C1 := List^[N].Colors;
  2990.       if C1 = Colors then
  2991.       begin
  2992.         Index := N;
  2993.         if (IconSize.X = List^[N].Width) and (IconSize.Y = List^[N].Height) then
  2994.           Break;  // exact match on size and color
  2995.       end
  2996.       else if Index = -1 then
  2997.       begin            // take the first icon with fewer colors than screen
  2998.         if C1 <= Colors then
  2999.         begin
  3000.           Index := N;
  3001.           C2 := C1;
  3002.         end;
  3003.       end
  3004.       else if C1 > C2 then  // take icon with more colors than first match
  3005.         Index := N;
  3006.     end;
  3007.     if Index = -1 then Index := 0;
  3008. *)
  3009.     with List^[Index] do
  3010.     begin
  3011.       IconSize.X := Width;
  3012.       IconSize.Y := Height;
  3013.       BI := AllocMem(DIBSize);
  3014.       try
  3015.         Stream.Seek(DIBOffset  - (HeaderLen + StartOffset), 1);
  3016.         Stream.Read(BI^, DIBSize);
  3017.         TwoBitsFromDIB(BI^, XorBits, AndBits, IconSize);
  3018.         GetObject(AndBits, SizeOf(Windows.TBitmap), @AndInfo);
  3019.         GetObject(XorBits, SizeOf(Windows.TBitmap), @XorInfo);
  3020.         with AndInfo do
  3021.           AndLen := bmWidthBytes * bmHeight * bmPlanes;
  3022.         with XorInfo do
  3023.           XorLen :=  bmWidthBytes * bmHeight * bmPlanes;
  3024.         Length := AndLen + XorLen;
  3025.         ResData := AllocMem(Length);
  3026.         try
  3027.           AndMem := ResData;
  3028.           with AndInfo do
  3029.             XorMem := Pointer(Longint(ResData) + AndLen);
  3030.           GetBitmapBits(AndBits, AndLen, AndMem);
  3031.           GetBitmapBits(XorBits, XorLen, XorMem);
  3032.           DeleteObject(XorBits);
  3033.           DeleteObject(AndBits);
  3034.           Icon := CreateIcon(HInstance, IconSize.X, IconSize.Y,
  3035.             XorInfo.bmPlanes, XorInfo.bmBitsPixel, AndMem, XorMem);
  3036.           if Icon = 0 then GDIError;
  3037.         finally
  3038.           FreeMem(ResData, Length);
  3039.         end;
  3040.       finally
  3041.         FreeMem(BI, DIBSize);
  3042.       end;
  3043.     end;
  3044.   finally
  3045.     FreeMem(List, HeaderLen);
  3046.   end;
  3047. end;
  3048.  
  3049. function ComputeAldusChecksum(var WMF: TMetafileHeader): Word;
  3050. type
  3051.   PWord = ^Word;
  3052. var
  3053.   pW: PWord;
  3054.   pEnd: PWord;
  3055. begin
  3056.   Result := 0;
  3057.   pW := @WMF;
  3058.   pEnd := @WMF.CheckSum;
  3059.   while Longint(pW) < Longint(pEnd) do
  3060.   begin
  3061.     Result := Result xor pW^;
  3062.     Inc(Longint(pW), SizeOf(Word));
  3063.   end;
  3064. end;
  3065.  
  3066. procedure InitializeBitmapInfoHeader(Bitmap: HBITMAP; var BI: TBitmapInfoHeader;
  3067.   Colors: Integer);
  3068. var
  3069.   DS: TDIBSection;
  3070.   Bytes: Integer;
  3071. begin
  3072.   DS.dsbmih.biSize := 0;
  3073.   Bytes := GetObject(Bitmap, SizeOf(DS), @DS);
  3074.   if Bytes = 0 then InvalidBitmap
  3075.   else if (Bytes >= (sizeof(DS.dsbm) + sizeof(DS.dsbmih))) and
  3076.     (DS.dsbmih.biSize >= DWORD(sizeof(DS.dsbmih))) then
  3077.     BI := DS.dsbmih
  3078.   else
  3079.   begin
  3080.     FillChar(BI, sizeof(BI), 0);
  3081.     with BI, DS.dsbm do
  3082.     begin
  3083.       biSize := SizeOf(BI);
  3084.       biWidth := bmWidth;
  3085.       biHeight := bmHeight;
  3086.     end;
  3087.   end;
  3088.   case Colors of
  3089.     2: BI.biBitCount := 1;
  3090.     3..16:
  3091.       begin
  3092.         BI.biBitCount := 4;
  3093.         BI.biClrUsed := Colors;
  3094.       end;
  3095.     17..256:
  3096.       begin
  3097.         BI.biBitCount := 8;
  3098.         BI.biClrUsed := Colors;
  3099.       end;
  3100.   else
  3101.     BI.biBitCount := DS.dsbm.bmBitsPixel * DS.dsbm.bmPlanes;
  3102.   end;
  3103.   BI.biPlanes := 1;
  3104.   if BI.biClrImportant > BI.biClrUsed then
  3105.     BI.biClrImportant := BI.biClrUsed;
  3106.   if BI.biSizeImage = 0 then
  3107.     BI.biSizeImage := BytesPerScanLine(BI.biWidth, BI.biBitCount, 32) * Abs(BI.biHeight);
  3108. end;
  3109.  
  3110. procedure InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: DWORD;
  3111.   var ImageSize: DWORD; Colors: Integer);
  3112. var
  3113.   BI: TBitmapInfoHeader;
  3114. begin
  3115.   InitializeBitmapInfoHeader(Bitmap, BI, Colors);
  3116.   if BI.biBitCount > 8 then
  3117.   begin
  3118.     InfoHeaderSize := SizeOf(TBitmapInfoHeader);
  3119.     if (BI.biCompression and BI_BITFIELDS) <> 0 then
  3120.       Inc(InfoHeaderSize, 12);
  3121.   end
  3122.   else
  3123.     if BI.biClrUsed = 0 then
  3124.       InfoHeaderSize := SizeOf(TBitmapInfoHeader) +
  3125.         SizeOf(TRGBQuad) * (1 shl BI.biBitCount)
  3126.     else
  3127.       InfoHeaderSize := SizeOf(TBitmapInfoHeader) +
  3128.         SizeOf(TRGBQuad) * BI.biClrUsed;
  3129.   ImageSize := BI.biSizeImage;
  3130. end;
  3131.  
  3132. procedure GetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: DWORD;
  3133.   var ImageSize: DWORD);
  3134. begin
  3135.   InternalGetDIBSizes(Bitmap, InfoHeaderSize, ImageSize, 0);
  3136. end;
  3137.  
  3138. function InternalGetDIB(Bitmap: HBITMAP; Palette: HPALETTE;
  3139.   var BitmapInfo; var Bits; Colors: Integer): Boolean;
  3140. var
  3141.   OldPal: HPALETTE;
  3142.   DC: HDC;
  3143. begin
  3144.   InitializeBitmapInfoHeader(Bitmap, TBitmapInfoHeader(BitmapInfo), Colors);
  3145.   OldPal := 0;
  3146.   DC := CreateCompatibleDC(0);
  3147.   try
  3148.     if Palette <> 0 then
  3149.     begin
  3150.       OldPal := SelectPalette(DC, Palette, False);
  3151.       RealizePalette(DC);
  3152.     end;
  3153.     Result := GetDIBits(DC, Bitmap, 0, TBitmapInfoHeader(BitmapInfo).biHeight, @Bits,
  3154.       TBitmapInfo(BitmapInfo), DIB_RGB_COLORS) <> 0;
  3155.   finally
  3156.     if OldPal <> 0 then SelectPalette(DC, OldPal, False);
  3157.     DeleteDC(DC);
  3158.   end;
  3159. end;
  3160.  
  3161. function GetDIB(Bitmap: HBITMAP; Palette: HPALETTE; var BitmapInfo; var Bits): Boolean;
  3162. begin
  3163.   Result := InternalGetDIB(Bitmap, Palette, BitmapInfo, Bits, 0);
  3164. end;
  3165.  
  3166. procedure WinError;
  3167. begin
  3168. end;
  3169.  
  3170. procedure CheckBool(Result: Bool);
  3171. begin
  3172.   if not Result then WinError;
  3173. end;
  3174.  
  3175. procedure WriteIcon(Stream: TStream; Icon: HICON; WriteLength: Boolean);
  3176. var
  3177.   IconInfo: TIconInfo;
  3178.   MonoInfoSize, ColorInfoSize: DWORD;
  3179.   MonoBitsSize, ColorBitsSize: DWORD;
  3180.   MonoInfo, MonoBits, ColorInfo, ColorBits: Pointer;
  3181.   CI: TCursorOrIcon;
  3182.   List: TIconRec;
  3183.   Length: Longint;
  3184. begin
  3185.   FillChar(CI, SizeOf(CI), 0);
  3186.   FillChar(List, SizeOf(List), 0);
  3187.   CheckBool(GetIconInfo(Icon, IconInfo));
  3188.   try
  3189.     InternalGetDIBSizes(IconInfo.hbmMask, MonoInfoSize, MonoBitsSize, 2);
  3190.     InternalGetDIBSizes(IconInfo.hbmColor, ColorInfoSize, ColorBitsSize, 16);
  3191.     MonoInfo := nil;
  3192.     MonoBits := nil;
  3193.     ColorInfo := nil;
  3194.     ColorBits := nil;
  3195.     try
  3196.       MonoInfo := AllocMem(MonoInfoSize);
  3197.       MonoBits := AllocMem(MonoBitsSize);
  3198.       ColorInfo := AllocMem(ColorInfoSize);
  3199.       ColorBits := AllocMem(ColorBitsSize);
  3200.       InternalGetDIB(IconInfo.hbmMask, 0, MonoInfo^, MonoBits^, 2);
  3201.       InternalGetDIB(IconInfo.hbmColor, 0, ColorInfo^, ColorBits^, 16);
  3202.       if WriteLength then
  3203.       begin
  3204.         Length := SizeOf(CI) + SizeOf(List) + ColorInfoSize +
  3205.           ColorBitsSize + MonoBitsSize;
  3206.         Stream.Write(Length, SizeOf(Length));
  3207.       end;
  3208.       with CI do
  3209.       begin
  3210.         CI.wType := RC3_ICON;
  3211.         CI.Count := 1;
  3212.       end;
  3213.       Stream.Write(CI, SizeOf(CI));
  3214.       with List, PBitmapInfoHeader(ColorInfo)^ do
  3215.       begin
  3216.         Width := biWidth;
  3217.         Height := biHeight;
  3218.         Colors := biPlanes * biBitCount;
  3219.         DIBSize := ColorInfoSize + ColorBitsSize + MonoBitsSize;
  3220.         DIBOffset := SizeOf(CI) + SizeOf(List);
  3221.       end;
  3222.       Stream.Write(List, SizeOf(List));
  3223.       with PBitmapInfoHeader(ColorInfo)^ do
  3224.         Inc(biHeight, biHeight); { color height includes mono bits }
  3225.       Stream.Write(ColorInfo^, ColorInfoSize);
  3226.       Stream.Write(ColorBits^, ColorBitsSize);
  3227.       Stream.Write(MonoBits^, MonoBitsSize);
  3228.     finally
  3229.       FreeMem(ColorInfo, ColorInfoSize);
  3230.       FreeMem(ColorBits, ColorBitsSize);
  3231.       FreeMem(MonoInfo, MonoInfoSize);
  3232.       FreeMem(MonoBits, MonoBitsSize);
  3233.     end;
  3234.   finally
  3235.     DeleteObject(IconInfo.hbmColor);
  3236.     DeleteObject(IconInfo.hbmMask);
  3237.   end;
  3238. end;
  3239.  
  3240. { TGraphic }
  3241.  
  3242. constructor TGraphic.Create;
  3243. begin
  3244.   inherited Create;
  3245. end;
  3246.  
  3247. procedure TGraphic.Changed(Sender: TObject);
  3248. begin
  3249.   FModified := True;
  3250.   if Assigned(FOnChange) then FOnChange(Self);
  3251. end;
  3252.  
  3253. procedure TGraphic.DefineProperties(Filer: TFiler);
  3254.  
  3255.   function DoWrite: Boolean;
  3256.   begin
  3257.     if Filer.Ancestor <> nil then
  3258.       Result := not (Filer.Ancestor is TGraphic) or
  3259.         not Equals(TGraphic(Filer.Ancestor))
  3260.     else
  3261.       Result := not Empty;
  3262.   end;
  3263.  
  3264. begin
  3265.   Filer.DefineBinaryProperty('Data', ReadData, WriteData, DoWrite);
  3266. end;
  3267.  
  3268. function TGraphic.Equals(Graphic: TGraphic): Boolean;
  3269. var
  3270.   MyImage, GraphicsImage: TMemoryStream;
  3271. begin
  3272.   Result := (Graphic <> nil) and (ClassType = Graphic.ClassType);
  3273.   if Empty or Graphic.Empty then
  3274.   begin
  3275.     Result := Empty and Graphic.Empty;
  3276.     Exit;
  3277.   end;
  3278.   if Result then
  3279.   begin
  3280.     MyImage := TMemoryStream.Create;
  3281.     try
  3282.       WriteData(MyImage);
  3283.       GraphicsImage := TMemoryStream.Create;
  3284.       try
  3285.         Graphic.WriteData(GraphicsImage);
  3286.         Result := (MyImage.Size = GraphicsImage.Size) and
  3287.           CompareMem(MyImage.Memory, GraphicsImage.Memory, MyImage.Size);
  3288.       finally
  3289.         GraphicsImage.Free;
  3290.       end;
  3291.     finally
  3292.       MyImage.Free;
  3293.     end;
  3294.   end;
  3295. end;
  3296.  
  3297. function TGraphic.GetPalette: HPALETTE;
  3298. begin
  3299.   Result := 0;
  3300. end;
  3301.  
  3302. function TGraphic.GetTransparent: Boolean;
  3303. begin
  3304.   Result := FTransparent;
  3305. end;
  3306.  
  3307. procedure TGraphic.LoadFromFile(const Filename: string);
  3308. var
  3309.   Stream: TStream;
  3310. begin
  3311.   Stream := TFileStream.Create(Filename, fmOpenRead or fmShareDenyWrite);
  3312.   try
  3313.     LoadFromStream(Stream);
  3314.   finally
  3315.     Stream.Free;
  3316.   end;
  3317. end;
  3318.  
  3319. procedure TGraphic.Progress(Sender: TObject; Stage: TProgressStage;
  3320.   PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);
  3321. begin
  3322.   if Assigned(FOnProgress) then
  3323.     FOnProgress(Sender, Stage, PercentDone, RedrawNow, R, Msg);
  3324. end;
  3325.  
  3326. procedure TGraphic.ReadData(Stream: TStream);
  3327. begin
  3328.   LoadFromStream(Stream);
  3329. end;
  3330.  
  3331. procedure TGraphic.SaveToFile(const Filename: string);
  3332. var
  3333.   Stream: TStream;
  3334. begin
  3335.   Stream := TFileStream.Create(Filename, fmCreate);
  3336.   try
  3337.     SaveToStream(Stream);
  3338.   finally
  3339.     Stream.Free;
  3340.   end;
  3341. end;
  3342.  
  3343. procedure TGraphic.SetPalette(Value: HPalette);
  3344. begin
  3345. end;
  3346.  
  3347. procedure TGraphic.SetModified(Value: Boolean);
  3348. begin
  3349.   if Value then
  3350.     Changed(Self) else
  3351.     FModified := False;
  3352. end;
  3353.  
  3354. procedure TGraphic.SetTransparent(Value: Boolean);
  3355. begin
  3356.   if Value <> FTransparent then
  3357.   begin
  3358.     FTransparent := Value;
  3359.     Changed(Self);
  3360.   end;
  3361. end;
  3362.  
  3363. procedure TGraphic.WriteData(Stream: TStream);
  3364. begin
  3365.   SaveToStream(Stream);
  3366. end;
  3367.  
  3368. { TPicture }
  3369.  
  3370. type
  3371.   PFileFormat = ^TFileFormat;
  3372.   TFileFormat = record
  3373.     GraphicClass: TGraphicClass;
  3374.     Extension: string;
  3375.     Description: string;
  3376.     DescResID: Integer;
  3377.   end;
  3378.  
  3379.   TFileFormatsList = class(TList)
  3380.   public
  3381.     constructor Create;
  3382.     destructor Destroy; override;
  3383.     procedure Add(const Ext, Desc: String; DescID: Integer; AClass: TGraphicClass);
  3384.     function FindExt(Ext: string): TGraphicClass;
  3385.     function FindClassName(const Classname: string): TGraphicClass;
  3386.     procedure Remove(AClass: TGraphicClass);
  3387.     procedure BuildFilterStrings(GraphicClass: TGraphicClass;
  3388.       var Descriptions, Filters: string);
  3389.   end;
  3390.  
  3391. constructor TFileFormatsList.Create;
  3392. begin
  3393.   inherited Create;
  3394.   Add('wmf', SVMetafiles, 0, TMetafile);
  3395.   Add('emf', SVEnhMetafiles, 0, TMetafile);
  3396.   Add('ico', SVIcons, 0, TIcon);
  3397.   Add('bmp', SVBitmaps, 0, TBitmap);
  3398. end;
  3399.  
  3400. destructor TFileFormatsList.Destroy;
  3401. var
  3402.   I: Integer;
  3403. begin
  3404.   for I := 0 to Count-1 do
  3405.     Dispose(PFileFormat(Items[I]));
  3406.   inherited Destroy;
  3407. end;
  3408.  
  3409. procedure TFileFormatsList.Add(const Ext, Desc: String; DescID: Integer;
  3410.   AClass: TGraphicClass);
  3411. var
  3412.   NewRec: PFileFormat;
  3413. begin
  3414.   New(NewRec);
  3415.   with NewRec^ do
  3416.   begin
  3417.     Extension := AnsiLowerCase(Ext);
  3418.     GraphicClass := AClass;
  3419.     Description := Desc;
  3420.     DescResID := DescID;
  3421.   end;
  3422.   inherited Add(NewRec);
  3423. end;
  3424.  
  3425. function TFileFormatsList.FindExt(Ext: string): TGraphicClass;
  3426. var
  3427.   I: Integer;
  3428. begin
  3429.   Ext := AnsiLowerCase(Ext);
  3430.   for I := Count-1 downto 0 do
  3431.     with PFileFormat(Items[I])^ do
  3432.       if Extension = Ext then
  3433.       begin
  3434.         Result := GraphicClass;
  3435.         Exit;
  3436.       end;
  3437.   Result := nil;
  3438. end;
  3439.  
  3440. function TFileFormatsList.FindClassName(const ClassName: string): TGraphicClass;
  3441. var
  3442.   I: Integer;
  3443. begin
  3444.   for I := Count-1 downto 0 do
  3445.   begin
  3446.     Result := PFileFormat(Items[I])^.GraphicClass;
  3447.     if Result.ClassName = Classname then Exit;
  3448.   end;
  3449.   Result := nil;
  3450. end;
  3451.  
  3452. procedure TFileFormatsList.Remove(AClass: TGraphicClass);
  3453. var
  3454.   I: Integer;
  3455.   P: PFileFormat;
  3456. begin
  3457.   for I := Count-1 downto 0 do
  3458.   begin
  3459.     P := PFileFormat(Items[I]);
  3460.     if P^.GraphicClass.InheritsFrom(AClass) then
  3461.     begin
  3462.       Dispose(P);
  3463.       Delete(I);
  3464.     end;
  3465.   end;
  3466. end;
  3467.  
  3468. procedure TFileFormatsList.BuildFilterStrings(GraphicClass: TGraphicClass;
  3469.   var Descriptions, Filters: string);
  3470. var
  3471.   C, I: Integer;
  3472.   P: PFileFormat;
  3473. begin
  3474.   Descriptions := '';
  3475.   Filters := '';
  3476.   C := 0;
  3477.   for I := Count-1 downto 0 do
  3478.   begin
  3479.     P := PFileFormat(Items[I]);
  3480.     if P^.GraphicClass.InheritsFrom(GraphicClass) and (P^.Extension <> '') then
  3481.       with P^ do
  3482.       begin
  3483.         if C <> 0 then
  3484.         begin
  3485.           Descriptions := Descriptions + '|';
  3486.           Filters := Filters + ';';
  3487.         end;
  3488.         if (Description = '') and (DescResID <> 0) then
  3489.           Description := LoadStr(DescResID);
  3490.         FmtStr(Descriptions, '%s%s (*.%s)|*.%2:s', [Descriptions, Description, Extension]);
  3491.         FmtStr(Filters, '%s*.%s', [Filters, Extension]);
  3492.         Inc(C);
  3493.       end;
  3494.   end;
  3495.   if C > 1 then
  3496.     FmtStr(Descriptions, '%s (%s)|%1:s|%s', [sAllFilter, Filters, Descriptions]);
  3497. end;
  3498.  
  3499. type
  3500.   TClipboardFormats = class
  3501.   private
  3502.     FClasses: TList;
  3503.     FFormats: TList;
  3504.   public
  3505.     constructor Create;
  3506.     destructor Destroy; override;
  3507.     procedure Add(Fmt: Word; AClass: TGraphicClass);
  3508.     function FindFormat(Fmt: Word): TGraphicClass;
  3509.     procedure Remove(AClass: TGraphicClass);
  3510.   end;
  3511.  
  3512. constructor TClipboardFormats.Create;
  3513. begin
  3514.   FClasses := TList.Create;
  3515.   FFormats := TList.Create;
  3516.   Add(CF_METAFILEPICT, TMetafile);
  3517.   Add(CF_ENHMETAFILE, TMetafile);
  3518.   Add(CF_BITMAP, TBitmap);
  3519. end;
  3520.  
  3521. destructor TClipboardFormats.Destroy;
  3522. begin
  3523.   FClasses.Free;
  3524.   FFormats.Free;
  3525. end;
  3526.  
  3527. procedure TClipboardFormats.Add(Fmt: Word; AClass: TGraphicClass);
  3528. var
  3529.   I: Integer;
  3530. begin
  3531.   I := FClasses.Add(AClass);
  3532.   try
  3533.     FFormats.Add(Pointer(Integer(Fmt)));
  3534.   except
  3535.     FClasses.Delete(I);
  3536.     raise;
  3537.   end;
  3538. end;
  3539.  
  3540. function TClipboardFormats.FindFormat(Fmt: Word): TGraphicClass;
  3541. var
  3542.   I: Integer;
  3543. begin
  3544.   for I := FFormats.Count-1 downto 0 do
  3545.     if Word(FFormats[I]) = Fmt then
  3546.     begin
  3547.       Result := FClasses[I];
  3548.       Exit;
  3549.     end;
  3550.   Result := nil;
  3551. end;
  3552.  
  3553. procedure TClipboardFormats.Remove(AClass: TGraphicClass);
  3554. var
  3555.   I: Integer;
  3556. begin
  3557.   for I := FClasses.Count-1 downto 0 do
  3558.     if TGraphicClass(FClasses[I]).InheritsFrom(AClass) then
  3559.     begin
  3560.       FClasses.Delete(I);
  3561.       FFormats.Delete(I);
  3562.     end;
  3563. end;
  3564.  
  3565. var
  3566.   ClipboardFormats: TClipboardFormats = nil;
  3567.   FileFormats: TFileFormatsList = nil;
  3568.  
  3569. function GetFileFormats: TFileFormatsList;
  3570. begin
  3571.   if FileFormats = nil then FileFormats := TFileFormatsList.Create;
  3572.   Result := FileFormats;
  3573. end;
  3574.  
  3575. function GetClipboardFormats: TClipboardFormats;
  3576. begin
  3577.   if ClipboardFormats = nil then ClipboardFormats := TClipboardFormats.Create;
  3578.   Result := ClipboardFormats;
  3579. end;
  3580.  
  3581. constructor TPicture.Create;
  3582. begin
  3583.   inherited Create;
  3584.   GetFileFormats;
  3585.   GetClipboardFormats;
  3586. end;
  3587.  
  3588. destructor TPicture.Destroy;
  3589. begin
  3590.   FGraphic.Free;
  3591.   inherited Destroy;
  3592. end;
  3593.  
  3594. procedure TPicture.AssignTo(Dest: TPersistent);
  3595. begin
  3596.   if Graphic is Dest.ClassType then
  3597.     Dest.Assign(Graphic)
  3598.   else
  3599.     inherited AssignTo(Dest);
  3600. end;
  3601.  
  3602. procedure TPicture.ForceType(GraphicType: TGraphicClass);
  3603. begin
  3604.   if not (Graphic is GraphicType) then
  3605.   begin
  3606.     FGraphic.Free;
  3607.     FGraphic := nil;
  3608.     FGraphic := GraphicType.Create;
  3609.     FGraphic.OnChange := Changed;
  3610.     FGraphic.OnProgress := Progress;
  3611.     Changed(Self);
  3612.   end;
  3613. end;
  3614.  
  3615. function TPicture.GetBitmap: TBitmap;
  3616. begin
  3617.   ForceType(TBitmap);
  3618.   Result := TBitmap(Graphic);
  3619. end;
  3620.  
  3621. function TPicture.GetIcon: TIcon;
  3622. begin
  3623.   ForceType(TIcon);
  3624.   Result := TIcon(Graphic);
  3625. end;
  3626.  
  3627. function TPicture.GetMetafile: TMetafile;
  3628. begin
  3629.   ForceType(TMetafile);
  3630.   Result := TMetafile(Graphic);
  3631. end;
  3632.  
  3633. procedure TPicture.SetBitmap(Value: TBitmap);
  3634. begin
  3635.   SetGraphic(Value);
  3636. end;
  3637.  
  3638. procedure TPicture.SetIcon(Value: TIcon);
  3639. begin
  3640.   SetGraphic(Value);
  3641. end;
  3642.  
  3643. procedure TPicture.SetMetafile(Value: TMetafile);
  3644. begin
  3645.   SetGraphic(Value);
  3646. end;
  3647.  
  3648. procedure TPicture.SetGraphic(Value: TGraphic);
  3649. var
  3650.   NewGraphic: TGraphic;
  3651. begin
  3652.   NewGraphic := nil;
  3653.   if Value <> nil then
  3654.   begin
  3655.     NewGraphic := TGraphicClass(Value.ClassType).Create;
  3656.     NewGraphic.Assign(Value);
  3657.     NewGraphic.OnChange := Changed;
  3658.     NewGraphic.OnProgress := Progress;
  3659.   end;
  3660.   try
  3661.     FGraphic.Free;
  3662.     FGraphic := NewGraphic;
  3663.     Changed(Self);
  3664.   except
  3665.     NewGraphic.Free;
  3666.     raise;
  3667.   end;
  3668. end;
  3669.  
  3670. { Based on the extension of Filename, create the cooresponding TGraphic class
  3671.   and call its LoadFromFile method. }
  3672.  
  3673. procedure TPicture.LoadFromFile(const Filename: string);
  3674. var
  3675.   Ext: string;
  3676.   NewGraphic: TGraphic;
  3677.   GraphicClass: TGraphicClass;
  3678. begin
  3679.   Ext := ExtractFileExt(Filename);
  3680.   Delete(Ext, 1, 1);
  3681.   GraphicClass := FileFormats.FindExt(Ext);
  3682.   if GraphicClass = nil then
  3683.     raise EInvalidGraphic.CreateFmt(SUnknownExtension, [Ext]);
  3684.  
  3685.   NewGraphic := GraphicClass.Create;
  3686.   try
  3687.     NewGraphic.OnProgress := Progress;
  3688.     NewGraphic.LoadFromFile(Filename);
  3689.   except
  3690.     NewGraphic.Free;
  3691.     raise;
  3692.   end;
  3693.   FGraphic.Free;
  3694.   FGraphic := NewGraphic;
  3695.   FGraphic.OnChange := Changed;
  3696.   Changed(Self);
  3697. end;
  3698.  
  3699. procedure TPicture.SaveToFile(const Filename: string);
  3700. begin
  3701.   if FGraphic <> nil then FGraphic.SaveToFile(Filename);
  3702. end;
  3703.  
  3704. procedure TPicture.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  3705.   APalette: HPALETTE);
  3706. var
  3707.   NewGraphic: TGraphic;
  3708.   GraphicClass: TGraphicClass;
  3709. begin
  3710.   GraphicClass := ClipboardFormats.FindFormat(AFormat);
  3711.   if GraphicClass = nil then
  3712.     InvalidGraphic(@SUnknownClipboardFormat);
  3713.  
  3714.   NewGraphic := GraphicClass.Create;
  3715.   try
  3716.     NewGraphic.OnProgress := Progress;
  3717.     NewGraphic.LoadFromClipboardFormat(AFormat, AData, APalette);
  3718.   except
  3719.     NewGraphic.Free;
  3720.     raise;
  3721.   end;
  3722.   FGraphic.Free;
  3723.   FGraphic := NewGraphic;
  3724.   FGraphic.OnChange := Changed;
  3725.   Changed(Self);
  3726. end;
  3727.  
  3728. procedure TPicture.SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  3729.   var APalette: HPALETTE);
  3730. begin
  3731.   if FGraphic <> nil then
  3732.     FGraphic.SaveToClipboardFormat(AFormat, AData, APalette);
  3733. end;
  3734.  
  3735. class function TPicture.SupportsClipboardFormat(AFormat: Word): Boolean;
  3736. begin
  3737.   Result := GetClipboardFormats.FindFormat(AFormat) <> nil;
  3738. end;
  3739.  
  3740. procedure TPicture.Assign(Source: TPersistent);
  3741. begin
  3742.   if Source = nil then
  3743.     SetGraphic(nil)
  3744.   else if Source is TPicture then
  3745.     SetGraphic(TPicture(Source).Graphic)
  3746.   else if Source is TGraphic then
  3747.     SetGraphic(TGraphic(Source))
  3748.   else
  3749.     inherited Assign(Source);
  3750. end;
  3751.  
  3752. class procedure TPicture.RegisterFileFormat(const AExtension,
  3753.   ADescription: string; AGraphicClass: TGraphicClass);
  3754. begin
  3755.   GetFileFormats.Add(AExtension, ADescription, 0, AGraphicClass);
  3756. end;
  3757.  
  3758. class procedure TPicture.RegisterFileFormatRes(const AExtension: String;
  3759.   ADescriptionResID: Integer; AGraphicClass: TGraphicClass);
  3760. begin
  3761.   GetFileFormats.Add(AExtension, '', ADescriptionResID, AGraphicClass);
  3762. end;
  3763.  
  3764. class procedure TPicture.RegisterClipboardFormat(AFormat: Word;
  3765.   AGraphicClass: TGraphicClass);
  3766. begin
  3767.   GetClipboardFormats.Add(AFormat, AGraphicClass);
  3768. end;
  3769.  
  3770. class procedure TPicture.UnRegisterGraphicClass(AClass: TGraphicClass);
  3771. begin
  3772.   if FileFormats <> nil then FileFormats.Remove(AClass);
  3773.   if ClipboardFormats <> nil then ClipboardFormats.Remove(AClass);
  3774. end;
  3775.  
  3776. procedure TPicture.Changed(Sender: TObject);
  3777. begin
  3778.   if Assigned(FOnChange) then FOnChange(Self);
  3779.   if FNotify <> nil then FNotify.Changed;
  3780. end;
  3781.  
  3782. procedure TPicture.Progress(Sender: TObject; Stage: TProgressStage;
  3783.   PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);
  3784. begin
  3785.   if Assigned(FOnProgress) then FOnProgress(Sender, Stage, PercentDone, RedrawNow, R, Msg);
  3786. end;
  3787.  
  3788. procedure TPicture.ReadData(Stream: TStream);
  3789. var
  3790.   CName: string[63];
  3791.   NewGraphic: TGraphic;
  3792.   GraphicClass: TGraphicClass;
  3793. begin
  3794.   Stream.Read(CName[0], 1);
  3795.   Stream.Read(CName[1], Integer(CName[0]));
  3796.   GraphicClass := FileFormats.FindClassName(CName);
  3797.   NewGraphic := nil;
  3798.   if GraphicClass <> nil then
  3799.   begin
  3800.     NewGraphic := GraphicClass.Create;
  3801.     try
  3802.       NewGraphic.ReadData(Stream);
  3803.     except
  3804.       NewGraphic.Free;
  3805.       raise;
  3806.     end;
  3807.   end;
  3808.   FGraphic.Free;
  3809.   FGraphic := NewGraphic;
  3810.   if NewGraphic <> nil then
  3811.   begin
  3812.     NewGraphic.OnChange := Changed;
  3813.     NewGraphic.OnProgress := Progress;
  3814.   end;
  3815.   Changed(Self);
  3816. end;
  3817.  
  3818. procedure TPicture.WriteData(Stream: TStream);
  3819. var
  3820.   CName: string[63];
  3821. begin
  3822.   with Stream do
  3823.   begin
  3824.     if Graphic <> nil then
  3825.       CName := Graphic.ClassName else
  3826.       CName := '';
  3827.     Write(CName, Length(CName) + 1);
  3828.     if Graphic <> nil then
  3829.       Graphic.WriteData(Stream);
  3830.   end;
  3831. end;
  3832.  
  3833. procedure TPicture.DefineProperties(Filer: TFiler);
  3834.  
  3835.   function DoWrite: Boolean;
  3836.   var
  3837.     Ancestor: TPicture;
  3838.   begin
  3839.     if Filer.Ancestor <> nil then
  3840.     begin
  3841.       Result := True;
  3842.       if Filer.Ancestor is TPicture then
  3843.       begin
  3844.         Ancestor := TPicture(Filer.Ancestor);
  3845.         Result := not ((Graphic = Ancestor.Graphic) or
  3846.           ((Graphic <> nil) and (Ancestor.Graphic <> nil) and
  3847.           Graphic.Equals(Ancestor.Graphic)));
  3848.       end;
  3849.     end
  3850.     else Result := Graphic <> nil;
  3851.   end;
  3852.  
  3853. begin
  3854.   Filer.DefineBinaryProperty('Data', ReadData, WriteData, DoWrite);
  3855. end;
  3856.  
  3857. function TPicture.GetWidth: Integer;
  3858. begin
  3859.   Result := 0;
  3860.   if FGraphic <> nil then Result := FGraphic.Width;
  3861. end;
  3862.  
  3863. function TPicture.GetHeight: Integer;
  3864. begin
  3865.   Result := 0;
  3866.   if FGraphic <> nil then Result := FGraphic.Height;
  3867. end;
  3868.  
  3869. { TMetafileImage }
  3870.  
  3871. destructor TMetafileImage.Destroy;
  3872. begin
  3873.   if FHandle <> 0 then DeleteEnhMetafile(FHandle);
  3874.   InternalDeletePalette(FPalette);
  3875.   inherited Destroy;
  3876. end;
  3877.  
  3878. procedure TMetafileImage.FreeHandle;
  3879. begin
  3880. end;
  3881.  
  3882.  
  3883. { TMetafileCanvas }
  3884.  
  3885. constructor TMetafileCanvas.Create(AMetafile: TMetafile; ReferenceDevice: HDC);
  3886. begin
  3887.   CreateWithComment(AMetafile, ReferenceDevice, AMetafile.CreatedBy,
  3888.     AMetafile.Description);
  3889. end;
  3890.  
  3891. constructor TMetafileCanvas.CreateWithComment(AMetafile : TMetafile;
  3892.   ReferenceDevice: HDC; const CreatedBy, Description: String);
  3893. var
  3894.   RefDC: HDC;
  3895.   R: TRect;
  3896.   Temp: HDC;
  3897.   P: PChar;
  3898. begin
  3899.   inherited Create;
  3900.   FMetafile := AMetafile;
  3901.   RefDC := ReferenceDevice;
  3902.   if ReferenceDevice = 0 then RefDC := GetDC(0);
  3903.   try
  3904.     if FMetafile.MMWidth = 0 then
  3905.       if FMetafile.Width = 0 then
  3906.         FMetafile.MMWidth := GetDeviceCaps(RefDC, HORZSIZE)*100
  3907.       else
  3908.         FMetafile.MMWidth := MulDiv(FMetafile.Width,
  3909.           GetDeviceCaps(RefDC, HORZSIZE)*100, GetDeviceCaps(RefDC, HORZRES));
  3910.     if FMetafile.MMHeight = 0 then
  3911.       if FMetafile.Height = 0 then
  3912.         FMetafile.MMHeight := GetDeviceCaps(RefDC, VERTSIZE)*100
  3913.       else
  3914.         FMetafile.MMHeight := MulDiv(FMetafile.Height,
  3915.           GetDeviceCaps(RefDC, VERTSIZE)*100, GetDeviceCaps(RefDC, VERTRES));
  3916.     R := Rect(0,0,FMetafile.MMWidth,FMetafile.MMHeight);
  3917.     if (Length(CreatedBy) > 0) or (Length(Description) > 0) then
  3918.       P := PChar(CreatedBy+#0+Description+#0#0)
  3919.     else
  3920.       P := nil;
  3921.     Temp := CreateEnhMetafile(RefDC, nil, @R, P);
  3922.     if Temp = 0 then GDIError;
  3923.     Handle := Temp;
  3924.   finally
  3925.     if ReferenceDevice = 0 then ReleaseDC(0, RefDC);
  3926.   end;
  3927. end;
  3928.  
  3929. destructor TMetafileCanvas.Destroy;
  3930. var
  3931.   Temp: HDC;
  3932. begin
  3933.   Temp := Handle;
  3934.   Handle := 0;
  3935.   FMetafile.Handle := CloseEnhMetafile(Temp);
  3936.   inherited Destroy;
  3937. end;
  3938.  
  3939. { TMetafile }
  3940.  
  3941. constructor TMetafile.Create;
  3942. begin
  3943.   inherited Create;
  3944.   FEnhanced := True;
  3945.   FTransparent := True;
  3946.   Assign(nil);
  3947. end;
  3948.  
  3949. destructor TMetafile.Destroy;
  3950. begin
  3951.   FImage.Release;
  3952.   inherited Destroy;
  3953. end;
  3954.  
  3955. procedure TMetafile.Assign(Source: TPersistent);
  3956. var
  3957.   Pal: HPalette;
  3958. begin
  3959.   if (Source = nil) or (Source is TMetafile) then
  3960.   begin
  3961.     Pal := 0;
  3962.     if FImage <> nil then
  3963.     begin
  3964.       Pal := FImage.FPalette;
  3965.       FImage.Release;
  3966.     end;
  3967.     if Assigned(Source) then
  3968.     begin
  3969.       FImage := TMetafile(Source).FImage;
  3970.       FEnhanced := TMetafile(Source).Enhanced;
  3971.     end
  3972.     else
  3973.     begin
  3974.       FImage := TMetafileImage.Create;
  3975.       FEnhanced := True;
  3976.     end;
  3977.     FImage.Reference;
  3978.     PaletteModified := (Pal <> Palette) and (Palette <> 0);
  3979.     Changed(Self);
  3980.   end
  3981.   else
  3982.     inherited Assign(Source);
  3983. end;
  3984.  
  3985. procedure TMetafile.Clear;
  3986. begin
  3987.   NewImage;
  3988. end;
  3989.  
  3990. procedure TMetafile.Draw(ACanvas: TCanvas; const Rect: TRect);
  3991. var
  3992.   MetaPal, OldPal: HPALETTE;
  3993.   R: TRect;
  3994. begin
  3995.   if FImage = nil then Exit;
  3996.   MetaPal := Palette;
  3997.   OldPal := 0;
  3998.   if MetaPal <> 0 then
  3999.   begin
  4000.     OldPal := SelectPalette(ACanvas.Handle, MetaPal, True);
  4001.     RealizePalette(ACanvas.Handle);
  4002.   end;
  4003.   R := Rect;
  4004.   Dec(R.Right);  // Metafile rect includes right and bottom coords
  4005.   Dec(R.Bottom);
  4006.   PlayEnhMetaFile(ACanvas.Handle, FImage.FHandle, R);
  4007.   if MetaPal <> 0 then
  4008.     SelectPalette(ACanvas.Handle, OldPal, True);
  4009. end;
  4010.  
  4011. function TMetafile.GetAuthor: String;
  4012. var
  4013.   Temp: Integer;
  4014. begin
  4015.   Result := '';
  4016.   if (FImage = nil) or (FImage.FHandle = 0) then Exit;
  4017.   Temp := GetEnhMetafileDescription(FImage.FHandle, 0, nil);
  4018.   if Temp <= 0 then Exit;
  4019.   SetLength(Result, Temp);
  4020.   GetEnhMetafileDescription(FImage.FHandle, Temp, PChar(Result));
  4021.   SetLength(Result, StrLen(PChar(Result)));
  4022. end;
  4023.  
  4024. function TMetafile.GetDesc: String;
  4025. var
  4026.   Temp: Integer;
  4027. begin
  4028.   Result := '';
  4029.   if (FImage = nil) or (FImage.FHandle = 0) then Exit;
  4030.   Temp := GetEnhMetafileDescription(FImage.FHandle, 0, nil);
  4031.   if Temp <= 0 then Exit;
  4032.   SetLength(Result, Temp);
  4033.   GetEnhMetafileDescription(FImage.FHandle, Temp, PChar(Result));
  4034.   Delete(Result, 1, StrLen(PChar(Result))+1);
  4035.   SetLength(Result, StrLen(PChar(Result)));
  4036. end;
  4037.  
  4038. function TMetafile.GetEmpty;
  4039. begin
  4040.   Result := FImage = nil;
  4041. end;
  4042.  
  4043. function TMetafile.GetHandle: HENHMETAFILE;
  4044. begin
  4045.   if Assigned(FImage) then
  4046.     Result := FImage.FHandle
  4047.   else
  4048.     Result := 0;
  4049. end;
  4050.  
  4051. const
  4052.   HundredthMMPerInch = 2540;
  4053.  
  4054. function TMetafile.GetHeight: Integer;
  4055. var
  4056.   EMFHeader: TEnhMetaHeader;
  4057. begin
  4058.   if FImage = nil then NewImage;
  4059.   with FImage do
  4060.    if FInch = 0 then
  4061.      if FHandle = 0 then
  4062.        Result := FTempHeight
  4063.      else
  4064.      begin               { convert 0.01mm units to referenceDC device pixels }
  4065.        GetEnhMetaFileHeader(FHandle, Sizeof(EMFHeader), @EMFHeader);
  4066.        Result := MulDiv(FHeight,                     { metafile height in 0.01mm }
  4067.          EMFHeader.szlDevice.cy,                      { device height in pixels }
  4068.          EMFHeader.szlMillimeters.cy*100);            { device height in mm }
  4069.      end
  4070.    else          { for WMF files, convert to font dpi based device pixels }
  4071.      Result := MulDiv(FHeight, ScreenLogPixels, HundredthMMPerInch);
  4072. end;
  4073.  
  4074. function TMetafile.GetInch: Word;
  4075. begin
  4076.   Result := 0;
  4077.   if FImage <> nil then Result := FImage.FInch;
  4078. end;
  4079.  
  4080. function TMetafile.GetMMHeight: Integer;
  4081. begin
  4082.   if FImage = nil then NewImage;
  4083.   Result := FImage.FHeight;
  4084. end;
  4085.  
  4086. function TMetafile.GetMMWidth: Integer;
  4087. begin
  4088.   if FImage = nil then NewImage;
  4089.   Result := FImage.FWidth;
  4090. end;
  4091.  
  4092. function TMetafile.GetPalette: HPALETTE;
  4093. var
  4094.   LogPal: TMaxLogPalette;
  4095.   Count: Integer;
  4096. begin
  4097.   Result := 0;
  4098.   if (FImage = nil) or (FImage.FHandle = 0) then Exit;
  4099.   if FImage.FPalette = 0 then
  4100.   begin
  4101.     Count := GetEnhMetaFilePaletteEntries(FImage.FHandle, 0, nil);
  4102.     if Count = 0 then
  4103.       Exit
  4104.     else if Count > 256 then
  4105.       Count := Count and $FF;
  4106.     InternalDeletePalette(FImage.FPalette);
  4107.     LogPal.palVersion := $300;
  4108.     LogPal.palNumEntries := Count;
  4109.     GetEnhMetaFilePaletteEntries(FImage.FHandle, Count, @LogPal.palPalEntry);
  4110.     FImage.FPalette := CreatePalette(PLogPalette(@LogPal)^);
  4111.   end;
  4112.   Result := FImage.FPalette;
  4113. end;
  4114.  
  4115. function TMetafile.GetWidth: Integer;
  4116. var
  4117.   EMFHeader: TEnhMetaHeader;
  4118. begin
  4119.   if FImage = nil then NewImage;
  4120.   with FImage do
  4121.     if FInch = 0 then
  4122.       if FHandle = 0 then
  4123.         Result := FTempWidth
  4124.       else
  4125.       begin     { convert 0.01mm units to referenceDC device pixels }
  4126.         GetEnhMetaFileHeader(FHandle, Sizeof(EMFHeader), @EMFHeader);
  4127.         Result := MulDiv(FWidth,                      { metafile width in 0.01mm }
  4128.           EMFHeader.szlDevice.cx,                      { device width in pixels }
  4129.           EMFHeader.szlMillimeters.cx*100);            { device width in 0.01mm }
  4130.       end
  4131.     else      { for WMF files, convert to font dpi based device pixels }
  4132.       Result := MulDiv(FWidth, ScreenLogPixels, HundredthMMPerInch);
  4133. end;
  4134.  
  4135. procedure TMetafile.LoadFromStream(Stream: TStream);
  4136. begin
  4137.   if TestEMF(Stream) then
  4138.     ReadEMFStream(Stream)
  4139.   else
  4140.     ReadWMFStream(Stream, Stream.Size - Stream.Position);
  4141.   PaletteModified := Palette <> 0;
  4142.   Changed(Self);
  4143. end;
  4144.  
  4145. procedure TMetafile.NewImage;
  4146. begin
  4147.   FImage.Release;
  4148.   FImage := TMetafileImage.Create;
  4149.   FImage.Reference;
  4150. end;
  4151.  
  4152. procedure TMetafile.ReadData(Stream: TStream);
  4153. var
  4154.   Length: Longint;
  4155. begin
  4156.   Stream.Read(Length, SizeOf(Longint));
  4157.   if Length <= 4 then
  4158.     Assign(nil)
  4159.   else
  4160.     if TestEMF(Stream) then
  4161.       ReadEMFStream(Stream)
  4162.     else
  4163.       ReadWMFStream(Stream, Length - Sizeof(Length));
  4164.   PaletteModified := Palette <> 0;
  4165.   Changed(Self);
  4166. end;
  4167.  
  4168. procedure TMetafile.ReadEMFStream(Stream: TStream);
  4169. var
  4170.   EnhHeader: TEnhMetaheader;
  4171.   Buf: PChar;
  4172. begin
  4173.   NewImage;
  4174.   Stream.ReadBuffer(EnhHeader, Sizeof(EnhHeader));
  4175.   if EnhHeader.dSignature <> ENHMETA_SIGNATURE then InvalidMetafile;
  4176.   GetMem(Buf, EnhHeader.nBytes);
  4177.   with FImage do
  4178.   try
  4179.     Move(EnhHeader, Buf^, Sizeof(EnhHeader));
  4180.     Stream.ReadBuffer(PChar(Buf + Sizeof(EnhHeader))^,
  4181.       EnhHeader.nBytes - Sizeof(EnhHeader));
  4182.     FHandle := SetEnhMetafileBits(EnhHeader.nBytes, Buf);
  4183.     if FHandle = 0 then InvalidMetafile;
  4184.     FInch := 0;
  4185.     with EnhHeader.rclFrame do
  4186.     begin
  4187.       FWidth := Right - Left;    { in 0.01 mm units }
  4188.       FHeight := Bottom - Top;
  4189.     end;
  4190.     Enhanced := True;
  4191.   finally
  4192.     FreeMem(Buf, EnhHeader.nBytes);
  4193.   end;
  4194. end;
  4195.  
  4196. procedure TMetafile.ReadWMFStream(Stream: TStream; Length: Longint);
  4197. var
  4198.   WMF: TMetafileHeader;
  4199.   BitMem: Pointer;
  4200.   MFP: TMetaFilePict;
  4201.   EMFHeader: TEnhMetaheader;
  4202. begin
  4203.   NewImage;
  4204.   Stream.Read(WMF, SizeOf(WMF));
  4205.   if (WMF.Key <> WMFKEY) or (ComputeAldusChecksum(WMF) <> WMF.CheckSum) then
  4206.     InvalidMetafile;
  4207.   Dec(Length, SizeOf(WMF));
  4208.   GetMem(Bitmem, Length);
  4209.   with FImage do
  4210.   try
  4211.     Stream.Read(BitMem^, Length);
  4212.     FImage.FInch := WMF.Inch;
  4213.     if WMF.Inch = 0 then WMF.Inch := 96;
  4214.     FWidth := MulDiv(WMF.Box.Right - WMF.Box.Left,HundredthMMPerInch,WMF.Inch);
  4215.     FHeight := MulDiv(WMF.Box.Bottom - WMF.Box.Top,HundredthMMPerInch,WMF.Inch);
  4216.     with MFP do
  4217.     begin
  4218.       MM := MM_ANISOTROPIC;
  4219.       xExt := 0;
  4220.       yExt := 0;
  4221.       hmf := 0;
  4222.     end;
  4223.     FHandle := SetWinMetaFileBits(Length, BitMem, 0, MFP);
  4224.     if FHandle = 0 then InvalidMetafile;
  4225.     // Get the maximum extent actually used by the metafile output
  4226.     // and re-convert the wmf data using the new extents.
  4227.     // This helps preserve whitespace margins in WMFs
  4228.     GetEnhMetaFileHeader(FHandle, Sizeof(EMFHeader), @EMFHeader);
  4229.     with MFP, EMFHeader.rclFrame do
  4230.     begin
  4231.       MM := MM_ANISOTROPIC;
  4232.       xExt := Right;
  4233.       yExt := Bottom;
  4234.       hmf := 0;
  4235.     end;
  4236.     DeleteEnhMetafile(FHandle);
  4237.     FHandle := SetWinMetaFileBits(Length, BitMem, 0, MFP);
  4238.     if FHandle = 0 then InvalidMetafile;
  4239.     Enhanced := False;
  4240.   finally
  4241.     Freemem(BitMem, Length);
  4242.   end;
  4243. end;
  4244.  
  4245. procedure TMetafile.SaveToFile(const Filename: String);
  4246. var
  4247.   SaveEnh: Boolean;
  4248. begin
  4249.   SaveEnh := Enhanced;
  4250.   if AnsiLowerCaseFileName(ExtractFileExt(Filename)) = '.wmf' then
  4251.     Enhanced := False;              { For 16 bit compatibility }
  4252.   inherited SaveToFile(Filename);
  4253.   Enhanced := SaveEnh;
  4254. end;
  4255.  
  4256. procedure TMetafile.SaveToStream(Stream: TStream);
  4257. begin
  4258.   if FImage <> nil then
  4259.     if Enhanced then
  4260.       WriteEMFStream(Stream)
  4261.     else
  4262.       WriteWMFStream(Stream);
  4263. end;
  4264.  
  4265. procedure TMetafile.SetHandle(Value: HENHMETAFILE);
  4266. var
  4267.   EnhHeader: TEnhMetaHeader;
  4268. begin
  4269.   if (Value <> 0) and
  4270.     (GetEnhMetafileHeader(Value, sizeof(EnhHeader), @EnhHeader) = 0) then
  4271.     InvalidMetafile;
  4272.   UniqueImage;
  4273.   if FImage.FHandle <> 0 then DeleteEnhMetafile(FImage.FHandle);
  4274.   InternalDeletePalette(FImage.FPalette);
  4275.   FImage.FPalette := 0;
  4276.   FImage.FHandle := Value;
  4277.   FImage.FTempWidth := 0;
  4278.   FImage.FTempHeight := 0;
  4279.   if Value <> 0 then
  4280.     with EnhHeader.rclFrame do
  4281.     begin
  4282.       FImage.FWidth := Right - Left;
  4283.       FImage.FHeight := Bottom - Top;
  4284.     end;
  4285.   PaletteModified := Palette <> 0;
  4286.   Changed(Self);
  4287. end;
  4288.  
  4289. procedure TMetafile.SetHeight(Value: Integer);
  4290. var
  4291.   EMFHeader: TEnhMetaHeader;
  4292. begin
  4293.   if FImage = nil then NewImage;
  4294.   with FImage do
  4295.     if FInch = 0 then
  4296.       if FHandle = 0 then
  4297.         FTempHeight := Value
  4298.       else
  4299.       begin                 { convert device pixels to 0.01mm units }
  4300.         GetEnhMetaFileHeader(FHandle, Sizeof(EMFHeader), @EMFHeader);
  4301.         MMHeight := MulDiv(Value,                      { metafile height in pixels }
  4302.           EMFHeader.szlMillimeters.cy*100,             { device height in 0.01mm }
  4303.           EMFHeader.szlDevice.cy);                     { device height in pixels }
  4304.       end
  4305.     else
  4306.       MMHeight := MulDiv(Value, HundredthMMPerInch, ScreenLogPixels);
  4307. end;
  4308.  
  4309. procedure TMetafile.SetInch(Value: Word);
  4310. begin
  4311.   if FImage = nil then NewImage;
  4312.   if FImage.FInch <> Value then
  4313.   begin
  4314.     UniqueImage;
  4315.     FImage.FInch := Value;
  4316.     Changed(Self);
  4317.   end;
  4318. end;
  4319.  
  4320. procedure TMetafile.SetMMHeight(Value: Integer);
  4321. begin
  4322.   if FImage = nil then NewImage;
  4323.   FImage.FTempHeight := 0;
  4324.   if FImage.FHeight <> Value then
  4325.   begin
  4326.     UniqueImage;
  4327.     FImage.FHeight := Value;
  4328.     Changed(Self);
  4329.   end;
  4330. end;
  4331.  
  4332. procedure TMetafile.SetMMWidth(Value: Integer);
  4333. begin
  4334.   if FImage = nil then NewImage;
  4335.   FImage.FTempWidth := 0;
  4336.   if FImage.FWidth <> Value then
  4337.   begin
  4338.     UniqueImage;
  4339.     FImage.FWidth := Value;
  4340.     Changed(Self);
  4341.   end;
  4342. end;
  4343.  
  4344. procedure TMetafile.SetTransparent(Value: Boolean);
  4345. begin
  4346.   // Ignore assignments to this property.
  4347.   // Metafiles must always be considered transparent.
  4348. end;
  4349.  
  4350. procedure TMetafile.SetWidth(Value: Integer);
  4351. var
  4352.   EMFHeader: TEnhMetaHeader;
  4353. begin
  4354.   if FImage = nil then NewImage;
  4355.   with FImage do
  4356.     if FInch = 0 then
  4357.       if FHandle = 0 then
  4358.         FTempWidth := Value
  4359.       else
  4360.       begin                 { convert device pixels to 0.01mm units }
  4361.         GetEnhMetaFileHeader(FHandle, Sizeof(EMFHeader), @EMFHeader);
  4362.         MMWidth := MulDiv(Value,                      { metafile width in pixels }
  4363.           EMFHeader.szlMillimeters.cx*100,            { device width in mm }
  4364.           EMFHeader.szlDevice.cx);                    { device width in pixels }
  4365.       end
  4366.     else
  4367.       MMWidth := MulDiv(Value, HundredthMMPerInch, ScreenLogPixels);
  4368. end;
  4369.  
  4370. function TMetafile.TestEMF(Stream: TStream): Boolean;
  4371. var
  4372.   Size: Longint;
  4373.   Header: TEnhMetaHeader;
  4374. begin
  4375.   Size := Stream.Size - Stream.Position;
  4376.   if Size > Sizeof(Header) then
  4377.   begin
  4378.     Stream.Read(Header, Sizeof(Header));
  4379.     Stream.Seek(-Sizeof(Header), soFromCurrent);
  4380.   end;
  4381.   Result := (Size > Sizeof(Header)) and
  4382.     (Header.iType = EMR_HEADER) and (Header.dSignature = ENHMETA_SIGNATURE);
  4383. end;
  4384.  
  4385. procedure TMetafile.UniqueImage;
  4386. var
  4387.   NewImage: TMetafileImage;
  4388. begin
  4389.   if FImage = nil then
  4390.     Self.NewImage
  4391.   else
  4392.     if FImage.FRefCount > 1 then
  4393.     begin
  4394.       NewImage:= TMetafileImage.Create;
  4395.       if FImage.FHandle <> 0 then
  4396.         NewImage.FHandle := CopyEnhMetafile(FImage.FHandle, nil);
  4397.       NewImage.FHeight := FImage.FHeight;
  4398.       NewImage.FWidth := FImage.FWidth;
  4399.       NewImage.FInch := FImage.FInch;
  4400.       NewImage.FTempWidth := FImage.FTempWidth;
  4401.       NewImage.FTempHeight := FImage.FTempHeight;
  4402.       FImage.Release;
  4403.       FImage := NewImage;
  4404.       FImage.Reference;
  4405.     end;
  4406. end;
  4407.  
  4408. procedure TMetafile.WriteData(Stream: TStream);
  4409. var
  4410.   SavePos: Longint;
  4411. begin
  4412.   if FImage <> nil then
  4413.   begin
  4414.     SavePos := 0;
  4415.     Stream.Write(SavePos, Sizeof(SavePos));
  4416.     SavePos := Stream.Position - Sizeof(SavePos);
  4417.     if Enhanced then
  4418.       WriteEMFStream(Stream)
  4419.     else
  4420.       WriteWMFStream(Stream);
  4421.     Stream.Seek(SavePos, soFromBeginning);
  4422.     SavePos := Stream.Size - SavePos;
  4423.     Stream.Write(SavePos, Sizeof(SavePos));
  4424.     Stream.Seek(0, soFromEnd);
  4425.   end;
  4426. end;
  4427.  
  4428. procedure TMetafile.WriteEMFStream(Stream: TStream);
  4429. var
  4430.   Buf: Pointer;
  4431.   Length: Longint;
  4432. begin
  4433.   if FImage = nil then Exit;
  4434.   Length := GetEnhMetaFileBits(FImage.FHandle, 0, nil);
  4435.   if Length = 0 then Exit;
  4436.   GetMem(Buf, Length);
  4437.   try
  4438.     GetEnhMetaFileBits(FImage.FHandle, Length, Buf);
  4439.     Stream.WriteBuffer(Buf^, Length);
  4440.   finally
  4441.     FreeMem(Buf, Length);
  4442.   end;
  4443. end;
  4444.  
  4445. procedure TMetafile.WriteWMFStream(Stream: TStream);
  4446. var
  4447.   WMF: TMetafileHeader;
  4448.   Bits: Pointer;
  4449.   Length: UINT;
  4450.   RefDC: HDC;
  4451. begin
  4452.   if FImage = nil then Exit;
  4453.   FillChar(WMF, SizeOf(WMF), 0);
  4454.   with FImage do
  4455.   begin
  4456.     with WMF do
  4457.     begin
  4458.       Key := WMFKEY;
  4459.       if FInch = 0 then
  4460.         Inch := 96          { WMF defaults to 96 units per inch }
  4461.       else
  4462.         Inch := FInch;
  4463.       with Box do
  4464.       begin
  4465.         Right := MulDiv(FWidth, WMF.Inch, HundredthMMPerInch);
  4466.         Bottom := MulDiv(FHeight, WMF.Inch, HundredthMMPerInch);
  4467.       end;
  4468.       CheckSum := ComputeAldusChecksum(WMF);
  4469.     end;
  4470.     RefDC := GetDC(0);
  4471.     try
  4472.       Length := GetWinMetaFileBits(FHandle, 0, nil, MM_ANISOTROPIC, RefDC);
  4473.       GetMem(Bits, Length);
  4474.       try
  4475.         if GetWinMetaFileBits(FHandle, Length, Bits, MM_ANISOTROPIC,
  4476.           RefDC) < Length then GDIError;
  4477.         Stream.WriteBuffer(WMF, SizeOf(WMF));
  4478.         Stream.WriteBuffer(Bits^, Length);
  4479.       finally
  4480.         FreeMem(Bits, Length);
  4481.       end;
  4482.     finally
  4483.       ReleaseDC(0, RefDC);
  4484.     end;
  4485.   end;
  4486. end;
  4487.  
  4488. procedure TMetafile.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  4489.   APalette: HPALETTE);
  4490. var
  4491.   EnhHeader: TEnhMetaHeader;
  4492. begin
  4493.   AData := GetClipboardData(CF_ENHMETAFILE); // OS will convert WMF to EMF
  4494.   if AData = 0 then  InvalidGraphic(@SUnknownClipboardFormat);
  4495.   NewImage;
  4496.   with FImage do
  4497.   begin
  4498.     FHandle := CopyEnhMetafile(AData, nil);
  4499.     GetEnhMetaFileHeader(FHandle, sizeof(EnhHeader), @EnhHeader);
  4500.     with EnhHeader.rclFrame do
  4501.     begin
  4502.       FWidth := Right - Left;
  4503.       FHeight := Bottom - Top;
  4504.     end;
  4505.     FInch := 0;
  4506.   end;
  4507.   Enhanced := True;
  4508.   PaletteModified := Palette <> 0;
  4509.   Changed(Self);
  4510. end;
  4511.  
  4512. procedure TMetafile.SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  4513.   var APalette: HPALETTE);
  4514. begin
  4515.   if FImage = nil then Exit;
  4516.   AFormat := CF_ENHMETAFILE;
  4517.   APalette := 0;
  4518.   AData := CopyEnhMetaFile(FImage.FHandle, nil);
  4519. end;
  4520.  
  4521. function TMetafile.ReleaseHandle: HENHMETAFILE;
  4522. begin
  4523.   UniqueImage;
  4524.   Result := FImage.FHandle;
  4525.   FImage.FHandle := 0;
  4526. end;
  4527.  
  4528. var
  4529.   BitmapCanvasList: TThreadList = nil;
  4530.  
  4531. { TBitmapCanvas }
  4532. { Create a canvas that gets its DC from the memory DC cache }
  4533. type
  4534.   TBitmapCanvas = class(TCanvas)
  4535.   private
  4536.     FBitmap: TBitmap;
  4537.     FOldBitmap: HBITMAP;
  4538.     FOldPalette: HPALETTE;
  4539.     procedure FreeContext;
  4540.   protected
  4541.     procedure CreateHandle; override;
  4542.   public
  4543.     constructor Create(ABitmap: TBitmap);
  4544.     destructor Destroy; override;
  4545.   end;
  4546.  
  4547. { FreeMemoryContexts is called by the VCL main winproc to release
  4548.   memory DCs after every message is processed (garbage collection).
  4549.   Only memory DCs not locked by other threads will be freed.
  4550. }
  4551. procedure FreeMemoryContexts;
  4552. var
  4553.   I: Integer;
  4554. begin
  4555.   with BitmapCanvasList.LockList do
  4556.   try
  4557.     for I := Count-1 downto 0 do
  4558.     with TBitmapCanvas(Items[I]) do
  4559.       if TryLock then
  4560.       try
  4561.         FreeContext;
  4562.       finally
  4563.         Unlock;
  4564.       end;
  4565.   finally
  4566.     BitmapCanvasList.UnlockList;
  4567.   end;
  4568. end;
  4569.  
  4570. { DeselectBitmap is called to ensure that a bitmap handle is not
  4571.   selected into any memory DC anywhere in the system.  If the bitmap
  4572.   handle is in use by a locked canvas, DeselectBitmap must wait for
  4573.   the canvas to unlock. }
  4574.  
  4575. procedure DeselectBitmap(AHandle: HBITMAP);
  4576. var
  4577.   I: Integer;
  4578. begin
  4579.   if AHandle = 0 then Exit;
  4580.   with BitmapCanvasList.LockList do
  4581.   try
  4582.     for I := Count - 1 downto 0 do
  4583.       with TBitmapCanvas(Items[I]) do
  4584.         if (FBitmap <> nil) and (FBitmap.FImage.FHandle = AHandle) then
  4585.           FreeContext;
  4586.   finally
  4587.     BitmapCanvasList.UnlockList;
  4588.   end;
  4589. end;
  4590.  
  4591. constructor TBitmapCanvas.Create(ABitmap: TBitmap);
  4592. begin
  4593.   inherited Create;
  4594.   FBitmap := ABitmap;
  4595. end;
  4596.  
  4597. destructor TBitmapCanvas.Destroy;
  4598. begin
  4599.   FreeContext;
  4600.   inherited Destroy;
  4601. end;
  4602.  
  4603. procedure TBitmapCanvas.FreeContext;
  4604. var
  4605.   H: HBITMAP;
  4606. begin
  4607.   if FHandle <> 0 then
  4608.   begin
  4609.     Lock;
  4610.     try
  4611.       if FOldBitmap <> 0 then SelectObject(FHandle, FOldBitmap);
  4612.       if FOldPalette <> 0 then SelectPalette(FHandle, FOldPalette, True);
  4613.       H := FHandle;
  4614.       Handle := 0;
  4615.       DeleteDC(H);
  4616.       BitmapCanvasList.Remove(Self);
  4617.     finally
  4618.       Unlock;
  4619.     end;
  4620.   end;
  4621. end;
  4622.  
  4623. procedure TBitmapCanvas.CreateHandle;
  4624. var
  4625.   H: HBITMAP;
  4626. begin
  4627.   if FBitmap <> nil then
  4628.   begin
  4629.     Lock;
  4630.     try
  4631.       FBitmap.HandleNeeded;
  4632.       DeselectBitmap(FBitmap.FImage.FHandle);
  4633. //!!      DeselectBitmap(FBitmap.FImage.FMaskHandle);
  4634.       FBitmap.PaletteNeeded;
  4635.       H := CreateCompatibleDC(0);
  4636.       if FBitmap.FImage.FHandle <> 0 then
  4637.         FOldBitmap := SelectObject(H, FBitmap.FImage.FHandle) else
  4638.         FOldBitmap := 0;
  4639.       if FBitmap.FImage.FPalette <> 0 then
  4640.       begin
  4641.         FOldPalette := SelectPalette(H, FBitmap.FImage.FPalette, True);
  4642.         RealizePalette(H);
  4643.       end
  4644.       else
  4645.         FOldPalette := 0;
  4646.       Handle := H;
  4647.       BitmapCanvasList.Add(Self);
  4648.     finally
  4649.       Unlock;
  4650.     end;
  4651.   end;
  4652. end;
  4653.  
  4654. { TSharedImage }
  4655.  
  4656. procedure TSharedImage.Reference;
  4657. begin
  4658.   Inc(FRefCount);
  4659. end;
  4660.  
  4661. procedure TSharedImage.Release;
  4662. begin
  4663.   if Pointer(Self) <> nil then
  4664.   begin
  4665.     Dec(FRefCount);
  4666.     if FRefCount = 0 then
  4667.     begin
  4668.       FreeHandle;
  4669.       Free;
  4670.     end;
  4671.   end;
  4672. end;
  4673.  
  4674. { TBitmapImage }
  4675.  
  4676. destructor TBitmapImage.Destroy;
  4677. begin
  4678.   if FDIBHandle <> 0 then
  4679.   begin
  4680.     DeselectBitmap(FDIBHandle);
  4681.     DeleteObject(FDIBHandle);
  4682.     FDIBHandle := 0;
  4683.   end;
  4684.   FreeHandle;
  4685.   if FDIB.dshSection <> 0 then CloseHandle(FDIB.dshSection);
  4686.   FreeAndNil(FSaveStream);
  4687.   inherited Destroy;
  4688. end;
  4689.  
  4690. procedure TBitmapImage.FreeHandle;
  4691. begin
  4692.   if (FHandle <> 0) and (FHandle <> FDIBHandle) then
  4693.   begin
  4694.     DeselectBitmap(FHandle);
  4695.     DeleteObject(FHandle);
  4696.   end;
  4697.   if FMaskHandle <> 0 then
  4698.   begin
  4699.     DeselectBitmap(FMaskHandle);
  4700.     DeleteObject(FMaskHandle);
  4701.     FMaskHandle := 0;
  4702.   end;
  4703.   InternalDeletePalette(FPalette);
  4704.   FHandle := 0;
  4705.   FPalette := 0;
  4706. end;
  4707.  
  4708. { TBitmap }
  4709.  
  4710. const
  4711.   { Mapping from color in DIB to system color }
  4712.   Grays: array[0..3] of TColor = (clWhite, clSilver, clGray, clBlack);
  4713.   SysGrays: array[0..3] of TColor = (clBtnHighlight, clBtnFace, clBtnShadow,
  4714.     clBtnText);
  4715.  
  4716. { This function will replace OldColors in Handle's colortable with NewColors and
  4717.   return a new DDB which uses that color table.  For bitmap's with more than
  4718.   256 colors (8bpp) this function returns the original bitmap. }
  4719. function CreateMappedBmp(Handle: HBITMAP; const OldColors, NewColors: array of TColor): HBITMAP;
  4720. var
  4721.   Bitmap: PBitmapInfoHeader;
  4722.   ColorCount: Integer;
  4723.   BitmapInfoSize: DWORD;
  4724.   BitmapBitsSize: DWORD;
  4725.   Bits: Pointer;
  4726.   Colors: PRGBQuadArray;
  4727.   I, J: Integer;
  4728.   OldColor, NewColor: Integer;
  4729.   ScreenDC, DC: HDC;
  4730.   Save: HBITMAP;
  4731. begin
  4732.   Result := Handle;
  4733.   if Handle = 0 then Exit;
  4734.   InternalGetDIBSizes(Handle, BitmapInfoSize, BitmapBitsSize, 0);
  4735.   Bitmap := AllocMem(DWORD(BitmapInfoSize) + BitmapBitsSize);
  4736.   try
  4737.     Bits := Pointer(DWORD(Bitmap) + BitmapInfoSize);
  4738.     InternalGetDIB(Handle, 0, Bitmap^, Bits^, 0);
  4739.     if Bitmap^.biBitCount <= 8 then
  4740.     begin
  4741.       ColorCount := 1 shl (Bitmap^.biBitCount);
  4742.       Colors := Pointer(DWORD(Bitmap) + Bitmap^.biSize);
  4743.       ByteSwapColors(Colors^, ColorCount);
  4744.       for I := 0 to ColorCount - 1 do
  4745.         for J := Low(OldColors) to High(OldColors) do
  4746.         begin
  4747.           OldColor := ColorToRGB(OldColors[J]);
  4748.           if Integer(Colors[I]) = OldColor then
  4749.           begin
  4750.             NewColor := ColorToRGB(NewColors[J]);
  4751.             Integer(Colors[I]) := NewColor;
  4752.           end;
  4753.         end;
  4754.       ByteSwapColors(Colors^, ColorCount);
  4755.       ScreenDC := GetDC(0);
  4756.       try
  4757.         DC := CreateCompatibleDC(ScreenDC);
  4758.         if DC <> 0 then
  4759.           with Bitmap^ do
  4760.           begin
  4761.             Result := CreateCompatibleBitmap(ScreenDC, biWidth, biHeight);
  4762.             if Result <> 0 then
  4763.             begin
  4764.               Save := SelectObject(DC, Result);
  4765.               StretchDIBits(DC, 0, 0, biWidth, biHeight, 0, 0, biWidth, biHeight,
  4766.                 Bits, PBitmapInfo(Bitmap)^, DIB_RGB_COLORS, SrcCopy);
  4767.               SelectObject(DC, Save);
  4768.             end;
  4769.           end;
  4770.           DeleteDC(DC);
  4771.       finally
  4772.         ReleaseDC(0, ScreenDC);
  4773.       end;
  4774.     end;
  4775.   finally
  4776.     FreeMem(Bitmap, BitmapInfoSize + BitmapBitsSize);
  4777.   end;
  4778. end;
  4779.  
  4780. { This function will create a new DDB from the bitmap resource, replacing
  4781.   OldColors in the colortable with NewColors.  If the bitmap resource has more
  4782.   than 256 colors (8bpp) this function returns the new DDB without color
  4783.   modifications. }
  4784. function CreateMappedRes(Instance: THandle; ResName: PChar;
  4785.   const OldColors, NewColors: array of TColor): HBITMAP;
  4786. var
  4787.   Rsrc: HRSRC;
  4788.   Res: THandle;
  4789.   ColorCount: DWORD;
  4790.   BitmapInfoSize: Integer;
  4791.   Bitmap: PBitmapInfoHeader;
  4792.   BitmapInfo: PBitmapInfoHeader;
  4793.   Colors: PRGBQuadArray;
  4794.   I, J: Integer;
  4795.   OldColor, NewColor: Integer;
  4796.   Bits: Pointer;
  4797.   ScreenDC, DC: HDC;
  4798.   Save: HBITMAP;
  4799.   Temp: TBitmap;
  4800. begin
  4801.   Result := 0;
  4802.   Rsrc := FindResource(Instance, ResName, RT_BITMAP);
  4803.   if Rsrc = 0 then Exit;
  4804.   Res := LoadResource(Instance, Rsrc);
  4805.   try
  4806.     { Lock the bitmap and get a pointer to the color table. }
  4807.     Bitmap := LockResource(Res);
  4808.     if Bitmap <> nil then
  4809.     try
  4810.       if (Bitmap^.biBitCount * Bitmap^.biPlanes) <= 8 then
  4811.       begin
  4812.         ColorCount := 1 shl (Bitmap^.biBitCount);
  4813.         BitmapInfoSize := Bitmap^.biSize + ColorCount * SizeOf(TRGBQuad);
  4814.         GetMem(BitmapInfo, BitmapInfoSize);
  4815.         try
  4816.           Move(Bitmap^, BitmapInfo^, BitmapInfoSize);
  4817.           if Bitmap^.biBitCount <= 8 then
  4818.           begin
  4819.             Colors := Pointer(DWORD(BitmapInfo) + BitmapInfo^.biSize);
  4820.             ByteSwapColors(Colors^, ColorCount);
  4821.             for I := 0 to ColorCount - 1 do
  4822.               for J := Low(OldColors) to High(OldColors) do
  4823.               begin
  4824.                 OldColor := ColorToRGB(OldColors[J]);
  4825.                 if Integer(Colors[I]) = OldColor then
  4826.                 begin
  4827.                   NewColor := ColorToRGB(NewColors[J]);
  4828.                   Integer(Colors[I]) := NewColor;
  4829.                 end;
  4830.               end;
  4831.             ByteSwapColors(Colors^, ColorCount);
  4832.           end;
  4833.           { First skip over the header structure and color table entries, if any. }
  4834.           Bits := Pointer(Longint(Bitmap) + BitmapInfoSize);
  4835.           { Create a color bitmap compatible with the display device. }
  4836.           ScreenDC := GetDC(0);
  4837.           try
  4838.             DC := CreateCompatibleDC(ScreenDC);
  4839.             if DC <> 0 then
  4840.               with BitmapInfo^ do
  4841.               begin
  4842.                 Result := CreateCompatibleBitmap(ScreenDC, biWidth, biHeight);
  4843.                 if Result <> 0 then
  4844.                 begin
  4845.                   Save := SelectObject(DC, Result);
  4846.                   StretchDIBits(DC, 0, 0, biWidth, biHeight, 0, 0, biWidth, biHeight,
  4847.                     Bits, PBitmapInfo(BitmapInfo)^, DIB_RGB_COLORS, SrcCopy);
  4848.                   SelectObject(DC, Save);
  4849.                 end;
  4850.               end;
  4851.               DeleteDC(DC);
  4852.           finally
  4853.             ReleaseDC(0, ScreenDC);
  4854.           end;
  4855.         finally
  4856.           FreeMem(BitmapInfo, BitmapInfoSize);
  4857.         end;
  4858.       end
  4859.       else
  4860.       begin
  4861.         Temp := TBitmap.Create;
  4862.         try
  4863.           Temp.LoadFromResourceID(Instance, Integer(ResName));
  4864.           Result := Temp.ReleaseHandle;
  4865.         finally
  4866.           Temp.Free;
  4867.         end;
  4868.       end;
  4869.     finally
  4870.       UnlockResource(Res);
  4871.     end;
  4872.   finally
  4873.     FreeResource(Res);
  4874.   end;
  4875. end;
  4876.  
  4877. { This function replaces the standard gray colors in a bitmap with the system
  4878.   grays (Grays, SysGrays). }
  4879. function CreateGrayMappedBmp(Handle: HBITMAP): HBITMAP;
  4880. begin
  4881.   Result := CreateMappedBmp(Handle, Grays, SysGrays);
  4882. end;
  4883.  
  4884. { This function replaces the standard gray colors in a bitmap resource with the
  4885.   system grays (Grays, SysGrays). }
  4886. function CreateGrayMappedRes(Instance: THandle; ResName: PChar): HBITMAP;
  4887. begin
  4888.   Result := CreateMappedRes(Instance, ResName, Grays, SysGrays);
  4889. end;
  4890.  
  4891. procedure UpdateDIBColorTable(DIBHandle: HBITMAP; Pal: HPalette;
  4892.   const DIB: TDIBSection);
  4893. var
  4894.   ScreenDC, DC: HDC;
  4895.   OldBM: HBitmap;
  4896.   ColorCount: Integer;
  4897.   Colors: array [Byte] of TRGBQuad;
  4898. begin
  4899.   if (DIBHandle <> 0) and (DIB.dsbmih.biBitCount <= 8) then
  4900.   begin
  4901.     ColorCount := PaletteToDIBColorTable(Pal, Colors);
  4902.     if ColorCount = 0 then Exit;
  4903.     ScreenDC := GetDC(0);
  4904.     DC := CreateCompatibleDC(ScreenDC);
  4905.     OldBM := SelectObject(DC, DIBHandle);
  4906.     try
  4907.       SetDIBColorTable(DC, 0, ColorCount, Colors);
  4908.     finally
  4909.       SelectObject(DC, OldBM);
  4910.       DeleteDC(DC);
  4911.       ReleaseDC(0, ScreenDC);
  4912.     end;
  4913.   end;
  4914. end;
  4915.  
  4916. procedure FixupBitFields(var DIB: TDIBSection);
  4917. begin
  4918.   if (DIB.dsbmih.biCompression and BI_BITFIELDS <> 0) and
  4919.     (DIB.dsBitFields[0] = 0) then
  4920.     if DIB.dsbmih.biBitCount = 16 then
  4921.     begin
  4922.       // fix buggy 16 bit color drivers
  4923.       DIB.dsBitFields[0] := $F800;
  4924.       DIB.dsBitFields[1] := $07E0;
  4925.       DIB.dsBitFields[2] := $001F;
  4926.     end else if DIB.dsbmih.biBitCount = 32 then
  4927.     begin
  4928.       // fix buggy 32 bit color drivers
  4929.       DIB.dsBitFields[0] := $00FF0000;
  4930.       DIB.dsBitFields[1] := $0000FF00;
  4931.       DIB.dsBitFields[2] := $000000FF;
  4932.     end;
  4933. end;
  4934.  
  4935. function CopyBitmap(Handle: HBITMAP; OldPalette, NewPalette: HPALETTE;
  4936.   var DIB: TDIBSection; Canvas: TCanvas): HBITMAP;
  4937. var
  4938.   OldScr, NewScr: HBITMAP;
  4939.   ScreenDC, NewImageDC, OldImageDC: HDC;
  4940.   BI: PBitmapInfo;
  4941.   BitsMem: Pointer;
  4942.   SrcDIB: TDIBSection;
  4943.   MonoColors: array [0..1] of Integer;
  4944.   Pal1, Pal2: HPalette;
  4945. begin
  4946.   Result := 0;
  4947.   with DIB, dsbm, dsbmih do
  4948.   begin
  4949.     if (biSize <> 0) and ((biWidth = 0) or (biHeight = 0)) then Exit;
  4950.     if (biSize = 0) and ((bmWidth = 0) or (bmHeight = 0)) then Exit;
  4951.   end;
  4952.  
  4953.   DeselectBitmap(Handle);
  4954.  
  4955.   SrcDIB.dsbmih.biSize := 0;
  4956.   if Handle <> 0 then
  4957.     if GetObject(Handle, sizeof(SrcDIB), @SrcDIB) < sizeof(SrcDIB.dsbm) then
  4958.       InvalidBitmap;
  4959.  
  4960.   ScreenDC := GDICheck(GetDC(0));
  4961.   NewImageDC := GDICheck(CreateCompatibleDC(ScreenDC));
  4962.   with DIB.dsbm do
  4963.   try
  4964.     if DIB.dsbmih.biSize < DWORD(sizeof(DIB.dsbmih)) then
  4965.       if (bmPlanes or bmBitsPixel) = 1 then // monochrome
  4966.         Result := GDICheck(CreateBitmap(bmWidth, bmHeight, 1, 1, nil))
  4967.       else  // Create DDB
  4968.         Result := GDICheck(CreateCompatibleBitmap(ScreenDC, bmWidth, bmHeight))
  4969.     else  // Create DIB
  4970.     begin
  4971.       GetMem(BI, sizeof(TBitmapInfo) + 256 * sizeof(TRGBQuad));
  4972.       with DIB.dsbmih do
  4973.       try
  4974.         biSize := sizeof(BI.bmiHeader);
  4975.         biPlanes := 1;
  4976.         if biBitCount = 0 then
  4977.           biBitCount := GetDeviceCaps(ScreenDC, BITSPIXEL) * GetDeviceCaps(ScreenDC, PLANES);
  4978.         BI.bmiHeader := DIB.dsbmih;
  4979.         bmWidth := biWidth;
  4980.         bmHeight := biHeight;
  4981.  
  4982.         if (biBitCount <= 8) then
  4983.         begin
  4984.           if (biBitCount = 1) and (SrcDIB.dsbm.bmBits = nil) then
  4985.           begin  // set mono DIB to white/black when converting from DDB.
  4986.             Integer(BI^.bmiColors[0]) := 0;
  4987.             PInteger(Integer(@BI^.bmiColors) + sizeof(Integer))^ := $FFFFFF;
  4988.           end
  4989.           else if (NewPalette <> 0) then
  4990.             PaletteToDIBColorTable(NewPalette, PRGBQuadArray(@BI.bmiColors)^)
  4991.           else if Handle <> 0 then
  4992.           begin
  4993.             NewScr := SelectObject(NewImageDC, Handle);
  4994.             if (SrcDIB.dsbmih.biSize > 0) and (SrcDIB.dsbm.bmBits <> nil) then
  4995.               biClrUsed := GetDIBColorTable(NewImageDC, 0, 256, BI^.bmiColors)
  4996.             else
  4997.               GetDIBits(NewImageDC, Handle, 0, Abs(biHeight), nil, BI^, DIB_RGB_COLORS);
  4998.             SelectObject(NewImageDC, NewScr);
  4999.           end;
  5000.         end
  5001.         else if ((biBitCount = 16) or (biBitCount = 32)) and
  5002.           ((biCompression and BI_BITFIELDS) <> 0) then
  5003.         begin
  5004.           FixupBitFields(DIB);
  5005.           Move(DIB.dsBitFields, BI.bmiColors, sizeof(DIB.dsBitFields));
  5006.         end;
  5007.  
  5008.         Result := GDICheck(CreateDIBSection(ScreenDC, BI^, DIB_RGB_COLORS, BitsMem, 0, 0));
  5009.         if (BitsMem = nil) then GDIError;
  5010.  
  5011.         if (Handle <> 0) and (SrcDIB.dsbm.bmWidth = biWidth) and
  5012.           (SrcDIB.dsbm.bmHeight = biHeight) and (biBitCount > 8) then
  5013.         begin    // shortcut bitblt steps
  5014.           GetDIBits(NewImageDC, Handle, 0, Abs(biHeight), BitsMem, BI^, DIB_RGB_COLORS);
  5015.           Exit;
  5016.         end;
  5017.       finally
  5018.         FreeMem(BI);
  5019.       end;
  5020.     end;
  5021.  
  5022.     GDICheck(Result);
  5023.     NewScr := GDICheck(SelectObject(NewImageDC, Result));
  5024.     try
  5025.       try
  5026.         Pal1 := 0;
  5027.         Pal2 := 0;
  5028.         if NewPalette <> 0 then
  5029.         begin
  5030.           Pal1 := SelectPalette(NewImageDC, NewPalette, False);
  5031.           RealizePalette(NewImageDC);
  5032.         end;
  5033.         try
  5034.           if Canvas <> nil then
  5035.           begin
  5036.             FillRect(NewImageDC, Rect(0, 0, bmWidth, bmHeight),
  5037.               Canvas.Brush.Handle);
  5038.             SetTextColor(NewImageDC, ColorToRGB(Canvas.Font.Color));
  5039.             SetBkColor(NewImageDC, ColorToRGB(Canvas.Brush.Color));
  5040.             if (DIB.dsbmih.biBitCount = 1) and (DIB.dsbm.bmBits <> nil) then
  5041.             begin
  5042.               MonoColors[0] := ColorToRGB(Canvas.Font.Color);
  5043.               MonoColors[1] := ColorToRGB(Canvas.Brush.Color);
  5044.               SetDIBColorTable(NewImageDC, 0, 2, MonoColors);
  5045.             end;
  5046.           end
  5047.           else
  5048.             PatBlt(NewImageDC, 0, 0, bmWidth, bmHeight, WHITENESS);
  5049.           if Handle <> 0 then
  5050.           begin
  5051.             OldImageDC := GDICheck(CreateCompatibleDC(ScreenDC));
  5052.             try
  5053.               OldScr := GDICheck(SelectObject(OldImageDC, Handle));
  5054.               if OldPalette <> 0 then
  5055.               begin
  5056.                 Pal2 := SelectPalette(OldImageDC, OldPalette, False);
  5057.                 RealizePalette(OldImageDC);
  5058.               end;
  5059.               if Canvas <> nil then
  5060.               begin
  5061.                 SetTextColor(OldImageDC, ColorToRGB(Canvas.Font.Color));
  5062.                 SetBkColor(OldImageDC, ColorToRGB(Canvas.Brush.Color));
  5063.               end;
  5064.               BitBlt(NewImageDC, 0, 0, bmWidth, bmHeight, OldImageDC, 0, 0, SRCCOPY);
  5065.               if OldPalette <> 0 then
  5066.                 SelectPalette(OldImageDC, Pal2, True);
  5067.               GDICheck(SelectObject(OldImageDC, OldScr));
  5068.             finally
  5069.               DeleteDC(OldImageDC);
  5070.             end;
  5071.           end;
  5072.         finally
  5073.           if NewPalette <> 0 then
  5074.             SelectPalette(NewImageDC, Pal1, True);
  5075.         end;
  5076.       finally
  5077.         SelectObject(NewImageDC, NewScr);
  5078.       end;
  5079.     except
  5080.       DeleteObject(Result);
  5081.       raise;
  5082.     end;
  5083.   finally
  5084.     DeleteDC(NewImageDC);
  5085.     ReleaseDC(0, ScreenDC);
  5086.     if (Result <> 0) then GetObject(Result, sizeof(DIB), @DIB);
  5087.   end;
  5088. end;
  5089.  
  5090. function CopyPalette(Palette: HPALETTE): HPALETTE;
  5091. var
  5092.   PaletteSize: Integer;
  5093.   LogPal: TMaxLogPalette;
  5094. begin
  5095.   Result := 0;
  5096.   if Palette = 0 then Exit;
  5097.   PaletteSize := 0;
  5098.   if GetObject(Palette, SizeOf(PaletteSize), @PaletteSize) = 0 then Exit;
  5099.   if PaletteSize = 0 then Exit;
  5100.   with LogPal do
  5101.   begin
  5102.     palVersion := $0300;
  5103.     palNumEntries := PaletteSize;
  5104.     GetPaletteEntries(Palette, 0, PaletteSize, palPalEntry);
  5105.   end;
  5106.   Result := CreatePalette(PLogPalette(@LogPal)^);
  5107. end;
  5108.  
  5109. function CopyBitmapAsMask(Handle: HBITMAP; Palette: HPALETTE;
  5110.   TransparentColor: TColorRef): HBITMAP;
  5111. var
  5112.   DIB: TDIBSection;
  5113.   ScreenDC, BitmapDC, MonoDC: HDC;
  5114.   BkColor: TColorRef;
  5115.   Remove: Boolean;
  5116.   SaveBitmap, SaveMono: HBITMAP;
  5117. begin
  5118.   Result := 0;
  5119.   if (Handle <> 0) and (GetObject(Handle, SizeOf(DIB), @DIB) <> 0) then
  5120.   begin
  5121.     DeselectBitmap(Handle);
  5122.     ScreenDC := 0;
  5123.     MonoDC := 0;
  5124.     try
  5125.       ScreenDC := GDICheck(GetDC(0));
  5126.       MonoDC := GDICheck(CreateCompatibleDC(ScreenDC));
  5127.       with DIB, dsBm do
  5128.       begin
  5129.         Result := CreateBitmap(bmWidth, bmHeight, 1, 1, nil);
  5130.         if Result <> 0 then
  5131.         begin
  5132.           SaveMono := SelectObject(MonoDC, Result);
  5133.           if TransparentColor = TColorRef(clNone) then
  5134.             PatBlt(MonoDC, 0, 0, bmWidth, bmHeight, Blackness)
  5135.           else
  5136.           begin
  5137.             BitmapDC := GDICheck(CreateCompatibleDC(ScreenDC));
  5138.             try
  5139.               { Convert DIB to DDB }
  5140.               if bmBits <> nil then
  5141.               begin
  5142.                 Remove := True;
  5143.                 DIB.dsbmih.biSize := 0;
  5144.                 Handle := CopyBitmap(Handle, Palette, Palette, DIB, nil);
  5145.               end
  5146.               else Remove := False;
  5147.               SaveBitmap := SelectObject(BitmapDC, Handle);
  5148.               if Palette <> 0 then
  5149.               begin
  5150.                 SelectPalette(BitmapDC, Palette, False);
  5151.                 RealizePalette(BitmapDC);
  5152.                 SelectPalette(MonoDC, Palette, False);
  5153.                 RealizePalette(MonoDC);
  5154.               end;
  5155.               BkColor := SetBkColor(BitmapDC, TransparentColor);
  5156.               BitBlt(MonoDC, 0, 0, bmWidth, bmHeight, BitmapDC, 0, 0, SrcCopy);
  5157.               SetBkColor(BitmapDC, BkColor);
  5158.               if SaveBitmap <> 0 then SelectObject(BitmapDC, SaveBitmap);
  5159.               if Remove then DeleteObject(Handle);
  5160.             finally
  5161.               DeleteDC(BitmapDC);
  5162.             end;
  5163.           end;
  5164.           if SaveMono <> 0 then SelectObject(MonoDC, SaveMono);
  5165.         end;
  5166.       end;
  5167.     finally
  5168.       if MonoDC <> 0 then DeleteDC(MonoDC);
  5169.       if ScreenDC <> 0 then ReleaseDC(0, ScreenDC);
  5170.     end;
  5171.   end;
  5172. end;
  5173.  
  5174. constructor TBitmap.Create;
  5175. begin
  5176.   inherited Create;
  5177.   FTransparentColor := clDefault;
  5178.   FImage := TBitmapImage.Create;
  5179.   FImage.Reference;
  5180.   if DDBsOnly then HandleType := bmDDB;
  5181. end;
  5182.  
  5183. destructor TBitmap.Destroy;
  5184. begin
  5185.   FreeContext;
  5186.   FImage.Release;
  5187.   FCanvas.Free;
  5188.   inherited Destroy;
  5189. end;
  5190.  
  5191. procedure TBitmap.Assign(Source: TPersistent);
  5192. var
  5193.   DIB: TDIBSection;
  5194. begin
  5195.   if (Source = nil) or (Source is TBitmap) then
  5196.   begin
  5197.     EnterCriticalSection(BitmapImageLock);
  5198.     try
  5199.       if Source <> nil then
  5200.       begin
  5201.         TBitmap(Source).FImage.Reference;
  5202.         FImage.Release;
  5203.         FImage := TBitmap(Source).FImage;
  5204.         FTransparent := TBitmap(Source).FTransparent;
  5205.         FTransparentColor := TBitmap(Source).FTransparentColor;
  5206.         FTransparentMode := TBitmap(Source).FTransparentMode;
  5207.       end
  5208.       else
  5209.       begin
  5210.         FillChar(DIB, Sizeof(DIB), 0);
  5211.         NewImage(0, 0, DIB, False);
  5212.       end;
  5213.     finally
  5214.       LeaveCriticalSection(BitmapImageLock);
  5215.     end;
  5216.     PaletteModified := Palette <> 0;
  5217.     Changed(Self);
  5218.   end
  5219.   else inherited Assign(Source);
  5220. end;
  5221.  
  5222. procedure TBitmap.CopyImage(AHandle: HBITMAP; APalette: HPALETTE; DIB: TDIBSection);
  5223. var
  5224.   NewHandle, NewPalette: THandle;
  5225. begin
  5226.   FreeContext;
  5227.   NewHandle := 0;
  5228.   NewPalette := 0;
  5229.   try
  5230.     if APalette = SystemPalette16 then
  5231.       NewPalette := APalette
  5232.     else
  5233.       NewPalette := CopyPalette(APalette);
  5234.     NewHandle := CopyBitmap(AHandle, APalette, NewPalette, DIB, FCanvas);
  5235.     NewImage(NewHandle, NewPalette, DIB, FImage.FOS2Format);
  5236.   except
  5237.     InternalDeletePalette(NewPalette);
  5238.     if NewHandle <> 0 then DeleteObject(NewHandle);
  5239.     raise;
  5240.   end;
  5241. end;
  5242.  
  5243. { Called by the FCanvas whenever an operation is going to be performed on the
  5244.   bitmap that would modify it.  Since modifications should only affect this
  5245.   TBitmap, the handle needs to be 'cloned' if it is being refered to by more
  5246.   than one TBitmap }
  5247. procedure TBitmap.Changing(Sender: TObject);
  5248. begin
  5249.   FreeImage;
  5250.   FImage.FDIB.dsbmih.biClrUsed := 0;
  5251.   FImage.FDIB.dsbmih.biClrImportant := 0;
  5252.   FreeAndNil(FImage.FSaveStream);
  5253. end;
  5254.  
  5255. procedure TBitmap.Changed(Sender: TObject);
  5256. begin
  5257.   FMaskBitsValid := False;
  5258.   inherited Changed(Sender);
  5259. end;
  5260.  
  5261. procedure TBitmap.Dormant;
  5262. begin
  5263.   FreeContext; // !! InternalDeletePalette fails without this
  5264.   DIBNeeded;
  5265.   FImage.FreeHandle;
  5266. end;
  5267.  
  5268. procedure TBitmap.Draw(ACanvas: TCanvas; const Rect: TRect);
  5269. var
  5270.   OldPalette: HPalette;
  5271.   RestorePalette: Boolean;
  5272.   DoHalftone: Boolean;
  5273.   Pt: TPoint;
  5274.   BPP: Integer;
  5275.   MaskDC: HDC;
  5276.   Save: THandle;
  5277. begin
  5278.   with Rect, FImage do
  5279.   begin
  5280.     ACanvas.RequiredState(csAllValid);
  5281.     PaletteNeeded;
  5282.     OldPalette := 0;
  5283.     RestorePalette := False;
  5284.  
  5285.     if FPalette <> 0 then
  5286.     begin
  5287.       OldPalette := SelectPalette(ACanvas.FHandle, FPalette, True);
  5288.       RealizePalette(ACanvas.FHandle);
  5289.       RestorePalette := True;
  5290.     end;
  5291.     BPP := GetDeviceCaps(ACanvas.FHandle, BITSPIXEL) *
  5292.       GetDeviceCaps(ACanvas.FHandle, PLANES);
  5293.     DoHalftone := (BPP <= 8) and (BPP < (FDIB.dsbm.bmBitsPixel * FDIB.dsbm.bmPlanes));
  5294.     if DoHalftone then
  5295.     begin
  5296.       GetBrushOrgEx(ACanvas.FHandle, pt);
  5297.       SetStretchBltMode(ACanvas.FHandle, HALFTONE);
  5298.       SetBrushOrgEx(ACanvas.FHandle, pt.x, pt.y, @pt);
  5299.     end else if not Monochrome then
  5300.       SetStretchBltMode(ACanvas.Handle, STRETCH_DELETESCANS);
  5301.     try
  5302.       { Call MaskHandleNeeded prior to creating the canvas handle since
  5303.         it causes FreeContext to be called. }
  5304.       if Transparent then MaskHandleNeeded;
  5305.       Canvas.RequiredState(csAllValid);
  5306.       if Transparent then
  5307.       begin
  5308.         Save := 0;
  5309.         MaskDC := 0;
  5310.         try
  5311.           MaskDC := GDICheck(CreateCompatibleDC(0));
  5312.           Save := SelectObject(MaskDC, FMaskHandle);
  5313.           TransparentStretchBlt(ACanvas.FHandle, Left, Top, Right - Left,
  5314.             Bottom - Top, Canvas.FHandle, 0, 0, FDIB.dsbm.bmWidth,
  5315.             FDIB.dsbm.bmHeight, MaskDC, 0, 0);
  5316.         finally
  5317.           if Save <> 0 then SelectObject(MaskDC, Save);
  5318.           if MaskDC <> 0 then DeleteDC(MaskDC);
  5319.         end;
  5320.       end
  5321.       else
  5322.         StretchBlt(ACanvas.FHandle, Left, Top, Right - Left, Bottom - Top,
  5323.           Canvas.FHandle, 0, 0, FDIB.dsbm.bmWidth,
  5324.           FDIB.dsbm.bmHeight, ACanvas.CopyMode);
  5325.     finally
  5326.       if RestorePalette then
  5327.         SelectPalette(ACanvas.FHandle, OldPalette, True);
  5328.     end;
  5329.   end;
  5330. end;
  5331.  
  5332. { FreeImage:
  5333.   If there are multiple references to the image, create a unique copy of the image.
  5334.   If FHandle = FDIBHandle, the DIB memory will be updated when the drawing
  5335.   handle is drawn upon, so no changes are needed to maintain image integrity.
  5336.   If FHandle <> FDIBHandle, the DIB will not track with changes made to
  5337.   the DDB, so destroy the DIB handle (but keep the DIB pixel format info).  }
  5338. procedure TBitmap.FreeImage;
  5339. var
  5340.   P: HPalette;
  5341. begin
  5342.   with FImage do
  5343.     if FRefCount > 1 then
  5344.     begin
  5345.       HandleNeeded;
  5346.       if FHalftone then
  5347.         P := 0
  5348.       else
  5349.         P := FPalette;
  5350.       CopyImage(FHandle, P, FDIB)
  5351.     end
  5352.     else if (FHandle <> 0) and (FHandle <> FDIBHandle) then
  5353.     begin
  5354.       if FDIBHandle <> 0 then
  5355.         if not DeleteObject(FDIBHandle) then GDIError;
  5356.       FDIBHandle := 0;
  5357.       FDIB.dsbm.bmBits := nil;
  5358.     end;
  5359. end;
  5360.  
  5361. function TBitmap.GetEmpty;
  5362. begin
  5363.   with FImage do
  5364.     Result := (FHandle = 0) and (FDIBHandle = 0);
  5365. end;
  5366.  
  5367. function TBitmap.GetCanvas: TCanvas;
  5368. begin
  5369.   if FCanvas = nil then
  5370.   begin
  5371.     HandleNeeded;
  5372.     FCanvas := TBitmapCanvas.Create(Self);
  5373.     FCanvas.OnChange := Changed;
  5374.     FCanvas.OnChanging := Changing;
  5375.   end;
  5376.   Result := FCanvas;
  5377. end;
  5378.  
  5379. { Since the user might modify the contents of the HBITMAP it must not be
  5380.   shared by another TBitmap when given to the user nor should it be selected
  5381.   into a DC. }
  5382. function TBitmap.GetHandle: HBITMAP;
  5383. begin
  5384.   FreeContext;
  5385.   HandleNeeded;
  5386.   Changing(Self);
  5387.   Result := FImage.FHandle;
  5388. end;
  5389.  
  5390. function TBitmap.GetHandleType: TBitmapHandleType;
  5391. begin
  5392.   with FImage do
  5393.   begin
  5394.     if (FHandle = 0) or (FHandle = FDIBHandle) then
  5395.       if FDIBHandle = 0 then
  5396.         if FDIB.dsbmih.biSize = 0 then
  5397.           Result := bmDDB
  5398.         else
  5399.           Result := bmDIB
  5400.       else
  5401.         Result := bmDIB
  5402.     else
  5403.       Result := bmDDB;
  5404.   end;
  5405. end;
  5406.  
  5407. function TBitmap.GetHeight: Integer;
  5408. begin
  5409.   Result := Abs(FImage.FDIB.dsbm.bmHeight);
  5410. end;
  5411.  
  5412. function TBitmap.GetMaskHandle: HBITMAP;
  5413. begin
  5414.   MaskHandleNeeded;
  5415.   Result := FImage.FMaskHandle;
  5416. end;
  5417.  
  5418. function TBitmap.GetMonochrome: Boolean;
  5419. begin
  5420.   with FImage.FDIB.dsbm do
  5421.     Result := (bmPlanes = 1) and (bmBitsPixel = 1);
  5422. end;
  5423.  
  5424. function TBitmap.GetPalette: HPALETTE;
  5425. begin
  5426.   PaletteNeeded;
  5427.   Result := FImage.FPalette;
  5428. end;
  5429.  
  5430. function TBitmap.GetPixelFormat: TPixelFormat;
  5431. begin
  5432.   Result := pfCustom;
  5433.   if HandleType = bmDDB then
  5434.     Result := pfDevice
  5435.   else
  5436.     with FImage.FDIB, dsbmih do
  5437.       case biBitCount of
  5438.         1: Result := pf1Bit;
  5439.         4: Result := pf4Bit;
  5440.         8: Result := pf8Bit;
  5441.        16: case biCompression of
  5442.              BI_RGB : Result := pf15Bit;
  5443.              BI_BITFIELDS: if dsBitFields[1] = $7E0 then Result := pf16Bit;
  5444.            end;
  5445.        24: Result := pf24Bit;
  5446.        32: if biCompression = BI_RGB then Result := pf32Bit;
  5447.       end;
  5448. end;
  5449.  
  5450. function TBitmap.GetScanLine(Row: Integer): Pointer;
  5451. begin
  5452.   Changing(Self);
  5453.   with FImage.FDIB, dsbm, dsbmih do
  5454.   begin
  5455.     if (Row < 0) or (Row > bmHeight) then
  5456.       InvalidOperation(@SScanLine);
  5457.     DIBNeeded;
  5458.     GDIFlush;
  5459.     if biHeight > 0 then  // bottom-up DIB
  5460.       Row := biHeight - Row - 1;
  5461.     Integer(Result) := Integer(bmBits) +
  5462.       Row * BytesPerScanline(biWidth, biBitCount, 32);
  5463.   end;
  5464. end;
  5465.  
  5466. function TBitmap.GetTransparentColor: TColor;
  5467. begin
  5468.   if FTransparentColor = clDefault then
  5469.   begin
  5470.     if Monochrome then
  5471.       Result := clWhite
  5472.     else
  5473.       Result := Canvas.Pixels[0, Height - 1];
  5474.   end
  5475.   else Result := ColorToRGB(FTransparentColor);
  5476.   Result := Result or $02000000;
  5477. end;
  5478.  
  5479. function TBitmap.GetWidth: Integer;
  5480. begin
  5481.   Result := FImage.FDIB.dsbm.bmWidth;
  5482. end;
  5483.  
  5484. procedure TBitmap.DIBNeeded;
  5485. begin
  5486.   with FImage do
  5487.   begin
  5488.     if (FHandle = 0) or (FDIBHandle <> 0) then Exit;
  5489.     PaletteNeeded;
  5490.     if FDIB.dsbmih.biSize = 0 then
  5491.     begin
  5492.       GetObject(FHandle, sizeof(FDIB), @FDIB);
  5493.       with FDIB, dsbm, dsbmih do
  5494.       begin
  5495.         biSize := sizeof(dsbmih);
  5496.         biWidth := bmWidth;
  5497.         biHeight := bmHeight;
  5498.         biPlanes := 1;
  5499.         biBitCount := bmPlanes * bmBitsPixel;
  5500.       end;
  5501.     end;
  5502.     FDIBHandle := CopyBitmap(FHandle, FPalette, FPalette, FDIB, nil);
  5503.   end;
  5504. end;
  5505.  
  5506. procedure TBitmap.FreeContext;
  5507. begin
  5508.   if (FCanvas <> nil) then TBitmapCanvas(FCanvas).FreeContext;
  5509. end;
  5510.  
  5511. procedure TBitmap.HandleNeeded;
  5512. begin
  5513.   with FImage do
  5514.     if FHandle = 0 then
  5515.       FHandle := FDIBHandle;
  5516. end;
  5517.  
  5518. procedure TBitmap.Mask(TransparentColor: TColor);
  5519. var
  5520.   NewHandle, NewPalette: THandle;
  5521.   DIB: TDIBSection;
  5522. begin
  5523.   NewHandle := 0;
  5524.   NewPalette := 0;
  5525.   try
  5526.     FreeContext;
  5527.     HandleNeeded;
  5528.     NewHandle := CopyBitmapAsMask(FImage.FHandle, FImage.FPalette,
  5529.       ColorToRGB(TransparentColor));
  5530.     FillChar(DIB, SizeOf(DIB), 0);
  5531.     GetObject(NewHandle, SizeOf(DIB), @DIB);
  5532.     if FImage.FPalette = SystemPalette16 then
  5533.       NewPalette := FImage.FPalette
  5534.     else
  5535.       NewPalette := CopyPalette(FImage.FPalette);
  5536.     NewImage(NewHandle, NewPalette, DIB, FImage.FOS2Format);
  5537.   except
  5538.     InternalDeletePalette(NewPalette);
  5539.     if NewHandle <> 0 then DeleteObject(NewHandle);
  5540.     raise;
  5541.   end;
  5542.   Changed(Self);
  5543. end;
  5544.  
  5545. procedure TBitmap.MaskHandleNeeded;
  5546. begin
  5547.   if FMaskValid and FMaskBitsValid then Exit;
  5548.   with FImage do
  5549.   begin
  5550.     { Delete existing mask if any }
  5551.     if FMaskHandle <> 0 then
  5552.     begin
  5553.       DeselectBitmap(FMaskHandle);
  5554.       DeleteObject(FMaskHandle);
  5555.       FMaskHandle := 0;
  5556.     end;
  5557.     FreeContext;
  5558.     HandleNeeded;
  5559.     FMaskHandle := CopyBitmapAsMask(FHandle, FPalette, GetTransparentColor);
  5560.     FMaskValid := True;
  5561.     FMaskBitsValid := True;
  5562.   end;
  5563. end;
  5564.  
  5565. procedure TBitmap.PaletteNeeded;
  5566. var
  5567.   DC: HDC;
  5568. begin
  5569.   with FImage do
  5570.   begin
  5571.     if FIgnorePalette or (FPalette <> 0) or (FDIBHandle = 0) then Exit;
  5572.     if FHandle = FDIBHandle then DeselectBitmap(FDIBHandle);
  5573.     FPalette := PaletteFromDIBColorTable(FDIBHandle, nil, 1 shl FDIB.dsbmih.biBitCount);
  5574.     if FPalette <> 0 then Exit;
  5575.     DC := GDICheck(GetDC(0));
  5576.     FHalftone := FHalftone or
  5577.       ((GetDeviceCaps(DC, BITSPIXEL) * GetDeviceCaps(DC, PLANES)) <
  5578.       (FDIB.dsbm.bmBitsPixel * FDIB.dsbm.bmPlanes));
  5579.     if FHalftone then FPalette := CreateHalftonePalette(DC);
  5580.     ReleaseDC(0, DC);
  5581.     if FPalette = 0 then IgnorePalette := True;
  5582.   end;
  5583. end;
  5584.  
  5585. procedure TBitmap.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  5586.   APalette: HPALETTE);
  5587. var
  5588.   DIB: TDIBSection;
  5589. begin
  5590.   if (AFormat <> CF_BITMAP) or (AData = 0) then
  5591.     InvalidGraphic(@SUnknownClipboardFormat);
  5592.   FreeContext;
  5593.   FillChar(DIB, sizeof(DIB), 0);
  5594.   GetObject(AData, sizeof(DIB), @DIB);
  5595.   if DIB.dsbm.bmBits = nil then DIB.dsbmih.biSize := 0;
  5596.   CopyImage(AData, APalette, DIB);
  5597.   FImage.FOS2Format := False;
  5598.   PaletteModified := Palette <> 0;
  5599.   Changed(Self);
  5600. end;
  5601.  
  5602. procedure TBitmap.LoadFromStream(Stream: TStream);
  5603. begin
  5604.   ReadStream(Stream, Stream.Size - Stream.Position);
  5605. end;
  5606.  
  5607. procedure TBitmap.LoadFromResourceName(Instance: THandle; const ResName: string);
  5608. var
  5609.   Stream: TCustomMemoryStream;
  5610. begin
  5611.   Stream := TResourceStream.Create(Instance, ResName, RT_BITMAP);
  5612.   try
  5613.     ReadDIB(Stream, Stream.Size);
  5614.   finally
  5615.     Stream.Free;
  5616.   end;
  5617. end;
  5618.  
  5619. procedure TBitmap.LoadFromResourceID(Instance: THandle; ResID: Integer);
  5620. var
  5621.   Stream: TCustomMemoryStream;
  5622. begin
  5623.   Stream := TResourceStream.CreateFromID(Instance, ResID, RT_BITMAP);
  5624.   try
  5625.     ReadDIB(Stream, Stream.Size);
  5626.   finally
  5627.     Stream.Free;
  5628.   end;
  5629. end;
  5630.  
  5631. procedure TBitmap.NewImage(NewHandle: HBITMAP; NewPalette: HPALETTE;
  5632.   const NewDIB: TDIBSection; OS2Format: Boolean; RLEStream: TStream = nil);
  5633. var
  5634.   Image: TBitmapImage;
  5635. begin
  5636.   Image := TBitmapImage.Create;
  5637.   with Image do
  5638.   try
  5639.     FHandle := NewHandle;
  5640.     FPalette := NewPalette;
  5641.     FDIB := NewDIB;
  5642.     FOS2Format := OS2Format;
  5643.     if FDIB.dsbm.bmBits <> nil then FDIBHandle := FHandle;
  5644.     FSaveStream := RLEStream as TMemoryStream;
  5645.   except
  5646.     Image.Free;
  5647.     raise;
  5648.   end;
  5649.   //!! replace with InterlockedExchange()
  5650.   EnterCriticalSection(BitmapImageLock);
  5651.   try
  5652.     FImage.Release;
  5653.     FImage := Image;
  5654.     FImage.Reference;
  5655.   finally
  5656.     LeaveCriticalSection(BitmapImageLock);
  5657.   end;
  5658.   FMaskValid := False;
  5659. end;
  5660.  
  5661. procedure TBitmap.ReadData(Stream: TStream);
  5662. var
  5663.   Size: Longint;
  5664. begin
  5665.   Stream.Read(Size, SizeOf(Size));
  5666.   ReadStream(Stream, Size);
  5667. end;
  5668.  
  5669. procedure TBitmap.ReadDIB(Stream: TStream; ImageSize: LongWord);
  5670. const
  5671.   DIBPalSizes: array [Boolean] of Byte = (sizeof(TRGBQuad), sizeof(TRGBTriple));
  5672. var
  5673.   DC, MemDC: HDC;
  5674.   BitsMem: Pointer;
  5675.   OS2Header: TBitmapCoreHeader;
  5676.   BitmapInfo: PBitmapInfo;
  5677.   ColorTable: Pointer;
  5678.   HeaderSize: Integer;
  5679.   OS2Format: Boolean;
  5680.   BMHandle, OldBMP: HBITMAP;
  5681.   DIB: TDIBSection;
  5682.   Pal, OldPal: HPalette;
  5683.   RLEStream: TStream;
  5684. begin
  5685.   Pal := 0;
  5686.   BMHandle := 0;
  5687.   RLEStream := nil;
  5688.   Stream.Read(HeaderSize, sizeof(HeaderSize));
  5689.   OS2Format := HeaderSize = sizeof(OS2Header);
  5690.   if OS2Format then HeaderSize := sizeof(TBitmapInfoHeader);
  5691.   GetMem(BitmapInfo, HeaderSize + 12 + 256 * sizeof(TRGBQuad));
  5692.   with BitmapInfo^ do
  5693.   try
  5694.     try
  5695.       if OS2Format then  // convert OS2 DIB to Win DIB
  5696.       begin
  5697.         Stream.Read(Pointer(Longint(@OS2Header) + sizeof(HeaderSize))^,
  5698.           sizeof(OS2Header) - sizeof(HeaderSize));
  5699.         FillChar(bmiHeader, sizeof(bmiHeader), 0);
  5700.         with bmiHeader, OS2Header do
  5701.         begin
  5702.           biWidth := bcWidth;
  5703.           biHeight := bcHeight;
  5704.           biPlanes := bcPlanes;
  5705.           biBitCount := bcBitCount;
  5706.         end;
  5707.         Dec(ImageSize, sizeof(OS2Header));
  5708.       end
  5709.       else
  5710.       begin // support bitmap headers larger than TBitmapInfoHeader
  5711.         Stream.Read(Pointer(Longint(BitmapInfo) + sizeof(HeaderSize))^,
  5712.           HeaderSize - sizeof(HeaderSize));
  5713.         Dec(ImageSize, HeaderSize);
  5714.  
  5715.         if (bmiHeader.biCompression <> BI_BITFIELDS) and
  5716.           (bmiHeader.biCompression <> BI_RGB) then
  5717.         begin // Preserve funky non-DIB data (like RLE) until modified
  5718.           RLEStream := TMemoryStream.Create;
  5719.           // source stream could be unidirectional.  don't reverse seek
  5720.           RLEStream.Write(HeaderSize, sizeof(HeaderSize));
  5721.           RLEStream.Write(Pointer(Longint(BitmapInfo) + sizeof(HeaderSize))^,
  5722.             HeaderSize - sizeof(HeaderSize));
  5723.           RLEStream.CopyFrom(Stream, ImageSize);
  5724.           RLEStream.Seek(ImageSize, soFromEnd);
  5725.           Stream := RLEStream;  // the rest of the proc reads from RLEStream
  5726.         end;
  5727.       end;
  5728.  
  5729.       with bmiHeader do
  5730.       begin
  5731.         biSize := HeaderSize;
  5732.         ColorTable := Pointer(Longint(BitmapInfo) + HeaderSize);
  5733.  
  5734.         { check number of planes. DIBs must be 1 color plane (packed pixels) }
  5735.         if biPlanes <> 1 then InvalidBitmap;
  5736.  
  5737.         // 3 DWORD color element bit masks (ie 888 or 565) can precede colors
  5738.         // TBitmapInfoHeader sucessors include these masks in the headersize
  5739.         if (HeaderSize = sizeof(TBitmapInfoHeader)) and
  5740.           ((biBitCount = 16) or (biBitCount = 32)) and
  5741.           (biCompression = BI_BITFIELDS) then
  5742.         begin
  5743.           Stream.ReadBuffer(ColorTable^, 3 * sizeof(DWORD));
  5744.           Inc(Longint(ColorTable), 3 * sizeof(DWORD));
  5745.           Dec(ImageSize, 3 * sizeof(DWORD));
  5746.         end;
  5747.  
  5748.         // Read the color palette
  5749.         if biClrUsed = 0 then
  5750.           biClrUsed := GetDInColors(biBitCount);
  5751.         Stream.ReadBuffer(ColorTable^, biClrUsed * DIBPalSizes[OS2Format]);
  5752.         Dec(ImageSize, biClrUsed * DIBPalSizes[OS2Format]);
  5753.  
  5754.         // biSizeImage can be zero. If zero, compute the size.
  5755.         if biSizeImage = 0 then            // top-down DIBs have negative height
  5756.           biSizeImage := BytesPerScanLine(biWidth, biBitCount, 32) * Abs(biHeight);
  5757.  
  5758.         if biSizeImage < ImageSize then ImageSize := biSizeImage;
  5759.       end;
  5760.  
  5761.       { convert OS2 color table to DIB color table }
  5762.       if OS2Format then RGBTripleToQuad(ColorTable^);
  5763.  
  5764.       DC := GDICheck(GetDC(0));
  5765.       try
  5766.         if ((bmiHeader.biCompression <> BI_RGB) and
  5767.           (bmiHeader.biCompression <> BI_BITFIELDS)) or DDBsOnly then
  5768.         begin
  5769.           MemDC := 0;
  5770.           GetMem(BitsMem, ImageSize);
  5771.           try
  5772.             Stream.ReadBuffer(BitsMem^, ImageSize);
  5773.             MemDC := GDICheck(CreateCompatibleDC(DC));
  5774.             OldBMP := SelectObject(MemDC, CreateCompatibleBitmap(DC, 1, 1));
  5775.             OldPal := 0;
  5776.             if bmiHeader.biClrUsed > 0 then
  5777.             begin
  5778.               Pal := PaletteFromDIBColorTable(0, ColorTable, bmiHeader.biClrUsed);
  5779.               OldPal := SelectPalette(MemDC, Pal, False);
  5780.               RealizePalette(MemDC);
  5781.             end;
  5782.  
  5783.             try
  5784.               BMHandle := CreateDIBitmap(MemDC, BitmapInfo^.bmiHeader, CBM_INIT, BitsMem,
  5785.                 BitmapInfo^, DIB_RGB_COLORS);
  5786.               if (BMHandle = 0) then
  5787.                 if GetLastError = 0 then InvalidBitmap else RaiseLastWin32Error;
  5788.             finally
  5789.               if OldPal <> 0 then
  5790.                 SelectPalette(MemDC, OldPal, True);
  5791.               DeleteObject(SelectObject(MemDC, OldBMP));
  5792.             end;
  5793.           finally
  5794.             if MemDC <> 0 then DeleteDC(MemDC);
  5795.             FreeMem(BitsMem);
  5796.           end;
  5797.         end
  5798.         else
  5799.         begin
  5800.           BMHandle := CreateDIBSection(DC, BitmapInfo^, DIB_RGB_COLORS, BitsMem, 0, 0);
  5801.           if (BMHandle = 0) or (BitsMem = nil) then
  5802.             if GetLastError = 0 then InvalidBitmap else RaiseLastWin32Error;
  5803.  
  5804.           try
  5805.             Stream.ReadBuffer(BitsMem^, ImageSize);
  5806.           except
  5807.             DeleteObject(BMHandle);
  5808.             raise;
  5809.           end;
  5810.         end;
  5811.       finally
  5812.         ReleaseDC(0, DC);
  5813.       end;
  5814.       // Hi-color DIBs don't preserve color table, so create palette now
  5815.       if (bmiHeader.biBitCount > 8) and (bmiHeader.biClrUsed > 0) and (Pal = 0)then
  5816.         Pal := PaletteFromDIBColorTable(0, ColorTable, bmiHeader.biClrUsed);
  5817.  
  5818.       FillChar(DIB, sizeof(DIB), 0);
  5819.       GetObject(BMHandle, Sizeof(DIB), @DIB);
  5820.       // GetObject / CreateDIBSection don't preserve these info values
  5821.       DIB.dsBmih.biXPelsPerMeter := bmiHeader.biXPelsPerMeter;
  5822.       DIB.dsBmih.biYPelsPerMeter := bmiHeader.biYPelsPerMeter;
  5823.       DIB.dsBmih.biClrUsed := bmiHeader.biClrUsed;
  5824.       DIB.dsBmih.biClrImportant := bmiHeader.biClrImportant;
  5825.     except
  5826.       RLEStream.Free;
  5827.       raise;
  5828.     end;
  5829.   finally
  5830.     FreeMem(BitmapInfo);
  5831.   end;
  5832.   NewImage(BMHandle, Pal, DIB, OS2Format, RLEStream);
  5833.   PaletteModified := Palette <> 0;
  5834.   Changed(Self);
  5835. end;
  5836.  
  5837. procedure TBitmap.ReadStream(Stream: TStream; Size: Longint);
  5838. var
  5839.   Bmf: TBitmapFileHeader;
  5840.   DIB: TDIBSection;
  5841. begin
  5842.   FreeContext;
  5843.   if Size = 0 then
  5844.   begin
  5845.     FillChar(DIB, sizeof(DIB), 0);
  5846.     NewImage(0, 0, DIB, False);
  5847.   end
  5848.   else
  5849.   begin
  5850.     Stream.ReadBuffer(Bmf, sizeof(Bmf));
  5851.     if Bmf.bfType <> $4D42 then InvalidBitmap;
  5852.     ReadDIB(Stream, Size - sizeof(Bmf));
  5853.   end;
  5854. end;
  5855.  
  5856. procedure TBitmap.SetHandle(Value: HBITMAP);
  5857. var
  5858.   DIB: TDIBSection;
  5859.   APalette: HPALETTE;
  5860. begin
  5861.   with FImage do
  5862.     if FHandle <> Value then
  5863.     begin
  5864.       FreeContext;
  5865.       FillChar(DIB, sizeof(DIB), 0);
  5866.       if Value <> 0 then
  5867.         GetObject(Value, SizeOf(DIB), @DIB);
  5868.       if FRefCount = 1 then
  5869.       begin
  5870.         APalette := FPalette;
  5871.         FPalette := 0;
  5872.       end
  5873.       else
  5874.         if FPalette = SystemPalette16 then
  5875.           APalette := SystemPalette16
  5876.         else
  5877.           APalette := CopyPalette(FPalette);
  5878.       try
  5879.         NewImage(Value, APalette, DIB, False);
  5880.       except
  5881.         InternalDeletePalette(APalette);
  5882.         raise;
  5883.       end;
  5884.       Changed(Self);
  5885.     end;
  5886. end;
  5887.  
  5888. procedure TBitmap.SetHandleType(Value: TBitmapHandleType);
  5889. var
  5890.   DIB: TDIBSection;
  5891.   AHandle: HBITMAP;
  5892.   NewPalette: HPALETTE;
  5893.   DoCopy: Boolean;
  5894. begin
  5895.   if Value = GetHandleType then Exit;
  5896.   with FImage do
  5897.   begin
  5898.     if (FHandle = 0) and (FDIBHandle = 0) then
  5899.       if Value = bmDDB then
  5900.         FDIB.dsbmih.biSize := 0
  5901.       else
  5902.         FDIB.dsbmih.biSize := sizeof(FDIB.dsbmih)
  5903.     else
  5904.     begin
  5905.       if Value = bmDIB then
  5906.       begin
  5907.         if (FDIBHandle <> 0) and (FDIBHandle = FHandle) then Exit;
  5908.         FreeContext;
  5909.         PaletteNeeded;
  5910.         DIBNeeded;
  5911.         if FRefCount = 1 then
  5912.         begin
  5913.           AHandle := FDIBHandle;
  5914.           FDIBHandle := 0;
  5915.           NewPalette := FPalette;
  5916.           FPalette := 0;
  5917.           NewImage(AHandle, NewPalette, FDIB, FOS2Format);
  5918.         end
  5919.         else
  5920.           CopyImage(FDIBHandle, FPalette, FDIB);
  5921.       end
  5922.       else
  5923.       begin
  5924.         if (FHandle <> 0) and (FHandle <> FDIBHandle) then Exit;
  5925.         FreeContext;
  5926.         PaletteNeeded;
  5927.         DIB := FDIB;
  5928.         DIB.dsbmih.biSize := 0;   // flag to tell CopyBitmap to create a DDB
  5929.         DoCopy := FRefCount = 1;
  5930.         if DoCopy then
  5931.           NewPalette := FPalette
  5932.         else
  5933.           NewPalette := CopyPalette(FPalette);
  5934.         AHandle := CopyBitmap(FDIBHandle, FPalette, NewPalette, DIB, nil);
  5935.         if DoCopy then
  5936.           FHandle := AHandle
  5937.         else
  5938.           NewImage(AHandle, NewPalette, DIB, FOS2Format);
  5939.       end;
  5940.       Changed(Self);
  5941.     end;
  5942.   end;
  5943. end;
  5944.  
  5945. procedure TBitmap.SetHeight(Value: Integer);
  5946. var
  5947.   DIB: TDIBSection;
  5948. begin
  5949.   with FImage do
  5950.     if FDIB.dsbm.bmHeight <> Value then
  5951.     begin
  5952.       HandleNeeded;
  5953.       DIB := FDIB;
  5954.       DIB.dsbm.bmHeight := Value;
  5955.       DIB.dsbmih.biHeight := Value;
  5956.       CopyImage(FHandle, FPalette, DIB);
  5957.       Changed(Self);
  5958.     end;
  5959. end;
  5960.  
  5961. procedure TBitmap.SetMaskHandle(Value: HBITMAP);
  5962. begin
  5963.   with FImage do
  5964.     if FMaskHandle <> Value then
  5965.     begin
  5966.       FMaskHandle := Value;
  5967.       FMaskValid := True;
  5968.       FMaskBitsValid := True;
  5969.     end;
  5970. end;
  5971.  
  5972. procedure TBitmap.SetMonochrome(Value: Boolean);
  5973. var
  5974.   DIB: TDIBSection;
  5975. begin
  5976.   with FImage, FDIB.dsbmih do
  5977.     if Value <> ((biPlanes = 1) and (biBitCount = 1)) then
  5978.     begin
  5979.       HandleNeeded;
  5980.       DIB := FDIB;
  5981.       with DIB.dsbmih, DIB.dsbm do
  5982.       begin
  5983.         biSize := 0;   // request DDB handle
  5984.         biPlanes := Byte(Value);  // 0 = request screen BMP format
  5985.         biBitCount := Byte(Value);
  5986.         bmPlanes := Byte(Value);
  5987.         bmBitsPixel := Byte(Value);
  5988.       end;
  5989.       CopyImage(FHandle, FPalette, DIB);
  5990.       Changed(Self);
  5991.     end;
  5992. end;
  5993.  
  5994. procedure TBitmap.SetPalette(Value: HPALETTE);
  5995. var
  5996.   AHandle: HBITMAP;
  5997.   DIB: TDIBSection;
  5998. begin
  5999.   if FImage.FPalette <> Value then
  6000.   begin
  6001.     with FImage do
  6002.       if (Value = 0) and (FRefCount = 1) then
  6003.       begin
  6004.         InternalDeletePalette(FPalette);
  6005.         FPalette := 0;
  6006.       end
  6007.       else
  6008.       begin
  6009.         FreeContext;
  6010.         HandleNeeded;
  6011.         DIB := FDIB;
  6012.         AHandle := CopyBitmap(FHandle, FPalette, Value, DIB, nil);
  6013.         try
  6014.           NewImage(AHandle, Value, DIB, FOS2Format);
  6015.         except
  6016.           DeleteObject(AHandle);
  6017.           raise;
  6018.         end;
  6019.       end;
  6020.     UpdateDIBColorTable(FImage.FDIBHandle, Value, FImage.FDIB);
  6021.     PaletteModified := True;
  6022.     Changed(Self);
  6023.   end;
  6024. end;
  6025.  
  6026. procedure TBitmap.SetPixelFormat(Value: TPixelFormat);
  6027. const
  6028.   BitCounts: array [pf1Bit..pf32Bit] of Byte = (1,4,8,16,16,24,32);
  6029. var
  6030.   DIB: TDIBSection;
  6031.   Pal: HPalette;
  6032.   DC: HDC;
  6033.   KillPal: Boolean;
  6034. begin
  6035.   if Value = GetPixelFormat then Exit;
  6036.   case Value of
  6037.     pfDevice:
  6038.       begin
  6039.         HandleType := bmDDB;
  6040.         Exit;
  6041.       end;
  6042.     pfCustom: InvalidGraphic(@SInvalidPixelFormat);
  6043.   else
  6044.     FillChar(DIB, sizeof(DIB), 0);
  6045.     DIB.dsbm := FImage.FDIB.dsbm;
  6046.     KillPal := False;
  6047.     with DIB, dsbm, dsbmih do
  6048.     begin
  6049.       bmBits := nil;
  6050.       biSize := sizeof(DIB.dsbmih);
  6051.       biWidth := bmWidth;
  6052.       biHeight := bmHeight;
  6053.       biPlanes := 1;
  6054.       biBitCount := BitCounts[Value];
  6055.       Pal := FImage.FPalette;
  6056.       case Value of
  6057.         pf4Bit: Pal := SystemPalette16;
  6058.         pf8Bit:
  6059.           begin
  6060.             DC := GDICheck(GetDC(0));
  6061.             Pal := CreateHalftonePalette(DC);
  6062.             KillPal := True;
  6063.             ReleaseDC(0, DC);
  6064.           end;
  6065.         pf16Bit:
  6066.           begin
  6067.             biCompression := BI_BITFIELDS;
  6068.             dsBitFields[0] := $F800;
  6069.             dsBitFields[1] := $07E0;
  6070.             dsBitFields[2] := $001F;
  6071.           end;
  6072.       end;
  6073.       try
  6074.         CopyImage(Handle, Pal, DIB);
  6075.         PaletteModified := Pal <> 0;
  6076.       finally
  6077.         if KillPal then DeleteObject(Pal);
  6078.       end;
  6079.       Changed(Self);
  6080.     end;
  6081.   end;
  6082. end;
  6083.  
  6084. procedure TBitmap.SetTransparentColor(Value: TColor);
  6085. begin
  6086.   if Value <> FTransparentColor then
  6087.   begin
  6088.     if Value = clDefault then
  6089.       FTransparentMode := tmAuto else
  6090.       FTransparentMode := tmFixed;
  6091.     FTransparentColor := Value;
  6092.     if FImage.FRefCount > 1 then
  6093.     with FImage do
  6094.     begin
  6095.       HandleNeeded;
  6096.       CopyImage(FHandle, FPalette, FDIB);
  6097.     end;
  6098.     Changed(Self);
  6099.   end;
  6100. end;
  6101.  
  6102. procedure TBitmap.SetTransparentMode(Value: TTransparentMode);
  6103. begin
  6104.   if Value <> FTransparentMode then
  6105.   begin
  6106.     if Value = tmAuto then
  6107.       SetTransparentColor(clDefault) else
  6108.       SetTransparentColor(GetTransparentColor);
  6109.   end;
  6110. end;
  6111.  
  6112. procedure TBitmap.SetWidth(Value: Integer);
  6113. var
  6114.   DIB: TDIBSection;
  6115. begin
  6116.   with FImage do
  6117.     if FDIB.dsbm.bmWidth <> Value then
  6118.     begin
  6119.       HandleNeeded;
  6120.       DIB := FDIB;
  6121.       DIB.dsbm.bmWidth := Value;
  6122.       DIB.dsbmih.biWidth := Value;
  6123.       CopyImage(FHandle, FPalette, DIB);
  6124.       Changed(Self);
  6125.     end;
  6126. end;
  6127.  
  6128. procedure TBitmap.WriteData(Stream: TStream);
  6129. begin
  6130.   WriteStream(Stream, True);
  6131. end;
  6132.  
  6133. procedure TBitmap.WriteStream(Stream: TStream; WriteSize: Boolean);
  6134. const
  6135.   PalSize: array [Boolean] of Byte = (sizeof(TRGBQuad), sizeof(TRGBTriple));
  6136. var
  6137.   Size, ColorCount: DWORD;
  6138.   HeaderSize: DWORD;
  6139.   BMF: TBitmapFileHeader;
  6140.   Save: THandle;
  6141.   BC: TBitmapCoreHeader;
  6142.   Colors: array [Byte] of TRGBQuad;
  6143. begin
  6144.   if FImage.FSaveStream <> nil then
  6145.   begin
  6146.     Size := FImage.FSaveStream.Size;
  6147.     if WriteSize then
  6148.       Stream.WriteBuffer(Size, sizeof(Size));
  6149.     Stream.Write(FImage.FSaveStream.Memory^, Size);
  6150.     Exit;
  6151.   end;
  6152.   DIBNeeded;
  6153.   with FImage do
  6154.   begin
  6155.     Size := 0;
  6156.     if FDIBHandle <> 0 then
  6157.     begin
  6158.       InternalGetDIBSizes(FDIBHandle, HeaderSize, Size, FDIB.dsbmih.biClrUsed);
  6159.       if FOS2Format then
  6160.       begin // OS2 format cannot have partial palette
  6161.         HeaderSize := sizeof(BC);
  6162.         if FDIB.dsbmih.biBitCount <= 8 then
  6163.           Inc(HeaderSize, sizeof(TRGBTriple) * (1 shl FDIB.dsbmih.biBitCount));
  6164.       end;
  6165.       Inc(Size, HeaderSize + sizeof(BMF));
  6166.  
  6167.       FillChar(BMF, sizeof(BMF), 0);
  6168.       BMF.bfType := $4D42;
  6169.  
  6170.       Canvas.RequiredState([csHandleValid]);
  6171.       Save := GDICheck(SelectObject(FCanvas.FHandle, FDIBHandle));
  6172.       ColorCount := GetDIBColorTable(FCanvas.FHandle, 0, 256, Colors);
  6173.       SelectObject(FCanvas.FHandle, Save);
  6174.       // GetDIBColorTable always reports the full palette; trim it back for partial palettes
  6175.       if (0 < FDIB.dsbmih.biClrUsed) and (FDIB.dsbmih.biClrUsed < ColorCount) then
  6176.         ColorCount := FDIB.dsbmih.biClrUsed;
  6177.       if (not FOS2Format) and (ColorCount = 0) and (FPalette <> 0) and not FHalftone then
  6178.       begin
  6179.         ColorCount := PaletteToDIBColorTable(FPalette, Colors);
  6180.         if FDIB.dsbmih.biBitCount > 8 then
  6181.         begin  // optional color palette for hicolor images (non OS2)
  6182.           Inc(Size, ColorCount * sizeof(TRGBQuad));
  6183.           Inc(HeaderSize, ColorCount * sizeof(TRGBQuad));
  6184.         end;
  6185.       end;
  6186.  
  6187.       BMF.bfSize := Size;
  6188.       BMF.bfOffBits := sizeof(BMF) + HeaderSize;
  6189.     end;
  6190.  
  6191.     if WriteSize then Stream.WriteBuffer(Size, SizeOf(Size));
  6192.  
  6193.     if Size <> 0 then
  6194.     begin
  6195.       FixupBitFields(FDIB);
  6196.       if (ColorCount <> 0) then
  6197.       begin
  6198.         if (FDIB.dsbmih.biClrUsed = 0) or (FDIB.dsbmih.biClrUsed <> ColorCount) then
  6199.           FDIB.dsbmih.biClrUsed := ColorCount;
  6200.         if FOS2Format then RGBQuadToTriple(Colors, Integer(ColorCount));
  6201.       end;
  6202.       if FOS2Format then
  6203.       begin
  6204.         with BC, FDIB.dsbmih do
  6205.         begin
  6206.           bcSize := sizeof(BC);
  6207.           bcWidth := biWidth;
  6208.           bcHeight := biHeight;
  6209.           bcPlanes := 1;
  6210.           bcBitCount := biBitCount;
  6211.         end;
  6212.         Stream.WriteBuffer(BMF, sizeof(BMF));
  6213.         Stream.WriteBuffer(BC, sizeof(BC));
  6214.       end
  6215.       else
  6216.       begin
  6217.         Stream.WriteBuffer(BMF, Sizeof(BMF));
  6218.         Stream.WriteBuffer(FDIB.dsbmih, Sizeof(FDIB.dsbmih));
  6219.         if (FDIB.dsbmih.biBitCount > 8) and
  6220.           ((FDIB.dsbmih.biCompression and BI_BITFIELDS) <> 0) then
  6221.           Stream.WriteBuffer(FDIB.dsBitfields, 12);
  6222.       end;
  6223.       Stream.WriteBuffer(Colors, ColorCount * PalSize[FOS2Format]);
  6224.       Stream.WriteBuffer(FDIB.dsbm.bmBits^, FDIB.dsbmih.biSizeImage);
  6225.     end;
  6226.   end;
  6227. end;
  6228.  
  6229. { ReleaseHandle gives up ownership of the bitmap handle the TBitmap contains. }
  6230. function TBitmap.ReleaseHandle: HBITMAP;
  6231. begin
  6232.   HandleNeeded;
  6233.   Changing(Self);
  6234.   with FImage do
  6235.   begin
  6236.     Result := FHandle;
  6237.     if FHandle = FDIBHandle then
  6238.     begin
  6239.       FDIBHandle := 0;
  6240.       FDIB.dsbm.bmBits := nil;
  6241.     end;
  6242.     FHandle := 0;
  6243.   end;
  6244. end;
  6245.  
  6246. function TBitmap.ReleaseMaskHandle: HBITMAP;
  6247. begin
  6248.   Result := GetMaskHandle;
  6249.   FImage.FMaskHandle := 0;
  6250. end;
  6251.  
  6252. function TBitmap.ReleasePalette: HPALETTE;
  6253. begin
  6254.   HandleNeeded;
  6255.   Changing(Self);
  6256.   Result := FImage.FPalette;
  6257.   FImage.FPalette := 0;
  6258. end;
  6259.  
  6260. procedure TBitmap.SaveToStream(Stream: TStream);
  6261. begin
  6262.   WriteStream(Stream, False);
  6263. end;
  6264.  
  6265. procedure TBitmap.SaveToClipboardFormat(var Format: Word; var Data: THandle;
  6266.   var APalette: HPALETTE);
  6267. var
  6268.   DIB: TDIBSection;
  6269. begin
  6270.   Format := CF_BITMAP;
  6271.   HandleNeeded;
  6272.   with FImage do
  6273.   begin
  6274.     DIB := FDIB;
  6275.     DIB.dsbmih.biSize := 0;   // copy to device bitmap
  6276.     DIB.dsbm.bmBits := nil;
  6277.     Data := CopyBitmap(FHandle, FPalette, FPalette, DIB, FCanvas);
  6278.   end;
  6279.   try
  6280.     APalette := CopyPalette(FImage.FPalette);
  6281.   except
  6282.     DeleteObject(Data);
  6283.     raise;
  6284.   end;
  6285. end;
  6286.  
  6287. function TBitmap.TransparentColorStored: Boolean;
  6288. begin
  6289.   Result := FTransparentMode = tmFixed;
  6290. end;
  6291.  
  6292. { TIconImage }
  6293.  
  6294. destructor TIconImage.Destroy;
  6295. begin
  6296.   FMemoryImage.Free;
  6297.   inherited Destroy;
  6298. end;
  6299.  
  6300. procedure TIconImage.FreeHandle;
  6301. begin
  6302.   if FHandle <> 0 then DestroyIcon(FHandle);
  6303.   FHandle := 0;
  6304. end;
  6305.  
  6306. { TIcon }
  6307.  
  6308. constructor TIcon.Create;
  6309. begin
  6310.   inherited Create;
  6311.   FTransparent := True;
  6312.   FImage := TIconImage.Create;
  6313.   FImage.Reference;
  6314. end;
  6315.  
  6316. destructor TIcon.Destroy;
  6317. begin
  6318.   FImage.Release;
  6319.   inherited Destroy;
  6320. end;
  6321.  
  6322. procedure TIcon.Assign(Source: TPersistent);
  6323. begin
  6324.   if (Source = nil) or (Source is TIcon) then
  6325.   begin
  6326.     if Source <> nil then
  6327.     begin
  6328.       TIcon(Source).FImage.Reference;
  6329.       FImage.Release;
  6330.       FImage := TIcon(Source).FImage;
  6331.     end else
  6332.       NewImage(0, nil);
  6333.     Changed(Self);
  6334.     Exit;
  6335.   end;
  6336.   inherited Assign(Source);
  6337. end;
  6338.  
  6339. procedure TIcon.Draw(ACanvas: TCanvas; const Rect: TRect);
  6340. begin
  6341.   with Rect.TopLeft do
  6342.   begin
  6343.     ACanvas.RequiredState([csHandleValid]);
  6344.     DrawIconEx(ACanvas.FHandle, X, Y, Handle, 0, 0, 0, 0, DI_NORMAL);
  6345.   end;
  6346. end;
  6347.  
  6348. function TIcon.GetEmpty: Boolean;
  6349. begin
  6350.   with FImage do
  6351.     Result := (FHandle = 0) and (FMemoryImage = nil);
  6352. end;
  6353.  
  6354. function TIcon.GetHandle: HICON;
  6355. begin
  6356.   HandleNeeded;
  6357.   Result := FImage.FHandle;
  6358. end;
  6359.  
  6360. function TIcon.GetHeight: Integer;
  6361. begin
  6362.   Result := FImage.FSize.y;
  6363.   if Result = 0 then
  6364.     Result := GetSystemMetrics(SM_CYICON)
  6365. end;
  6366.  
  6367. function TIcon.GetWidth: Integer;
  6368. begin
  6369.   Result := FImage.FSize.X;
  6370.   if Result = 0 then
  6371.     Result := GetSystemMetrics(SM_CXICON);
  6372. end;
  6373.  
  6374. procedure TIcon.HandleNeeded;
  6375. var
  6376.   CI: TCursorOrIcon;
  6377.   NewHandle: HICON;
  6378. begin
  6379.   with FImage do
  6380.   begin
  6381.     if FHandle <> 0 then Exit;
  6382.     if FMemoryImage = nil then Exit;
  6383.     FMemoryImage.Position := 0;
  6384.     FMemoryImage.ReadBuffer(CI, SizeOf(CI));
  6385.     case CI.wType of
  6386.       RC3_STOCKICON: NewHandle := StockIcon;
  6387.       RC3_ICON: ReadIcon(FMemoryImage, NewHandle, CI.Count, SizeOf(CI),
  6388.         FRequestedSize, FSize);
  6389.     else
  6390.       InvalidIcon;
  6391.     end;
  6392.     FHandle := NewHandle;
  6393.   end;
  6394. end;
  6395.  
  6396. procedure TIcon.ImageNeeded;
  6397. var
  6398.   Image: TMemoryStream;
  6399.   CI: TCursorOrIcon;
  6400. begin
  6401.   with FImage do
  6402.   begin
  6403.     if FMemoryImage <> nil then Exit;
  6404.     if FHandle = 0 then InvalidIcon;
  6405.     Image := TMemoryStream.Create;
  6406.     try
  6407.       if GetHandle = StockIcon then
  6408.       begin
  6409.         FillChar(CI, SizeOf(CI), 0);
  6410.         Image.WriteBuffer(CI, SizeOf(CI));
  6411.       end
  6412.       else
  6413.         WriteIcon(Image, Handle, False);
  6414.     except
  6415.       Image.Free;
  6416.       raise;
  6417.     end;
  6418.     FMemoryImage := Image;
  6419.   end;
  6420. end;
  6421.  
  6422. procedure TIcon.LoadFromStream(Stream: TStream);
  6423. var
  6424.   Image: TMemoryStream;
  6425.   CI: TCursorOrIcon;
  6426. begin
  6427.   Image := TMemoryStream.Create;
  6428.   try
  6429.     Image.SetSize(Stream.Size - Stream.Position);
  6430.     Stream.ReadBuffer(Image.Memory^, Image.Size);
  6431.     Image.ReadBuffer(CI, SizeOf(CI));
  6432.     if not (CI.wType in [RC3_STOCKICON, RC3_ICON]) then InvalidIcon;
  6433.     NewImage(0, Image);
  6434.   except
  6435.     Image.Free;
  6436.     raise;
  6437.   end;
  6438.   Changed(Self);
  6439. end;
  6440.  
  6441. procedure TIcon.NewImage(NewHandle: HICON; NewImage: TMemoryStream);
  6442. var
  6443.   Image: TIconImage;
  6444. begin
  6445.   Image := TIconImage.Create;
  6446.   try
  6447.     Image.FHandle := NewHandle;
  6448.     Image.FMemoryImage := NewImage;
  6449.   except
  6450.     Image.Free;
  6451.     raise;
  6452.   end;
  6453.   Image.Reference;
  6454.   FImage.Release;
  6455.   FImage := Image;
  6456. end;
  6457.  
  6458. function TIcon.ReleaseHandle: HICON;
  6459. begin
  6460.   with FImage do
  6461.   begin
  6462.     if FRefCount > 1 then NewImage(CopyIcon(FHandle), nil);
  6463.     Result := FHandle;
  6464.     FHandle := 0;
  6465.   end;
  6466.   Changed(Self);
  6467. end;
  6468.  
  6469. procedure TIcon.SetHandle(Value: HICON);
  6470. begin
  6471.   NewImage(Value, nil);
  6472.   Changed(Self);
  6473. end;
  6474.  
  6475. procedure TIcon.SetHeight(Value: Integer);
  6476. begin
  6477.   if FImage.FHandle = 0 then
  6478.     FRequestedSize.Y := Value
  6479.   else
  6480.     InvalidOperation(@SChangeIconSize);
  6481. end;
  6482.  
  6483. procedure TIcon.SetTransparent(Value: Boolean);
  6484. begin
  6485.   // Ignore assignments to this property.
  6486.   // Icons are always transparent.
  6487. end;
  6488.  
  6489. procedure TIcon.SetWidth(Value: Integer);
  6490. begin
  6491.   if FImage.FHandle = 0 then
  6492.     FRequestedSize.X := Value
  6493.   else
  6494.     InvalidOperation(@SChangeIconSize);
  6495. end;
  6496.  
  6497. procedure TIcon.SaveToStream(Stream: TStream);
  6498. begin
  6499.   ImageNeeded;
  6500.   with FImage.FMemoryImage do Stream.WriteBuffer(Memory^, Size);
  6501. end;
  6502.  
  6503. procedure TIcon.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  6504.   APalette: HPALETTE);
  6505. begin
  6506.   InvalidOperation(@SIconToClipboard);
  6507. end;
  6508.  
  6509. procedure TIcon.SaveToClipboardFormat(var Format: Word; var Data: THandle;
  6510.   var APalette: HPALETTE);
  6511. begin
  6512.   InvalidOperation(@SIconToClipboard);
  6513. end;
  6514.  
  6515.  
  6516. function GraphicFilter(GraphicClass: TGraphicClass): string;
  6517. var
  6518.   Filters: string;
  6519. begin
  6520.   GetFileFormats.BuildFilterStrings(GraphicClass, Result, Filters);
  6521. end;
  6522.  
  6523. function GraphicExtension(GraphicClass: TGraphicClass): string;
  6524. var
  6525.   I: Integer;
  6526. begin
  6527.   for I := GetFileFormats.Count-1 downto 0 do
  6528.     if PFileFormat(FileFormats[I])^.GraphicClass.ClassName = GraphicClass.ClassName then
  6529.     begin
  6530.       Result := PFileFormat(FileFormats[I])^.Extension;
  6531.       Exit;
  6532.     end;
  6533.   Result := '';
  6534. end;
  6535.  
  6536. function GraphicFileMask(GraphicClass: TGraphicClass): string;
  6537. var
  6538.   Descriptions: string;
  6539. begin
  6540.   GetFileFormats.BuildFilterStrings(GraphicClass, Descriptions, Result);
  6541. end;
  6542.  
  6543. procedure InitScreenLogPixels;
  6544. const
  6545.   Pal16: array [0..15] of TColor =
  6546.     (clBlack, clMaroon, clGreen, clOlive, clNavy, clPurple, clTeal, clDkGray,
  6547.      clLtGray, clRed, clLime, clYellow, clBlue, clFuchsia, clAqua, clWhite);
  6548. var
  6549.   DC: HDC;
  6550. begin
  6551.   DC := GetDC(0);
  6552.   ScreenLogPixels := GetDeviceCaps(DC, LOGPIXELSY);
  6553.   ReleaseDC(0,DC);
  6554. //!!  SystemPalette16 := GetStockObject(DEFAULT_PALETTE);
  6555.   SystemPalette16 := CreateSystemPalette(Pal16);
  6556. end;
  6557.  
  6558. function GetDefFontCharSet: TFontCharSet;
  6559. var
  6560.   DisplayDC: HDC;
  6561.   TxtMetric: TTEXTMETRIC;
  6562. begin
  6563.   Result := DEFAULT_CHARSET;
  6564.   DisplayDC := GetDC(0);
  6565.   if (DisplayDC <> 0) then
  6566.   begin
  6567.     if (SelectObject(DisplayDC, StockFont) <> 0) then
  6568.       if (GetTextMetrics(DisplayDC, TxtMetric)) then
  6569.         Result := TxtMetric.tmCharSet;
  6570.     ReleaseDC(0, DisplayDC);
  6571.   end;
  6572. end;
  6573.  
  6574. procedure InitDefFontData;
  6575. var
  6576.   Charset: TFontCharset;
  6577. begin
  6578.   DefFontData.Height := -MulDiv(8, ScreenLogPixels, 72);
  6579.   if not SysLocale.FarEast then Exit;
  6580.   Charset := GetDefFontCharset;
  6581.   case Charset of
  6582.     SHIFTJIS_CHARSET:
  6583.       begin
  6584.         DefFontData.Name := 'élér éoâSâVâbâN';
  6585.         DefFontData.Height := -MulDiv(9, ScreenLogPixels, 72);
  6586.         DefFontData.CharSet := CharSet;
  6587.       end;
  6588.   end;
  6589. end;
  6590.  
  6591. type
  6592.   PPattern = ^TPattern;
  6593.   TPattern = record
  6594.     Next: PPattern;
  6595.     Bitmap: TBitmap;
  6596.     BkColorRef: TColorRef;
  6597.     FgColorRef: TColorRef;
  6598.   end;
  6599.  
  6600.   TPatternManager = class(TObject)
  6601.   private
  6602.     List: PPattern;
  6603.     FLock: TRTLCriticalSection;
  6604.     function CreateBitmap(BkColor, FgColor: TColor): TBitmap;
  6605.   public
  6606.     constructor Create;
  6607.     destructor Destroy; override;
  6608.     function AllocPattern(BkColor, FgColor: TColorRef): PPattern;
  6609.     procedure FreePatterns;
  6610.     procedure Lock;
  6611.     procedure Unlock;
  6612.   end;
  6613.  
  6614. constructor TPatternManager.Create;
  6615. begin
  6616.   InitializeCriticalSection(FLock);
  6617. end;
  6618.  
  6619. destructor TPatternManager.Destroy;
  6620. begin
  6621.   FreePatterns;
  6622.   DeleteCriticalSection(FLock);
  6623. end;
  6624.  
  6625. procedure TPatternManager.Lock;
  6626. begin
  6627.   EnterCriticalSection(FLock);
  6628. end;
  6629.  
  6630. procedure TPatternManager.Unlock;
  6631. begin
  6632.   LeaveCriticalSection(FLock);
  6633. end;
  6634.  
  6635. function TPatternManager.AllocPattern(BkColor, FgColor: TColorRef): PPattern;
  6636. begin
  6637.   Lock;
  6638.   try
  6639.     Result := List;
  6640.     while (Result <> nil) and ((Result^.BkColorRef <> BkColor) or
  6641.       (Result^.FgColorRef <> FgColor)) do
  6642.       Result := Result^.Next;
  6643.     if Result = nil then
  6644.     begin
  6645.       GetMem(Result, SizeOf(TPattern));
  6646.       with Result^ do
  6647.       begin
  6648.         Next := List;
  6649.         Bitmap := CreateBitmap(BkColor, FgColor);
  6650.         BkColorRef := BkColor;
  6651.         FgColorRef := FgColor;
  6652.       end;
  6653.       List := Result;
  6654.     end;
  6655.   finally
  6656.     Unlock;
  6657.   end;
  6658. end;
  6659.  
  6660. function TPatternManager.CreateBitmap(BkColor, FgColor: TColor): TBitmap;
  6661. var
  6662.   X, Y: Integer;
  6663. begin
  6664.   Result := TBitmap.Create;
  6665.   try
  6666.     with Result do
  6667.     begin
  6668.       Width := 8;
  6669.       Height := 8;
  6670.       with Canvas do
  6671.       begin
  6672.         Brush.Style := bsSolid;
  6673.         Brush.Color := BkColor;
  6674.         FillRect(Rect(0, 0, Width, Height));
  6675.         for Y := 0 to 8 do
  6676.           for X := 0 to 8 do
  6677.             if (Y mod 2) = (X mod 2) then  { toggles between even/odd pixles }
  6678.               Pixels[X, Y] := FgColor;     { on even/odd rows }
  6679.       end;
  6680.       Dormant;
  6681.     end;
  6682.   except
  6683.     Result.Free;
  6684.     raise;
  6685.   end;
  6686. end;
  6687.  
  6688. procedure TPatternManager.FreePatterns;
  6689. var
  6690.   P: PPattern;
  6691. begin
  6692.   while List <> nil do
  6693.   begin
  6694.     P := List;
  6695.     with P^ do
  6696.     begin
  6697.       Lock;
  6698.       try
  6699.         List := Next
  6700.       finally
  6701.         Unlock;
  6702.       end;
  6703.       if Bitmap <> nil then Bitmap.Free;
  6704.     end;
  6705.     FreeMem(P);
  6706.   end;
  6707. end;
  6708.  
  6709. var
  6710.   PatternManager: TPatternManager;
  6711.  
  6712.  
  6713. function AllocPatternBitmap(BkColor, FgColor: TColor): TBitmap;
  6714. begin
  6715.   if PatternManager <> nil then
  6716.     Result := PatternManager.AllocPattern(ColorToRGB(BkColor),
  6717.       ColorToRGB(FgColor)).Bitmap
  6718.     else
  6719.       Result := nil;
  6720. end;
  6721.  
  6722. initialization
  6723.   InitScreenLogPixels;
  6724.   InitializeCriticalSection(BitmapImageLock);
  6725.   InitializeCriticalSection(CounterLock);
  6726.   StockPen := GetStockObject(BLACK_PEN);
  6727.   StockBrush := GetStockObject(HOLLOW_BRUSH);
  6728.   StockFont := GetStockObject(SYSTEM_FONT);
  6729.   StockIcon := LoadIcon(0, IDI_APPLICATION);
  6730.   InitDefFontData;
  6731.   FontManager := TResourceManager.Create(SizeOf(TFontData));
  6732.   PenManager := TResourceManager.Create(SizeOf(TPenData));
  6733.   BrushManager := TResourceManager.Create(SizeOf(TBrushData));
  6734.   PatternManager := TPatternManager.Create;
  6735.   BitmapCanvasList := TThreadList.Create;
  6736.   CanvasList := TThreadList.Create;
  6737.   RegisterIntegerConsts(TypeInfo(TColor), IdentToColor, ColorToIdent);
  6738.   RegisterIntegerConsts(TypeInfo(TFontCharset), IdentToCharset, CharsetToIdent);
  6739. finalization
  6740.   PatternManager.Free;
  6741.   FileFormats.Free;
  6742.   ClipboardFormats.Free;
  6743.   FreeMemoryContexts;
  6744.   BitmapCanvasList.Free;
  6745.   CanvasList.Free;
  6746.   FontManager.Free;
  6747.   PenManager.Free;
  6748.   BrushManager.Free;
  6749.   DeleteObject(SystemPalette16);
  6750.   DeleteCriticalSection(BitmapImageLock);
  6751.   DeleteCriticalSection(CounterLock);
  6752. end.
  6753.