teepng.pas

Delphi TeeChartPro.6.01的源代码

    png_set_compression_level:procedure(png_ptr: Ppng_struct; Level: Integer); stdcall;
    png_set_write_fn       : procedure(png_ptr: PPng_Struct;
                                     io_ptr: Pointer; write_data_fn: png_rw_ptr;
                                     output_flush_fn: png_flush_ptr); stdcall;
    png_set_write_status_fn: procedure(png_ptr: PPng_Struct;
                             write_row_fn: Pointer); stdcall;
    png_set_IHDR           : procedure(png_ptr: PPng_Struct; info_ptr: PPng_Info;
                             width, height: Cardinal; bit_depth, color_type, interlace_type,
                             compression_type, filter_type: Integer); stdcall;
    png_write_info         : procedure(png_ptr: PPng_Struct; info_ptr: PPng_Info); stdcall;
    png_write_image        : procedure(png_ptr: PPng_Struct; image: PPByte); stdcall;
    png_write_end          : procedure(png_ptr: PPng_Struct; info_ptr: PPng_Info); stdcall;
    png_write_flush        : procedure(png_ptr: PPng_Struct); stdcall;
    png_destroy_write_struct : procedure(png_ptr_ptr: PPPng_Struct;
                               info_ptr_ptr: PPPng_Info); stdcall;

    PngLib : HINST=0;

const PNG_LIBPNG_VER_STRING =  '1.0.1';
      PNG_COLOR_TYPE_RGB:        Integer = 2;
      PNG_INTERLACE_NONE:  Integer = 0;
      PNG_COMPRESSION_TYPE_DEFAULT: Integer = 0;
      PNG_FILTER_TYPE_DEFAULT: Integer = 0;

var IStream : TStream;

procedure LoadProcs;
begin
  png_create_write_struct :=GetProcAddress(PngLib,'png_create_write_struct');
  png_create_info_struct  :=GetProcAddress(PngLib,'png_create_info_struct');
  png_set_compression_level:=GetProcAddress(PngLib,'png_set_compression_level');
  png_set_write_fn        :=GetProcAddress(PngLib,'png_set_write_fn');
  png_set_write_status_fn :=GetProcAddress(PngLib,'png_set_write_status_fn');
  png_set_IHDR            :=GetProcAddress(PngLib,'png_set_IHDR');
  png_write_info          :=GetProcAddress(PngLib,'png_write_info');
  png_write_image         :=GetProcAddress(PngLib,'png_write_image');
  png_write_end           :=GetProcAddress(PngLib,'png_write_end');
  png_write_flush         :=GetProcAddress(PngLib,'png_write_flush');
  png_destroy_write_struct:=GetProcAddress(PngLib,'png_destroy_write_struct');
end;
{$ENDIF}

Constructor TPNGExportFormat.Create;
begin
  inherited;
  FCompression:=TeePNG_DefaultCompressionLevel;
  FPixel:={$IFDEF CLX}pf32Bit{$ELSE}pfDevice{$ENDIF};
end;

function TPNGExportFormat.Description:String;
begin
  result:=TeeMsg_AsPNG;
end;

function TPNGExportFormat.FileFilter:String;
begin
  result:=TeeMsg_PNGFilter;
end;

function TPNGExportFormat.FileExtension:String;
begin
  result:='PNG';
end;

Function TPNGExportFormat.Bitmap:TBitmap;
begin
  result:=Panel.TeeCreateBitmap(Panel.Color,TeeRect(0,0,Width,Height),FPixel);
end;

procedure TPNGExportFormat.DoCopyToClipboard;
var tmp : TBitmap;
begin
  tmp:=Bitmap;
  try
    Clipboard.Assign(tmp);
  finally
    tmp.Free;
  end;
end;

Procedure TPNGExportFormat.CheckProperties;
begin
  if not Assigned(FProperties) then
  begin
    FProperties:=TTeePNGOptions.Create(nil);
    FProperties.IFormat:=Self;
    FProperties.UpDown1.Position:=FCompression;
  end;
end;

Procedure TPNGExportFormat.SetCompression(const Value:Integer);
begin
  FCompression:=Value;
  if Assigned(FProperties) then
     FProperties.UpDown1.Position:=FCompression;
end;

Function TPNGExportFormat.Options(Check:Boolean=True):TForm;
begin
  if Check then CheckProperties;
  result:=FProperties;
