bspngimage.pas

BusinessSkinForm的控件包与实例

function TbsPngPointerList.Remove(Value: Pointer): Pointer;
var
  I, Position: Integer;
begin
  Position := -1;
  FOR I := 0 TO Count - 1 DO
    if Value = Item[I] then Position := I;
  if Position >= 0 then
  begin
    Result := Item[Position];
    Dec(fCount);
    if Position < Integer(FCount) then
      System.Move(fMemory^[Position + 1], fMemory^[Position],
      (Integer(fCount) - Position) * SizeOf(Pointer));
  end {if Position >= 0} else Result := nil
end;

procedure TbsPngPointerList.Add(Value: Pointer);
begin
  Count := Count + 1;
  Item[Count - 1] := Value;
end;

destructor TbsPngPointerList.Destroy;
begin
  if fMemory <> nil then
    FreeMem(fMemory, fCount * sizeof(Pointer));
  inherited Destroy;
end;

function TbsPngPointerList.GetItem(Index: Cardinal): Pointer;
begin
  if (Index <= Count - 1) then
    Result := fMemory[Index]
  else
    Result := nil;
end;

procedure TbsPngPointerList.Insert(Value: Pointer; Position: Cardinal);
begin
  if (Position < Count) or (Count = 0) then
  begin
    SetSize(Count + 1);
    if Position < Count then
      System.Move(fMemory^[Position], fMemory^[Position + 1],
        (Count - Position - 1) * SizeOf(Pointer));
    Item[Position] := Value;
  end;
end;

procedure TbsPngPointerList.SetItem(Index: Cardinal; const Value: Pointer);
begin
  if (Index <= Count - 1) then
    fMemory[Index] := Value
end;

procedure TbsPngPointerList.SetSize(const Size: Cardinal);
begin
  if (fMemory = nil) and (Size > 0) then
    GetMem(fMemory, Size * SIZEOF(Pointer))
  else
    if Size > 0 then
      ReallocMem(fMemory, Size * SIZEOF(Pointer))
    else
    begin
      FreeMem(fMemory);
      fMemory := nil;
    end;
  fCount := Size;
end;

{TbsPngList}

function TbsPngList.FindPngLayer(PngLayerClass: TbsPngLayerClass): TbsPngLayer;
var
  i: Integer;
begin
  Result := nil;
  for i := 0 to Count - 1 do
    if Item[i] is PngLayerClass then
    begin
      Result := Item[i];
      Break
    end
end;

procedure TbsPngList.RemovePngLayer(PngLayer: TbsPngLayer);
begin
  Remove(PngLayer);
  PngLayer.Free
end;

function TbsPngList.Add(PngLayerClass: TbsPngLayerClass): TbsPngLayer;
var
  IHDR: TbsPngLayerIHDR;
  IEND: TbsPngLayerIEND;

  IDAT: TbsPngLayerIDAT;
  PLTE: TbsPngLayerPLTE;
begin
  Result := nil; 
  if ((PngLayerClass = TbsPngLayerIHDR) or (PngLayerClass = TbsPngLayerIDAT) or
    (PngLayerClass = TbsPngLayerPLTE) or (PngLayerClass = TbsPngLayerIEND)) and not
    (Owner.BeingCreated)
    then
      begin
      end
  else if ((PngLayerClass = TbsPngLayergAMA) and (ItemFromClass(TbsPngLayergAMA) <> nil)) or
     ((PngLayerClass = TbsPngLayertRNS) and (ItemFromClass(TbsPngLayertRNS) <> nil)) or
     ((PngLayerClass = TbsPngLayerpHYs) and (ItemFromClass(TbsPngLayerpHYs) <> nil)) then
     begin
     end
  else if ((ItemFromClass(TbsPngLayerIEND) = nil) or
    (ItemFromClass(TbsPngLayerIHDR) = nil)) and not Owner.BeingCreated then
    begin
    end
  else
  begin
    IHDR := ItemFromClass(TbsPngLayerIHDR) as TbsPngLayerIHDR;
    IEND := ItemFromClass(TbsPngLayerIEND) as TbsPngLayerIEND;
    Result := PngLayerClass.Create(Owner);
    if (PngLayerClass = TbsPngLayergAMA) or (PngLayerClass = TbsPngLayerpHYs) or
      (PngLayerClass = TbsPngLayerPLTE) then
      Insert(Result, IHDR.Index + 1)
    else if (PngLayerClass = TbsPngLayerIEND) then
      Insert(Result, Count)
    else if (PngLayerClass = TbsPngLayerIHDR) then
      Insert(Result, 0)
    else if (PngLayerClass = TbsPngLayertRNS) then
    begin
      IDAT := ItemFromClass(TbsPngLayerIDAT) as TbsPngLayerIDAT;
      PLTE := ItemFromClass(TbsPngLayerPLTE) as TbsPngLayerPLTE;
      if Assigned(PLTE) then
        Insert(Result, PLTE.Index + 1)
      else if Assigned(IDAT) then
        Insert(Result, IDAT.Index)
      else
        Insert(Result, IHDR.Index + 1)
    end
    else
      Insert(Result, IEND.Index);
  end 
