bspngimage.pas

BusinessSkinForm的控件包与实例

    procedure EncodeInterlacedPalette148(const Pass: Byte;
      Src, Dest, Trans: pChar);
    procedure EncodeInterlacedGrayscale16(const Pass: Byte;
      Src, Dest, Trans: pChar);
    procedure EncodeInterlacedRGBAlpha8(const Pass: Byte;
      Src, Dest, Trans: pChar);
    procedure EncodeInterlacedRGBAlpha16(const Pass: Byte;
      Src, Dest, Trans: pChar);
    procedure EncodeInterlacedGrayscaleAlpha8(const Pass: Byte;
      Src, Dest, Trans: pChar);
    procedure EncodeInterlacedGrayscaleAlpha16(const Pass: Byte;
      Src, Dest, Trans: pChar);
  public
    function LoadFromStream(Stream: TStream; const PngLayerName: TbsPngLayerName;
      Size: Integer): Boolean; override;
    function SaveToStream(Stream: TStream): Boolean; override;
  end;

  TbsPngLayertIME = class(TbsPngLayer)
  private
    fYear: Word;
    fMonth, fDay, fHour, fMinute, fSecond: Byte;
  public
    function LoadFromStream(Stream: TStream; const PngLayerName: TbsPngLayerName;
      Size: Integer): Boolean; override;
    function SaveToStream(Stream: TStream): Boolean; override;
    procedure Assign(Source: TbsPngLayer); override;
    property Year: Word read fYear write fYear;
    property Month: Byte read fMonth write fMonth;
    property Day: Byte read fDay write fDay;
    property Hour: Byte read fHour write fHour;
    property Minute: Byte read fMinute write fMinute;
    property Second: Byte read fSecond write fSecond;
  end;

  TbsPngLayertEXt = class(TbsPngLayer)
  private
    fKeyword, fText: String;
  public
    function LoadFromStream(Stream: TStream; const PngLayerName: TbsPngLayerName;
      Size: Integer): Boolean; override;
    function SaveToStream(Stream: TStream): Boolean; override;
    procedure Assign(Source: TbsPngLayer); override;
    property Keyword: String read fKeyword write fKeyword;
    property Text: String read fText write fText;
  end;

  TbsPngLayerzTXt = class(TbsPngLayertEXt)
    function LoadFromStream(Stream: TStream; const PngLayerName: TbsPngLayerName;
      Size: Integer): Boolean; override;
    function SaveToStream(Stream: TStream): Boolean; override;
  end;

procedure RegisterPngLayer(PngLayerClass: TbsPngLayerClass);
function update_crc(crc: Integer; buf: pByteArray; len: Integer): Cardinal;
function ByteSwap(const a: integer): integer;

{$ENDIF}

implementation

{$IFNDEF VER200}

var
  PngLayerClasses: TbsPngPointerList;
  crc_table: Array[0..255] of Cardinal;
  crc_table_computed: Boolean;

procedure DrawTransparentBitmap(dc: HDC; srcBits: Pointer;
  var srcHeader: TBitmapInfoHeader;
  srcBitmapInfo: pBitmapInfo; Rect: TRect; cTransparentColor: COLORREF);
var
  cColor:   COLORREF;
  bmAndBack, bmAndObject, bmAndMem: HBITMAP;
  bmBackOld, bmObjectOld, bmMemOld: HBITMAP;
  hdcMem, hdcBack, hdcObject, hdcTemp: HDC;
  ptSize, orgSize: TPOINT;
  OldBitmap, DrawBitmap: HBITMAP;
begin
  hdcTemp := CreateCompatibleDC(dc);

  DrawBitmap := CreateDIBitmap(dc, srcHeader, CBM_INIT, srcBits, srcBitmapInfo^,
    DIB_RGB_COLORS);
  OldBitmap := SelectObject(hdcTemp, DrawBitmap);

  OrgSize.x := abs(srcHeader.biWidth);
  OrgSize.y := abs(srcHeader.biHeight);
  ptSize.x := Rect.Right - Rect.Left;
  ptSize.y := Rect.Bottom - Rect.Top;

  hdcBack  := CreateCompatibleDC(dc);
  hdcObject := CreateCompatibleDC(dc);
  hdcMem   := CreateCompatibleDC(dc);

  bmAndBack  := CreateBitmap(ptSize.x, ptSize.y, 1, 1, nil);
  bmAndObject := CreateBitmap(ptSize.x, ptSize.y, 1, 1, nil);

  bmAndMem   := CreateCompatibleBitmap(dc, ptSize.x, ptSize.y);

  bmBackOld  := SelectObject(hdcBack, bmAndBack);
  bmObjectOld := SelectObject(hdcObject, bmAndObject);
  bmMemOld   := SelectObject(hdcMem, bmAndMem);

  cColor := SetBkColor(hdcTemp, cTransparentColor);

  StretchBlt(hdcObject, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0,
    orgSize.x, orgSize.y, SRCCOPY);

  SetBkColor(hdcTemp, cColor);

  BitBlt(hdcBack, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0,
       NOTSRCCOPY);

  BitBlt(hdcMem, 0, 0, ptSize.x, ptSize.y, dc, Rect.Left, Rect.Top,
       SRCCOPY);

  BitBlt(hdcMem, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, SRCAND);

  StretchBlt(hdcTemp, 0, 0, OrgSize.x, OrgSize.y, hdcBack, 0, 0,
    PtSize.x, PtSize.y, SRCAND);

  StretchBlt(hdcMem, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0,
    OrgSize.x, OrgSize.y, SRCPAINT);

  BitBlt(dc, Rect.Left, Rect.Top, ptSize.x, ptSize.y, hdcMem, 0, 0, SRCCOPY);

  DeleteObject(SelectObject(hdcBack, bmBackOld));
  DeleteObject(SelectObject(hdcObject, bmObjectOld));
  DeleteObject(SelectObject(hdcMem, bmMemOld));
  DeleteObject(SelectObject(hdcTemp, OldBitmap));

  DeleteDC(hdcMem);
  DeleteDC(hdcBack);
  DeleteDC(hdcObject);
  DeleteDC(hdcTemp);