end;

{$IFNDEF LINUX}
Const PNGDLL='LPng.dll';

Procedure InitPngLib;
begin
  PngLib:=TeeLoadLibrary(PNGDll);
end;

procedure WriteImageStream(png_ptr: Pointer; var Data: Pointer; Length: Cardinal); stdcall;
begin
  IStream.WriteBuffer(Data,Length);
end;

procedure FlushImageStream(png_ptr: Pointer); stdcall;
begin
end;

procedure TPNGExportFormat.SaveToStreamCompression(AStream:TStream; CompressionLevel:Integer);
var Data : PByte;
    FBytesPerPixel: Integer;

  Procedure SetBitmapStream(Bitmap:TBitmap; var PicData:TPicData);
  var DC : HDC;
  begin
    PicData.Stream.Clear;
    PicData.Stream.SetSize(SizeOf(TBITMAPINFOHEADER)+ Bitmap.Height*(Bitmap.Width+4)*3);
    With TBITMAPINFOHEADER(PicData.Stream.Memory^) do
    Begin
      biSize := SizeOf(TBITMAPINFOHEADER);
      biWidth := Bitmap.Width;
      biHeight := Bitmap.Height;
      biPlanes := 1;
      biBitCount := 24;
      biCompression := bi_RGB;
      biSizeImage := 0;
      biXPelsPerMeter :=1;
      biYPelsPerMeter :=1;
      biClrUsed :=0;
      biClrImportant :=0;
    end;

    PicData.Aptr:=Pchar(PicData.Stream.Memory)+SizeOf(TBITMAPINFOHEADER);
    DC:=GetDC(0);
    try
      GetDIBits(DC, {$IFDEF CLX}QPixmap_hbm{$ENDIF}(Bitmap.Handle), 0, Bitmap.Height, PicData.Aptr,
                TBITMAPINFO(PicData.Stream.Memory^), dib_RGB_Colors);
    finally
      ReleaseDC(0,DC);
    end;

    With PicData do
    begin
      Width      :=Bitmap.Width;
      Height     :=Bitmap.Height;
      LineWidth  :=Bitmap.Width*3;
      LineWidth  :=((LineWidth+3) div 4)*4;
      BLineWidth :=Bitmap.Height*3;
      BLineWidth :=((BLineWidth+3) div 4)*4;
    end;
  end;

  procedure Init;
  type PCardinal  = ^Cardinal;
  var CValuep : PCardinal;
      y       : Integer;
  begin
    CValuep:=Pointer(RowPtrs);
    for y:=0 to PicData.Height-1 do
    begin
      CValuep^:=Cardinal(Data)+Cardinal(PicData.Width*FBytesPerPixel*y);
      Inc(CValuep);
    end;
  end;

  Procedure CopyImage;
  var x : Integer;
      y : Integer;
      AktPicP,
      AktP     : PChar;
  begin
    for y:=0 to PicData.Height-1 do
      for x:=0 to PicData.Width-1 do
      begin
        AktPicP:=PChar(PicData.Aptr) +  y*PicData.LineWidth + x*3;
        AktP:=PChar(Data) +  (PicData.Height-1-y)*(FBytesPerPixel*PicData.Width) + x*FBytesPerPixel;
        BYTE((AktP+0)^):=BYTE((AktPicP+2)^);
        BYTE((AktP+1)^):=BYTE((AktPicP+1)^);
        BYTE((AktP+2)^):=BYTE((AktPicP+0)^);
      end;
  end;

  Procedure GetMemory;
  begin
    GetMem(Data,PicData.Height*PicData.Width*FBytesPerPixel);
    GetMem(RowPtrs, SizeOf(Pointer)*PicData.Height);
  end;

  Procedure FreeMemory;
  begin
    if Assigned(Data) then FreeMem(Data);
    if Assigned(RowPtrs) then FreeMem(RowPtrs);
  end;

  Procedure DoSaveToStream;
  var png     : PPng_Struct;
      pnginfo : PPng_Info;
      tmp     : Array[0..32] of Char;
  begin
    IStream:=AStream;
    tmp:=PNG_LIBPNG_VER_STRING;
    png:=png_create_write_struct(tmp, nil, nil, nil);
    if Assigned(png) then
    try
      pnginfo:=png_create_info_struct(png);
      png_set_write_fn(png, @SaveBuf, WriteImageStream, FlushImageStream);
      png_set_write_status_fn(png, nil);

      png_set_IHDR(png, pnginfo, PicData.Width, PicData.Height, 8,
                   PNG_COLOR_TYPE_RGB,
                   PNG_INTERLACE_NONE,
                   PNG_COMPRESSION_TYPE_DEFAULT,
                   PNG_FILTER_TYPE_DEFAULT);

      png_write_info(png, pnginfo);

      {$IFNDEF TEEOCX}
      if CompressionLevel=-1 then
         CompressionLevel:=FProperties.UpDown1.Position;
      {$ENDIF}

      png_set_compression_level(png,CompressionLevel);
      png_write_image(png, PPByte(RowPtrs));
      png_write_end(png, pnginfo);
      png_write_flush(png);
    finally
      png_destroy_write_struct(@png, @pnginfo);
    end;
    IStream:=nil;
  end;