end;

function TbsPngList.GetItem(Index: Cardinal): TbsPngLayer;
begin
  Result := inherited GetItem(Index);
end;

function TbsPngList.ItemFromClass(PngLayerClass: TbsPngLayerClass): TbsPngLayer;
var
  i: Integer;
begin
  Result := nil;
  FOR i := 0 TO Count - 1 DO
    if Item[i] is PngLayerClass then
    begin
      Result := Item[i];
      break;
    end {if}
end;

{TbsPngLayer}

procedure TbsPngLayer.ResizeData(const NewSize: Cardinal);
begin
  fDataSize := NewSize;
  ReallocMem(fData, NewSize + 1);
end;

function TbsPngLayer.GetIndex: Integer;
var
  i: Integer;
begin
  Result := -1; 
  FOR i := 0 TO Owner.PngLayers.Count - 1 DO
    if Owner.PngLayers.Item[i] = Self then
    begin
      Result := i;
      exit;
    end;
end;

function TbsPngLayer.GetHeader: TbsPngLayerIHDR;
begin
  Result := Owner.PngLayers.Item[0] as TbsPngLayerIHDR;
end;

procedure TbsPngLayer.Assign(Source: TbsPngLayer);
begin
  fName := Source.fName;
  ResizeData(Source.fDataSize);
  if fDataSize > 0 then CopyMemory(fData, Source.fData, fDataSize);
end;

constructor TbsPngLayer.Create(Owner: TbsPngImage);
var
  PngLayerName: String;
begin
  inherited Create;
  PngLayerName := System.Copy(ClassName, Length('TbsPngLayer') + 1, Length(ClassName));
  if Length(PngLayerName) = 4 then CopyMemory(@fName[0], @PngLayerName[1], 4);
  GetMem(fData, 1);
  fDataSize := 0;
  fOwner := Owner;
end;

destructor TbsPngLayer.Destroy;
begin
  FreeMem(fData, fDataSize + 1);
  inherited Destroy;
end;

function TbsPngLayer.GetPngLayerName: String;
begin
  Result := fName
end;

class function TbsPngLayer.GetName: String;
begin
  Result := System.Copy(ClassName, Length('TbsPngLayer') + 1, Length(ClassName));
end;

function TbsPngLayer.SaveData(Stream: TStream): Boolean;
var
  PngLayerSize, PngLayerCRC: Cardinal;
begin
  PngLayerSize := ByteSwap(DataSize);
  Stream.Write(PngLayerSize, 4);
  Stream.Write(fName, 4);
  if DataSize > 0 then Stream.Write(Data^, DataSize);
  PngLayerCRC := update_crc($ffffffff, @fName[0], 4);
  PngLayerCRC := Byteswap(update_crc(PngLayerCRC, Data, DataSize) xor $ffffffff);
  Stream.Write(PngLayerCRC, 4);
  Result := TRUE;
end;

function TbsPngLayer.SaveToStream(Stream: TStream): Boolean;
begin
  Result := SaveData(Stream)
end;

function TbsPngLayer.LoadFromStream(Stream: TStream; const PngLayerName: TbsPngLayerName;
  Size: Integer): Boolean;
var
  CheckCRC: Cardinal;
  RightCRC: Cardinal;
begin
  ResizeData(Size);
  if Size > 0 then Stream.Read(fData^, Size);
  Stream.Read(CheckCRC, 4);
  CheckCrc := ByteSwap(CheckCRC);
   RightCRC := update_crc($ffffffff, @PngLayerName[0], 4);
   RightCRC := update_crc(RightCRC, fData, Size) xor $ffffffff;
   Result := RightCRC = CheckCrc;
   if not Result then
   begin
     exit;
   end;
end;

{TbsPngLayertIME}

function TbsPngLayertIME.LoadFromStream(Stream: TStream;
  const PngLayerName: TbsPngLayerName; Size: Integer): Boolean;
begin
  Result := inherited LoadFromStream(Stream, PngLayerName, Size);
  if not Result or (Size <> 7) then exit; {Size must be 7}
  fYear := ((pByte(Longint(Data) )^) * 256)+ (pByte(Longint(Data) + 1)^);
  fMonth := pByte(Longint(Data) + 2)^;
  fDay := pByte(Longint(Data) + 3)^;
  fHour := pByte(Longint(Data) + 4)^;
  fMinute := pByte(Longint(Data) + 5)^;
  fSecond := pByte(Longint(Data) + 6)^;
end;

procedure TbsPngLayertIME.Assign(Source: TbsPngLayer);
begin
  fYear := TbsPngLayertIME(Source).fYear;
  fMonth := TbsPngLayertIME(Source).fMonth;
  fDay := TbsPngLayertIME(Source).fDay;
  fHour := TbsPngLayertIME(Source).fHour;
  fMinute := TbsPngLayertIME(Source).fMinute;
  fSecond := TbsPngLayertIME(Source).fSecond;
