Subversion Repositories spacemission

Rev

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

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