iepsd.pas

·ImageEn 2.3.0 ImageEn一组用于图像处理、查看和分析的Delphi控件。能够保存几种图像格式

  context.Stream:=Stream;
  context.IOParams:=IOParams;
  context.Layers:=layers;
  context.LoadLayers:=LoadLayers;
  context.XProgress:=Progress;
  context.MergedBitmap:=MergedBitmap;

  with context do
  begin

    thumbnailLoaded:=false;

    if assigned(XProgress.fOnProgress) then
      XProgress.fOnProgress(XProgress.Sender, 0);

    Stream.Read(header,sizeof(TPSDHeader));
    with header do
    begin
      Version:=IESwapWord(Version);
      Channels:=IESwapWord(Channels);
      Rows:=IESwapDWord(Rows);
      Columns:=IESwapDWord(Columns);
      Depth:=IESwapWord(Depth);
      Mode:=IESwapWord(Mode);
      if not CompareMem(@Signature,@MAGIK,4) or (Version<>1) or (Channels<1) or (Channels>24) or (Depth<1) or (Depth>16) or (Mode>9) then
      begin
        Progress.Aborting^:=true;
        exit;
      end;
    end;

    if assigned(MergedBitmap) and MergedBitmap.EncapsulatedFromTBitmap then
      MergedBitmap:=TIEBitmap.Create;

    IOParams.Width:=header.Columns;
    IOParams.Height:=header.Rows;
    IOParams.BitsPerSample:=header.Depth;
    IOParams.SamplesPerPixel:=header.Channels;
    IOParams.DpiX:=96;  // waiting for actual parameters
    IOParams.DpiY:=96;  // waiting for actual parameters

    // Read Color mode data section
    ReadColorMap(context);

    // Read Image resources section
    transpindex:=-1;  // no transp index
    ReadImageResources(context);

    // Read Layer and mask information section
    ReadLayerAndMaskInfo(context);

    // Read image data section (merged image)
    if ((not LoadLayers) or (layers=nil) or (layers.Count=0)) and assigned(MergedBitmap) and (not IOParams.GetThumbnail or not thumbnailLoaded) then
    begin
      compression:=GetSmallint(Stream);
      getmem(sizes,sizeof(word)*header.Channels*header.Rows);
      if compression=1 then
        Stream.Read(sizes^,sizeof(word)*header.Channels*header.Rows)
      else
        for i:=0 to header.Channels*header.Rows-1 do
          sizes[i]:=IESwapWord(IEBitmapRowLen(header.Columns, header.Depth, 8));
      cursize:=0;
      for i:=0 to header.Channels-1 do
        ReadImageData(Stream,MergedBitmap,header.Columns,header.Rows,header.Depth,header.mode,colormap,transpindex,compression,sizes,cursize,i);
      freemem(sizes);
    end;

    // free buffers
    if colormap<>nil then
      freemem(colormap);

    // process NativePixelFormat
    if (not IOParams.IsNativePixelFormat) and (layers<>nil) then
      for i:=0 to layers.Count-1 do
        with TIELayer(layers[i]) do
          if (Bitmap.PixelFormat<>ie24RGB) and (Bitmap.PixelFormat<>ie1g) and not IsMask then
            Bitmap.PixelFormat:=ie24RGB;
    if (not IOParams.IsNativePixelFormat) and assigned(MergedBitmap) then
      if (MergedBitmap.PixelFormat<>ie24RGB) and (MergedBitmap.PixelFormat<>ie1g) then
        MergedBitmap.PixelFormat:=ie24RGB;
  end;

  if context.MergedBitmap<>MergedBitmap then
  begin
    MergedBitmap.Assign(context.MergedBitmap);
    FreeAndNil(context.MergedBitmap);
  end;

end;


////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

const
  PIXELFORMAT2MODE:array [TIEPixelFormat] of integer = (1000,0,2,1,1,3,1000,4,3,9);

