bspngimage.pas

BusinessSkinForm的控件包与实例

procedure TbsPngLayerIHDR.Assign(Source: TbsPngLayer);
begin
  if Source is TbsPngLayerIHDR then
  begin
    IHDRData := TbsPngLayerIHDR(Source).IHDRData;
    PrepareImageData();
    CopyMemory(ImageData, TbsPngLayerIHDR(Source).ImageData,
      BytesPerRow * Integer(Height));
    CopyMemory(ImageAlpha, TbsPngLayerIHDR(Source).ImageAlpha,
      Integer(Width) * Integer(Height));
    BitmapInfo.bmiColors := TbsPngLayerIHDR(Source).BitmapInfo.bmiColors;
    CopyPalette(TbsPngLayerIHDR(Source).ImagePalette, ImagePalette);
  end;
end;

procedure TbsPngLayerIHDR.FreeImageData;
begin
  {Free old image data}
  if ImageHandle <> 0  then DeleteObject(ImageHandle);
  if ImageDC     <> 0  then DeleteDC(ImageDC);
  if ImageAlpha <> nil then FreeMem(ImageAlpha);
  if ImagePalette <> 0 then DeleteObject(ImagePalette);
  if ExtraImageData <> nil then FreeMem(ExtraImageData);
  ImageHandle := 0; ImageDC := 0; ImageAlpha := nil; ImageData := nil;
  ImagePalette := 0; ExtraImageData := nil;
end;

function TbsPngLayerIHDR.LoadFromStream(Stream: TStream; const PngLayerName: TbsPngLayerName;
  Size: Integer): Boolean;
begin
  Result := inherited LoadFromStream(Stream, PngLayerName, Size);
  if not Result then Exit;
  if (fDataSize < SIZEOF(TIHdrData)) then
  begin
    Result := False;
    exit;
  end;

  IHDRData := pIHDRData(fData)^;
  IHDRData.Width := ByteSwap(IHDRData.Width);
  IHDRData.Height := ByteSwap(IHDRData.Height);

  if (IHDRData.Width > High(Word)) or (IHDRData.Height > High(Word)) then
  begin
    Result := False;
    exit;
  end; 
  if (IHDRData.CompressionMethod <> 0) then
  begin
    Result := False;
    exit;
  end;
  if (IHDRData.InterlaceMethod <> 0) and (IHDRData.InterlaceMethod <> 1) then
  begin
    Result := False;
    exit;
  end;
  Owner.InterlaceMethod := TbsInterlaceMethod(IHDRData.InterlaceMethod);
  PrepareImageData();
end;

function TbsPngLayerIHDR.SaveToStream(Stream: TStream): Boolean;
begin
  if BitDepth = 2 then BitDepth := 4;
  ResizeData(SizeOf(TIHDRData));
  pIHDRData(fData)^ := IHDRData;
  pIHDRData(fData)^.Width := ByteSwap(pIHDRData(fData)^.Width);
  pIHDRData(fData)^.Height := ByteSwap(pIHDRData(fData)^.Height);
  pIHDRData(fData)^.InterlaceMethod := Byte(Owner.InterlaceMethod);
  Result := inherited SaveToStream(Stream);
end;

function TbsPngLayerIHDR.CreateGrayscalePalette(Bitdepth: Integer): HPalette;
var
  j: Integer;
  palEntries: TMaxLogPalette;
begin
  if Bitdepth = 16 then Bitdepth := 8;
  fillchar(palEntries, sizeof(palEntries), 0);
  palEntries.palVersion := $300;
  palEntries.palNumEntries := 1 shl Bitdepth;
  for j := 0 to palEntries.palNumEntries - 1 do
  begin
    palEntries.palPalEntry[j].peRed  :=
      fOwner.GammaTable[MulDiv(j, 255, palEntries.palNumEntries - 1)];
    palEntries.palPalEntry[j].peGreen := palEntries.palPalEntry[j].peRed;
    palEntries.palPalEntry[j].peBlue := palEntries.palPalEntry[j].peRed;
  end;
  Result := CreatePalette(pLogPalette(@palEntries)^);
end;