end;

procedure make_crc_table;
var
  c: Cardinal;
  n, k: Integer;
begin
  for n := 0 to 255 do
  begin
    c := Cardinal(n);
    for k := 0 to 7 do
    begin
      if Boolean(c and 1) then
        c := $edb88320 xor (c shr 1)
      else
        c := c shr 1;
    end;
    crc_table[n] := c;
  end;
  crc_table_computed := true;
end;

function update_crc(crc: Integer; buf: pByteArray; len: Integer): Cardinal;
var
  c: Cardinal;
  n: Integer;
begin
  c := crc;
  if not crc_table_computed then make_crc_table;
  for n := 0 to len - 1 do
    c := crc_table[(c XOR buf^[n]) and $FF] XOR (c shr 8);
  Result := c;
end;

function PaethPredictor(a, b, c: Byte): Byte;
var
  pa, pb, pc: Integer;
begin
  pa := abs(b - c);
  pb := abs(a - c);
  pc := abs(a + b - c * 2);
  if (pa <= pb) and (pa <= pc) then
    Result := a
  else
    if pb <= pc then
      Result := b
    else
      Result := c;
end;

function ByteSwap(const a: integer): integer;
asm
  bswap eax
end;

function ByteSwap16(inp:word): word;
asm
  bswap eax
  shr   eax, 16
end;

function BytesForPixels(const Pixels: Integer; const ColorType,
  BitDepth: Byte): Integer;
begin
  case ColorType of
    COLOR_GRAYSCALE, COLOR_PALETTE:
      Result := (Pixels * BitDepth + 7) div 8;
    COLOR_RGB:
      Result := (Pixels * BitDepth * 3) div 8;
    COLOR_GRAYSCALEALPHA:
      Result := (Pixels * BitDepth * 2) div 8;
    COLOR_RGBALPHA:
      Result := (Pixels * BitDepth * 4) div 8;
    else
      Result := 0;
  end; 
end;

type
  pPngLayerClassInfo = ^TbsPngLayerClassInfo;
  TbsPngLayerClassInfo = record
    ClassName: TbsPngLayerClass;
  end;

procedure RegisterPngLayer(PngLayerClass: TbsPngLayerClass);
var
  NewClass: pPngLayerClassInfo;
begin
  if PngLayerClasses = nil then PngLayerClasses := TbsPngPointerList.Create(nil);
  new(NewClass);
  NewClass^.ClassName := PngLayerClass;
  PngLayerClasses.Add(NewClass);
end;

procedure FreePngLayerClassList;
var
  i: Integer;
begin
  if (PngLayerClasses <> nil) then
  begin
    FOR i := 0 TO PngLayerClasses.Count - 1 do
      Dispose(pPngLayerClassInfo(PngLayerClasses.Item[i]));
    PngLayerClasses.Free;
  end;
end;

procedure RegisterCommonPngLayers;
begin
  RegisterPngLayer(TbsPngLayerIEND);
  RegisterPngLayer(TbsPngLayerIHDR);
  RegisterPngLayer(TbsPngLayerIDAT);
  RegisterPngLayer(TbsPngLayerPLTE);
  RegisterPngLayer(TbsPngLayergAMA);
  RegisterPngLayer(TbsPngLayertRNS);
  RegisterPngLayer(TbsPngLayerpHYs);
  RegisterPngLayer(TbsPngLayertIME);
  RegisterPngLayer(TbsPngLayertEXt);
  RegisterPngLayer(TbsPngLayerzTXt);
end;

function CreateClassPngLayer(Owner: TbsPngImage; Name: TbsPngLayerName): TbsPngLayer;
var
  i       : Integer;
  NewPngLayer: TbsPngLayerClass;
