pngimage1.pas

查看html文件的控件

{When the chunk is being created}
constructor TChunkTIME.Create(AOwner: TChunkList);
begin
  inherited;

  {Initial size and value}
  fStream.SetSize(7); { Paul - fStream.Size := 7; }
  DateTime := Now;
end;

{:Return the value of the date and time stamped on the chunk}
function TChunkTIME.GetDateTime: TDateTime;
var
  Data    : TTimeChunk;
begin
  {Makes sure that the stream size is 7}
  if fStream.Size <> 7 then
    CallError(TIME_CORRUPTED);

  {Read the data into the record}
  Data := pTimeChunk(fStream.Memory)^;
  Data.Year := SwapLong(Data.Year);

  {Return value}
  with Data do
    {Test if time is corrupted}
    try
      if Year = 0 then Year := 2000;
      Result := EncodeDate(Year, Month, Day);
      ReplaceTime(Result, EncodeTime(Hour, Min, Sec, 0));
    except
      ShowMessageFmt('Year: %d, Month: %d, Day: %d, Hour: %d, Min: %d,' +
        'Sec: %d', [Year, Month, Day, Hour, Min, Sec]);
      CallError(TIME_CORRUPTED);
    end;

end;

{:Set the value for the date and time in the chunk}
procedure TChunkTIME.SetDateTime(const Value: TDateTime);
var
  Year,
  Month,
  Day,
  Hour,
  Min,
  Sec,
  MSec   : word;
  Temp   : Byte;
begin
  fStream.Clear;

  {Get the datetime values}
  DecodeTime(Value, Hour, Min, Sec, MSec);
  DecodeDate(Value, Year, Month, Day);

  {Write the values}
  Year := SwapLong(Year);
  fStream.Write(Year, 2);
  Temp := Month; fStream.Write(Temp, 1);
  Temp := Day;   fStream.Write(Temp, 1);
  Temp := Hour;  fStream.Write(Temp, 1);
  Temp := Min;   fStream.Write(Temp, 1);
  Temp := Sec;   fStream.Write(Sec, 1);
end;

{When the chunk is being saved}
procedure TChunkTRNS.SaveToStream(Stream: TStream);
var
  Temp: Byte;
begin
  {Clear the data contents}
  fStream.Clear;

  {Write different transparency for different color formats}
  case IHDR.ColorType of
    RGB:
    begin
      {RGB data}
      Temp := GetRValue(Bitmap.TransparentColor);  fStream.Write(Temp, 1);
      Temp := GetGValue(Bitmap.TransparentColor);  fStream.Write(Temp, 1);
      Temp := GetBValue(Bitmap.TransparentColor);  fStream.Write(Temp, 1);
    end;
  else
    exit;
  end;

  inherited;
end;

{:Return value of one of the properties}
function TChunkZTXT.GetValue(Index: Integer): String;
var
  fKeyword: Pchar;
  DSize   : Integer;
  fText   : Pchar; { Paul - Array of Char; }
  Decode  : TZDecompressionStream;
begin
  {Read the keyword}
  fKeyword := fStream.Memory;

  {Get the size of the uncompressed text and resize the holder}
  DSize := fStream.Size - Length(fKeyword) - 2;
  GetMem(fText,DSize); { Paul - SetLength(fText, DSize); }

  {Create a especial stream to decompress}
  fStream.Position := Length(fKeyword) + 2;
  Decode := TZDecompressionStream.Create(fStream);
  Decode.Read(fText[0], DSize);
  case Index of
  0:
    Result := fKeyword;
  else
    Result := ftext; { Paul - pchar(@fText[0]); }
  end;
  {Free that stream}
  Decode.Free;

end;

{:Set the value of one of the properties}
procedure TChunkZTXT.SetValue(Index: Integer; Value: String);
var
  fKeyword, fText: pchar;
  Encode         : TZCompressionStream;
  Method         : Byte;
begin
  {Test which property to set}
  case Index of
  0: begin
      {Setting keyword}
      fKeyword := pchar(Value);
      fText := pchar(Text);
    end;
  else
    begin
      {Setting text}
      fText := pchar(Value);
      fKeyword := pchar(Keyword);
    end;
  end;

  {Clear the stream for rewriting}
  fStream.Clear;
  fStream.Position := 0;
  Method := 0;

  {Write data}
  fStream.Write(fKeyword[0], Length(fKeyword) + 1); {+1 to include null character}
  fStream.Write(Method, 1);

  Encode := TZCompressionStream.Create(fStream, zcDefault);
  Encode.Write(fText[0], Length(fText));
  Encode.Free;

end;

{:When the TEXT chunk is being created}
constructor TChunkTEXT.Create(AOwner: TChunkList);
begin
  inherited;
  fType := 'tEXt';
  {Set the stream size to 2 and set the two bytes as null}
  fStream.SetSize(2); { Paul - fStream.Size := 2; }
  pByteArray(fStream.Memory)^[0] := 0;
  pByteArray(fStream.Memory)^[1] := 0;