end;

function TbsPngLayertIME.SaveToStream(Stream: TStream): Boolean;
begin
  ResizeData(7);  
  pWord(Data)^ := ByteSwap16(Year);
  pByte(Longint(Data) + 2)^ := Month;
  pByte(Longint(Data) + 3)^ := Day;
  pByte(Longint(Data) + 4)^ := Hour;
  pByte(Longint(Data) + 5)^ := Minute;
  pByte(Longint(Data) + 6)^ := Second;
  Result := inherited SaveToStream(Stream);
end;

{TbsPngLayerztX}

function TbsPngLayerzTXt.LoadFromStream(Stream: TStream;
  const PngLayerName: TbsPngLayerName; Size: Integer): Boolean;
var
  ErrorOutput: String;
  CompressionMethod: Byte;
  Output: Pointer;
  OutputSize: Integer;
begin
  Result := inherited LoadFromStream(Stream, PngLayerName, Size);
  if not Result or (Size < 4) then exit;
  fKeyword := PChar(Data);
  if Longint(fKeyword) = 0 then
    CompressionMethod := pByte(Data)^
  else
    CompressionMethod := pByte(Longint(fKeyword) + Length(fKeyword))^;
  fText := '';

  if CompressionMethod = 0 then
  begin
    Output := nil;
    if DecompressZLIB(PChar(Longint(Data) + Length(fKeyword) + 2),
      Size - Length(fKeyword) - 2, Output, OutputSize, ErrorOutput) then
    begin
      SetLength(fText, OutputSize);
      CopyMemory(@fText[1], Output, OutputSize);
    end;
    FreeMem(Output);
  end; 
end;

function TbsPngLayerztXt.SaveToStream(Stream: TStream): Boolean;
var
  Output: Pointer;
  OutputSize: Integer;
  ErrorOutput: String;
begin
  Output := nil;
  if fText = '' then fText := ' ';
  if CompressZLIB(@fText[1], Length(fText), Owner.CompressionLevel, Output,
    OutputSize, ErrorOutput) then
  begin
    ResizeData(Length(fKeyword) + 2 + OutputSize);
    Fillchar(Data^, DataSize, #0);
    if Keyword <> '' then
      CopyMemory(Data, @fKeyword[1], Length(Keyword));
    pByte(Ptr(Longint(Data) + Length(Keyword) + 1))^ := 0;
    if OutputSize > 0 then
      CopyMemory(Ptr(Longint(Data) + Length(Keyword) + 2), Output, OutputSize);
    Result := SaveData(Stream);
  end {if CompressZLIB(...} else Result := False;
  if Output <> nil then FreeMem(Output)
end;

{TbsPngLayertEXt}

procedure TbsPngLayertEXt.Assign(Source: TbsPngLayer);
begin
  fKeyword := TbsPngLayertEXt(Source).fKeyword;
  fText := TbsPngLayertEXt(Source).fText;
end;

function TbsPngLayertEXt.LoadFromStream(Stream: TStream;
  const PngLayerName: TbsPngLayerName; Size: Integer): Boolean;
begin
  Result := inherited LoadFromStream(Stream, PngLayerName, Size);
  if not Result or (Size < 3) then exit;
  fKeyword := PChar(Data);
  SetLength(fText, Size - Length(fKeyword) - 1);
  CopyMemory(@fText[1], Ptr(Longint(Data) + Length(fKeyword) + 1),
    Length(fText));
end;

function TbsPngLayertEXt.SaveToStream(Stream: TStream): Boolean;
begin
  ResizeData(Length(fKeyword) + 1 + Length(fText));
  Fillchar(Data^, DataSize, #0);
  if Keyword <> '' then
    CopyMemory(Data, @fKeyword[1], Length(Keyword));
  if Text <> '' then
    CopyMemory(Ptr(Longint(Data) + Length(Keyword) + 1), @fText[1],
      Length(Text));
  Result := inherited SaveToStream(Stream);
end;


{TbsPngLayerIHDR}

constructor TbsPngLayerIHDR.Create(Owner: TbsPngImage);
begin
  ImageHandle := 0;
  ImagePalette := 0;
  ImageDC := 0;
  inherited Create(Owner);
end;

destructor TbsPngLayerIHDR.Destroy;
begin
  FreeImageData();
  inherited Destroy;
end;

procedure CopyPalette(Source: HPALETTE; Destination: HPALETTE);
var
  PaletteSize: Integer;
  Entries: Array[Byte] of TPaletteEntry;
begin
  PaletteSize := 0;
  if GetObject(Source, SizeOf(PaletteSize), @PaletteSize) = 0 then Exit;
  if PaletteSize = 0 then Exit;
  ResizePalette(Destination, PaletteSize);
  GetPaletteEntries(Source, 0, PaletteSize, Entries);
  SetPaletteEntries(Destination, 0, PaletteSize, Entries);
end;