// put 16 bit signed value
procedure PutSmallint(Stream:TStream; value:smallint);
begin
  value:=IESwapWord(value);
  Stream.Write(value,2);
end;

// put 32 bit signed value
procedure PutLongint(Stream:TStream; value:longint);
begin
  value:=IESwapDWord(value);
  Stream.Write(value,4);
end;

procedure PutByte(Stream:TStream; value:byte);
begin
  Stream.Write(value,1);
end;

// put 16 bit signed value at specified position, restoring the previous one when exits
procedure PutSmallintAt(Stream:TStream; position:int64; value:smallint);
var
  prev:int64;
begin
  prev:=Stream.Position;
  Stream.Position:=position;
  value:=IESwapWord(value);
  Stream.Write(value,2);
  Stream.Position:=prev;
end;

// put 32 bit signed value at specified position, restoring the previous one when exits
procedure PutLongintAt(Stream:TStream; position:int64; value:longint);
var
  prev:int64;
begin
  prev:=Stream.Position;
  Stream.Position:=position;
  value:=IESwapDWord(value);
  Stream.Write(value,4);
  Stream.Position:=prev;
end;

procedure WriteAt(Stream:TStream; position:int64; const value; len:integer);
var
  prev:int64;
begin
  prev:=Stream.Position;
  Stream.Position:=position;
  Stream.Write(value,len);
  Stream.Position:=prev;
end;


procedure WriteColorMap(var context:TPSDWriterContext);
var
  colormap:PColorMap;
  i:integer;
begin
  with context do
  begin

    if mergedImage.PixelFormat = ie8p then
    begin
      // 256 values palette
      PutLongint(Stream,768);
      getmem(colormap,768);
      for i:=0 to 255 do
      begin
        colormap[0][i]:=mergedImage.Palette[i].r;
        colormap[1][i]:=mergedImage.Palette[i].g;
        colormap[2][i]:=mergedImage.Palette[i].b;
      end;
      Stream.Write(colormap[0][0],768);
      freemem(colormap);
    end
    else
    begin
      // empty section
      PutLongint(Stream,0);
    end;

  end;
end;

procedure WriteResource(Stream:TStream; ID:smallint; name:string; data:pointer; size:integer);
begin
  // align position
  if (Stream.Position and $1)<>0 then
    PutByte(Stream,0);
  // 8BIM
  Stream.Write(RESMAGIK[0],4);
  // ID
  PutSmallint(Stream,ID);
  // name
  PutSmallint(Stream,length(name));
  Stream.Write(name[1],length(name));
  // data
  PutLongint(Stream,size);
  Stream.Write(pbyte(data)^,size);
end;

procedure WriteThumbnailToBuffer(var context:TPSDWriterContext; var buf:pointer; var buflen:integer);
var
  ms:TMemoryStream;
  thumbinfo:TPSDThumbnailInfo;
  dummyParams:TIOParamsVals;
  dummyProgress:TProgressRec;
  dummyAbort:boolean;
begin
  with context do
  begin
    ms:=TMemoryStream.Create;

    // write empty header (because compressedsize is still not available)
    fillchar(thumbinfo,sizeof(TPSDThumbnailInfo),0);
    ms.Write(thumbinfo,sizeof(TPSDThumbnailInfo));

    // write jpeg image
    dummyParams:=TIOParamsVals.Create(nil);
    dummyAbort:=false;
    dummyProgress.fOnProgress:=nil;
    dummyProgress.Sender:=nil;
    dummyProgress.Aborting:=@dummyAbort;
    WriteJpegStream(ms, IOParams.EXIF_Bitmap, dummyParams, dummyProgress);
    dummyParams.Free;

    // write actual header
    ms.Position:=0;
    thumbinfo.format:=IESwapDWord(1);
    thumbinfo.width:=IESwapDWord(IOParams.EXIF_Bitmap.Width);
    thumbinfo.height:=IESwapDWord(IOParams.EXIF_Bitmap.Height);
    thumbinfo.widthbytes:=IESwapDWord(IOParams.EXIF_Bitmap.Width * 3);
    thumbinfo.size:=IESwapDWord(IOParams.EXIF_Bitmap.Width * IOParams.EXIF_Bitmap.Height * 3);
    thumbinfo.compressedsize:=ms.Size-sizeof(TPSDThumbnailInfo);
    thumbinfo.bitspixel:=24;
    thumbinfo.planes:=1;
    ms.Write(thumbinfo,sizeof(TPSDThumbnailInfo));

    // copy memory stream to memory buffer
    buflen:=ms.Size;
    getmem(buf, buflen);
    copymemory(buf,ms.Memory,buflen);
    ms.free;
  end;
