pngwritetbitmap.pas

   1 {unit to write tbitmaps to a png using plugwashes png code}\r
   2 \r
   3 { Copyright (C) 2008 Peter Green\r
   4   For conditions of distribution and use, see copyright notice in zlib_license.txt\r
   5   which is included in the package\r
   6       ----------------------------------------------------------------------------- }\r
   7       \r
   8 \r
   9 unit pngwritetbitmap;\r
  10 \r
  11 interface\r
  12 uses\r
  13   pngwrite,\r
  14   sysutils,\r
  15   classes,\r
  16   {$ifdef win32}\r
  17     windows,\r
  18   {$endif}\r
  19   {$ifndef fpc}\r
  20 \r
  21     Graphics;\r
  22 \r
  23   {$else}\r
  24     pgtbitmap;\r
  25   {$endif}\r
  26   \r
  27 procedure savetbitmaptopng(image:tbitmap;destination : tstream);\r
  28 implementation\r
  29 procedure savetbitmaptopng(image:tbitmap;destination : tstream);\r
  30 var\r
  31   paletteentrieswin : array[0..255] of TPaletteEntry;\r
  32   paletteentriespng : array[0..768] of byte;\r
  33   f:tpngwrite;\r
  34   i : integer;\r
  35   colortype : tcolortype;\r
  36 begin\r
  37   if (image.PixelFormat <> pf8bit) and (image.pixelformat <> pf24bit) then raise exception.create('unsupported image format, only 8 bit and 24 bit per pixel are currently supported.');\r
  38   if image.PixelFormat = pf24bit then begin\r
  39     colortype := ctbgr;\r
  40   end else begin\r
  41     colortype := ctpallette;\r
  42   end;\r
  43   pngstart(f,destination,8,colortype,image.Height,image.Width);\r
  44 \r
  45   if image.pixelformat = pf8bit then begin\r
  46     GetPaletteEntries(image.Palette,0,256,paletteEntrieswin);\r
  47 \r
  48     //writeln('about to start png write');\r
  49     //writeln('about to prepare pallette');\r
  50     for i := 0 to 255 do begin\r
  51       paletteentriespng[(i*3)  ] := paletteEntrieswin[i].pered;\r
  52       paletteentriespng[(i*3)+1] := paletteEntrieswin[i].pegreen;\r
  53       paletteentriespng[(i*3)+2] := paletteEntrieswin[i].peblue;\r
  54     end;\r
  55     //writeln('about to write pallette');\r
  56     pngwritepal(f,@paletteentriespng,256 );\r
  57   end;\r
  58 \r
  59   pngstartdata(f);\r
  60   {$O-}\r
  61   for i := 0 to Image.Height -1 do begin;\r
  62     //writeln('about to write scanline ',i,'image.height=',image.height,'image.ScanLine[i]',longint(image.ScanLine[i]));\r
  63     pngwritescanline(f,image.ScanLine[i]);\r
  64   end;\r
  65   //writeln('about to close main data block');\r
  66   pngfinishdata(f);\r
  67   //writeln('about to close png');\r
  68   pngfinish(f);\r
  69 \r
  70 end;\r
  71 end.\r