begin
  NewPngLayer := TbsPngLayer;
  if Assigned(PngLayerClasses) then
    FOR i := 0 TO PngLayerClasses.Count - 1 DO
    begin
      if pPngLayerClassInfo(PngLayerClasses.Item[i])^.ClassName.GetName = Name then
      begin
        NewPngLayer := pPngLayerClassInfo(PngLayerClasses.Item[i])^.ClassName;
        break;
      end;
    end;
  Result := NewPngLayer.Create(Owner);
  Result.fName := Name;
end;

const
  ZLIBAllocate = High(Word);

function ZLIBInitInflate(Stream: TStream): TZStreamRec2;
begin
  Fillchar(Result, SIZEOF(TZStreamRec2), #0);
  with Result do
  begin
    GetMem(Data, ZLIBAllocate);
    fStream := Stream;
  end;
  InflateInit_(@Result.zlib, zlib_version, SIZEOF(z_stream));
end;

function ZLIBInitDeflate(Stream: TStream;
  Level: TbsCompressionlevel; Size: Cardinal): TZStreamRec2;
begin
  Fillchar(Result, SIZEOF(TZStreamRec2), #0);
  with Result do
  begin
    GetMem(Data, Size);
    fStream := Stream;
    ZLIB.next_out := Data;
    ZLIB.avail_out := Size;
  end;
  deflateInit_(@Result.zlib, Level, zlib_version, sizeof(z_stream));
end;

procedure ZLIBTerminateDeflate(var ZLIBStream: TZStreamRec2);
begin
  DeflateEnd(ZLIBStream.zlib);
  FreeMem(ZLIBStream.Data, ZLIBAllocate);
end;

procedure ZLIBTerminateInflate(var ZLIBStream: TZStreamRec2);
begin
  InflateEnd(ZLIBStream.zlib);
  FreeMem(ZLIBStream.Data, ZLIBAllocate);
end;

function DecompressZLIB(const Input: Pointer; InputSize: Integer;
  var Output: Pointer; var OutputSize: Integer;
  var ErrorOutput: String): Boolean;
var
  StreamRec : z_stream;
  Buffer    : Array[Byte] of Byte;
  InflateRet: Integer;
begin
  with StreamRec do
  begin
    Result := True;
    OutputSize := 0;
    FillChar(StreamRec, SizeOf(z_stream), #0);
    InflateInit_(@StreamRec, zlib_version, SIZEOF(z_stream));
    next_in := Input;
    avail_in := InputSize;
    repeat
      if (avail_out = 0) then
      begin
        next_out := @Buffer;
        avail_out := SizeOf(Buffer);
      end; 
      InflateRet := inflate(StreamRec, 0);
      if (InflateRet = Z_STREAM_END) or (InflateRet = 0) then
      begin
        inc(OutputSize, total_out);
        if Output = nil then
          GetMem(Output, OutputSize) else ReallocMem(Output, OutputSize);
        CopyMemory(Ptr(Longint(Output) + OutputSize - total_out),
          @Buffer, total_out);
      end
      else if InflateRet < 0 then
      begin
        Result := False;
        ErrorOutput := StreamRec.msg;
        InflateEnd(StreamRec);
        Exit;
      end;
    until InflateRet = Z_STREAM_END;
    InflateEnd(StreamRec);
  end;
end;

function CompressZLIB(Input: Pointer; InputSize, CompressionLevel: Integer;
  var Output: Pointer; var OutputSize: Integer;
  var ErrorOutput: String): Boolean;
var
  StreamRec : z_stream;
  Buffer    : Array[Byte] of Byte;
  DeflateRet: Integer;
begin
  with StreamRec do
  begin
    Result := True;
    FillChar(StreamRec, SizeOf(z_stream), #0);
    DeflateInit_(@StreamRec, CompressionLevel,zlib_version, SIZEOF(StreamRec));

    next_in := Input;
    avail_in := InputSize;

    while avail_in > 0 do
    begin
      if avail_out = 0 then
      begin
        next_out := @Buffer;
        avail_out := SizeOf(Buffer);
      end;

      DeflateRet := deflate(StreamRec, Z_FINISH);

      if (DeflateRet = Z_STREAM_END) or (DeflateRet = 0) then
      begin
        inc(OutputSize, total_out);
        if Output = nil then
          GetMem(Output, OutputSize) else ReallocMem(Output, OutputSize);

        CopyMemory(Ptr(Longint(Output) + OutputSize - total_out),
          @Buffer, total_out);
      end
      else if DeflateRet < 0 then
      begin
        Result := False;
        ErrorOutput := StreamRec.msg;
        DeflateEnd(StreamRec);
        Exit;
      end;

    end;
    DeflateEnd(StreamRec);
  end;
end;

{TbsPngPointerList}

constructor TbsPngPointerList.Create(AOwner: TbsPngImage);
begin
  inherited Create;
  fOwner := AOwner;
  fMemory := nil;
  fCount := 0;
end;