pngwritetbitmap.pas

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