var tmpBitmap : TBitmap;
begin
  { delayed load of LPNG.DLL procedure addresses }
  if PngLib=0 then InitPngLib;
  if not Assigned(png_create_write_struct) then LoadProcs;

  CheckSize;
  PicData.Stream:=TMemoryStream.Create;
  try
    tmpBitmap:=Bitmap;
    try
      SetBitmapStream(tmpBitmap,PicData); { 5.01 }

      FBytesPerPixel:=3;
      GetMemory;
      try
        Init;
        CopyImage;

        {$IFDEF TEEOCX}
        PNGSection.Enter;
        {$ENDIF}

        DoSaveToStream;

        {$IFDEF TEEOCX}
        PNGSection.Leave;
        {$ENDIF}
      finally
        FreeMemory;
      end;
    finally
      tmpBitmap.Free;
    end;
  finally
    PicData.Stream.Free;
  end;
end;

procedure ClearProcs;
begin
  png_create_write_struct :=nil;
  png_create_info_struct  :=nil;
  png_set_compression_level:=nil;
  png_set_write_fn        :=nil;
  png_set_write_status_fn :=nil;
  png_set_IHDR            :=nil;
  png_write_info          :=nil;
  png_write_image         :=nil;
  png_write_end           :=nil;
  png_write_flush         :=nil;
  png_destroy_write_struct:=nil;
end;

{$ELSE}

// LINUX:

procedure TPNGExportFormat.SaveToStreamCompression(AStream:TStream; CompressionLevel:Integer);
var tmpBitmap : TBitmap;
begin
  CheckSize;
  tmpBitmap:=Bitmap;
  try
    tmpBitmap.SaveToStream(AStream); { pending: convert to PNG }
  finally
    tmpBitmap.Free;
  end;
end;

{$ENDIF}

procedure TPNGExportFormat.SaveToStream(AStream:TStream);
begin
  CheckProperties;
  SaveToStreamCompression(AStream,FProperties.UpDown1.Position);
end;

procedure TTeePNGOptions.FormCreate(Sender: TObject);
begin
  UpDown1.Position:=TeePNG_DefaultCompressionLevel;
end;

{$IFNDEF LINUX}
Function FileInPath(Const FileName:String):Boolean;
var tmp : array[0..4095] of Char;
begin
  result:=(GetEnvironmentVariable('PATH',tmp,SizeOf(tmp))>0) and
          (FileSearch(FileName,tmp)<>'');
end;
{$ENDIF}

procedure TTeePNGOptions.Edit1Change(Sender: TObject);
begin
  if Assigned(IFormat) then
     IFormat.FCompression:=UpDown1.Position;
end;

initialization
  {$IFNDEF LINUX}
    {$IFDEF TEEOCX}
    if not Assigned(PNGSection) then
       PNGSection:=TCriticalSection.Create;
    {$ENDIF}
  if FileInPath(PNGDLL) then
  {$ENDIF}
     RegisterTeeExportFormat(TPNGExportFormat);
finalization
  UnRegisterTeeExportFormat(TPNGExportFormat);
  {$IFNDEF LINUX}
    {$IFDEF TEEOCX}
    if Assigned(PNGSection) then PNGSection.Free;
    {$ENDIF}
  if PngLib>0 then
  begin
    TeeFreeLibrary(PngLib);
    PngLib:=0;
    ClearProcs;
  end;
  {$ENDIF}
end.