Subversion Repositories spacemission

Rev

Rev 1 | Go to most recent revision | Blame | Compare with Previous | Last modification | View Log | RSS feed

  1. {*******************************************************}
  2. {                                                       }
  3. {       DIB and PAINTBOX componets                      }
  4. {                                                       }
  5. {       Copyright (C) 1997-2000 Hiroyuki Hori           }
  6. {         base components and effects                   }
  7. {       Copyright (C) 2000 Keith Murray                 }
  8. {         supernova effect                              }
  9. {       Copyright (C) 2000 Michel Hibon                 }
  10. {         new special effects added for DIB             }
  11. {       Copyright (C) 2001 Joakim Back                  }
  12. {         conFusion effects (as DxFusion)               }
  13. {       Copyright (C) 2003 Babak Sateli                 }
  14. {         24-bit DIB effect as supplement ones          }
  15. {       Copyright (C) 2004-2012 Jaro Benes              }
  16. {         32-bit DIB effect with alphachannel           }
  17. {         direct works with texture buffer              }
  18. {         modified and adapted all adopted functions    }
  19. {                                                       }
  20. {*******************************************************}
  21.  
  22. unit DIB;
  23.  
  24. interface
  25.  
  26. {$INCLUDE DelphiXcfg.inc}
  27. {$DEFINE USE_SCANLINE}
  28.  
  29. uses
  30.   Windows, SysUtils, Classes, Graphics, Controls,
  31.   {$IFDEF VER17UP} Types, UITypes,{$ENDIF}
  32.   Math;
  33.  
  34. type
  35.   TColorLineStyle = (csSolid, csGradient, csRainbow);
  36.   TColorLinePixelGeometry = (pgPoint, pgCircular, pgRectangular);
  37.   PRGBQuads = ^TRGBQuads;
  38.   TRGBQuads = array[0..255] of TRGBQuad;
  39.  
  40.   TPaletteEntries = array[0..255] of TPaletteEntry;
  41.  
  42.   PBGR = ^TBGR;
  43.   TBGR = packed record
  44.     B, G, R: Byte;
  45.   end;
  46.  
  47.   {   Added this type for New SPecial Effect   }
  48.   TFilter = array[0..2, 0..2] of SmallInt;
  49.   TLines = array[0..0] of TBGR;
  50.   PLines = ^TLines;
  51.   TBytes = array[0..0] of Byte;
  52.   PBytes = ^TBytes;
  53.   TPBytes = array[0..0] of PBytes;
  54.   PPBytes = ^TPBytes;
  55.   {   End of type's   }
  56.  
  57.   PArrayBGR = ^TArrayBGR;
  58.   TArrayBGR = array[0..10000] of TBGR;
  59.  
  60.   PArrayByte = ^TArrayByte;
  61.   TArrayByte = array[0..10000] of Byte;
  62.  
  63.   PArrayWord = ^TArrayWord;
  64.   TArrayWord = array[0..10000] of Word;
  65.  
  66.   PArrayDWord = ^TArrayDWord;
  67.   TArrayDWord = array[0..10000] of DWord;
  68.  
  69.   {  TDIBPixelFormat  }
  70.  
  71.   TDIBPixelFormat = record
  72.     RBitMask, GBitMask, BBitMask: DWORD;
  73.     RBitCount, GBitCount, BBitCount: DWORD;
  74.     RShift, GShift, BShift: DWORD;
  75.     RBitCount2, GBitCount2, BBitCount2: DWORD;
  76.   end;
  77.  
  78.   {  TDIBSharedImage  }
  79.  
  80.   TDIBSharedImage = class(TSharedImage)
  81.   private
  82.     FBitCount: Integer;
  83.     FBitmapInfo: PBitmapInfo;
  84.     FBitmapInfoSize: Integer;
  85.     FChangePalette: Boolean;
  86.     FColorTable: TRGBQuads;
  87.     FColorTablePos: Integer;
  88.     FCompressed: Boolean;
  89.     FDC: THandle;
  90.     FHandle: THandle;
  91.     FHeight: Integer;
  92.     FMemoryImage: Boolean;
  93.     FNextLine: Integer;
  94.     FOldHandle: THandle;
  95.     FPalette: HPalette;
  96.     FPaletteCount: Integer;
  97.     FPBits: Pointer;
  98.     FPixelFormat: TDIBPixelFormat;
  99.     FSize: Integer;
  100.     FTopPBits: Pointer;
  101.     FWidth: Integer;
  102.     FWidthBytes: Integer;
  103.     constructor Create;
  104.     procedure NewImage(AWidth, AHeight, ABitCount: Integer;
  105.       const PixelFormat: TDIBPixelFormat; const ColorTable: TRGBQuads; MemoryImage, Compressed: Boolean);
  106.     procedure Duplicate(Source: TDIBSharedImage; MemoryImage: Boolean); {$IFDEF VER9UP}inline;{$ENDIF}
  107.     procedure Compress(Source: TDIBSharedImage);
  108.     procedure Decompress(Source: TDIBSharedImage; MemoryImage: Boolean);
  109.     procedure ReadData(Stream: TStream; MemoryImage: Boolean);
  110.     function GetPalette: THandle;
  111.     procedure SetColorTable(const Value: TRGBQuads);
  112.   protected
  113.     procedure FreeHandle; override;
  114.   public
  115.     destructor Destroy; override;
  116.   end;
  117.  
  118.   {  TFilterTypeResample  }
  119.  
  120.   TFilterTypeResample = (ftrBox, ftrTriangle, ftrHermite, ftrBell, ftrBSpline,
  121.     ftrLanczos3, ftrMitchell);
  122.  
  123.   TDistortType = (dtFast, dtSlow);
  124.   {DXFusion effect type}
  125.   TFilterMode = (fmNormal, fmMix50, fmMix25, fmMix75);
  126.  
  127.   {  TLightSource  }
  128.  
  129.   TLightSource = record
  130.     X, Y: Integer;
  131.     Size1, Size2: Integer;
  132.     Color: TColor;
  133.   end;
  134.  
  135.   {  TLightArray  }
  136.  
  137.   TLightArray = array{$IFNDEF VER4UP} [0..0]{$ENDIF} of TLightsource;
  138.  
  139.   {  TMatrixSetting  }
  140.  
  141.   TMatrixSetting = array[0..9] of Integer;
  142.  
  143.   {  TDIB  }
  144.  
  145.   TDIB = class(TGraphic)
  146.   private
  147.     FCanvas: TCanvas;
  148.     FImage: TDIBSharedImage;
  149.  
  150.     FProgressName: string;
  151.     FProgressOldY: DWORD;
  152.     FProgressOldTime: DWORD;
  153.     FProgressOld: DWORD;
  154.     FProgressY: DWORD;
  155.     {  For speed-up  }
  156.     FBitCount: Integer;
  157.     FHeight: Integer;
  158.     FNextLine: Integer;
  159.     FNowPixelFormat: TDIBPixelFormat;
  160.     FPBits: Pointer;
  161.     FSize: Integer;
  162.     FTopPBits: Pointer;
  163.     FWidth: Integer;
  164.     FWidthBytes: Integer;
  165.     FLUTDist: array[0..255, 0..255] of Integer;
  166.     LG_COUNT: Integer;
  167.     LG_DETAIL: Integer;
  168.     FFreeList: TList;
  169.     procedure AllocHandle;
  170.     procedure CanvasChanging(Sender: TObject);
  171.     procedure Changing(MemoryImage: Boolean);
  172.     procedure ConvertBitCount(ABitCount: Integer);
  173.     function GetBitmapInfo: PBitmapInfo;
  174.     function GetBitmapInfoSize: Integer;
  175.     function GetCanvas: TCanvas;
  176.     function GetHandle: THandle;
  177.     function GetPaletteCount: Integer;
  178.     function GetPixel(X, Y: Integer): DWORD;
  179.     function GetPBits: Pointer;
  180.     function GetPBitsReadOnly: Pointer;
  181.     function GetScanLine(Y: Integer): Pointer;
  182.     function GetScanLineReadOnly(Y: Integer): Pointer;
  183.     function GetTopPBits: Pointer;
  184.     function GetTopPBitsReadOnly: Pointer;
  185.     procedure SetBitCount(Value: Integer);
  186.     procedure SetImage(Value: TDIBSharedImage); {$IFDEF VER9UP}inline;{$ENDIF}
  187.     procedure SetNowPixelFormat(const Value: TDIBPixelFormat);
  188.     procedure SetPixel(X, Y: Integer; Value: DWORD);
  189.     procedure StartProgress(const Name: string);
  190.     procedure EndProgress;
  191.     procedure UpdateProgress(PercentY: Integer);
  192.  
  193.     {   Added these 3 functions for New Specials Effects   }
  194.     function Interval(iMin, iMax, iValue: Integer; iMark: Boolean): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
  195.     function IntToByte(i: Integer): Byte; {$IFDEF VER9UP}inline;{$ENDIF}
  196.     function TrimInt(i, Min, Max: Integer): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
  197.     {   End of 3 functions for New Special Effect   }
  198.  
  199.     procedure Darkness(Amount: Integer);
  200.     function GetAlphaChannel: TDIB;
  201.     procedure SetAlphaChannel(const Value: TDIB);
  202.     function GetClientRect: TRect;
  203.     function GetRGBChannel: TDIB;
  204.     procedure SetRGBChannel(const Value: TDIB);
  205.   protected
  206.     procedure DefineProperties(Filer: TFiler); override;
  207.     procedure Draw(ACanvas: TCanvas; const ARect: TRect); override;
  208.     function GetEmpty: Boolean; override;
  209.     function GetHeight: Integer; override;
  210.     function GetPalette: HPalette; override;
  211.     function GetWidth: Integer; override;
  212.     procedure ReadData(Stream: TStream); override;
  213.     procedure SetHeight(Value: Integer); override;
  214.     procedure SetPalette(Value: HPalette); override;
  215.     procedure SetWidth(Value: Integer); override;
  216.     procedure WriteData(Stream: TStream); override;
  217.   public
  218.     ColorTable: TRGBQuads;
  219.     PixelFormat: TDIBPixelFormat;
  220.     constructor Create; override;
  221.     destructor Destroy; override;
  222.     procedure Assign(Source: TPersistent); override;
  223.     procedure Clear;
  224.     procedure Compress;
  225.     procedure Decompress;
  226.     procedure FreeHandle;
  227.     function HasAlphaChannel: Boolean;
  228.     function AssignAlphaChannel(ALPHA: TDIB; ForceResize: Boolean{$IFDEF VER4UP} = False{$ENDIF}): Boolean;
  229.     procedure RetAlphaChannel(out oDIB: TDIB);
  230.     procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  231.       APalette: HPALETTE); override;
  232.     procedure LoadFromStream(Stream: TStream); override;
  233.     procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  234.       var APalette: HPALETTE); override;
  235.     procedure SaveToStream(Stream: TStream); override;
  236.     procedure SetSize(AWidth, AHeight, ABitCount: Integer); {$IFDEF VER5UP}reintroduce;{$ENDIF} //{$IFDEF VER9UP} overload;{$ENDIF}
  237.     procedure UpdatePalette;
  238.     {  Special effect  }
  239.     procedure Blur(ABitCount: Integer; Radius: Integer);
  240.     procedure Greyscale(ABitCount: Integer);
  241.     procedure Mirror(MirrorX, MirrorY: Boolean);
  242.     procedure Negative;
  243.  
  244.     {   Added New Special Effect   }
  245.     procedure Spray(Amount: Integer);
  246.     procedure Emboss;
  247.     procedure AddMonoNoise(Amount: Integer);
  248.     procedure AddGradiantNoise(Amount: byte);
  249.     function Twist(bmp: TDIB; Amount: byte): Boolean;
  250.     function FishEye(bmp: TDIB): Boolean;
  251.     function SmoothRotateWrap(Bmp: TDIB; cx, cy: Integer; Degree: Extended): Boolean;
  252.     procedure Lightness(Amount: Integer);
  253.     procedure Saturation(Amount: Integer);
  254.     procedure Contrast(Amount: Integer);
  255.     procedure AddRGB(aR, aG, aB: Byte);
  256.     function Filter(Dest: TDIB; Filter: TFilter): Boolean;
  257.     procedure Sharpen(Amount: Integer);
  258.     function IntToColor(i: Integer): TBGR; {$IFDEF VER9UP}inline;{$ENDIF}
  259.     function Rotate(Dst: TDIB; cx, cy: Integer; Angle: Double): Boolean;
  260.     procedure SplitBlur(Amount: Integer);
  261.     procedure GaussianBlur(Bmp: TDIB; Amount: Integer);
  262.     {   End of New Special Effect   }
  263.     {
  264.     New effect for TDIB
  265.     with Some Effects like AntiAlias, Contrast,
  266.     Lightness, Saturation, GaussianBlur, Mosaic,
  267.     Twist, Splitlight, Trace, Emboss, etc.
  268.     Works with 24bit color DIBs.
  269.  
  270.     This component is based on TProEffectImage component version 1.0 by
  271.     Written By Babak Sateli (babak_sateli@yahoo.com, http://raveland.netfirms.com)
  272.  
  273.     and modified by (c) 2004 Jaro Benes
  274.     for DelphiX use.
  275.  
  276.     Demo was modified into DXForm with function like  original
  277.  
  278.     DISCLAIMER
  279.     This component is provided AS-IS without any warranty of any kind, either express or
  280.     implied. This component is freeware and can be used in any software product.
  281.     }
  282.     procedure DoInvert;
  283.     procedure DoAddColorNoise(Amount: Integer);
  284.     procedure DoAddMonoNoise(Amount: Integer);
  285.     procedure DoAntiAlias;
  286.     procedure DoContrast(Amount: Integer);
  287.     procedure DoFishEye(Amount: Integer);
  288.     procedure DoGrayScale;
  289.     procedure DoLightness(Amount: Integer);
  290.     procedure DoDarkness(Amount: Integer);
  291.     procedure DoSaturation(Amount: Integer);
  292.     procedure DoSplitBlur(Amount: Integer);
  293.     procedure DoGaussianBlur(Amount: Integer);
  294.     procedure DoMosaic(Size: Integer);
  295.     procedure DoTwist(Amount: Integer);
  296.     procedure DoSplitlight(Amount: Integer);
  297.     procedure DoTile(Amount: Integer);
  298.     procedure DoSpotLight(Amount: Integer; Spot: TRect);
  299.     procedure DoTrace(Amount: Integer);
  300.     procedure DoEmboss;
  301.     procedure DoSolorize(Amount: Integer);
  302.     procedure DoPosterize(Amount: Integer);
  303.     procedure DoBrightness(Amount: Integer);
  304.     procedure DoResample(AmountX, AmountY: Integer; TypeResample: TFilterTypeResample);
  305.     {rotate}
  306.     procedure DoSmoothRotate(Src: TDIB; cx, cy: Integer; Angle: Extended);
  307.     procedure DoColorize(ForeColor, BackColor: TColor);
  308.     {Simple explosion spoke effect}
  309.     procedure DoNovaEffect(sr, sg, sb, cx, cy, radius,
  310.       nspokes, randomhue, randomspok, randgauss: Integer; onProgress: TProgressEvent);
  311.  
  312.     {Simple Mandelbrot-set drawing}
  313.     procedure DrawMandelbrot(ao, au: Integer; bo, bu: Double);
  314.  
  315.     {Sephia effect}
  316.     procedure SephiaEffect(Depth: Integer{$IFDEF VER4UP} = 20{$ENDIF});
  317.  
  318.     {Simple blend pixel}
  319.     procedure BlendPixel(const X, Y: Integer; aColor: Cardinal; Alpha: Byte); {$IFDEF VER9UP}inline;{$ENDIF}
  320.     {Line in polar system}
  321.     procedure LinePolar(x, y: Integer; AngleInDegree, Length: extended;
  322.       Color: cardinal);
  323.  
  324.     {special version Dark/Light procedure in percent}
  325.     procedure Darker(Percent: Integer);
  326.     procedure Lighter(Percent: Integer);
  327.  
  328.     {Simple graphical crypt}
  329.     procedure EncryptDecrypt(const Key: Integer);
  330.  
  331.     { Standalone DXFusion }
  332.     {--- c o n F u s i o n ---}
  333.     {By Joakim Back, www.back.mine.nu}
  334.     {Huge thanks to Ilkka Tuomioja for helping out with the project.}
  335.  
  336.     {
  337.     modified by (c) 2005 Jaro Benes for DelphiX use.
  338.     }
  339.  
  340.     procedure CreateDIBFromBitmap(const Bitmap: TBitmap);
  341.     {Drawing Methods.}
  342.     procedure DrawOn(Dest: TRect; DestCanvas: TCanvas;
  343.       Xsrc, Ysrc: Integer);
  344.     procedure DrawTo(SrcDIB: TDIB; X, Y, Width, Height, SourceX,
  345.       SourceY: Integer);
  346.     procedure DrawTransparent(SrcDIB: TDIB; const X, Y, Width, Height,
  347.       SourceX, SourceY: Integer; const Color: TColor); {$IFDEF VER5UP} reintroduce;{$ENDIF} //{$IFDEF VER9UP} overload;{$ENDIF}
  348.     procedure DrawShadow(SrcDIB: TDIB; X, Y, Width, Height, Frame: Integer;
  349.       FilterMode: TFilterMode);
  350.     procedure DrawShadows(SrcDIB: TDIB; X, Y, Width, Height, Frame: Integer;
  351.       Alpha: Byte);
  352.     procedure DrawDarken(SrcDIB: TDIB; X, Y, Width, Height,
  353.       Frame: Integer);
  354.     procedure DrawAdditive(SrcDIB: TDIB; X, Y, Width, Height: Integer; Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF};
  355.       Frame: Integer{$IFDEF VER4UP} = 0{$ENDIF});
  356.     procedure DrawQuickAlpha(SrcDIB: TDIB; const X, Y, Width, Height,
  357.       SourceX, SourceY: Integer; const Color: TColor;
  358.       FilterMode: TFilterMode);
  359.     procedure DrawTranslucent(SrcDIB: TDIB; const X, Y, Width, Height,
  360.       SourceX, SourceY: Integer; const Color: TColor);
  361.     procedure DrawMorphed(SrcDIB: TDIB; const X, Y, Width, Height, SourceX,
  362.       SourceY: Integer; const Color: TColor);
  363.     procedure DrawAlpha(SrcDIB: TDIB; const X, Y, Width, Height, SourceX,
  364.       SourceY, Alpha: Integer; const Color: TColor);
  365.     procedure DrawAlphaMask(SrcDIB, MaskDIB: TDIB; const X, Y, Width,
  366.       Height, SourceX, SourceY: Integer);
  367.     procedure DrawAntialias(SrcDIB: TDIB);
  368.     procedure Draw3x3Matrix(SrcDIB: TDIB; Setting: TMatrixSetting);
  369.     procedure DrawMono(SrcDIB: TDIB; const X, Y, Width, Height, SourceX,
  370.       SourceY: Integer; const TransColor, ForeColor, BackColor: TColor);
  371.     {One-color Filters.}
  372.     procedure FilterLine(X1, Y1, X2, Y2: Integer; Color: TColor;
  373.       FilterMode: TFilterMode); {$IFDEF VER9UP}inline;{$ENDIF}
  374.     procedure FilterRect(X, Y, Width, Height: Integer; Color: TColor;
  375.       FilterMode: TFilterMode); {$IFDEF VER9UP}inline;{$ENDIF}
  376.     { Lightsource. }
  377.     procedure InitLight(Count, Detail: Integer);
  378.     procedure DrawLights(FLight: TLightArray; AmbientLight: TColor);
  379.     //
  380.     // effect for special purpose
  381.     //
  382.     procedure FadeOut(DIB2: TDIB; Step: Byte);
  383.     procedure DoZoom(DIB2: TDIB; ZoomRatio: Real);
  384.     procedure DoBlur(DIB2: TDIB);
  385.     procedure FadeIn(DIB2: TDIB; Step: Byte);
  386.     procedure FillDIB8(Color: Byte);
  387.     procedure DoRotate(DIB1: TDIB; cX, cY, Angle: Integer);
  388.     procedure Distort(DIB1: TDIB; dt: TDistortType; cX, cY, Angle: Integer; Factor: Real);
  389.     function Ink(DIB: TDIB; const SprayInit: Boolean; const AmountSpray: Integer): Boolean;
  390.     // lines
  391.     procedure AntialiasedLine(x1, y1, x2, y2: Integer; color: TColor); {$IFDEF VER9UP} inline; {$ENDIF}
  392.     function GetColorBetween(StartColor, EndColor: TColor; Pointvalue,
  393.       FromPoint, ToPoint: Extended): TColor;
  394.     procedure ColoredLine(const iStart, iEnd: TPoint; iColorStyle: TColorLineStyle;
  395.       iGradientFrom, iGradientTo: TColor; iPixelGeometry: TColorLinePixelGeometry;
  396.       iRadius: WORD);
  397.     // standard property
  398.     property BitCount: Integer read FBitCount write SetBitCount;
  399.     property BitmapInfo: PBitmapInfo read GetBitmapInfo;
  400.     property BitmapInfoSize: Integer read GetBitmapInfoSize;
  401.     property Canvas: TCanvas read GetCanvas;
  402.     property Handle: THandle read GetHandle;
  403.     property Height: Integer read FHeight write SetHeight;
  404.     property NextLine: Integer read FNextLine;
  405.     property NowPixelFormat: TDIBPixelFormat read FNowPixelFormat write SetNowPixelFormat;
  406.     property PaletteCount: Integer read GetPaletteCount;
  407.     property PBits: Pointer read GetPBits;
  408.     property PBitsReadOnly: Pointer read GetPBitsReadOnly;
  409.     property Pixels[X, Y: Integer]: DWORD read GetPixel write SetPixel;
  410.     property ScanLine[Y: Integer]: Pointer read GetScanLine;
  411.     property ScanLineReadOnly[Y: Integer]: Pointer read GetScanLineReadOnly;
  412.     property Size: Integer read FSize;
  413.     property TopPBits: Pointer read GetTopPBits;
  414.     property TopPBitsReadOnly: Pointer read GetTopPBitsReadOnly;
  415.     property Width: Integer read FWidth write SetWidth;
  416.     property WidthBytes: Integer read FWidthBytes;
  417.     property AlphaChannel: TDIB read GetAlphaChannel write SetAlphaChannel;
  418.     property RGBChannel: TDIB read GetRGBChannel write SetRGBChannel;
  419.     function CreateBitmapFromDIB: TBitmap;
  420.     procedure Fill(aColor: TColor);
  421.     property ClientRect: TRect read GetClientRect;
  422.   end;
  423.  
  424.   {  TDIBitmap  }
  425.  
  426.   TDIBitmap = class(TDIB) end;
  427.  
  428.   {  TCustomDXDIB  }
  429.  
  430.   TCustomDXDIB = class(TComponent)
  431.   private
  432.     FDIB: TDIB;
  433.     procedure SetDIB(Value: TDIB);
  434.   public
  435.     constructor Create(AOnwer: TComponent); override;
  436.     destructor Destroy; override;
  437.     property DIB: TDIB read FDIB write SetDIB;
  438.   end;
  439.  
  440.   {  TDXDIB  }
  441.  
  442.   TDXDIB = class(TCustomDXDIB)
  443.   published
  444.     property DIB;
  445.   end;
  446.  
  447.   {  TCustomDXPaintBox  }
  448.  
  449.   TCustomDXPaintBox = class(TGraphicControl)
  450.   private
  451.     FAutoStretch: Boolean;
  452.     FCenter: Boolean;
  453.     FDIB: TDIB;
  454.     FKeepAspect: Boolean;
  455.     FStretch: Boolean;
  456.     FViewWidth: Integer;
  457.     FViewHeight: Integer;
  458.     procedure SetAutoStretch(Value: Boolean);
  459.     procedure SetCenter(Value: Boolean);
  460.     procedure SetDIB(Value: TDIB);
  461.     procedure SetKeepAspect(Value: Boolean);
  462.     procedure SetStretch(Value: Boolean);
  463.     procedure SetViewWidth(Value: Integer);
  464.     procedure SetViewHeight(Value: Integer);
  465.   protected
  466.     function GetPalette: HPALETTE; override;
  467.   public
  468.     constructor Create(AOwner: TComponent); override;
  469.     destructor Destroy; override;
  470.     procedure Paint; override;
  471.     property AutoStretch: Boolean read FAutoStretch write SetAutoStretch;
  472.     property Canvas;
  473.     property Center: Boolean read FCenter write SetCenter;
  474.     property DIB: TDIB read FDIB write SetDIB;
  475.     property KeepAspect: Boolean read FKeepAspect write SetKeepAspect;
  476.     property Stretch: Boolean read FStretch write SetStretch;
  477.     property ViewWidth: Integer read FViewWidth write SetViewWidth;
  478.     property ViewHeight: Integer read FViewHeight write SetViewHeight;
  479.   end;
  480.  
  481.   {  TDXPaintBox  }
  482.  
  483.   TDXPaintBox = class(TCustomDXPaintBox)
  484.   published
  485. {$IFDEF VER4UP}property Anchors; {$ENDIF}
  486.     property AutoStretch;
  487.     property Center;
  488. {$IFDEF VER4UP}property Constraints; {$ENDIF}
  489.     property DIB;
  490.     property KeepAspect;
  491.     property Stretch;
  492.     property ViewWidth;
  493.     property ViewHeight;
  494.  
  495.     property Align;
  496.     property DragCursor;
  497.     property DragMode;
  498.     property Enabled;
  499.     property ParentShowHint;
  500.     property PopupMenu;
  501.     property ShowHint;
  502.     property Visible;
  503.     property OnClick;
  504.     property OnDblClick;
  505.     property OnDragDrop;
  506.     property OnDragOver;
  507.     property OnEndDrag;
  508.     property OnMouseDown;
  509.     property OnMouseMove;
  510.     property OnMouseUp;
  511. {$IFDEF VER9UP}property OnMouseWheel; {$ENDIF}
  512. {$IFDEF VER9UP}property OnResize; {$ENDIF}
  513. {$IFDEF VER9UP}property OnCanResize; {$ENDIF}
  514. {$IFDEF VER9UP}property OnContextPopup; {$ENDIF}
  515.     property OnStartDrag;
  516.   end;
  517.  
  518. const
  519.   DefaultFilterRadius: array[TFilterTypeResample] of Single = (0.5, 1, 1, 1.5, 2, 3, 2);
  520.  
  521. function MakeDIBPixelFormat(RBitCount, GBitCount, BBitCount: Integer): TDIBPixelFormat; {$IFDEF VER9UP}inline;{$ENDIF}
  522. function MakeDIBPixelFormatMask(RBitMask, GBitMask, BBitMask: Integer): TDIBPixelFormat; {$IFDEF VER9UP}inline;{$ENDIF}
  523. function pfRGB(const PixelFormat: TDIBPixelFormat; R, G, B: Byte): DWORD; {$IFDEF VER9UP}inline;{$ENDIF}
  524. procedure pfGetRGB(const PixelFormat: TDIBPixelFormat; Color: DWORD; var R, G, B: Byte); {$IFDEF VER9UP}inline;{$ENDIF}
  525. function pfGetRValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte; {$IFDEF VER9UP}inline;{$ENDIF}
  526. function pfGetGValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte; {$IFDEF VER9UP}inline;{$ENDIF}
  527. function pfGetBValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte; {$IFDEF VER9UP}inline;{$ENDIF}
  528.  
  529. function GreyscaleColorTable: TRGBQuads;
  530.  
  531. function RGBQuad(R, G, B: Byte): TRGBQuad; {$IFDEF VER9UP}inline;{$ENDIF}
  532. function PaletteEntryToRGBQuad(const Entry: TPaletteEntry): TRGBQuad; {$IFDEF VER9UP}inline;{$ENDIF}
  533. function PaletteEntriesToRGBQuads(const Entries: TPaletteEntries): TRGBQuads; {$IFDEF VER9UP}inline;{$ENDIF}
  534. function RGBQuadToPaletteEntry(const RGBQuad: TRGBQuad): TPaletteEntry; {$IFDEF VER9UP}inline;{$ENDIF}
  535. function RGBQuadsToPaletteEntries(const RGBQuads: TRGBQuads): TPaletteEntries; {$IFDEF VER9UP}inline;{$ENDIF}
  536.  
  537. function PosValue(Value: Integer): Integer;
  538.  
  539. type
  540.   TOC = 0..511;
  541. function DSin(const C: TOC): Single; {$IFDEF VER9UP}inline; {$ENDIF}
  542. function DCos(const C: TOC): Single; {$IFDEF VER9UP}inline; {$ENDIF}
  543.  
  544. {   Added Constants for TFilter Type   }
  545. const
  546.   EdgeFilter: TFilter = ((-1, -1, -1), (-1, 8, -1), (-1, -1, -1));
  547.   StrongOutlineFilter: TFilter = ((-100, 0, 0), (0, 0, 0), (0, 0, 100));
  548.   Enhance3DFilter: TFilter = ((-100, 5, 5), (5, 5, 5), (5, 5, 100));
  549.   LinearFilter: TFilter = ((-40, -40, -40), (-40, 255, -40), (-40, -40, -40));
  550.   GranularFilter: TFilter = ((-20, 5, 20), (5, -10, 5), (100, 5, -100));
  551.   SharpFilter: TFilter = ((-2, -2, -2), (-2, 20, -2), (-2, -2, -2));
  552. {   End of constants   }
  553.  
  554. {   Added Constants for DXFusion Type   }
  555. const
  556.   { 3x3 Matrix Presets. }
  557.   msEmboss: TMatrixSetting = (-1, -1, 0, -1, 6, 1, 0, 1, 1, 6);
  558.   msHardEmboss: TMatrixSetting = (-4, -2, -1, -2, 10, 2, -1, 2, 4, 8);
  559.   msBlur: TMatrixSetting = (1, 2, 1, 2, 4, 2, 1, 2, 1, 16);
  560.   msSharpen: TMatrixSetting = (-1, -1, -1, -1, 15, -1, -1, -1, -1, 7);
  561.   msEdgeDetect: TMatrixSetting = (-1, -1, -1, -1, 8, -1, -1, -1, -1, 1);
  562.  
  563. {Proportionaly scale of size, for recountin image sizes}
  564. function GetScale(SourceWidth, SourceHeight, TargetWidth, TargetHeight: Integer): Single; {$IFDEF VER9UP}inline;{$ENDIF}
  565.  
  566. procedure MakeDib(out DIB: TDIB; const iWidth, iHeight, iBitCount: Integer; iFillColor: TColor{$IFDEF VER4UP} = clBlack{$ENDIF}); {$IFDEF VER4UP}overload; {$ENDIF}
  567. procedure{$IFDEF VER4UP}MakeDib{$ELSE}MakeDIB2{$ENDIF}(out DIB: TDIB; iBitmap: TBitmap); {$IFDEF VER4UP}overload; {$ENDIF}
  568.  
  569. implementation
  570.  
  571. uses DXConsts, {$IFDEF PNG_GRAPHICS}pngimage,{$ENDIF} jpeg;
  572.  
  573. function GetScale(SourceWidth, SourceHeight, TargetWidth, TargetHeight: Integer): Single;
  574. var
  575.   XScale, YScale: Single;
  576. begin
  577.   XScale := 1;
  578.   YScale := 1;
  579.   if TargetWidth < SourceWidth then
  580.     XScale := TargetWidth / SourceWidth;
  581.   if TargetHeight < SourceHeight then
  582.     YScale := TargetHeight / SourceHeight;
  583.   Result := XScale;
  584.   if YScale < Result then
  585.     Result := YScale;
  586. end;
  587.  
  588. {$IFNDEF VER4UP}
  589. function Max(B1, B2: Integer): Integer;
  590. begin
  591.   if B1 >= B2 then Result := B1 else Result := B2;
  592. end;
  593.  
  594. function Min(B1, B2: Integer): Integer;
  595. begin
  596.   if B1 <= B2 then Result := B1 else Result := B2;
  597. end;
  598. {$ENDIF}
  599.  
  600. function DSin(const C: TOC): Single; {$IFDEF VER9UP}inline; {$ENDIF}
  601. begin
  602.   Result := sin(((c * 360) / 511) * Pi / 180);
  603. end;
  604.  
  605. function DCos(const C: TOC): Single; {$IFDEF VER9UP}inline; {$ENDIF}
  606. begin
  607.   Result := cos(((c * 360) / 511) * Pi / 180);
  608. end;
  609.  
  610. function MakeDIBPixelFormat(RBitCount, GBitCount, BBitCount: Integer): TDIBPixelFormat;
  611. begin
  612.   Result.RBitMask := ((1 shl RBitCount) - 1) shl (GBitCount + BBitCount);
  613.   Result.GBitMask := ((1 shl GBitCount) - 1) shl (BBitCount);
  614.   Result.BBitMask := (1 shl BBitCount) - 1;
  615.   Result.RBitCount := RBitCount;
  616.   Result.GBitCount := GBitCount;
  617.   Result.BBitCount := BBitCount;
  618.   Result.RBitCount2 := 8 - RBitCount;
  619.   Result.GBitCount2 := 8 - GBitCount;
  620.   Result.BBitCount2 := 8 - BBitCount;
  621.   Result.RShift := (GBitCount + BBitCount) - (8 - RBitCount);
  622.   Result.GShift := BBitCount - (8 - GBitCount);
  623.   Result.BShift := 8 - BBitCount;
  624. end;
  625.  
  626. function GetBitCount(b: Integer): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
  627. var
  628.   i: Integer;
  629. begin
  630.   i := 0;
  631.   while (i < 31) and (((1 shl i) and b) = 0) do Inc(i);
  632.  
  633.   Result := 0;
  634.   while ((1 shl i) and b) <> 0 do
  635.   begin
  636.     Inc(i);
  637.     Inc(Result);
  638.   end;
  639. end;
  640.  
  641. function MakeDIBPixelFormatMask(RBitMask, GBitMask, BBitMask: Integer): TDIBPixelFormat;
  642. begin
  643.   Result := MakeDIBPixelFormat(GetBitCount(RBitMask), GetBitCount(GBitMask),
  644.     GetBitCount(BBitMask));
  645. end;
  646.  
  647. function pfRGB(const PixelFormat: TDIBPixelFormat; R, G, B: Byte): DWORD;
  648. begin
  649.   with PixelFormat do
  650.     Result := ((R shl RShift) and RBitMask) or ((G shl GShift) and GBitMask) or
  651.       ((B shr BShift) and BBitMask);
  652. end;
  653.  
  654. procedure pfGetRGB(const PixelFormat: TDIBPixelFormat; Color: DWORD; var R, G, B: Byte);
  655. begin
  656.   with PixelFormat do
  657.   begin
  658.     R := (Color and RBitMask) shr RShift;
  659.     R := R or (R shr RBitCount2);
  660.     G := (Color and GBitMask) shr GShift;
  661.     G := G or (G shr GBitCount2);
  662.     B := (Color and BBitMask) shl BShift;
  663.     B := B or (B shr BBitCount2);
  664.   end;
  665. end;
  666.  
  667. function pfGetRValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte;
  668. begin
  669.   with PixelFormat do
  670.   begin
  671.     Result := (Color and RBitMask) shr RShift;
  672.     Result := Result or (Result shr RBitCount2);
  673.   end;
  674. end;
  675.  
  676. function pfGetGValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte;
  677. begin
  678.   with PixelFormat do
  679.   begin
  680.     Result := (Color and GBitMask) shr GShift;
  681.     Result := Result or (Result shr GBitCount2);
  682.   end;
  683. end;
  684.  
  685. function pfGetBValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte;
  686. begin
  687.   with PixelFormat do
  688.   begin
  689.     Result := (Color and BBitMask) shl BShift;
  690.     Result := Result or (Result shr BBitCount2);
  691.   end;
  692. end;
  693.  
  694. function GreyscaleColorTable: TRGBQuads;
  695. var
  696.   i: Integer;
  697. begin
  698.   for i := 0 to 255 do
  699.     with Result[i] do
  700.     begin
  701.       rgbRed := i;
  702.       rgbGreen := i;
  703.       rgbBlue := i;
  704.       rgbReserved := 0;
  705.     end;
  706. end;
  707.  
  708. function RGBQuad(R, G, B: Byte): TRGBQuad;
  709. begin
  710.   with Result do
  711.   begin
  712.     rgbRed := R;
  713.     rgbGreen := G;
  714.     rgbBlue := B;
  715.     rgbReserved := 0;
  716.   end;
  717. end;
  718.  
  719. function PaletteEntryToRGBQuad(const Entry: TPaletteEntry): TRGBQuad;
  720. begin
  721.   with Result do
  722.     with Entry do
  723.     begin
  724.       rgbRed := peRed;
  725.       rgbGreen := peGreen;
  726.       rgbBlue := peBlue;
  727.       rgbReserved := 0;
  728.     end;
  729. end;
  730.  
  731. function PaletteEntriesToRGBQuads(const Entries: TPaletteEntries): TRGBQuads;
  732. var
  733.   i: Integer;
  734. begin
  735.   for i := 0 to 255 do
  736.     Result[i] := PaletteEntryToRGBQuad(Entries[i]);
  737. end;
  738.  
  739. function RGBQuadToPaletteEntry(const RGBQuad: TRGBQuad): TPaletteEntry;
  740. begin
  741.   with Result do
  742.     with RGBQuad do
  743.     begin
  744.       peRed := rgbRed;
  745.       peGreen := rgbGreen;
  746.       peBlue := rgbBlue;
  747.       peFlags := 0;
  748.     end;
  749. end;
  750.  
  751. function RGBQuadsToPaletteEntries(const RGBQuads: TRGBQuads): TPaletteEntries;
  752. var
  753.   i: Integer;
  754. begin
  755.   for i := 0 to 255 do
  756.     Result[i] := RGBQuadToPaletteEntry(RGBQuads[i]);
  757. end;
  758.  
  759. {  TDIBSharedImage  }
  760.  
  761. type
  762.   PLocalDIBPixelFormat = ^TLocalDIBPixelFormat;
  763.   TLocalDIBPixelFormat = packed record
  764.     RBitMask, GBitMask, BBitMask: DWORD;
  765.   end;
  766.  
  767.   {  TPaletteItem  }
  768.  
  769.   TPaletteItem = class(TCollectionItem)
  770.   private
  771.     ID: Integer;
  772.     Palette: HPalette;
  773.     RefCount: Integer;
  774.     ColorTable: TRGBQuads;
  775.     ColorTableCount: Integer;
  776.     destructor Destroy; override;
  777.     procedure AddRef;
  778.     procedure Release; {$IFDEF VER17UP}reintroduce;{$ENDIF}
  779.   end;
  780.  
  781.   {  TPaletteManager  }
  782.  
  783.   TPaletteManager = class
  784.   private
  785.     FList: TCollection;
  786.     constructor Create;
  787.     destructor Destroy; override;
  788.     function CreatePalette(const ColorTable: TRGBQuads; ColorTableCount: Integer): HPalette;
  789.     procedure DeletePalette(var Palette: HPalette);
  790.   end;
  791.  
  792. {  TPaletteItem  }
  793.  
  794. destructor TPaletteItem.Destroy;
  795. begin
  796.   DeleteObject(Palette);
  797.   inherited Destroy;
  798. end;
  799.  
  800. procedure TPaletteItem.AddRef;
  801. begin
  802.   Inc(RefCount);
  803. end;
  804.  
  805. procedure TPaletteItem.Release;
  806. begin
  807.   Dec(RefCount);
  808.   if RefCount <= 0 then Free;
  809. end;
  810.  
  811. {  TPaletteManager  }
  812.  
  813. constructor TPaletteManager.Create;
  814. begin
  815.   inherited Create;
  816.   FList := TCollection.Create(TPaletteItem);
  817. end;
  818.  
  819. destructor TPaletteManager.Destroy;
  820. begin
  821.   FList.Free;
  822.   inherited Destroy;
  823. end;
  824.  
  825. function TPaletteManager.CreatePalette(const ColorTable: TRGBQuads; ColorTableCount: Integer): HPalette;
  826. type
  827.   TMyLogPalette = record
  828.     palVersion: Word;
  829.     palNumEntries: Word;
  830.     palPalEntry: TPaletteEntries;
  831.   end;
  832. var
  833.   i, ID: Integer;
  834.   Item: TPaletteItem;
  835.   LogPalette: TMyLogPalette;
  836. begin
  837.   {  Hash key making  }
  838.   ID := ColorTableCount;
  839.   for i := 0 to ColorTableCount - 1 do
  840.     with ColorTable[i] do
  841.     begin
  842.       Inc(ID, rgbRed);
  843.       Inc(ID, rgbGreen);
  844.       Inc(ID, rgbBlue);
  845.     end;
  846.  
  847.   {  Does the same palette already exist?  }
  848.   for i := 0 to FList.Count - 1 do
  849.   begin
  850.     Item := TPaletteItem(FList.Items[i]);
  851.     if (Item.ID = ID) and (Item.ColorTableCount = ColorTableCount) and
  852.       CompareMem(@Item.ColorTable, @ColorTable, ColorTableCount * SizeOf(TRGBQuad)) then
  853.     begin
  854.       Item.AddRef; Result := Item.Palette;
  855.       Exit;
  856.     end;
  857.   end;
  858.  
  859.   {  New palette making  }
  860.   Item := TPaletteItem.Create(FList);
  861.   Item.ID := ID;
  862.   Move(ColorTable, Item.ColorTable, ColorTableCount * SizeOf(TRGBQuad));
  863.   Item.ColorTableCount := ColorTableCount;
  864.  
  865.   with LogPalette do
  866.   begin
  867.     palVersion := $300;
  868.     palNumEntries := ColorTableCount;
  869.     palPalEntry := RGBQuadsToPaletteEntries(ColorTable);
  870.   end;
  871.  
  872.   Item.Palette := Windows.CreatePalette(PLogPalette(@LogPalette)^);
  873.   Item.AddRef; Result := Item.Palette;
  874. end;
  875.  
  876. procedure TPaletteManager.DeletePalette(var Palette: HPalette);
  877. var
  878.   i: Integer;
  879.   Item: TPaletteItem;
  880. begin
  881.   if Palette = 0 then Exit;
  882.  
  883.   for i := 0 to FList.Count - 1 do
  884.   begin
  885.     Item := TPaletteItem(FList.Items[i]);
  886.     if (Item.Palette = Palette) then
  887.     begin
  888.       Palette := 0;
  889.       Item.Release;
  890.       Exit;
  891.     end;
  892.   end;
  893. end;
  894.  
  895. var
  896.   FPaletteManager: TPaletteManager;
  897.  
  898. function PaletteManager: TPaletteManager;
  899. begin
  900.   if FPaletteManager = nil then
  901.     FPaletteManager := TPaletteManager.Create;
  902.   Result := FPaletteManager;
  903. end;
  904.  
  905. {  TDIBSharedImage  }
  906.  
  907. constructor TDIBSharedImage.Create;
  908. begin
  909.   inherited Create;
  910.   FMemoryImage := True;
  911.   SetColorTable(GreyscaleColorTable);
  912.   FColorTable := GreyscaleColorTable;
  913.   FPixelFormat := MakeDIBPixelFormat(8, 8, 8);
  914. end;
  915.  
  916. procedure TDIBSharedImage.NewImage(AWidth, AHeight, ABitCount: Integer;
  917.   const PixelFormat: TDIBPixelFormat; const ColorTable: TRGBQuads; MemoryImage, Compressed: Boolean);
  918. var
  919.   InfoOfs: Integer;
  920.   UsePixelFormat: Boolean;
  921. begin
  922.   {$IFNDEF D17UP}
  923.   {self recreation is not allowed here}
  924.   Create;
  925.   {$ENDIF}
  926.   {  Pixel format check  }
  927.   case ABitCount of
  928.     1: if not ((PixelFormat.RBitMask = $FF0000) and (PixelFormat.GBitMask = $00FF00) and (PixelFormat.BBitMask = $0000FF)) then
  929.         raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
  930.     4: if not ((PixelFormat.RBitMask = $FF0000) and (PixelFormat.GBitMask = $00FF00) and (PixelFormat.BBitMask = $0000FF)) then
  931.         raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
  932.     8: if not ((PixelFormat.RBitMask = $FF0000) and (PixelFormat.GBitMask = $00FF00) and (PixelFormat.BBitMask = $0000FF)) then
  933.         raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
  934.     16:
  935.       begin
  936.         if not (((PixelFormat.RBitMask = $7C00) and (PixelFormat.GBitMask = $03E0) and (PixelFormat.BBitMask = $001F)) or
  937.           ((PixelFormat.RBitMask = $F800) and (PixelFormat.GBitMask = $07E0) and (PixelFormat.BBitMask = $001F))) then
  938.           raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
  939.       end;
  940.     24:
  941.       begin
  942.         if not ((PixelFormat.RBitMask = $FF0000) and (PixelFormat.GBitMask = $00FF00) and (PixelFormat.BBitMask = $0000FF)) then
  943.           raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
  944.       end;
  945.     32:
  946.       begin
  947.         if not ((PixelFormat.RBitMask = $FF0000) and (PixelFormat.GBitMask = $00FF00) and (PixelFormat.BBitMask = $0000FF)) then
  948.           raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
  949.       end;
  950.   else
  951.     raise EInvalidGraphicOperation.CreateFmt(SInvalidDIBBitCount, [ABitCount]);
  952.   end;
  953.  
  954.   FBitCount := ABitCount;
  955.   FHeight := AHeight;
  956.   FWidth := AWidth;
  957.   FWidthBytes := (((AWidth * ABitCount) + 31) shr 5) * 4;
  958.   FNextLine := -FWidthBytes;
  959.   FSize := FWidthBytes * FHeight;
  960.   UsePixelFormat := ABitCount in [16, 32];
  961.  
  962.   FPixelFormat := PixelFormat;
  963.  
  964.   FPaletteCount := 0;
  965.   if FBitCount <= 8 then
  966.     FPaletteCount := 1 shl FBitCount;
  967.  
  968.   FBitmapInfoSize := SizeOf(TBitmapInfoHeader);
  969.   if UsePixelFormat then
  970.     Inc(FBitmapInfoSize, SizeOf(TLocalDIBPixelFormat));
  971.   Inc(FBitmapInfoSize, SizeOf(TRGBQuad) * FPaletteCount);
  972.  
  973.   GetMem(FBitmapInfo, FBitmapInfoSize);
  974.   FillChar(FBitmapInfo^, FBitmapInfoSize, 0);
  975.  
  976.   {  BitmapInfo setting.  }
  977.   with FBitmapInfo^.bmiHeader do
  978.   begin
  979.     biSize := SizeOf(TBitmapInfoHeader);
  980.     biWidth := FWidth;
  981.     biHeight := FHeight;
  982.     biPlanes := 1;
  983.     biBitCount := FBitCount;
  984.     if UsePixelFormat then
  985.       biCompression := BI_BITFIELDS
  986.     else
  987.     begin
  988.       if (FBitCount = 4) and (Compressed) then
  989.         biCompression := BI_RLE4
  990.       else if (FBitCount = 8) and (Compressed) then
  991.         biCompression := BI_RLE8
  992.       else
  993.         biCompression := BI_RGB;
  994.     end;
  995.     biSizeImage := FSize;
  996.     biXPelsPerMeter := 0;
  997.     biYPelsPerMeter := 0;
  998.     biClrUsed := 0;
  999.     biClrImportant := 0;
  1000.   end;
  1001.   InfoOfs := SizeOf(TBitmapInfoHeader);
  1002.  
  1003.   if UsePixelFormat then
  1004.   begin
  1005.     with PLocalDIBPixelFormat(Integer(FBitmapInfo) + InfoOfs)^ do
  1006.     begin
  1007.       RBitMask := PixelFormat.RBitMask;
  1008.       GBitMask := PixelFormat.GBitMask;
  1009.       BBitMask := PixelFormat.BBitMask;
  1010.     end;
  1011.  
  1012.     Inc(InfoOfs, SizeOf(TLocalDIBPixelFormat));
  1013.   end;
  1014.  
  1015.   FColorTablePos := InfoOfs;
  1016.  
  1017.   FColorTable := ColorTable;
  1018.   Move(FColorTable, Pointer(Integer(FBitmapInfo) + FColorTablePos)^, SizeOf(TRGBQuad) * FPaletteCount);
  1019.  
  1020.   FCompressed := FBitmapInfo^.bmiHeader.biCompression in [BI_RLE4, BI_RLE8];
  1021.   FMemoryImage := MemoryImage or FCompressed;
  1022.  
  1023.   {  DIB making.  }
  1024.   if not Compressed then
  1025.   begin
  1026.     if MemoryImage then
  1027.     begin
  1028.       FPBits := Pointer(GlobalAlloc(GMEM_FIXED, FSize));
  1029.       if FPBits = nil then
  1030.         OutOfMemoryError;
  1031.     end
  1032.     else
  1033.     begin
  1034.       FDC := CreateCompatibleDC(0);
  1035.  
  1036.       FHandle := CreateDIBSection(FDC, FBitmapInfo^, DIB_RGB_COLORS, FPBits, 0, 0);
  1037.       if FHandle = 0 then
  1038.         raise EOutOfResources.CreateFmt(SCannotMade, ['DIB']);
  1039.  
  1040.       FOldHandle := SelectObject(FDC, FHandle);
  1041.     end;
  1042.   end;
  1043.  
  1044.   FTopPBits := Pointer(Integer(FPBits) + (FHeight - 1) * FWidthBytes);
  1045. end;
  1046.  
  1047. procedure TDIBSharedImage.Duplicate(Source: TDIBSharedImage; MemoryImage: Boolean);
  1048. begin
  1049.   if Source = nil then Exit; //no source
  1050.  
  1051.   if Source.FSize = 0 then
  1052.   begin
  1053.     {$IFNDEF D17UP}
  1054.     {self recreation is not allowed here}
  1055.     Create;
  1056.     {$ENDIF}
  1057.     FMemoryImage := MemoryImage;
  1058.   end
  1059.   else
  1060.   begin
  1061.     NewImage(Source.FWidth, Source.FHeight, Source.FBitCount,
  1062.       Source.FPixelFormat, Source.FColorTable, MemoryImage, Source.FCompressed);
  1063.     if FCompressed then
  1064.     begin
  1065.       FBitmapInfo.bmiHeader.biSizeImage := Source.FBitmapInfo.bmiHeader.biSizeImage;
  1066.       GetMem(FPBits, FBitmapInfo.bmiHeader.biSizeImage);
  1067.       Move(Source.FPBits^, FPBits^, FBitmapInfo.bmiHeader.biSizeImage);
  1068.     end
  1069.     else
  1070.     begin
  1071.       Move(Source.FPBits^, FPBits^, FBitmapInfo.bmiHeader.biSizeImage);
  1072.     end;
  1073.   end;
  1074. end;
  1075.  
  1076. procedure TDIBSharedImage.Compress(Source: TDIBSharedImage);
  1077.  
  1078.   procedure EncodeRLE4;
  1079.   var
  1080.     Size: Integer;
  1081.  
  1082.     function AllocByte: PByte;
  1083.     begin
  1084.       if Size mod 4096 = 0 then
  1085.         ReAllocMem(FPBits, Size + 4095);
  1086.       Result := Pointer(Integer(FPBits) + Size);
  1087.       Inc(Size);
  1088.     end;
  1089.  
  1090.   var
  1091.     B1, B2, C: Byte;
  1092.     PB1, PB2: Integer;
  1093.     Src: PByte;
  1094.     X, Y: Integer;
  1095.  
  1096.     function GetPixel(x: Integer): Integer;
  1097.     begin
  1098.       if X and 1 = 0 then
  1099.         Result := PArrayByte(Src)[X shr 1] shr 4
  1100.       else
  1101.         Result := PArrayByte(Src)[X shr 1] and $0F;
  1102.     end;
  1103.  
  1104.   begin
  1105.     Size := 0;
  1106.  
  1107.     for y := 0 to Source.FHeight - 1 do
  1108.     begin
  1109.       x := 0;
  1110.       Src := Pointer(Integer(Source.FPBits) + y * FWidthBytes);
  1111.       while x < Source.FWidth do
  1112.       begin
  1113.         if (Source.FWidth - x > 3) and (GetPixel(x) = GetPixel(x + 2)) then
  1114.         begin
  1115.           {  Encoding mode  }
  1116.           B1 := 2;
  1117.           B2 := (GetPixel(x) shl 4) or GetPixel(x + 1);
  1118.  
  1119.           Inc(x, 2);
  1120.  
  1121.           C := B2;
  1122.  
  1123.           while (x < Source.FWidth) and (C and $F = GetPixel(x)) and (B1 < 255) do
  1124.           begin
  1125.             Inc(B1);
  1126.             Inc(x);
  1127.             C := (C shr 4) or (C shl 4);
  1128.           end;
  1129.  
  1130.           AllocByte^ := B1;
  1131.           AllocByte^ := B2;
  1132.         end
  1133.         else
  1134.           if (Source.FWidth - x > 5) and ((GetPixel(x) <> GetPixel(x + 2)) or (GetPixel(x + 1) <> GetPixel(x + 3))) and
  1135.             ((GetPixel(x + 2) = GetPixel(x + 4)) and (GetPixel(x + 3) = GetPixel(x + 5))) then
  1136.           begin
  1137.           {  Encoding mode }
  1138.             AllocByte^ := 2;
  1139.             AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x + 1);
  1140.             Inc(x, 2);
  1141.           end
  1142.           else
  1143.           begin
  1144.             if (Source.FWidth - x < 4) then
  1145.             begin
  1146.             {  Encoding mode }
  1147.               while Source.FWidth - x >= 2 do
  1148.               begin
  1149.                 AllocByte^ := 2;
  1150.                 AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x + 1);
  1151.                 Inc(x, 2);
  1152.               end;
  1153.  
  1154.               if Source.FWidth - x = 1 then
  1155.               begin
  1156.                 AllocByte^ := 1;
  1157.                 AllocByte^ := GetPixel(x) shl 4;
  1158.                 Inc(x);
  1159.               end;
  1160.             end
  1161.             else
  1162.             begin
  1163.             {  Absolute mode  }
  1164.               PB1 := Size; AllocByte;
  1165.               PB2 := Size; AllocByte;
  1166.  
  1167.               B1 := 0;
  1168.               B2 := 4;
  1169.  
  1170.               AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x + 1);
  1171.               AllocByte^ := (GetPixel(x + 2) shl 4) or GetPixel(x + 3);
  1172.  
  1173.               Inc(x, 4);
  1174.  
  1175.               while (x + 1 < Source.FWidth) and (B2 < 254) do
  1176.               begin
  1177.                 if (Source.FWidth - x > 3) and (GetPixel(x) = GetPixel(x + 2)) and (GetPixel(x + 1) = GetPixel(x + 3)) then
  1178.                   Break;
  1179.  
  1180.                 AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x + 1);
  1181.                 Inc(B2, 2);
  1182.                 Inc(x, 2);
  1183.               end;
  1184.  
  1185.               PByte(Integer(FPBits) + PB1)^ := B1;
  1186.               PByte(Integer(FPBits) + PB2)^ := B2;
  1187.             end;
  1188.           end;
  1189.  
  1190.         if Size and 1 = 1 then AllocByte;
  1191.       end;
  1192.  
  1193.       {  End of line  }
  1194.       AllocByte^ := 0;
  1195.       AllocByte^ := 0;
  1196.     end;
  1197.  
  1198.     {  End of bitmap  }
  1199.     AllocByte^ := 0;
  1200.     AllocByte^ := 1;
  1201.  
  1202.     FBitmapInfo.bmiHeader.biSizeImage := Size;
  1203.     FSize := Size;
  1204.   end;
  1205.  
  1206.   procedure EncodeRLE8;
  1207.   var
  1208.     Size: Integer;
  1209.  
  1210.     function AllocByte: PByte;
  1211.     begin
  1212.       if Size mod 4096 = 0 then
  1213.         ReAllocMem(FPBits, Size + 4095);
  1214.       Result := Pointer(Integer(FPBits) + Size);
  1215.       Inc(Size);
  1216.     end;
  1217.  
  1218.   var
  1219.     B1, B2: Byte;
  1220.     PB1, PB2: Integer;
  1221.     Src: PByte;
  1222.     X, Y: Integer;
  1223.   begin
  1224.     Size := 0;
  1225.  
  1226.     for y := 0 to Source.FHeight - 1 do
  1227.     begin
  1228.       x := 0;
  1229.       Src := Pointer(Integer(Source.FPBits) + y * FWidthBytes);
  1230.       while x < Source.FWidth do
  1231.       begin
  1232.         if (Source.FWidth - x > 2) and (Src^ = PByte(Integer(Src) + 1)^) then
  1233.         begin
  1234.           {  Encoding mode  }
  1235.           B1 := 2;
  1236.           B2 := Src^;
  1237.  
  1238.           Inc(x, 2);
  1239.           Inc(Src, 2);
  1240.  
  1241.           while (x < Source.FWidth) and (Src^ = B2) and (B1 < 255) do
  1242.           begin
  1243.             Inc(B1);
  1244.             Inc(x);
  1245.             Inc(Src);
  1246.           end;
  1247.  
  1248.           AllocByte^ := B1;
  1249.           AllocByte^ := B2;
  1250.         end
  1251.         else
  1252.           if (Source.FWidth - x > 2) and (Src^ <> PByte(Integer(Src) + 1)^) and (PByte(Integer(Src) + 1)^ = PByte(Integer(Src) + 2)^) then
  1253.           begin
  1254.           {  Encoding mode }
  1255.             AllocByte^ := 1;
  1256.             AllocByte^ := Src^; Inc(Src);
  1257.             Inc(x);
  1258.           end
  1259.           else
  1260.           begin
  1261.             if (Source.FWidth - x < 4) then
  1262.             begin
  1263.             {  Encoding mode }
  1264.               if Source.FWidth - x = 2 then
  1265.               begin
  1266.                 AllocByte^ := 1;
  1267.                 AllocByte^ := Src^; Inc(Src);
  1268.  
  1269.                 AllocByte^ := 1;
  1270.                 AllocByte^ := Src^; Inc(Src);
  1271.                 Inc(x, 2);
  1272.               end
  1273.               else
  1274.               begin
  1275.                 AllocByte^ := 1;
  1276.                 AllocByte^ := Src^; Inc(Src);
  1277.                 Inc(x);
  1278.               end;
  1279.             end
  1280.             else
  1281.             begin
  1282.             {  Absolute mode  }
  1283.               PB1 := Size; AllocByte;
  1284.               PB2 := Size; AllocByte;
  1285.  
  1286.               B1 := 0;
  1287.               B2 := 3;
  1288.  
  1289.               Inc(x, 3);
  1290.  
  1291.               AllocByte^ := Src^; Inc(Src);
  1292.               AllocByte^ := Src^; Inc(Src);
  1293.               AllocByte^ := Src^; Inc(Src);
  1294.  
  1295.               while (x < Source.FWidth) and (B2 < 255) do
  1296.               begin
  1297.                 if (Source.FWidth - x > 3) and (Src^ = PByte(Integer(Src) + 1)^) and (Src^ = PByte(Integer(Src) + 2)^) and (Src^ = PByte(Integer(Src) + 3)^) then
  1298.                   Break;
  1299.  
  1300.                 AllocByte^ := Src^; Inc(Src);
  1301.                 Inc(B2);
  1302.                 Inc(x);
  1303.               end;
  1304.  
  1305.               PByte(Integer(FPBits) + PB1)^ := B1;
  1306.               PByte(Integer(FPBits) + PB2)^ := B2;
  1307.             end;
  1308.           end;
  1309.  
  1310.         if Size and 1 = 1 then AllocByte;
  1311.       end;
  1312.  
  1313.       {  End of line  }
  1314.       AllocByte^ := 0;
  1315.       AllocByte^ := 0;
  1316.     end;
  1317.  
  1318.     {  End of bitmap  }
  1319.     AllocByte^ := 0;
  1320.     AllocByte^ := 1;
  1321.  
  1322.     FBitmapInfo.bmiHeader.biSizeImage := Size;
  1323.     FSize := Size;
  1324.   end;
  1325.  
  1326. begin
  1327.   if Source.FCompressed then
  1328.     Duplicate(Source, Source.FMemoryImage)
  1329.   else
  1330.   begin
  1331.     NewImage(Source.FWidth, Source.FHeight, Source.FBitCount,
  1332.       Source.FPixelFormat, Source.FColorTable, True, True);
  1333.     case FBitmapInfo.bmiHeader.biCompression of
  1334.       BI_RLE4: EncodeRLE4;
  1335.       BI_RLE8: EncodeRLE8;
  1336.     else
  1337.       Duplicate(Source, Source.FMemoryImage);
  1338.     end;
  1339.   end;
  1340. end;
  1341.  
  1342. procedure TDIBSharedImage.Decompress(Source: TDIBSharedImage; MemoryImage: Boolean);
  1343.  
  1344.   procedure DecodeRLE4;
  1345.   var
  1346.     B1, B2, C: Byte;
  1347.     Dest, Src, P: PByte;
  1348.     X, Y, i: Integer;
  1349.   begin
  1350.     Src := Source.FPBits;
  1351.     X := 0;
  1352.     Y := 0;
  1353.  
  1354.     while True do
  1355.     begin
  1356.       B1 := Src^; Inc(Src);
  1357.       B2 := Src^; Inc(Src);
  1358.  
  1359.       if B1 = 0 then
  1360.       begin
  1361.         case B2 of
  1362.           0: begin {  End of line  }
  1363.               X := 0;
  1364.               Inc(Y);
  1365.             end;
  1366.           1: Break; {  End of bitmap  }
  1367.           2: begin {  Difference of coordinates  }
  1368.               Inc(X, B1);
  1369.               Inc(Y, B2); Inc(Src, 2);
  1370.             end;
  1371.         else
  1372.           {  Absolute mode  }
  1373.           Dest := Pointer(Longint(FPBits) + Y * FWidthBytes);
  1374.  
  1375.           C := 0;
  1376.           for i := 0 to B2 - 1 do
  1377.           begin
  1378.             if i and 1 = 0 then
  1379.             begin
  1380.               C := Src^; Inc(Src);
  1381.             end
  1382.             else
  1383.             begin
  1384.               C := C shl 4;
  1385.             end;
  1386.  
  1387.             P := Pointer(Integer(Dest) + X shr 1);
  1388.             if X and 1 = 0 then
  1389.               P^ := (P^ and $0F) or (C and $F0)
  1390.             else
  1391.               P^ := (P^ and $F0) or ((C and $F0) shr 4);
  1392.  
  1393.             Inc(X);
  1394.           end;
  1395.         end;
  1396.       end
  1397.       else
  1398.       begin
  1399.         {  Encoding mode  }
  1400.         Dest := Pointer(Longint(FPBits) + Y * FWidthBytes);
  1401.  
  1402.         for i := 0 to B1 - 1 do
  1403.         begin
  1404.           P := Pointer(Integer(Dest) + X shr 1);
  1405.           if X and 1 = 0 then
  1406.             P^ := (P^ and $0F) or (B2 and $F0)
  1407.           else
  1408.             P^ := (P^ and $F0) or ((B2 and $F0) shr 4);
  1409.  
  1410.           Inc(X);
  1411.  
  1412.           // Swap nibble
  1413.           B2 := (B2 shr 4) or (B2 shl 4);
  1414.         end;
  1415.       end;
  1416.  
  1417.       {  Word arrangement  }
  1418.       Inc(Src, Longint(Src) and 1);
  1419.     end;
  1420.   end;
  1421.  
  1422.   procedure DecodeRLE8;
  1423.   var
  1424.     B1, B2: Byte;
  1425.     Dest, Src: PByte;
  1426.     X, Y: Integer;
  1427.   begin
  1428.     Dest := FPBits;
  1429.     Src := Source.FPBits;
  1430.     X := 0;
  1431.     Y := 0;
  1432.  
  1433.     while True do
  1434.     begin
  1435.       B1 := Src^; Inc(Src);
  1436.       B2 := Src^; Inc(Src);
  1437.  
  1438.       if B1 = 0 then
  1439.       begin
  1440.         case B2 of
  1441.           0: begin {  End of line  }
  1442.               X := 0; Inc(Y);
  1443.               Dest := Pointer(Longint(FPBits) + Y * FWidthBytes + X);
  1444.             end;
  1445.           1: Break; {  End of bitmap  }
  1446.           2: begin {  Difference of coordinates  }
  1447.               Inc(X, B1); Inc(Y, B2); Inc(Src, 2);
  1448.               Dest := Pointer(Longint(FPBits) + Y * FWidthBytes + X);
  1449.             end;
  1450.         else
  1451.           {  Absolute mode  }
  1452.           Move(Src^, Dest^, B2); Inc(Dest, B2); Inc(Src, B2);
  1453.         end;
  1454.       end
  1455.       else
  1456.       begin
  1457.         {  Encoding mode  }
  1458.         FillChar(Dest^, B1, B2); Inc(Dest, B1);
  1459.       end;
  1460.  
  1461.       {  Word arrangement  }
  1462.       Inc(Src, Longint(Src) and 1);
  1463.     end;
  1464.   end;
  1465.  
  1466. begin
  1467.   if not Source.FCompressed then
  1468.     Duplicate(Source, MemoryImage)
  1469.   else
  1470.   begin
  1471.     NewImage(Source.FWidth, Source.FHeight, Source.FBitCount,
  1472.       Source.FPixelFormat, Source.FColorTable, MemoryImage, False);
  1473.     case Source.FBitmapInfo.bmiHeader.biCompression of
  1474.       BI_RLE4: DecodeRLE4;
  1475.       BI_RLE8: DecodeRLE8;
  1476.     else
  1477.       Duplicate(Source, MemoryImage);
  1478.     end;
  1479.   end;
  1480. end;
  1481.  
  1482. procedure TDIBSharedImage.ReadData(Stream: TStream; MemoryImage: Boolean);
  1483. var
  1484.   BI: TBitmapInfoHeader;
  1485.   BC: TBitmapCoreHeader;
  1486.   BCRGB: array[0..255] of TRGBTriple;
  1487.  
  1488.   procedure LoadRLE4;
  1489.   begin
  1490.     FSize := BI.biSizeImage;
  1491.     //GetMem(FPBits, FSize);
  1492.     FPBits := GlobalAllocPtr(GMEM_FIXED, FSize);
  1493.     FBitmapInfo.bmiHeader.biSizeImage := FSize;
  1494.     Stream.ReadBuffer(FPBits^, FSize);
  1495.   end;
  1496.  
  1497.   procedure LoadRLE8;
  1498.   begin
  1499.     FSize := BI.biSizeImage;
  1500.     //GetMem(FPBits, FSize);
  1501.     FPBits := GlobalAllocPtr(GMEM_FIXED, FSize);
  1502.     FBitmapInfo.bmiHeader.biSizeImage := FSize;
  1503.     Stream.ReadBuffer(FPBits^, FSize);
  1504.   end;
  1505.  
  1506.   procedure LoadRGB;
  1507.   var
  1508.     y: Integer;
  1509.   begin
  1510.     if BI.biHeight < 0 then
  1511.     begin
  1512.       for y := 0 to Abs(BI.biHeight) - 1 do
  1513.         Stream.ReadBuffer(Pointer(Integer(FTopPBits) + y * FNextLine)^, FWidthBytes);
  1514.     end
  1515.     else
  1516.     begin
  1517.       Stream.ReadBuffer(FPBits^, FSize);
  1518.     end;
  1519.   end;
  1520.  
  1521. var
  1522.   i, PalCount: Integer;
  1523.   OS2: Boolean;
  1524.   Localpf: TLocalDIBPixelFormat;
  1525.   AColorTable: TRGBQuads;
  1526.   APixelFormat: TDIBPixelFormat;
  1527. begin
  1528.   if not Assigned(Stream) then Exit;
  1529.  
  1530.   {  Header size reading  }
  1531.   i := Stream.Read(BI.biSize, 4);
  1532.  
  1533.   if i = 0 then
  1534.   begin
  1535.     {$IFNDEF D17UP}
  1536.     {self recreation is not allowed here}
  1537.     Create;
  1538.     {$ENDIF}
  1539.     Exit;
  1540.   end;
  1541.   if i <> 4 then
  1542.     raise EInvalidGraphic.Create(SInvalidDIB);
  1543.  
  1544.   {  Kind check of DIB  }
  1545.   OS2 := False;
  1546.  
  1547.   case BI.biSize of
  1548.     SizeOf(TBitmapCoreHeader):
  1549.       begin
  1550.         {  OS/2 type  }
  1551.         Stream.ReadBuffer(Pointer(Integer(@BC) + 4)^, SizeOf(TBitmapCoreHeader) - 4);
  1552.  
  1553.         with BI do
  1554.         begin
  1555.           biClrUsed := 0;
  1556.           biCompression := BI_RGB;
  1557.           biBitCount := BC.bcBitCount;
  1558.           biHeight := BC.bcHeight;
  1559.           biWidth := BC.bcWidth;
  1560.         end;
  1561.  
  1562.         OS2 := True;
  1563.       end;
  1564.     SizeOf(TBitmapInfoHeader):
  1565.       begin
  1566.         {  Windows type  }
  1567.         Stream.ReadBuffer(Pointer(Integer(@BI) + 4)^, SizeOf(TBitmapInfoHeader) - 4);
  1568.       end;
  1569.   else
  1570.     raise EInvalidGraphic.Create(SInvalidDIB);
  1571.   end;
  1572.  
  1573.   {  Bit mask reading.  }
  1574.   if BI.biCompression = BI_BITFIELDS then
  1575.   begin
  1576.     Stream.ReadBuffer(Localpf, SizeOf(Localpf));
  1577.     with Localpf do
  1578.       APixelFormat := MakeDIBPixelFormatMask(RBitMask, GBitMask, BBitMask);
  1579.   end
  1580.   else
  1581.   begin
  1582.     if BI.biBitCount = 16 then
  1583.       APixelFormat := MakeDIBPixelFormat(5, 5, 5)
  1584.     else if BI.biBitCount = 32 then
  1585.       APixelFormat := MakeDIBPixelFormat(8, 8, 8)
  1586.     else
  1587.       APixelFormat := MakeDIBPixelFormat(8, 8, 8);
  1588.   end;
  1589.  
  1590.     {  Palette reading  }
  1591.   PalCount := BI.biClrUsed;
  1592.   if (PalCount = 0) and (BI.biBitCount <= 8) then
  1593.     PalCount := 1 shl BI.biBitCount;
  1594.   if PalCount > 256 then PalCount := 256;
  1595.  
  1596.   FillChar(AColorTable, SizeOf(AColorTable), 0);
  1597.  
  1598.   if OS2 then
  1599.   begin
  1600.     {  OS/2 type  }
  1601.     Stream.ReadBuffer(BCRGB, SizeOf(TRGBTriple) * PalCount);
  1602.     for i := 0 to PalCount - 1 do
  1603.     begin
  1604.       with BCRGB[i] do
  1605.         AColorTable[i] := RGBQuad(rgbtRed, rgbtGreen, rgbtBlue);
  1606.     end;
  1607.   end
  1608.   else
  1609.   begin
  1610.     {  Windows type  }
  1611.     Stream.ReadBuffer(AColorTable, SizeOf(TRGBQuad) * PalCount);
  1612.   end;
  1613.  
  1614.   {  DIB compilation  }
  1615.   NewImage(BI.biWidth, Abs(BI.biHeight), BI.biBitCount, APixelFormat, AColorTable,
  1616.     MemoryImage, BI.biCompression in [BI_RLE4, BI_RLE8]);
  1617.  
  1618.   {  Pixel data reading  }
  1619.   case BI.biCompression of
  1620.     BI_RGB: LoadRGB;
  1621.     BI_RLE4: LoadRLE4;
  1622.     BI_RLE8: LoadRLE8;
  1623.     BI_BITFIELDS: LoadRGB;
  1624.   else
  1625.     raise EInvalidGraphic.Create(SInvalidDIB);
  1626.   end;
  1627. end;
  1628.  
  1629. destructor TDIBSharedImage.Destroy;
  1630. begin
  1631.   if FHandle <> 0 then
  1632.   begin
  1633.     if FOldHandle <> 0 then SelectObject(FDC, FOldHandle);
  1634.     DeleteObject(FHandle);
  1635.   end
  1636.   else
  1637. //    GlobalFree(THandle(FPBits));
  1638.   begin
  1639.     if FPBits <> nil then
  1640.       GlobalFreePtr(FPBits);
  1641.   end;
  1642.  
  1643.   PaletteManager.DeletePalette(FPalette);
  1644.   if FDC <> 0 then DeleteDC(FDC);
  1645.  
  1646.   FreeMem(FBitmapInfo);
  1647.   inherited Destroy;
  1648. end;
  1649.  
  1650. procedure TDIBSharedImage.FreeHandle;
  1651. begin
  1652. end;
  1653.  
  1654. function TDIBSharedImage.GetPalette: THandle;
  1655. begin
  1656.   if FPaletteCount > 0 then
  1657.   begin
  1658.     if FChangePalette then
  1659.     begin
  1660.       FChangePalette := False;
  1661.       PaletteManager.DeletePalette(FPalette);
  1662.       FPalette := PaletteManager.CreatePalette(FColorTable, FPaletteCount);
  1663.     end;
  1664.     Result := FPalette;
  1665.   end else
  1666.     Result := 0;
  1667. end;
  1668.  
  1669. procedure TDIBSharedImage.SetColorTable(const Value: TRGBQuads);
  1670. begin
  1671.   FColorTable := Value;
  1672.   FChangePalette := True;
  1673.  
  1674.   if (FSize > 0) and (FPaletteCount > 0) then
  1675.   begin
  1676.     SetDIBColorTable(FDC, 0, 256, FColorTable);
  1677.     Move(FColorTable, Pointer(Integer(FBitmapInfo) + FColorTablePos)^, SizeOf(TRGBQuad) * FPaletteCount);
  1678.   end;
  1679. end;
  1680.  
  1681. { TDIB }
  1682.  
  1683. var
  1684.   FEmptyDIBImage: TDIBSharedImage;
  1685.  
  1686. function EmptyDIBImage: TDIBSharedImage;
  1687. begin
  1688.   if FEmptyDIBImage = nil then
  1689.   begin
  1690.     FEmptyDIBImage := TDIBSharedImage.Create;
  1691.     FEmptyDIBImage.Reference;
  1692.   end;
  1693.   Result := FEmptyDIBImage;
  1694. end;
  1695.  
  1696. constructor TDIB.Create;
  1697. begin
  1698.   inherited Create;
  1699.   SetImage(EmptyDIBImage);
  1700.  
  1701.   FFreeList := TList.Create;
  1702. end;
  1703.  
  1704. destructor TDIB.Destroy;
  1705. var
  1706.   D: TDIB;
  1707. begin
  1708.   SetImage(EmptyDIBImage);
  1709.   FCanvas.Free;
  1710.  
  1711.   while FFreeList.Count > 0 do
  1712.   try
  1713.     D := TDIB(FFreeList[0]);
  1714.     FFreeList.Remove(D);
  1715.     D.Free;
  1716.   except
  1717.   end;
  1718.   FFreeList.Free;
  1719.  
  1720.   inherited Destroy;
  1721. end;
  1722.  
  1723. procedure TDIB.Assign(Source: TPersistent);
  1724.  
  1725.   procedure AssignBitmap(Source: TBitmap);
  1726.   var
  1727.     Data: array[0..1023] of Byte;
  1728.     BitmapRec: Windows.PBitmap;
  1729.     DIBSectionRec: PDIBSection;
  1730.     PaletteEntries: TPaletteEntries;
  1731.   begin
  1732.     GetPaletteEntries(Source.Palette, 0, 256, PaletteEntries);
  1733.     ColorTable := PaletteEntriesToRGBQuads(PaletteEntries);
  1734.     UpdatePalette;
  1735.  
  1736.     case GetObject(Source.Handle, SizeOf(Data), @Data) of
  1737.       SizeOf(Windows.TBitmap):
  1738.         begin
  1739.           BitmapRec := @Data;
  1740.           case BitmapRec^.bmBitsPixel of
  1741.             16: PixelFormat := MakeDIBPixelFormat(5, 5, 5);
  1742.           else
  1743.             PixelFormat := MakeDIBPixelFormat(8, 8, 8);
  1744.           end;
  1745.           SetSize(BitmapRec^.bmWidth, BitmapRec^.bmHeight, BitmapRec^.bmBitsPixel);
  1746.         end;
  1747.       SizeOf(TDIBSection):
  1748.         begin
  1749.           DIBSectionRec := @Data;
  1750.           if DIBSectionRec^.dsBm.bmBitsPixel >= 24 then
  1751.           begin
  1752.             PixelFormat := MakeDIBPixelFormat(8, 8, 8);
  1753.           end
  1754.           else
  1755.             if DIBSectionRec^.dsBm.bmBitsPixel > 8 then
  1756.             begin
  1757.               PixelFormat := MakeDIBPixelFormatMask(DIBSectionRec^.dsBitfields[0], //correct I.Ceneff, thanks
  1758.                 DIBSectionRec^.dsBitfields[1], DIBSectionRec^.dsBitfields[2]);
  1759.             end
  1760.             else
  1761.             begin
  1762.               PixelFormat := MakeDIBPixelFormat(8, 8, 8);
  1763.             end;
  1764.           SetSize(DIBSectionRec^.dsBm.bmWidth, DIBSectionRec^.dsBm.bmHeight,
  1765.             DIBSectionRec^.dsBm.bmBitsPixel);
  1766.         end;
  1767.     else
  1768.       Exit;
  1769.     end;
  1770.  
  1771.     FillChar(PBits^, Size, 0);
  1772.     Canvas.Draw(0, 0, Source);
  1773.   end;
  1774.  
  1775.   procedure AssignGraphic(Source: TGraphic);
  1776.   {$IFDEF PNG_GRAPHICS}
  1777.   var
  1778.     alpha: TDIB;
  1779.     png: {$IFDEF VER12UP}TPngImage{$ELSE}TPNGObject{$ENDIF};
  1780.     i, j: Integer;
  1781.     q: pByteArray;
  1782.   {$ENDIF}
  1783.   begin
  1784.     {$IFDEF PNG_GRAPHICS}
  1785.     if Source is {$IFDEF VER12UP}TPngImage{$ELSE}TPNGObject{$ENDIF} then
  1786.     begin
  1787.       alpha := TDIB.Create;
  1788.       try
  1789.         {png image}
  1790.         png := {$IFDEF VER12UP}TPngImage{$ELSE}TPNGObject{$ENDIF}.Create;
  1791.         try
  1792.           png.Assign(Source);
  1793.           if png.TransparencyMode = ptmPartial then
  1794.           begin
  1795.             Alpha.SetSize(png.Width, png.Height, 8);
  1796.             {separate alpha}
  1797.             for i := 0 to png.Height - 1 do
  1798.             begin
  1799.               q := png.AlphaScanline[i];
  1800.               for j := 0 to png.Width - 1 do
  1801.                 alpha.Pixels[j,i] := q[j];
  1802.             end;
  1803.           end;
  1804.           SetSize(png.Width, png.Height, 32);
  1805.           FillChar(PBits^, Size, 0);
  1806.           Canvas.Draw(0, 0, png);
  1807.           Transparent := png.Transparent;
  1808.         finally
  1809.           png.Free;
  1810.         end;
  1811.         if not alpha.Empty then
  1812.           AssignAlphaChannel(alpha);
  1813.       finally
  1814.         alpha.Free;
  1815.       end;
  1816.     end
  1817.     else
  1818.     {$ENDIF}
  1819.     if Source is TBitmap then
  1820.       AssignBitmap(TBitmap(Source))
  1821.     else
  1822.     begin
  1823.       SetSize(Source.Width, Source.Height, 32);
  1824.       FillChar(PBits^, Size, 0);
  1825.       Canvas.Draw(0, 0, Source);
  1826.       Transparent := Source.Transparent;
  1827.       if not HasAlphaChannel then
  1828.       begin
  1829.         SetSize(Source.Width, Source.Height, 24);
  1830.         FillChar(PBits^, Size, 0);
  1831.         Canvas.Draw(0, 0, Source);
  1832.         Transparent := Source.Transparent;
  1833.       end
  1834.     end;
  1835.   end;
  1836.  
  1837. begin
  1838.   if Source = nil then
  1839.   begin
  1840.     Clear;
  1841.   end else if Source is TDIB then
  1842.   begin
  1843.     if Source <> Self then
  1844.       SetImage(TDIB(Source).FImage);
  1845.   end else if Source is TGraphic then
  1846.   begin
  1847.     AssignGraphic(TGraphic(Source));
  1848.   end else if Source is TPicture then
  1849.   begin
  1850.     if TPicture(Source).Graphic <> nil then
  1851.       AssignGraphic(TPicture(Source).Graphic)
  1852.     else
  1853.       Clear;
  1854.   end else
  1855.     inherited Assign(Source);
  1856. end;
  1857.  
  1858. procedure TDIB.Draw(ACanvas: TCanvas; const ARect: TRect);
  1859. var
  1860.   OldPalette: HPalette;
  1861.   OldMode: Integer;
  1862. begin
  1863.   if Size > 0 then
  1864.   begin
  1865.     if PaletteCount > 0 then
  1866.     begin
  1867.       OldPalette := SelectPalette(ACanvas.Handle, Palette, False);
  1868.       RealizePalette(ACanvas.Handle);
  1869.     end
  1870.     else
  1871.       OldPalette := 0;
  1872.     try
  1873.       OldMode := SetStretchBltMode(ACanvas.Handle, COLORONCOLOR);
  1874.       try
  1875.         GdiFlush;
  1876.         if FImage.FMemoryImage then
  1877.         begin
  1878.           with ARect do
  1879.           begin
  1880.             if StretchDIBits(ACanvas.Handle, Left, Top, Right - Left, Bottom - Top,
  1881.               0, 0, Self.Width, Self.Height, FImage.FPBits, FImage.FBitmapInfo^, DIB_RGB_COLORS, ACanvas.CopyMode) = 0 then
  1882.                MessageBeep(1);
  1883.           end;
  1884.         end
  1885.         else
  1886.         begin
  1887.           with ARect do
  1888.             StretchBlt(ACanvas.Handle, Left, Top, Right - Left, Bottom - Top,
  1889.               FImage.FDC, 0, 0, Self.Width, Self.Height, ACanvas.CopyMode);
  1890.         end;
  1891.       finally
  1892.         SetStretchBltMode(ACanvas.Handle, OldMode);
  1893.       end;
  1894.     finally
  1895.       SelectPalette(ACanvas.Handle, OldPalette, False);
  1896.     end;
  1897.   end;
  1898. end;
  1899.  
  1900. procedure TDIB.Clear;
  1901. begin
  1902.   SetImage(EmptyDIBImage);
  1903. end;
  1904.  
  1905. procedure TDIB.CanvasChanging(Sender: TObject);
  1906. begin
  1907.   Changing(False);
  1908. end;
  1909.  
  1910. procedure TDIB.Changing(MemoryImage: Boolean);
  1911. var
  1912.   TempImage: TDIBSharedImage;
  1913. begin
  1914.   if (FImage.RefCount > 1) or (FImage.FCompressed) or ((not MemoryImage) and (FImage.FMemoryImage)) then
  1915.   begin
  1916.     TempImage := TDIBSharedImage.Create;
  1917.     try
  1918.       TempImage.Decompress(FImage, FImage.FMemoryImage and MemoryImage);
  1919.     except
  1920.       TempImage.Free;
  1921.       raise;
  1922.     end;
  1923.     SetImage(TempImage);
  1924.   end;
  1925. end;
  1926.  
  1927. procedure TDIB.AllocHandle;
  1928. var
  1929.   TempImage: TDIBSharedImage;
  1930. begin
  1931.   if FImage.FMemoryImage then
  1932.   begin
  1933.     TempImage := TDIBSharedImage.Create;
  1934.     try
  1935.       TempImage.Decompress(FImage, False);
  1936.     except
  1937.       TempImage.Free;
  1938.       raise;
  1939.     end;
  1940.     SetImage(TempImage);
  1941.   end;
  1942. end;
  1943.  
  1944. procedure TDIB.Compress;
  1945. var
  1946.   TempImage: TDIBSharedImage;
  1947. begin
  1948.   if (not FImage.FCompressed) and (BitCount in [4, 8]) then
  1949.   begin
  1950.     TempImage := TDIBSharedImage.Create;
  1951.     try
  1952.       TempImage.Compress(FImage);
  1953.     except
  1954.       TempImage.Free;
  1955.       raise;
  1956.     end;
  1957.     SetImage(TempImage);
  1958.   end;
  1959. end;
  1960.  
  1961. procedure TDIB.Decompress;
  1962. var
  1963.   TempImage: TDIBSharedImage;
  1964. begin
  1965.   if FImage.FCompressed then
  1966.   begin
  1967.     TempImage := TDIBSharedImage.Create;
  1968.     try
  1969.       TempImage.Decompress(FImage, FImage.FMemoryImage);
  1970.     except
  1971.       TempImage.Free;
  1972.       raise;
  1973.     end;
  1974.     SetImage(TempImage);
  1975.   end;
  1976. end;
  1977.  
  1978. procedure TDIB.FreeHandle;
  1979. var
  1980.   TempImage: TDIBSharedImage;
  1981. begin
  1982.   if not FImage.FMemoryImage then
  1983.   begin
  1984.     TempImage := TDIBSharedImage.Create;
  1985.     try
  1986.       TempImage.Duplicate(FImage, True);
  1987.     except
  1988.       TempImage.Free;
  1989.       raise;
  1990.     end;
  1991.     SetImage(TempImage);
  1992.   end;
  1993. end;
  1994.  
  1995. type
  1996.   PRGBA = ^TRGBA;
  1997.   TRGBA = array[0..0] of Windows.TRGBQuad;
  1998.  
  1999. function TDIB.HasAlphaChannel: Boolean;
  2000.   {give that DIB contain the alphachannel}
  2001. var
  2002.   p: PRGBA;
  2003.   X, Y: Integer;
  2004. begin
  2005.   Result := True;
  2006.   if BitCount = 32 then
  2007.     for Y := 0 to Height - 1 do
  2008.     begin
  2009.       p := ScanLine[Y];
  2010.       for X := 0 to Width - 1 do
  2011.       begin
  2012.         if p[X].rgbReserved <> $0 then Exit;
  2013.       end
  2014.     end;
  2015.   Result := False;
  2016. end;
  2017.  
  2018. function TDIB.AssignAlphaChannel(ALPHA: TDIB; ForceResize: Boolean{$IFDEF VER4UP} = False{$ENDIF}): Boolean;
  2019.   {copy alphachannel from other DIB or add from DIB8}
  2020. var
  2021.   p32_0, p32_1: PRGBA;
  2022.   p24: Pointer;
  2023.   pB: PArrayByte;
  2024.   X, Y: Integer;
  2025.   tmpDIB, qAlpha: TDIB;
  2026. begin
  2027.   Result := False;
  2028.   if GetEmpty then Exit;
  2029.   {Alphachannel can be copy into 32bit DIB only!}
  2030.   if BitCount <> 32 then
  2031.   begin
  2032.     tmpDIB := TDIB.Create;
  2033.     try
  2034.       tmpDIB.Assign(Self);
  2035.       Clear;
  2036.       SetSize(tmpDIB.Width, tmpDIB.Height, 32);
  2037.       Canvas.Draw(0, 0, tmpDIB);
  2038.     finally
  2039.       tmpDIB.Free;
  2040.     end;
  2041.   end;
  2042.   qAlpha := TDIB.Create;
  2043.   try
  2044.     if not Assigned(Alpha) then Exit;
  2045.     if ForceResize then
  2046.     begin
  2047.       {create temp}
  2048.       tmpDIB := TDIB.Create;
  2049.       try
  2050.         {picture}
  2051.         tmpDIB.Assign(ALPHA);
  2052.         {resample size}
  2053.         tmpDIB.DoResample(Width, Height, ftrBSpline);
  2054.         {convert to greyscale}
  2055.         tmpDIB.Greyscale(8);
  2056.         {return picture to qAlpha}
  2057.         qAlpha.Assign(tmpDIB);
  2058.       finally
  2059.         tmpDIB.Free;
  2060.       end;
  2061.     end
  2062.     else
  2063.       {Must be the same size!}
  2064.       if not ((Width = ALPHA.Width) and (Height = ALPHA.Height)) then Exit
  2065.       else qAlpha.Assign(ALPHA);
  2066.     {It works now with qAlpha only}
  2067.     case qAlpha.BitCount of
  2068.       24:
  2069.         begin
  2070.           for Y := 0 to Height - 1 do
  2071.           begin
  2072.             p32_0 := ScanLine[Y];
  2073.             p24 := qAlpha.ScanLine[Y];
  2074.             for X := 0 to Width - 1 do with PBGR(p24)^ do
  2075.             begin
  2076.                 p32_0[X].rgbReserved := Round(0.30 * R + 0.59 * G + 0.11 * B);
  2077.               end
  2078.           end;
  2079.         end;
  2080.       32:
  2081.         begin
  2082.           for Y := 0 to Height - 1 do
  2083.           begin
  2084.             p32_0 := ScanLine[Y];
  2085.             p32_1 := qAlpha.ScanLine[Y];
  2086.             for X := 0 to Width - 1 do
  2087.             begin
  2088.               p32_0[X].rgbReserved := p32_1[X].rgbReserved;
  2089.             end
  2090.           end;
  2091.         end;
  2092.       8:
  2093.         begin
  2094.           for Y := 0 to Height - 1 do
  2095.           begin
  2096.             p32_0 := ScanLine[Y];
  2097.             pB := qAlpha.ScanLine[Y];
  2098.             for X := 0 to Width - 1 do
  2099.             begin
  2100.               p32_0[X].rgbReserved := pB[X];
  2101.             end
  2102.           end;
  2103.         end;
  2104.       1:
  2105.         begin
  2106.           for Y := 0 to Height - 1 do
  2107.           begin
  2108.             p32_0 := ScanLine[Y];
  2109.             pB := qAlpha.ScanLine[Y];
  2110.             for X := 0 to Width - 1 do
  2111.             begin
  2112.               if pB[X] = 0 then
  2113.                 p32_0[X].rgbReserved := $FF
  2114.               else
  2115.                 p32_0[X].rgbReserved := 0
  2116.             end
  2117.           end;
  2118.         end;
  2119.     else
  2120.       Exit;
  2121.     end;
  2122.     Result := True;
  2123.   finally
  2124.     qAlpha.Free;
  2125.   end;
  2126. end;
  2127.  
  2128. procedure TDIB.RetAlphaChannel(out oDIB: TDIB);
  2129.   {Store alphachannel information into DIB8}
  2130. var
  2131.   p0: PRGBA;
  2132.   pB: PArrayByte;
  2133.   X, Y: Integer;
  2134. begin
  2135.   oDIB := nil;
  2136.   if not HasAlphaChannel then exit;
  2137.   oDIB := TDIB.Create;
  2138.   oDIB.SetSize(Width, Height, 8);
  2139.   for Y := 0 to Height - 1 do
  2140.   begin
  2141.     p0 := ScanLine[Y];
  2142.     pB := oDIB.ScanLine[Y];
  2143.     for X := 0 to Width - 1 do
  2144.     begin
  2145.       pB[X] := p0[X].rgbReserved;
  2146.     end
  2147.   end;
  2148. end;
  2149.  
  2150. function TDIB.GetBitmapInfo: PBitmapInfo;
  2151. begin
  2152.   Result := FImage.FBitmapInfo;
  2153. end;
  2154.  
  2155. function TDIB.GetBitmapInfoSize: Integer;
  2156. begin
  2157.   Result := FImage.FBitmapInfoSize;
  2158. end;
  2159.  
  2160. function TDIB.GetCanvas: TCanvas;
  2161. begin
  2162.   if (FCanvas = nil) or (FCanvas.Handle = 0) then
  2163.   begin
  2164.     AllocHandle;
  2165.  
  2166.     FCanvas := TCanvas.Create;
  2167.     FCanvas.Handle := FImage.FDC;
  2168.     FCanvas.OnChanging := CanvasChanging;
  2169.   end;
  2170.   Result := FCanvas;
  2171. end;
  2172.  
  2173. function TDIB.GetEmpty: Boolean;
  2174. begin
  2175.   Result := Size = 0;
  2176. end;
  2177.  
  2178. function TDIB.GetHandle: THandle;
  2179. begin
  2180.   Changing(True);
  2181.   Result := FImage.FHandle;
  2182. end;
  2183.  
  2184. function TDIB.GetHeight: Integer;
  2185. begin
  2186.   Result := FHeight;
  2187. end;
  2188.  
  2189. function TDIB.GetPalette: HPalette;
  2190. begin
  2191.   Result := FImage.GetPalette;
  2192. end;
  2193.  
  2194. function TDIB.GetPaletteCount: Integer;
  2195. begin
  2196.   Result := FImage.FPaletteCount;
  2197. end;
  2198.  
  2199. function TDIB.GetPBits: Pointer;
  2200. begin
  2201.   Changing(True);
  2202.  
  2203.   if not FImage.FMemoryImage then
  2204.     GDIFlush;
  2205.   Result := FPBits;
  2206. end;
  2207.  
  2208. function TDIB.GetPBitsReadOnly: Pointer;
  2209. begin
  2210.   if not FImage.FMemoryImage then
  2211.     GDIFlush;
  2212.   Result := FPBits;
  2213. end;
  2214.  
  2215. function TDIB.GetScanLine(Y: Integer): Pointer;
  2216. begin
  2217.   Changing(True);
  2218.   if (Y < 0) or (Y >= FHeight) then
  2219.     raise EInvalidGraphicOperation.CreateFmt(SScanline, [Y]);
  2220.  
  2221.   if not FImage.FMemoryImage then
  2222.     GDIFlush;
  2223.   Result := Pointer(Integer(FTopPBits) + Y * FNextLine);
  2224. end;
  2225.  
  2226. function TDIB.GetScanLineReadOnly(Y: Integer): Pointer;
  2227. begin
  2228.   if (Y < 0) or (Y >= FHeight) then
  2229.     raise EInvalidGraphicOperation.CreateFmt(SScanline, [Y]);
  2230.  
  2231.   if not FImage.FMemoryImage then
  2232.     GDIFlush;
  2233.   Result := Pointer(Integer(FTopPBits) + Y * FNextLine);
  2234. end;
  2235.  
  2236. function TDIB.GetTopPBits: Pointer;
  2237. begin
  2238.   Changing(True);
  2239.  
  2240.   if not FImage.FMemoryImage then
  2241.     GDIFlush;
  2242.   Result := FTopPBits;
  2243. end;
  2244.  
  2245. function TDIB.GetTopPBitsReadOnly: Pointer;
  2246. begin
  2247.   if not FImage.FMemoryImage then
  2248.     GDIFlush;
  2249.   Result := FTopPBits;
  2250. end;
  2251.  
  2252. function TDIB.GetWidth: Integer;
  2253. begin
  2254.   Result := FWidth;
  2255. end;
  2256.  
  2257. const
  2258.   Mask1: array[0..7] of DWORD = ($80, $40, $20, $10, $08, $04, $02, $01);
  2259.   Mask1n: array[0..7] of DWORD = ($FFFFFF7F, $FFFFFFBF, $FFFFFFDF, $FFFFFFEF,
  2260.     $FFFFFFF7, $FFFFFFFB, $FFFFFFFD, $FFFFFFFE);
  2261.   Mask4: array[0..1] of DWORD = ($F0, $0F);
  2262.   Mask4n: array[0..1] of DWORD = ($FFFFFF0F, $FFFFFFF0);
  2263.  
  2264.   Shift1: array[0..7] of DWORD = (7, 6, 5, 4, 3, 2, 1, 0);
  2265.   Shift4: array[0..1] of DWORD = (4, 0);
  2266.  
  2267. function TDIB.GetPixel(X, Y: Integer): DWORD;
  2268. begin
  2269.   Decompress;
  2270.  
  2271.   Result := 0;
  2272.   if (X >= 0) and (X < FWidth) and (Y >= 0) and (Y < FHeight) then
  2273.   begin
  2274.     case FBitCount of
  2275.       1: Result := (PArrayByte(Integer(FTopPBits) + Y * FNextLine)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7];
  2276.       4: Result := ((PArrayByte(Integer(FTopPBits) + Y * FNextLine)[X shr 1] and Mask4[X and 1]) shr Shift4[X and 1]);
  2277.       8: Result := PArrayByte(Integer(FTopPBits) + Y * FNextLine)[X];
  2278.       16: Result := PArrayWord(Integer(FTopPBits) + Y * FNextLine)[X];
  2279.       24: with PArrayBGR(Integer(FTopPBits) + Y * FNextLine)[X] do
  2280.           Result := R or (G shl 8) or (B shl 16);
  2281.       32: Result := PArrayDWord(Integer(FTopPBits) + Y * FNextLine)[X];
  2282.     end;
  2283.   end;
  2284. end;
  2285.  
  2286. function TDIB.GetRGBChannel: TDIB;
  2287.   {Store RGB channel information into DIB24}
  2288. begin
  2289.   Result := nil;
  2290.   if Self.Empty then Exit;
  2291.   Result := TDIB.Create;
  2292.   Result.SetSize(Width, Height, 24);
  2293.   Self.DrawOn(Bounds(0,0, Self.Width, Self.Height), Result.Canvas, 0, 0);
  2294.   FFreeList.Add(Result);
  2295. end;
  2296.  
  2297. procedure TDIB.SetPixel(X, Y: Integer; Value: DWORD);
  2298. var
  2299.   P: PByte;
  2300. begin
  2301.   Changing(True);
  2302.  
  2303.   if (X >= 0) and (X < FWidth) and (Y >= 0) and (Y < FHeight) then
  2304.   begin
  2305.     case FBitCount of
  2306.       1: begin
  2307.           P := @PArrayByte(Integer(FTopPBits) + Y * FNextLine)[X shr 3];
  2308.           P^ := (P^ and Mask1n[X and 7]) or ((Value and 1) shl Shift1[X and 7]);
  2309.         end;
  2310.       4: begin
  2311.           P := (@PArrayByte(Integer(FTopPBits) + Y * FNextLine)[X shr 3]);
  2312.           P^ := ((P^ and Mask4n[X and 1]) or ((Value and 15) shl Shift4[X and 1]));
  2313.         end;
  2314.       8: PArrayByte(Integer(FTopPBits) + Y * FNextLine)[X] := Value;
  2315.       16: PArrayWord(Integer(FTopPBits) + Y * FNextLine)[X] := Value;
  2316.       24: with PArrayBGR(Integer(FTopPBits) + Y * FNextLine)[X] do
  2317.         begin
  2318.           B := Byte(Value shr 16);
  2319.           G := Byte(Value shr 8);
  2320.           R := Byte(Value);
  2321.         end;
  2322.       32: PArrayDWord(Integer(FTopPBits) + Y * FNextLine)[X] := Value;
  2323.     end;
  2324.   end;
  2325. end;
  2326.  
  2327. procedure TDIB.SetRGBChannel(const Value: TDIB);
  2328. var
  2329.   alpha: TDIB;
  2330. begin
  2331.   if Self.HasAlphaChannel then
  2332.   try
  2333.     RetAlphaChannel(alpha);
  2334.     Self.SetSize(Value.Width, Value.Height, 32);
  2335.     Value.DrawOn(Bounds(0,0,Value.Width, Value.Height), Self.Canvas, 0, 0);
  2336.     Self.AssignAlphaChannel(alpha, True);
  2337.   finally
  2338.     alpha.Free;
  2339.   end
  2340.   else
  2341.     Self.Assign(Value);
  2342. end;
  2343.  
  2344. procedure TDIB.DefineProperties(Filer: TFiler);
  2345. begin
  2346.   inherited DefineProperties(Filer);
  2347.   {  For interchangeability with an old version.  }
  2348.   Filer.DefineBinaryProperty('DIB', LoadFromStream, nil, False);
  2349. end;
  2350.  
  2351. type
  2352.   {  TGlobalMemoryStream  }
  2353.  
  2354.   TGlobalMemoryStream = class(TMemoryStream)
  2355.   private
  2356.     FHandle: THandle;
  2357.   public
  2358.     constructor Create(AHandle: THandle);
  2359.     destructor Destroy; override;
  2360.   end;
  2361.  
  2362. constructor TGlobalMemoryStream.Create(AHandle: THandle);
  2363. begin
  2364.   inherited Create;
  2365.   FHandle := AHandle;
  2366.   SetPointer(GlobalLock(AHandle), GlobalSize(AHandle));
  2367. end;
  2368.  
  2369. destructor TGlobalMemoryStream.Destroy;
  2370. begin
  2371.   GlobalUnLock(FHandle);
  2372.   SetPointer(nil, 0);
  2373.   inherited Destroy;
  2374. end;
  2375.  
  2376. procedure TDIB.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  2377.   APalette: HPALETTE);
  2378. var
  2379.   Stream: TGlobalMemoryStream;
  2380. begin
  2381.   Stream := TGlobalMemoryStream.Create(AData);
  2382.   try
  2383.     ReadData(Stream);
  2384.   finally
  2385.     Stream.Free;
  2386.   end;
  2387. end;
  2388.  
  2389. const
  2390.   BitmapFileType = Ord('B') + Ord('M') * $100;
  2391.  
  2392. procedure TDIB.LoadFromStream(Stream: TStream);
  2393. var
  2394.   BF: TBitmapFileHeader;
  2395.   i: Integer;
  2396.   ImageJPEG: TJPEGImage;
  2397. begin
  2398.   {  File header reading  }
  2399.   i := Stream.Read(BF, SizeOf(TBitmapFileHeader));
  2400.   if i = 0 then Exit;
  2401.   if i <> SizeOf(TBitmapFileHeader) then
  2402.     raise EInvalidGraphic.Create(SInvalidDIB);
  2403.  
  2404.   {  Is the head jpeg ?}
  2405.  
  2406.   if BF.bfType = $D8FF then
  2407.   begin
  2408.     ImageJPEG := TJPEGImage.Create;
  2409.     try
  2410.       try
  2411.         Stream.Position := 0;
  2412.         ImageJPEG.LoadFromStream(Stream);
  2413.       except
  2414.         on EInvalidGraphic do ImageJPEG := nil;
  2415.       end;
  2416.       if ImageJPEG <> nil then
  2417.       begin
  2418.         {set size and bitcount in natural units of jpeg}
  2419.         SetSize(ImageJPEG.Width, ImageJPEG.Height, 24);
  2420.         Canvas.Draw(0, 0, ImageJPEG);
  2421.         Exit
  2422.       end;
  2423.     finally
  2424.       ImageJPEG.Free;
  2425.     end;
  2426.   end
  2427.   else
  2428.   {  Is the head 'BM'?  }
  2429.     if BF.bfType <> BitmapFileType then
  2430.       raise EInvalidGraphic.Create(SInvalidDIB);
  2431.  
  2432.   ReadData(Stream);
  2433. end;
  2434.  
  2435. procedure TDIB.ReadData(Stream: TStream);
  2436. var
  2437.   TempImage: TDIBSharedImage;
  2438. begin
  2439.   TempImage := TDIBSharedImage.Create;
  2440.   try
  2441.     TempImage.ReadData(Stream, FImage.FMemoryImage);
  2442.   except
  2443.     TempImage.Free;
  2444.     raise;
  2445.   end;
  2446.   SetImage(TempImage);
  2447. end;
  2448.  
  2449. procedure TDIB.SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  2450.   var APalette: HPALETTE);
  2451. var
  2452.   P: Pointer;
  2453.   Stream: TMemoryStream;
  2454. begin
  2455.   AFormat := CF_DIB;
  2456.   APalette := 0;
  2457.  
  2458.   Stream := TMemoryStream.Create;
  2459.   try
  2460.     WriteData(Stream);
  2461.  
  2462.     AData := GlobalAlloc(GHND, Stream.Size);
  2463.     if AData = 0 then OutOfMemoryError;
  2464.  
  2465.     P := GlobalLock(AData);
  2466.     Move(Stream.Memory^, P^, Stream.Size);
  2467.     GlobalUnLock(AData);
  2468.   finally
  2469.     Stream.Free;
  2470.   end;
  2471. end;
  2472.  
  2473. procedure TDIB.SaveToStream(Stream: TStream);
  2474. var
  2475.   BF: TBitmapFileHeader;
  2476. begin
  2477.   if Empty then Exit;
  2478.  
  2479.   with BF do
  2480.   begin
  2481.     bfType := BitmapFileType;
  2482.     bfOffBits := SizeOf(TBitmapFileHeader) + BitmapInfoSize;
  2483.     bfSize := bfOffBits + FImage.FBitmapInfo^.bmiHeader.biSizeImage;
  2484.     bfReserved1 := 0;
  2485.     bfReserved2 := 0;
  2486.   end;
  2487.   Stream.WriteBuffer(BF, SizeOf(TBitmapFileHeader));
  2488.  
  2489.   WriteData(Stream);
  2490. end;
  2491.  
  2492. procedure TDIB.WriteData(Stream: TStream);
  2493. begin
  2494.   if Empty then Exit;
  2495.  
  2496.   if not FImage.FMemoryImage then
  2497.     GDIFlush;
  2498.  
  2499.   Stream.WriteBuffer(FImage.FBitmapInfo^, FImage.FBitmapInfoSize);
  2500.   Stream.WriteBuffer(FImage.FPBits^, FImage.FBitmapInfo.bmiHeader.biSizeImage);
  2501. end;
  2502.  
  2503. procedure TDIB.SetBitCount(Value: Integer);
  2504. begin
  2505.   if Value <= 0 then
  2506.     Clear
  2507.   else
  2508.   begin
  2509.     if Empty then
  2510.     begin
  2511.       SetSize(Max(Width, 1), Max(Height, 1), Value)
  2512.     end
  2513.     else
  2514.     begin
  2515.       ConvertBitCount(Value);
  2516.     end;
  2517.   end;
  2518. end;
  2519.  
  2520. procedure TDIB.SetHeight(Value: Integer);
  2521. begin
  2522.   if Value <= 0 then
  2523.     Clear
  2524.   else
  2525.   begin
  2526.     if Empty then
  2527.       SetSize(Max(Width, 1), Value, 8)
  2528.     else
  2529.       SetSize(Width, Value, BitCount);
  2530.   end;
  2531. end;
  2532.  
  2533. procedure TDIB.SetWidth(Value: Integer);
  2534. begin
  2535.   if Value <= 0 then
  2536.     Clear
  2537.   else
  2538.   begin
  2539.     if Empty then
  2540.       SetSize(Value, Max(Height, 1), 8)
  2541.     else
  2542.       SetSize(Value, Height, BitCount);
  2543.   end;
  2544. end;
  2545.  
  2546. procedure TDIB.SetImage(Value: TDIBSharedImage);
  2547. begin
  2548.   if FImage <> Value then
  2549.   begin
  2550.     if FCanvas <> nil then
  2551.       FCanvas.Handle := 0;
  2552.  
  2553.     FImage.Release;
  2554.     FImage := Value;
  2555.     FImage.Reference;
  2556.  
  2557.     if FCanvas <> nil then
  2558.       FCanvas.Handle := FImage.FDC;
  2559.  
  2560.     ColorTable := FImage.FColorTable;
  2561.     PixelFormat := FImage.FPixelFormat;
  2562.  
  2563.     FBitCount := FImage.FBitCount;
  2564.     FHeight := FImage.FHeight;
  2565.     FNextLine := FImage.FNextLine;
  2566.     FNowPixelFormat := FImage.FPixelFormat;
  2567.     FPBits := FImage.FPBits;
  2568.     FSize := FImage.FSize;
  2569.     FTopPBits := FImage.FTopPBits;
  2570.     FWidth := FImage.FWidth;
  2571.     FWidthBytes := FImage.FWidthBytes;
  2572.   end;
  2573. end;
  2574.  
  2575. procedure TDIB.SetNowPixelFormat(const Value: TDIBPixelFormat);
  2576. var
  2577.   Temp: TDIB;
  2578. begin
  2579.   if CompareMem(@Value, @FImage.FPixelFormat, SizeOf(TDIBPixelFormat)) then exit;
  2580.  
  2581.   PixelFormat := Value;
  2582.  
  2583.   Temp := TDIB.Create;
  2584.   try
  2585.     Temp.Assign(Self);
  2586.     SetSize(Width, Height, BitCount);
  2587.     Canvas.Draw(0, 0, Temp);
  2588.   finally
  2589.     Temp.Free;
  2590.   end;
  2591. end;
  2592.  
  2593. procedure TDIB.SetPalette(Value: HPalette);
  2594. var
  2595.   PaletteEntries: TPaletteEntries;
  2596. begin
  2597.   GetPaletteEntries(Value, 0, 256, PaletteEntries);
  2598.   DeleteObject(Value);
  2599.  
  2600.   ColorTable := PaletteEntriesToRGBQuads(PaletteEntries);