procedure TbsPngLayerIHDR.PaletteToDIB(Palette: HPalette);
var
  j: Integer;
  palEntries: TMaxLogPalette;
begin
  Fillchar(palEntries, sizeof(palEntries), #0);
  BitmapInfo.bmiHeader.biClrUsed := GetPaletteEntries(Palette, 0, 256, palEntries.palPalEntry[0]);
  for j := 0 to BitmapInfo.bmiHeader.biClrUsed - 1 do
  begin
    BitmapInfo.bmiColors[j].rgbBlue  := palEntries.palPalEntry[j].peBlue;
    BitmapInfo.bmiColors[j].rgbRed   := palEntries.palPalEntry[j].peRed;
    BitmapInfo.bmiColors[j].rgbGreen := palEntries.palPalEntry[j].peGreen;
  end;
end;

procedure TbsPngLayerIHDR.PrepareImageData();
  procedure SetInfo(const Bitdepth: Integer; const Palette: Boolean);
  begin
    HasPalette := Palette;
    with BitmapInfo.bmiHeader do
    begin
      biSize := sizeof(TBitmapInfoHeader);
      biHeight := Height;
      biWidth := Width;
      biPlanes := 1;
      biBitCount := BitDepth;
      biCompression := BI_RGB;
    end;
  end;
begin
  Fillchar(BitmapInfo, sizeof(TMaxBitmapInfo), #0);
  FreeImageData();
  case ColorType of
    COLOR_GRAYSCALE, COLOR_PALETTE, COLOR_GRAYSCALEALPHA:
      case BitDepth of
        1, 4, 8: SetInfo(BitDepth, TRUE);
        2      : SetInfo(4, TRUE);
        16     : SetInfo(8, TRUE);
      end;
    COLOR_RGB, COLOR_RGBALPHA:  SetInfo(24, FALSE);
  end;

  BytesPerRow := (((BitmapInfo.bmiHeader.biBitCount * Width) + 31)
    and not 31) div 8;

  if (ColorType = COLOR_RGBALPHA) or (ColorType = COLOR_GRAYSCALEALPHA) then
  begin
    GetMem(ImageAlpha, Integer(Width) * Integer(Height));
    FillChar(ImageAlpha^, Integer(Width) * Integer(Height), #0);
  end;

  if (BitDepth = 16) then
  begin
    GetMem(ExtraImageData, BytesPerRow * Integer(Height));
    FillChar(ExtraImageData^, BytesPerRow * Integer(Height), #0);
  end;

  ImageDC := CreateCompatibleDC(0);
  Self.Owner.Canvas.Handle := ImageDC;

  if HasPalette then
  begin
    if ColorType = COLOR_PALETTE then
      ImagePalette := CreateHalfTonePalette(ImageDC)
    else
      ImagePalette := CreateGrayscalePalette(Bitdepth);
    ResizePalette(ImagePalette, 1 shl BitmapInfo.bmiHeader.biBitCount);
    BitmapInfo.bmiHeader.biClrUsed := 1 shl BitmapInfo.bmiHeader.biBitCount;
    SelectPalette(ImageDC, ImagePalette, False);
    RealizePalette(ImageDC);
    PaletteTODIB(ImagePalette);
  end;

  ImageHandle := CreateDIBSection(ImageDC, pBitmapInfo(@BitmapInfo)^,
    DIB_RGB_COLORS, ImageData, 0, 0);
  SelectObject(ImageDC, ImageHandle);

  fillchar(ImageData^, BytesPerRow * Integer(Height), 0);
end;

{TbsPngLayertRNS}

procedure TbsPngLayertRNS.SetTransparentColor(const Value: ColorRef);
var
  i: Byte;
  LookColor: TRGBQuad;
begin
  Fillchar(PaletteValues, SizeOf(PaletteValues), #0);
  fBitTransparency := True;
  with Header do
    case ColorType of
      COLOR_GRAYSCALE:
      begin
        Self.ResizeData(2);
        pWord(@PaletteValues[0])^ := ByteSwap16(GetRValue(Value));
      end;
      COLOR_RGB:
      begin
        Self.ResizeData(6);
        pWord(@PaletteValues[0])^ := ByteSwap16(GetRValue(Value));
        pWord(@PaletteValues[2])^ := ByteSwap16(GetGValue(Value));
        pWord(@PaletteValues[4])^ := ByteSwap16(GetBValue(Value));
      end;
      COLOR_PALETTE:
      begin
        LookColor.rgbRed := GetRValue(Value);
        LookColor.rgbGreen := GetGValue(Value);
        LookColor.rgbBlue := GetBValue(Value);
        for i := 0 to BitmapInfo.bmiHeader.biClrUsed - 1 do
          if CompareMem(@BitmapInfo.bmiColors[i], @LookColor, 3) then
            Break;
        Fillchar(PaletteValues, i, 255);
        Self.ResizeData(i + 1)
      end;
    end;
end;

function TbsPngLayertRNS.GetTransparentColor: ColorRef;
var
  PalettePngLayer: TbsPngLayerPLTE;
  i: Integer;
  Value: Byte;
begin
  Result := 0;
  with Header do
    case ColorType of
      COLOR_GRAYSCALE:
      begin
        Value := BitmapInfo.bmiColors[PaletteValues[1]].rgbRed;
        Result := RGB(Value, Value, Value);
      end;
      COLOR_RGB:
        Result := RGB(fOwner.GammaTable[PaletteValues[1]],
        fOwner.GammaTable[PaletteValues[3]],
        fOwner.GammaTable[PaletteValues[5]]);
      COLOR_PALETTE:
      begin
        PalettePngLayer := Owner.PngLayers.ItemFromClass(TbsPngLayerPLTE) as TbsPngLayerPLTE;
        for i := 0 to Self.DataSize - 1 do
          if PaletteValues[i] = 0 then
            with PalettePngLayer.GetPaletteItem(i) do
            begin
              Result := RGB(rgbRed, rgbGreen, rgbBlue);
              break
            end
      end;
    end;
end;

function TbsPngLayertRNS.SaveToStream(Stream: TStream): Boolean;
begin
  if DataSize <= 256 then
    CopyMemory(fData, @PaletteValues[0], DataSize);
  Result := inherited SaveToStream(Stream);
end;

procedure TbsPngLayertRNS.Assign(Source: TbsPngLayer);
begin
  CopyMemory(@PaletteValues[0], @TbsPngLayerTrns(Source).PaletteValues[0], 256);
  fBitTransparency := TbsPngLayerTrns(Source).fBitTransparency;
  inherited Assign(Source);
end;

function TbsPngLayertRNS.LoadFromStream(Stream: TStream; const PngLayerName: TbsPngLayerName;
  Size: Integer): Boolean;
var
  i, Differ255: Integer;
begin
  Result := inherited LoadFromStream(Stream, PngLayerName, Size);

  if not Result then Exit;

  Fillchar(PaletteValues[0], 256, 255);
  CopyMemory(@PaletteValues[0], fData, Size);
  case Header.ColorType of
    COLOR_RGB, COLOR_GRAYSCALE: fBitTransparency := True;
    COLOR_PALETTE:
    begin
      Differ255 := 0;
      for i := 0 to Size - 1 do
        if PaletteValues[i] <> 255 then inc(Differ255);
      fBitTransparency := (Differ255 = 1);
    end;
  end;
end;

procedure TbsPngLayerIDAT.PreparePalette;
var
  Entries: Word;
  j      : Integer;
  palEntries: TMaxLogPalette;
begin
  with Header do
    if (ColorType = COLOR_GRAYSCALE) or (ColorType = COLOR_GRAYSCALEALPHA) then
    begin
      Entries := (1 shl Byte(BitmapInfo.bmiHeader.biBitCount));
      Fillchar(palEntries, sizeof(palEntries), #0);
      palEntries.palVersion := $300;
      palEntries.palNumEntries := Entries;
       FOR j := 0 TO Entries - 1 DO
        with palEntries.palPalEntry[j] do
        begin
          peRed := fOwner.GammaTable[MulDiv(j, 255, Entries - 1)];
          peGreen := peRed;
          peBlue := peRed;
        end;
        Owner.SetPalette(CreatePalette(pLogPalette(@palEntries)^));
    end;
end;

function TbsPngLayerIDAT.IDATZlibRead(var ZLIBStream: TZStreamRec2;
  Buffer: Pointer; Count: Integer; var EndPos: Integer;
  var crcfile: Cardinal): Integer;
var
  ProcResult : Integer;
  IDATHeader : Array[0..3] of char;
  IDATCRC    : Cardinal;
begin
  with ZLIBStream, ZLIBStream.zlib do
  begin
    next_out := Buffer;
    avail_out := Count;
    while avail_out > 0 do
    begin
      if (fStream.Position = EndPos) and (avail_out > 0) and
        (avail_in = 0) then
      begin
        fStream.Read(IDATCRC, 4);
        if crcfile xor $ffffffff <> Cardinal(ByteSwap(IDATCRC)) then
          begin
            Result := -1;
            exit;
          end;
        fStream.Read(EndPos, 4);
        fStream.Read(IDATHeader[0], 4);
        if IDATHeader <> 'IDAT' then
        begin
          result := -1;
          exit;
        end;
          crcfile := update_crc($ffffffff, @IDATHeader[0], 4);
        EndPos := fStream.Position + ByteSwap(EndPos);
      end;
      if avail_in = 0 then
      begin
        if fStream.Position + ZLIBAllocate > EndPos then
          avail_in := fStream.Read(Data^, EndPos - fStream.Position)
         else
          avail_in := fStream.Read(Data^, ZLIBAllocate);
        crcfile := update_crc(crcfile, Data, avail_in);

        if avail_in = 0 then
        begin
          Result := Count - avail_out;
          Exit;
        end;
        next_in := Data;
      end;

      ProcResult := inflate(zlib, 0);

      if (ProcResult < 0) then
      begin
        Result := -1;
        exit;
      end;
    end;
  end;

  Result := Count;
end;

{TbsPngLayerIDAT}

const
  RowStart: array[0..6] of Integer = (0, 0, 4, 0, 2, 0, 1);
  ColumnStart: array[0..6] of Integer = (0, 4, 0, 2, 0, 1, 0);
  RowIncrement: array[0..6] of Integer = (8, 8, 8, 4, 4, 2, 2);
  ColumnIncrement: array[0..6] of Integer = (8, 8, 4, 4, 2, 2, 1);

{Copy interlaced images with 1 byte for R, G, B}
procedure TbsPngLayerIDAT.CopyInterlacedRGB8(const Pass: Byte;
  Src, Dest, Trans, Extra: pChar);
var
  Col: Integer;
begin
  Col := ColumnStart[Pass];
  Dest := pChar(Longint(Dest) + Col * 3);
  repeat
    Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest);
    Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Dest);
    Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src)    )^]; inc(Dest);

    inc(Src, 3);
    inc(Dest, ColumnIncrement[Pass] * 3 - 3);
    inc(Col, ColumnIncrement[Pass]);
  until Col >= ImageWidth;
end;

procedure TbsPngLayerIDAT.CopyInterlacedRGB16(const Pass: Byte;
  Src, Dest, Trans, Extra: pChar);
var
  Col: Integer;
begin
  {Get first column and enter in loop}
  Col := ColumnStart[Pass];
  Dest := pChar(Longint(Dest) + Col * 3);
  repeat
    Byte(Dest^) := Owner.GammaTable[pByte(Longint(Src) + 4)^]; inc(Dest);
    Byte(Dest^) := Owner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest);
    Byte(Dest^) := Owner.GammaTable[pByte(Longint(Src)    )^]; inc(Dest);

    Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 5)^]; inc(Extra);
    Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 3)^]; inc(Extra);
    Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Extra);

    inc(Src, 6);
    inc(Dest, ColumnIncrement[Pass] * 3 - 3);
    inc(Col, ColumnIncrement[Pass]);
  until Col >= ImageWidth;
end;

procedure TbsPngLayerIDAT.CopyInterlacedPalette148(const Pass: Byte;
  Src, Dest, Trans, Extra: pChar);