end;

procedure WriteImageResources(var context:TPSDWriterContext);
var
  resinfo:TPSDResolutionInfo;
  ww:word;
  buf: pointer;
  buflen: integer;
  sizepos:int64;
begin
  with context do
  begin
    sizepos:=Stream.Position;
    PutLongint(Stream,0); // image resources size (now zero)

    // $03ED - Resolution information
    resinfo.hRes:=IESwapDWord(IOParams.DpiX*65536);
    resinfo.vRes:=IESwapDWord(IOParams.DpiY*65536);
    resinfo.hResUnit:=IESwapWord(1);    // 1=pixels per inch
    resinfo.vResUnit:=IESwapWord(1);    // 1=pixels per inch
    resinfo.WidthUnit:=IESwapWord(1);   // 1=in
    resinfo.HeightUnit:=IESwapWord(1);  // 1=in
    WriteResource( Stream, $03ED, '', @resinfo, sizeof(TPSDResolutionInfo) );

    // $0417 - Transparency index (Photoshop 6.0)
    // We uses index 255 for alpha channel. Colors that has the same index should be reindex to another similar index color.
    if mergedImage.PixelFormat=ie8p then
    begin
      ww:=IESwapWord(255);
      WriteResource( Stream, $0417, '', @ww, sizeof(word) );
    end;

    // $0404 - IPTC NAA
    IOParams.IPTC_Info.SaveToStandardBuffer(buf, buflen, false);
    if buflen>0 then
      WriteResource( Stream, $0404, '', buf, buflen );
    freemem(buf);

    // $040F - ICC Profile (Photoshop 5.0)
    if IOParams.InputICCProfile.RawLength>0 then
      WriteResource( Stream, $040F, '', IOParams.InputICCProfile.Raw, IOParams.InputICCProfile.RawLength );

    // $040C - Thumbnail (Photoshop 5.0)
    if (IOParams.EXIF_Bitmap<>nil) and not IOParams.EXIF_Bitmap.IsEmpty then
    begin
      WriteThumbnailToBuffer(context,buf,buflen);
      WriteResource( Stream, $040C, '', buf,buflen);
      freemem(buf);
    end;

    // 1060 - XMP
    if IOParams.XMP_Info<>'' then
      WriteResource( Stream, 1060, '', pchar(IOParams.XMP_Info), length(IOParams.XMP_Info)+1 ); // GIMP wants ZERO at the end

    PutLongintAt(Stream,sizepos,Stream.Size-sizepos-4);

  end;
end;

// outData must be already allocated (inLen*3)
procedure CompressBytes(inData:pbytearray; inLen:integer; outData:pbyte; var outLen:integer);
var
  n, rl: integer;
  si: shortint;
  bp: integer;
  procedure SavB;
  var
    qq: integer;
  begin
    // writes absolute bytes from bp to n-1
    qq := n - bp;
    if qq > 0 then
    begin
      // more bytes
      si := qq - 1;
      outData^:=si; inc(outData);                     // SafeStreamWrite(Stream, Aborting, si, 1);
      move(inData[bp],outData^,qq); inc(outData,qq);  // SafeStreamWrite(Stream, Aborting, pbyte(@inData[bp])^, qq);
      inc(outLen,qq+1);
    end;
  end;
