ImagingBitmap.pas 23 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804
  1. {
  2. $Id: ImagingBitmap.pas,v 1.12 2006/10/26 13:29:28 galfar Exp $
  3. Vampyre Imaging Library
  4. by Marek Mauder ([email protected])
  5. http://imaginglib.sourceforge.net
  6. The contents of this file are used with permission, subject to the Mozilla
  7. Public License Version 1.1 (the "License"); you may not use this file except
  8. in compliance with the License. You may obtain a copy of the License at
  9. http://www.mozilla.org/MPL/MPL-1.1.html
  10. Software distributed under the License is distributed on an "AS IS" basis,
  11. WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
  12. the specific language governing rights and limitations under the License.
  13. Alternatively, the contents of this file may be used under the terms of the
  14. GNU Lesser General Public License (the "LGPL License"), in which case the
  15. provisions of the LGPL License are applicable instead of those above.
  16. If you wish to allow use of your version of this file only under the terms
  17. of the LGPL License and not to allow others to use your version of this file
  18. under the MPL, indicate your decision by deleting the provisions above and
  19. replace them with the notice and other provisions required by the LGPL
  20. License. If you do not delete the provisions above, a recipient may use
  21. your version of this file under either the MPL or the LGPL License.
  22. For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
  23. }
  24. { This unit contains image format loader/saver for Windows Bitmap images.}
  25. unit ImagingBitmap;
  26. {$I ImagingOptions.inc}
  27. interface
  28. uses
  29. ImagingTypes, Imaging, ImagingUtility, ImagingFormats;
  30. type
  31. { Class for loading and saving Windows Bitmap images.
  32. It can load/save 8bit indexed, 16, 24, 32 bit RGB or ARGB
  33. images with or without RLE compression. It can also load 1/4 bit
  34. indexed images and OS2 bitmaps.}
  35. TBitmapFileFormat = class(TImageFileFormat)
  36. protected
  37. { Controls that RLE compression is used during saving. Accessible trough
  38. ImagingBitmapRLE option.}
  39. FUseRLE: LongBool;
  40. function GetSupportedFormats: TImageFormats; override;
  41. procedure LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
  42. OnlyFirstLevel: Boolean); override;
  43. procedure SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
  44. Index: LongInt); override;
  45. function MakeCompatible(const Image: TImageData; var Comp: TImageData): Boolean; override;
  46. public
  47. constructor Create; override;
  48. function TestFormat(Handle: TImagingHandle): Boolean; override;
  49. end;
  50. const
  51. SBitmapExtensions = 'bmp,dib';
  52. SBitmapFormatName = 'Windows Bitmap Image';
  53. BitmapSupportedFormats: TImageFormats = [ifIndex8, ifA1R5G5B5, ifA4R4G4B4,
  54. ifR8G8B8, ifA8R8G8B8, ifX1R5G5B5, ifX4R4G4B4, ifX8R8G8B8];
  55. BitmapDefaultRLE = True;
  56. implementation
  57. const
  58. { Bitmap file identifier 'BM'.}
  59. BMMagic: Word = 19778;
  60. { Constants for the TBitmapInfoHeader.Compression field.}
  61. BI_RGB = 0;
  62. BI_RLE8 = 1;
  63. BI_RLE4 = 2;
  64. BI_BITFIELDS = 3;
  65. type
  66. { File Header for Windows/OS2 bitmap file.}
  67. TBitmapFileHeader = packed record
  68. ID: Word; // Is always 19778 : 'BM'
  69. Size: LongWord; // Filesize
  70. Reserved1: Word;
  71. Reserved2: Word;
  72. Offset: LongWord; // Offset from start pos to beginning of image bits
  73. end;
  74. { Info Header for Windows bitmap file.}
  75. TBitmapInfoHeader = packed record
  76. Size: LongWord;
  77. Width: LongInt;
  78. Height: LongInt;
  79. Planes: Word;
  80. BitCount: Word;
  81. Compression: LongWord;
  82. SizeImage: LongWord;
  83. XPelsPerMeter: LongInt;
  84. YPelsPerMeter: LongInt;
  85. ClrUsed: LongInt;
  86. ClrImportant: LongInt;
  87. end;
  88. { Info Header for OS2 bitmaps.}
  89. TBitmapCoreHeader = packed record
  90. Size: LongWord;
  91. Width: Word;
  92. Height: Word;
  93. Planes: Word;
  94. BitCount: Word;
  95. end;
  96. { Used with BitmapInfo.Compression = BI_BITFIELDS.}
  97. TLocalPixelFormat = packed record
  98. RBitMask, GBitMask, BBitMask: LongWord;
  99. end;
  100. procedure Convert1To8(DataIn: Pointer; DataOut: Pointer; Width, Height,
  101. WidthBytes: LongInt);
  102. const
  103. Mask1: array[0..7] of Byte = ($80, $40, $20, $10, $08, $04, $02, $01);
  104. Shift1: array[0..7] of Byte = (7, 6, 5, 4, 3, 2, 1, 0);
  105. var
  106. X, Y: LongInt;
  107. begin
  108. for Y := 0 to Height - 1 do
  109. for X := 0 to Width - 1 do
  110. PByteArray(DataOut)[Y * Width + X] :=
  111. (PByteArray(DataIn)[Y * WidthBytes + X shr 3] and
  112. Mask1[X and 7]) shr Shift1[X and 7];
  113. end;
  114. procedure Convert4To8(DataIn: Pointer; DataOut: Pointer; Width, Height,
  115. WidthBytes: LongInt);
  116. const
  117. Mask4: array[0..1] of Byte = ($F0, $0F);
  118. Shift4: array[0..1] of Byte = (4, 0);
  119. var
  120. X, Y: LongInt;
  121. begin
  122. for Y := 0 to Height - 1 do
  123. for X := 0 to Width - 1 do
  124. PByteArray(DataOut)[Y * Width + X] :=
  125. (PByteArray(DataIn)[Y * WidthBytes + X shr 1] and
  126. Mask4[X and 1]) shr Shift4[X and 1];
  127. end;
  128. { TBitmapFileFormat class implementation }
  129. constructor TBitmapFileFormat.Create;
  130. begin
  131. inherited Create;
  132. FName := SBitmapFormatName;
  133. FCanLoad := True;
  134. FCanSave := True;
  135. FIsMultiImageFormat := False;
  136. FUseRLE := BitmapDefaultRLE;
  137. AddExtensions(SBitmapExtensions);
  138. RegisterOption(ImagingBitmapRLE, @FUseRLE);
  139. end;
  140. function TBitmapFileFormat.GetSupportedFormats: TImageFormats;
  141. begin
  142. Result := BitmapSupportedFormats;
  143. end;
  144. procedure TBitmapFileFormat.LoadData(Handle: TImagingHandle;
  145. var Images: TDynImageDataArray; OnlyFirstLevel: Boolean);
  146. var
  147. BF: TBitmapFileHeader;
  148. BI: TBitmapInfoHeader;
  149. BC: TBitmapCoreHeader;
  150. IsOS2: Boolean;
  151. LocalPF: TLocalPixelFormat;
  152. PalRGB: PPalette24;
  153. I, FPalSize, AlignedSize, StartPos, AlignedWidthBytes, WidthBytes: LongInt;
  154. FmtInfo: PImageFormatInfo;
  155. Data: Pointer;
  156. procedure LoadRGB;
  157. var
  158. I: LongInt;
  159. LineBuffer: PByte;
  160. begin
  161. with Images[0], GetIO do
  162. begin
  163. // if BI.Height is < 0 then image data are stored non-flipped
  164. // but default in windows is flipped so if Height is positive we must
  165. // flip it
  166. if BI.BitCount < 8 then
  167. begin
  168. // for 1 and 4 bit images load aligned data, they will be converted to
  169. // 8 bit and unaligned later
  170. GetMem(Data, AlignedSize);
  171. if BI.Height < 0 then
  172. begin
  173. Read(Handle, Data, AlignedSize);
  174. end
  175. else
  176. for I := Height - 1 downto 0 do
  177. Read(Handle, @PByteArray(Data)[I * AlignedWidthBytes], AlignedWidthBytes);
  178. end
  179. else
  180. begin
  181. // images with pixels of size >= 1 Byte are read line by line and
  182. // copied to image bits without padding bytes
  183. GetMem(LineBuffer, AlignedWidthBytes);
  184. if BI.Height < 0 then
  185. begin
  186. for I := 0 to Height - 1 do
  187. begin
  188. Read(Handle, LineBuffer, AlignedWidthBytes);
  189. Move(LineBuffer^, PByteArray(Bits)[I * WidthBytes], WidthBytes);
  190. end;
  191. end
  192. else
  193. begin
  194. for I := Height - 1 downto 0 do
  195. begin
  196. Read(Handle, LineBuffer, AlignedWidthBytes);
  197. Move(LineBuffer^, PByteArray(Bits)[I * WidthBytes], WidthBytes);
  198. end;
  199. end;
  200. FreeMemNil(LineBuffer);
  201. end;
  202. end;
  203. end;
  204. procedure LoadRLE4;
  205. var
  206. RLEData, Src, PLine, P: PByte;
  207. X, Y, I, S, C: LongInt;
  208. begin
  209. GetMem(Data, AlignedSize);
  210. GetMem(RLEData, BI.SizeImage);
  211. GetIO.Read(Handle, RLEData, BI.SizeImage);
  212. with Images[0] do
  213. try
  214. Src := RLEData;
  215. Y := 0;
  216. X := 0;
  217. while Y < Height do
  218. begin
  219. C := Src^;
  220. Inc(Src);
  221. S := Src^;
  222. Inc(Src);
  223. if C = 0 then
  224. begin
  225. case S of
  226. 0:
  227. begin
  228. // next line
  229. Inc(Y);
  230. X := 0;
  231. end;
  232. 1: Break; // end of bitmap
  233. 2:
  234. begin
  235. // delta of coordinates
  236. Inc(Src);
  237. Inc(X, Src^);
  238. Inc(Src);
  239. Inc(Y, Src^);
  240. end;
  241. else
  242. begin
  243. // absolute data
  244. PLine := @PByteArray(Data)[Y * AlignedWidthBytes];
  245. for I := 0 to S - 1 do
  246. begin
  247. if I and 1 = 0 then
  248. begin
  249. C := Src^;
  250. Inc(Src);
  251. end
  252. else
  253. begin
  254. C := C shl 4;
  255. end;
  256. P := @PByteArray(PLine)[X shr 1];
  257. if X and 1 = 0 then
  258. P^ := (P^ and $0F) or (C and $F0)
  259. else
  260. P^ := (P^ and $F0) or ((C and $F0) shr 4);
  261. Inc(X);
  262. end;
  263. end;
  264. end;
  265. end
  266. else
  267. begin
  268. // encoded data
  269. PLine := @PByteArray(Data)[Y * AlignedWidthBytes];
  270. for I := 0 to C - 1 do
  271. begin
  272. P := @PByteArray(PLine)[X shr 1];
  273. if X and 1 = 0 then
  274. P^ := (P^ and $0F) or (S and $F0)
  275. else
  276. P^ := (P^ and $F0) or ((S and $F0) shr 4);
  277. Inc(X);
  278. S := (S shr 4) or (S shl 4);
  279. end;
  280. end;
  281. Inc(Src, Longint(Src) and 1);
  282. end;
  283. finally
  284. FreeMem(RLEData);
  285. end;
  286. end;
  287. procedure LoadRLE8;
  288. var
  289. RLEData, Src: PByte;
  290. X, Y, I, S: LongInt;
  291. begin
  292. GetMem(Data, AlignedSize);
  293. GetMem(RLEData, BI.SizeImage);
  294. GetIO.Read(Handle, RLEData, BI.SizeImage);
  295. with Images[0] do
  296. try
  297. Src := RLEData;
  298. Y := 0;
  299. X := 0;
  300. while Y < Height do
  301. begin
  302. if Src^ = 0 then
  303. begin
  304. Inc(Src);
  305. case Src^ of
  306. 0:
  307. begin
  308. // next line
  309. Inc(Y);
  310. X := 0;
  311. end;
  312. 1: Break; // end of bitmap
  313. 2:
  314. begin
  315. // delta of coordinates
  316. Inc(Src);
  317. Inc(X, Src^);
  318. Inc(Src);
  319. Inc(Y, Src^);
  320. end;
  321. else
  322. begin
  323. // absolute data
  324. I := Src^;
  325. S := (I + 1) and (not 1);
  326. Inc(Src);
  327. Move(Src^, PByteArray(Data)[Y * LongInt(AlignedWidthBytes) + X], S);
  328. Inc(Src, S - 1);
  329. Inc(X, I);
  330. end;
  331. end;
  332. end
  333. else
  334. begin
  335. // encoded data
  336. I := Src^;
  337. Inc(Src);
  338. FillChar(PByteArray(Data)[Y * LongInt(AlignedWidthBytes) + X], I, Src^);
  339. Inc(X, I);
  340. end;
  341. Inc(Src);
  342. end;
  343. finally
  344. FreeMem(RLEData);
  345. end;
  346. end;
  347. begin
  348. SetLength(Images, 1);
  349. with GetIO, Images[0] do
  350. begin
  351. StartPos := Tell(Handle);
  352. Read(Handle, @BF, SizeOf(BF));
  353. Read(Handle, @BI.Size, SizeOf(BI.Size));
  354. IsOS2 := BI.Size = SizeOf(TBitmapCoreHeader);
  355. // Bitmap Info reading
  356. if IsOS2 then
  357. begin
  358. // OS/2 type bitmap, reads info header without 4 already read bytes
  359. Read(Handle, @PByteArray(@BC)[SizeOf(BI.Size)],
  360. SizeOf(TBitmapCoreHeader) - SizeOf(BI.Size));
  361. with BI do
  362. begin
  363. ClrUsed := 0;
  364. Compression := BI_RGB;
  365. BitCount := BC.BitCount;
  366. Height := BC.Height;
  367. Width := BC.Width;
  368. end;
  369. end
  370. else
  371. begin
  372. // Windows type bitmap
  373. Read(Handle, @PByteArray(@BI)[SizeOf(BI.Size)],
  374. SizeOf(TBitmapInfoHeader) - SizeOf(BI.Size));
  375. // SizeImage can be 0 for BI_RGB images, but it is here because of:
  376. // I saved 8bit bitmap in Paint Shop Pro 8 as OS2 RLE compressed.
  377. // It wrote strange 64 Byte Info header with SizeImage set to 0
  378. // Some progs were able to open it, some were not.
  379. if BI.SizeImage = 0 then
  380. BI.SizeImage := BF.Size - BF.Offset;
  381. end;
  382. // Bit mask reading
  383. if BI.Compression = BI_BITFIELDS then
  384. Read(Handle, @LocalPF, SizeOf(LocalPF));
  385. case BI.BitCount of
  386. 1, 4, 8: Format := ifIndex8;
  387. 16:
  388. if LocalPF.RBitMask = $0F00 then
  389. Format := ifX4R4G4B4
  390. else
  391. if LocalPF.RBitMask = $F800 then
  392. Format := ifR5G6B5
  393. else
  394. Format := ifA1R5G5B5;
  395. 24: Format := ifR8G8B8;
  396. 32: Format := ifA8R8G8B8;
  397. end;
  398. NewImage(BI.Width, Abs(BI.Height), Format, Images[0]);
  399. FmtInfo := GetFormatInfo(Format);
  400. WidthBytes := Width * FmtInfo.BytesPerPixel;
  401. AlignedWidthBytes := (((Width * BI.BitCount) + 31) shr 5) * 4;
  402. AlignedSize := Height * LongInt(AlignedWidthBytes);
  403. // Palette settings and reading
  404. if BI.BitCount <= 8 then
  405. begin
  406. // seek to the begining of palette
  407. Seek(Handle, StartPos + SizeOf(TBitmapFileHeader) + LongInt(BI.Size),
  408. smFromBeginning);
  409. if IsOS2 then
  410. begin
  411. // OS/2 type
  412. FPalSize := 1 shl BI.BitCount;
  413. GetMem(PalRGB, FPalSize * SizeOf(TColor24Rec));
  414. Read(Handle, PalRGB, FPalSize * SizeOf(TColor24Rec));
  415. for I := 0 to FPalSize - 1 do
  416. with PalRGB[I] do
  417. begin
  418. Palette[I].R := R;
  419. Palette[I].G := G;
  420. Palette[I].B := B;
  421. end;
  422. FreeMem(PalRGB);
  423. end
  424. else
  425. begin
  426. // Windows type
  427. FPalSize := BI.ClrUsed;
  428. if FPalSize = 0 then
  429. FPalSize := 1 shl BI.BitCount;
  430. Read(Handle, Palette, FPalSize * SizeOf(TColor32Rec));
  431. end;
  432. for I := 0 to FPalSize - 1 do
  433. Palette[I].A := $FF;
  434. end;
  435. // seek to the begining of image bits
  436. Seek(Handle, StartPos + LongInt(BF.Offset), smFromBeginning);
  437. case BI.Compression of
  438. BI_RGB: LoadRGB;
  439. BI_RLE4: LoadRLE4;
  440. BI_RLE8: LoadRLE8;
  441. BI_BITFIELDS: LoadRGB;
  442. end;
  443. // check if there is alpha channel present in A1R5GB5 images, if it is not
  444. // change format to X1R5G5B5
  445. if Format = ifA1R5G5B5 then
  446. begin
  447. if not Has16BitImageAlpha(Width * Height, Bits) then
  448. Format := ifX1R5G5B5;
  449. end;
  450. if BI.BitCount < 8 then
  451. begin
  452. // 1 and 4 bpp images are supported only for loading which is now
  453. // so we now convert them to 8bpp (and unalign scanlines).
  454. case BI.BitCount of
  455. 1: Convert1To8(Data, Bits, Width, Height, AlignedWidthBytes);
  456. 4: Convert4To8(Data, Bits, Width, Height, AlignedWidthBytes);
  457. end;
  458. FreeMem(Data);
  459. // enlarge palette
  460. ReallocMem(Palette, FmtInfo.PaletteEntries * SizeOf(TColor32Rec));
  461. end
  462. else if BI.Compression = BI_RLE8 then
  463. begin
  464. // scanlines were not unaligned during decoding so remove pad bytes now
  465. RemovePadBytes(Data, Bits, Width, Height, FmtInfo.BytesPerPixel, AlignedWidthBytes);
  466. FreeMem(Data);
  467. end;
  468. // images were not flipped when decoding
  469. if BI.Compression in [BI_RLE4, BI_RLE8] then
  470. if BI.Height > 0 then
  471. FlipImage(Images[0]);
  472. end;
  473. end;
  474. procedure TBitmapFileFormat.SaveData(Handle: TImagingHandle;
  475. const Images: TDynImageDataArray; Index: Integer);
  476. var
  477. Len, StartPos, EndPos, WidthBytes, AlignedSize: LongInt;
  478. Data: Pointer;
  479. BF: TBitmapFileHeader;
  480. BI: TBitmapInfoHeader;
  481. FmtInfo: PImageFormatInfo;
  482. ImageToSave: TImageData;
  483. LocalPF: TLocalPixelFormat;
  484. procedure SaveRLE8;
  485. const
  486. BufferSize = 65536;
  487. var
  488. Pos: LongInt;
  489. B1, B2: Byte;
  490. L1, L2: LongInt;
  491. Src, Buf: PByte;
  492. X, Y: LongInt;
  493. function AllocByte: PByte;
  494. begin
  495. if Pos mod BufferSize = 0 then
  496. ReallocMem(Buf, Pos + BufferSize - 1);
  497. Result := @PByteArray(Buf)[Pos];
  498. Inc(Pos);
  499. end;
  500. begin
  501. Buf := nil;
  502. Pos := 0;
  503. try
  504. for Y := 0 to ImageToSave.Height - 1 do
  505. begin
  506. X := 0;
  507. Src := @PByteArray(Data)[Y * WidthBytes];
  508. while X < ImageToSave.Width do
  509. begin
  510. if (ImageToSave.Width - X > 2) and
  511. (Src^ = PByteArray(Src)[1]) then
  512. begin
  513. // encoding mode
  514. B1 := 2;
  515. B2 := Src^;
  516. Inc(X, 2);
  517. Inc(Src, 2);
  518. while (X < ImageToSave.Width) and (Src^ = B2) and (B1 < 255) do
  519. begin
  520. Inc(B1);
  521. Inc(X);
  522. Inc(Src);
  523. end;
  524. AllocByte^ := B1;
  525. AllocByte^ := B2;
  526. end
  527. else
  528. if (ImageToSave.Width - X > 2) and (Src^ <> PByteArray(Src)[1]) and
  529. (PByteArray(Src)[1] = PByteArray(Src)[2]) then
  530. begin
  531. // encoding mode
  532. AllocByte^ := 1;
  533. AllocByte^ := Src^;
  534. Inc(Src);
  535. Inc(X);
  536. end
  537. else
  538. begin
  539. if (ImageToSave.Width - X < 4) then
  540. begin
  541. if ImageToSave.Width - X = 2 then
  542. begin
  543. // encoding mode
  544. AllocByte^ := 1;
  545. AllocByte^ := Src^;
  546. Inc(Src);
  547. AllocByte^ := 1;
  548. AllocByte^ := Src^;
  549. Inc(Src);
  550. Inc(X, 2);
  551. end
  552. else
  553. begin
  554. AllocByte^ := 1;
  555. AllocByte^ := Src^;
  556. Inc(Src);
  557. Inc(X);
  558. end;
  559. end
  560. else
  561. begin
  562. // absolute mode
  563. L1 := Pos;
  564. AllocByte;
  565. L2 := Pos;
  566. AllocByte;
  567. B1 := 0;
  568. B2 := 3;
  569. Inc(X, 3);
  570. AllocByte^ := Src^;
  571. Inc(Src);
  572. AllocByte^ := Src^;
  573. Inc(Src);
  574. AllocByte^ := Src^;
  575. Inc(Src);
  576. while (X < ImageToSave.Width) and (B2 < 255) do
  577. begin
  578. if (ImageToSave.Width - X > 3) and
  579. (Src^ = PByteArray(Src)[1]) and
  580. (Src^ = PByteArray(Src)[2]) and
  581. (Src^ = PByteArray(Src)[3]) then
  582. Break;
  583. AllocByte^ := Src^;
  584. Inc(Src);
  585. Inc(B2);
  586. Inc(X);
  587. end;
  588. PByteArray(Buf)[L1] := B1;
  589. PByteArray(Buf)[L2] := B2;
  590. end;
  591. end;
  592. if Pos and 1 = 1 then
  593. AllocByte;
  594. end;
  595. // end of line
  596. AllocByte^ := 0;
  597. AllocByte^ := 0;
  598. end;
  599. // end of bitmap
  600. AllocByte^ := 0;
  601. AllocByte^ := 1;
  602. GetIO.Write(Handle, Buf, Pos);
  603. finally
  604. FreeMem(Buf);
  605. end;
  606. end;
  607. begin
  608. Len := Length(Images);
  609. if Len = 0 then Exit;
  610. if (Index = MaxInt) or (Len = 1) then Index := 0;
  611. if MakeCompatible(Images[Index], ImageToSave) then
  612. with GetIO, ImageToSave do
  613. try
  614. FmtInfo := GetFormatInfo(Format);
  615. StartPos := Tell(Handle);
  616. FillChar(BF, SizeOf(BF), 0);
  617. FillChar(BI, SizeOf(BI), 0);
  618. // other fields will be filled later - we don't know all values now
  619. BF.ID := BMMagic;
  620. Write(Handle, @BF, SizeOF(BF));
  621. // other fields will be filled later - we don't know all values now
  622. BI.Size := SizeOf(BI);
  623. BI.Width := Width;
  624. BI.Height := -Height;
  625. BI.Planes := 1;
  626. BI.BitCount := FmtInfo.BytesPerPixel * 8;
  627. // set compression
  628. if (FmtInfo.BytesPerPixel = 1) and FUseRLE then
  629. BI.Compression := BI_RLE8
  630. else
  631. if (Format <> ifA1R5G5B5) and (FmtInfo.BytesPerPixel = 2) then
  632. BI.Compression := BI_BITFIELDS
  633. else
  634. BI.Compression := BI_RGB;
  635. Write(Handle, @BI, SizeOF(BI));
  636. // write mask info
  637. if BI.Compression = BI_BITFIELDS then
  638. with FmtInfo.PixelFormat^ do
  639. begin
  640. LocalPF.RBitMask := RBitMask;
  641. LocalPF.GBitMask := GBitMask;
  642. LocalPF.BBitMask := BBitMask;
  643. Write(Handle, @LocalPF, SizeOf(LocalPF));
  644. end;
  645. // write palette
  646. if Palette <> nil then
  647. Write(Handle, Palette, FmtInfo.PaletteEntries * SizeOf(TColor32Rec));
  648. BF.Offset := Tell(Handle) - StartPos;
  649. WidthBytes := (((Width * BI.BitCount) + 31) shr 5) * 4;
  650. AlignedSize := Height * WidthBytes;
  651. if Size <> AlignedSize then
  652. begin
  653. GetMem(Data, AlignedSize);
  654. AddPadBytes(Bits, Data, Width, Height, FmtInfo.BytesPerPixel, WidthBytes);
  655. end
  656. else
  657. Data := Bits;
  658. if BI.Compression = BI_RLE8 then
  659. SaveRLE8
  660. else
  661. Write(Handle, Data, AlignedSize);
  662. if Data <> Bits then
  663. FreeMem(Data);
  664. EndPos := Tell(Handle);
  665. Seek(Handle, StartPos, smFromBeginning);
  666. // rewrite header with new values
  667. BF.Size := EndPos - StartPos;
  668. BI.SizeImage := BF.Size - BF.Offset;
  669. Write(Handle, @BF, SizeOf(BF));
  670. Write(Handle, @BI, SizeOf(BI));
  671. Seek(Handle, EndPos, smFromBeginning);
  672. finally
  673. if Images[Index].Bits <> ImageToSave.Bits then
  674. FreeImage(ImageToSave);
  675. end;
  676. end;
  677. function TBitmapFileFormat.MakeCompatible(const Image: TImageData;
  678. var Comp: TImageData): Boolean;
  679. var
  680. Info: PImageFormatInfo;
  681. ConvFormat: TImageFormat;
  682. begin
  683. if not inherited MakeCompatible(Image, Comp) then
  684. begin
  685. Info := GetFormatInfo(Comp.Format);
  686. if Info.HasGrayChannel or Info.IsIndexed then
  687. // convert all grayscale and indexed images to Index8
  688. ConvFormat := ifIndex8
  689. else
  690. if Info.HasAlphaChannel or Info.IsFloatingPoint then
  691. // convert images with alpha channel or float to A8R8G8B8
  692. ConvFormat := ifA8R8G8B8
  693. else
  694. if Info.UsePixelFormat then
  695. // convert 16bit RGB images to A1R5G5B5
  696. ConvFormat := ifA1R5G5B5
  697. else
  698. // convert all other formats to R8G8B8
  699. ConvFormat := ifR8G8B8;
  700. ConvertImage(Comp, ConvFormat);
  701. end;
  702. Result := Comp.Format in GetSupportedFormats;
  703. end;
  704. function TBitmapFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
  705. var
  706. Hdr: TBitmapFileHeader;
  707. ReadCount: LongInt;
  708. begin
  709. Result := False;
  710. if Handle <> nil then
  711. with GetIO do
  712. begin
  713. ReadCount := Read(Handle, @Hdr, SizeOf(Hdr));
  714. Seek(Handle, -ReadCount, smFromCurrent);
  715. Result := (Hdr.ID = BMMagic) and (ReadCount = SizeOf(Hdr));
  716. end;
  717. end;
  718. initialization
  719. RegisterImageFileFormat(TBitmapFileFormat);
  720. {
  721. File Notes:
  722. -- TODOS ----------------------------------------------------
  723. - rewrite SaveRLE8, there is some error with MemCheck
  724. - add alpha check as with 16bit bitmaps to 32bt bitmaps too
  725. -- 0.19 Changes/Bug Fixes -----------------------------------
  726. - fixed wrong const that caused A4R4G4B4 BMPs to load as A1R5G5B5
  727. - fixed the bug that caused 8bit RLE compressed bitmaps to load as
  728. whole black
  729. -- 0.17 Changes/Bug Fixes -----------------------------------
  730. - 16 bit images are usually without alpha but some has alpha
  731. channel and there is no indication of it - so I have added
  732. a check: if all pixels of image are with alpha = 0 image is treated
  733. as X1R5G5B5 otherwise as A1R5G5B5
  734. -- 0.13 Changes/Bug Fixes -----------------------------------
  735. - when loading 1/4 bit images with dword aligned dimensions
  736. there was ugly memory rewritting bug causing image corruption
  737. }
  738. end.