end;

{:Return one of the properties of the chunk TEXT}
function TChunkTEXT.GetValue(Index: Integer): String;
var
  fKeyword, fText: pChar;
begin
  fKeyword := fStream.Memory;
  fText := @pByteArray(fStream.Memory)[Length(fKeyword) + 1];

  {Test which property to return}
  case Index of
  0: Result := fKeyword;
  else
     Result := fText;
  end;
end;

{:Set the value of the TEXT chunk}
procedure TChunkTEXT.SetValue(Index: Integer; Value: String);
var
  fKeyword, fText: pchar;
begin
  {Test which property to set}
  case Index of
  0: begin
      {Setting keyword}
      fKeyword := pchar(Value);
      fText := pchar(Text);
    end;
  else
    begin
      {Setting text}
      fText := pchar(Value);
      fKeyword := pchar(Keyword);
    end;
  end;

  {Clear the stream for rewriting}
  fStream.Clear;
  fStream.Position := 0;

  {Write data}
  fStream.Write(fKeyword[0], Length(fKeyword) + 1); {+1 to include null character}
  fStream.Write(fText[0], Length(fText) + 1);
end;

{:When the object is being destroyed}
destructor TChunkPLTE.Destroy;
begin
  {If the main bitmap is using the palette make it don't use it anymore}
  if Owner.Owner.Palette = fPalette then
    Owner.Owner.Palette := 0;

  {Delete the palette from the memory}
  if fPalette <> 0 then       {LDB}
    DeleteObject(fPalette);

  inherited;
end;



{Returns the palette from the image}
function TChunkPLTE.GetPalette: HPalette;
var
  MaxPalette: TMaxLogPalette;
  i: Integer;
  GamaChunk : TChunkGAMA;
begin
  GamaChunk := Gama;

  {Delete the old palette from the memory}
  if fPalette <> 0 then             {LDB}
    DeleteObject(fPalette);

  {The palette stream must be divisible by 3}
  if fStream.Size MOD 3 <> 0 then
    CallError(PNG_ERROR_INVALID_PLTE);

  {Set the MaxPalette attributes}
  with MaxPalette do
  begin
    Fillchar(MaxPalette, sizeof(MaxPalette), 0);
    palVersion := $300;
    palNumEntries := fStream.Size DIV 3;

    {Get each value}
    FOR i := 0 to palNumEntries - 1 DO
    WITH palPalEntry[i] do
    BEGIN
      peRed := pByteArray(fStream.Memory)[(i * 3)];
      {Correct red using gamma}
      if Assigned(GamaChunk) then
        peRed := GamaChunk.GammaTable[peRed];

      peGreen := pByteArray(fStream.Memory)[(i * 3) + 1];
      {Correct green using gamma}
      if Assigned(GamaChunk) then
        peGreen := GamaChunk.GammaTable[peGreen];

      peBlue := pByteArray(fStream.Memory)[(i * 3) + 2];
      {Correct red using gamma}
      if Assigned(GamaChunk) then
        peBlue := GamaChunk.GammaTable[peBlue];

      peFlags := 0;
    END;
    IF (IHDR.BitDepth = 2) and (palNumEntries < 16) then
    begin
      {Note: This is really a crazy fix for supporting 2bit}
      {images}
      palNumEntries := 16;
      copymemory(@palpalentry[4], @palpalentry[0], 21);
      copymemory(@palpalentry[8], @palpalentry[0], 21);
      copymemory(@palpalentry[12], @palpalentry[0], 21);

    end;

  end;

  {Create the palette object}
  fPalette := CreatePalette(PLogPalette(@MaxPalette)^);

  {Returns the palette handle}
  Result := fPalette;
end;

{:When the chunk is being saved}
procedure TChunkPLTE.SaveToStream(Stream: TStream);
var
  PaletteSize: Word;
  LogPalette : TMaxLogPalette;
  I          : Integer;
  GamaChunk  : TChunkGama;
begin
  GamaChunk := Gama;

  {Free the stream for rewritting}
  fStream.Clear;

  {If the image does not contains palette, exit}
  if Owner.Owner.Palette = 0 then
    exit
  else
  begin
    {If it does, retrieve the palette}

    {First discover the palette size}
    GetObject(Bitmap.Palette, SizeOf(WORD), @PaletteSize);
    {Now get the entries}
    GetPaletteEntries(Bitmap.Palette, 0, PaletteSize,
      LogPalette.palpalentry);

    {Now write the entries to the stream}
    FOR I := 0 TO PaletteSize - 1 DO
    With LogPalette do
    begin
      {Test if uses gamma}
      if Assigned(GamaChunk) then
      begin
        fStream.Write(GamaChunk.InverseTable[palPalEntry[i].peRed], 1);
        fStream.Write(GamaChunk.InverseTable[palPalEntry[i].peGreen], 1);
        fStream.Write(GamaChunk.InverseTable[palPalEntry[i].peBlue], 1);
      end
      else
      begin
        fStream.Write(palPalEntry[i].peRed, 1);
        fStream.Write(palPalEntry[i].peGreen, 1);
        fStream.Write(palPalEntry[i].peBlue, 1);
      end;
    end;

  end;

  {Call default writting}
  inherited;
end;

{:Copy interlaced data into the current image}
procedure TChunkIDAT.DecodeInterlacedRow(ImageData: Pointer; Data: pByteArray;
  ColStart, ColIncrement, RowBytes, Pass: Integer; GamaChunk: TChunkGama);
var
  J, I: Integer;
begin
  I := ColStart;
  J := 0;

  {Test for color type}
  CASE IHDR.ColorType of
    Palette, Grayscale:
    {Test for bit depth}
    CASE IHDR.BitDepth of
      2: {2 bits per pixel, not supported by TBitmap, so move to 4 bits}
        ConvertBits([@Data[0]], ImageData, IHDR.Width, PassMask[Pass], 2, 4);
      4: {4 bits per pixel}
        ConvertBits([@Data[0]], ImageData, IHDR.Width, PassMask[Pass], 4, 4);
      1: {1 bit per pixel}
        ConvertBits([@Data[0]], ImageData, IHDR.Width, PassMask[Pass], 1, 1);
      8: {1 byte per pixel}
      repeat
        pByteArray(ImageData)^[I] := Data^[J];
        inc(J);
        inc(I, ColIncrement);
      until J >= RowBytes;
     16:  {Grayscale interlaced images with 2 bytes per sample}
      repeat
        pByteArray(ImageData)^[I] := Data^[J];
        inc(J, 2);
        inc(I, ColIncrement);
      until J >= RowBytes;
    END;
    RGB:
    {Test for bit depth}
    CASE IHDR.BitDepth of
      8:   {1 byte per R, G, B}
      repeat
        with PRGBLine(ImageData)^[I] do
        begin
          rgbtRed := Data^[J];
          rgbtGreen := Data^[J + 1];
          rgbtBlue := Data^[J + 2];
          {Gamma correction}
          if Assigned(GamaChunk) then
          begin
            rgbtRed := GamaChunk.GammaTable[rgbtRed];
            rgbtGreen := GamaChunk.GammaTable[rgbtGreen];
            rgbtBlue := GamaChunk.GammaTable[rgbtBlue];
          end;
        end;
        inc(J, 3);
        inc(I, ColIncrement);
      until J >= RowBytes;
     16:   {2 bytes per R, G, B}
      repeat
        with PRGBLine(ImageData)^[I] do
        begin
          rgbtRed := Data^[J];
          rgbtGreen := Data^[J + 2];
          rgbtBlue := Data^[J + 4];
          {Gamma correction}
          if Assigned(GamaChunk) then
          begin
            rgbtRed := GamaChunk.GammaTable[rgbtRed];
            rgbtGreen := GamaChunk.GammaTable[rgbtGreen];
            rgbtBlue := GamaChunk.GammaTable[rgbtBlue];
          end;
        end;
        inc(J, 6);
        inc(I, ColIncrement);
      until J >= RowBytes;
    end;
    RGBALPHA:
    {Test for bit depth}
    CASE IHDR.BitDepth of
      8:   {1 byte per R, G, B, Alpha}
      repeat
        with PRGBLine(ImageData)^[I] do
        begin
          rgbtRed := Data^[J];
          rgbtGreen := Data^[J + 1];
          rgbtBlue := Data^[J + 2];
          {Gamma correction}
          if Assigned(GamaChunk) then
          begin
            rgbtRed := GamaChunk.GammaTable[rgbtRed];
            rgbtGreen := GamaChunk.GammaTable[rgbtGreen];
            rgbtBlue := GamaChunk.GammaTable[rgbtBlue];
          end;
        end;
        inc(J, 4);
        inc(I, ColIncrement);
      until J >= RowBytes;
     16:   {2 bytes per R, G, B, Alpha}
      repeat
        with PRGBLine(ImageData)^[I] do
        begin
          rgbtRed := Data^[J];
          rgbtGreen := Data^[J + 2];
          rgbtBlue := Data^[J + 4];
          {Gamma correction}
          if Assigned(GamaChunk) then
          begin
            rgbtRed := GamaChunk.GammaTable[rgbtRed];
            rgbtGreen := GamaChunk.GammaTable[rgbtGreen];
            rgbtBlue := GamaChunk.GammaTable[rgbtBlue];
          end;
        end;
        inc(J, 8);
        inc(I, ColIncrement);
      until J >= RowBytes;

    END;