begin
  outLen:=0;
  n := 0; // n is the initial position of the first group to compress
  bp := 0;
  while n < inLen do
  begin
    // look for equal bytes
    rl := 1;
    while ((n + rl) < inLen) and (inData[n] = inData[n + rl]) and (rl < 128) do
      inc(rl);
    if rl > 3 then
    begin
      SavB; // write absolute bytes from bp to n-1
      // replicates bytes
      si := -1 * (rl - 1);
      outData^:=si; inc(outData);         // SafeStreamWrite(Stream, Aborting, si, 1);
      outData^:=inData[n]; inc(outData);  // SafeStreamWrite(Stream, Aborting, inData[n], 1);
      inc(outLen,2);
      inc(n, rl);
      bp := n;
    end
    else if (n - bp) = 128 then
    begin
      SavB;
      bp := n;
    end
    else
      inc(n);
  end;
  SavB; // writes absolute bytes from bp to n-1
end;

type
  // specify saved sizes for each channel for each layer
  TSizes = array [0..10000000] of array [0..5] of integer;
  PSizes = ^TSizes;

// sizes can be null (in this case sizesIdx is unused)
// layerMask can be null
// if sizes is null supposes we are writing merged
// if we are writing merged and compressed then all channels lengths are grouped, while writing layers they are separated for each channel
procedure WritePixelData(var context:TPSDWriterContext; bitmap:TIEBitmap; layerMask:TIEBitmap; sizes:PSizes; sizesIdx:integer; doprogress:boolean);
var
  row,col:integer;
  pb,rb:pbyte;
  pw,wb:pword;
  pos1,pos2:int64;
  i,k:integer;
  rl:integer;
  channelCount:integer;
  bitmapWidth,bitmapHeight:integer;
  bitmapPixelFormat:TIEPixelFormat;
  rowbuf,cmpbuf:pbyte;
  actlen,cmplen:integer;

  procedure WriteRow;
  begin
    with context do
    begin
      CompressBytes(pbytearray(rowbuf),actlen,cmpbuf,cmplen);
      Stream.Write(cmpbuf^,cmplen);
      // write row length
      if sizes<>nil then
        PutSmallintAt(Stream,pos2+row*2,cmplen)
      else
        PutsmallintAt(Stream,pos2+i*bitmapHeight*2+row*2,cmplen);
    end;
  end;

begin
  with context do
  begin

    rl:=IEBitmapRowLen(Bitmap.Width,depth,8); // output rowlen
    getmem(rowbuf,Bitmap.Width*4);
    getmem(cmpbuf,Bitmap.Width*4);

    k:=0;

    if (sizes<>nil) and bitmap.HasAlphaChannel then
    begin
      // put alpha channel
      pos1:=Stream.Position;
      PutSmallint(Stream,1);  // compression
      // put blank row lengths
      pos2:=Stream.Position;
      Stream.Seek(Bitmap.AlphaChannel.Height*2,soFromCurrent);
      // write values
      for row:=0 to Bitmap.AlphaChannel.Height-1 do
      begin
        pb:=Bitmap.AlphaChannel.Scanline[row];
        actlen:=0;
        case depth of
          8:
            begin
              actlen:=Bitmap.AlphaChannel.Width;
              move(pb^,rowbuf^,actlen);
            end;
          16:
            begin
              wb:=pword(rowbuf);
              for col:=0 to Bitmap.AlphaChannel.Width-1 do
              begin
                wb^:=IESwapWord(pb^*257);
                inc(wb);
                inc(pb);
                inc(actlen,2);
              end;
            end;
        end;
        WriteRow;
      end;
      // write channel size
      PutLongintAt(Stream,sizes[sizesIdx][k],Stream.Size-pos1);  // included compression tag
      //
      inc(k);
    end;

    // put color channels
    channelCount:=bitmap.ChannelCount;