BSOne.SFC/EM.Lib/ImageEn_SRC/Source/iepsd.pas

2207 lines
68 KiB
Plaintext

(* ImageEn Build 7.0.0.06.2637 @ 7-4-17 14:58:42.679 *)
(*
Copyright (c) 1998-2017 by Carlotta Calandra. All rights reserved.
Copyright (c) 2011-2017 by Xequte Software.
This software comes without express or implied warranty.
In no case shall the author be liable for any damage or unwanted behavior of any
computer hardware and/or software.
Author grants you the right to include the component
in your application, whether COMMERCIAL, SHAREWARE, or FREEWARE.
ImageEn, IEvolution and ImageEn ActiveX may not be included in any
commercial, shareware or freeware libraries or components.
www.ImageEn.com
*)
(*
File version 1004
*)
unit iepsd;
{$R-}
{$Q-}
{$I ie.inc}
interface
{$ifdef IEINCLUDEPSD}
uses
Windows, Graphics, classes, sysutils, ImageEnProc, ImageEnIO, hyiedefs, iexBitmaps;
procedure IEReadPSD(Stream: TStream; MergedBitmap: TIEBitmap; var IOParams: TIOParams; var Progress: TProgressRec; LoadLayers: boolean; layers: TList);
procedure IEWritePSD(Stream: TStream; var IOParams: TIOParams; var Progress: TProgressRec; mergedImage: TIEBitmap; layers: TList);
function IETryPSD(Stream: TStream): boolean;
{$endif}
implementation
{$ifdef IEINCLUDEPSD}
uses
imageenview, jpegfilt, iesettings, hyieutils, iexLayers;
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
// PSD Read
const
MAXLAYERNAME = 1024;
type
TPSDHeader = packed record
Signature: array [0..3] of AnsiChar; // must be '8BPS'
Version : word; // must be 1
Reserved: array [0..5] of byte; // must be 0
Channels: word; // 1 to 24
Rows: longint; // 1 to 30000
Columns: longint; // 1 to 30000
Depth: word; // 1, 8, 16
Mode: word; // 0=bitmap, 1=grayscale, 2=indexed, 3=RGB, 4=CMYK, 7=mutlichannel, 8=duotone, 9=lab
end;
TColorMapChannel = array [0..255] of byte;
TColorMap = array of TColorMapChannel;
TPSDResolutionInfo = packed record
hRes: longint; // fixed point number: pixels per inch
hResUnit: word; // 1=pixels per inch, 2=pixels per centimeter
WidthUnit: word; // 1=in, 2=cm, 3=pt, 4=picas, 5=columns
vRes: longint; // fixed point number: pixels per inch
vResUnit: word; // 1=pixels per inch, 2=pixels per centimeter
HeightUnit: word; // 1=in, 2=cm, 3=pt, 4=picas, 5=columns
end;
PPSDResolutionInfo = ^TPSDResolutionInfo;
TPSDThumbnailInfo = packed record
format: longint; // 1=jpeg 0=raw
width: longint; // thumbnail width
height: longint; // thumbnail height
widthbytes: longint; // rowlen aligned
size: longint; // uncompressed size
compressedsize: longint; // compressed size
bitspixel: word; // bits per pixel (24)
planes: word; // number of planes (1)
end;
PPSDThumbnailInfo = ^TPSDThumbnailInfo;
TPSDReaderContext = class
Stream: TStream;
IOParams: TIOParams;
header: TPSDHeader;
colormap: TColorMap;
transpindex: integer; // index of transparency when mode=indexed (2)
layers: TList;
LoadLayers: boolean;
XProgress: TProgressRec;
MergedBitmap: TIEBitmap;
thumbnailLoaded: boolean;
hasPremultipliedAlpha: boolean;
hasICC: boolean;
end;
const
MAGIK: array [0..3] of AnsiChar = '8BPS';
RESMAGIK: array [0..3] of AnsiChar = '8BIM';
procedure ReadImageData(Stream: TStream; Bitmap: TIEBitmap; width, height, depth, mode: integer; colormap: TColorMap; transpindex: integer; compression: smallint; sizes: TIEArrayOfDWord; var cursize: integer; channel: integer; progress: PProgressRec = nil); forward;
// get 16 bit signed value
function GetSmallint(Stream: TStream): smallint;
begin
Stream.Read(result, 2);
result := IESwapWord(result);
end;
// get 32 bit signed value
function GetLongint(Stream: TStream): longint;
begin
Stream.Read(result, 4);
result := IESwapDWord(result);
end;
// get 64 bit signed value
function GetInt64(Stream: TStream): int64;
begin
Stream.Read(result, 8);
result := IESwapInt64(result);
end;
function GetByte(Stream: TStream): byte;
begin
Stream.Read(result, 1);
end;
function GetWord(Stream: TStream): word;
begin
Stream.Read(result, 2);
result := IESwapWord(result);
end;
function GetDWord(Stream: TStream): dword;
begin
Stream.Read(result, 4);
result := IESwapDWord(result);
end;
function IETryPSD(Stream: TStream): boolean;
var
lpos: int64;
header: TPSDHeader;
begin
result := false;
lpos := Stream.Position;
try
Stream.Read(header, sizeof(TPSDHeader));
if not CompareMem(@header.Signature, @MAGIK, 4) then
exit;
with header do
begin
Version := IESwapWord(Version); // 1 = PSD, 2 = PSB
Channels := IESwapWord(Channels);
Rows := IESwapDWord(Rows);
Columns := IESwapDWord(Columns);
Depth := IESwapWord(Depth);
Mode := IESwapWord(Mode);
if ((Version <> 1) and (Version <> 2)) or (Channels < 1) or (Channels > 24) or (Depth < 1) or (Depth > 16) or (Mode > 9) then
exit;
end;
result := true;
finally
Stream.Position := lpos;
end;
end;
// read Color mode data section
procedure ReadColorMap(context: TPSDReaderContext);
var
colormaplen: longint;
begin
with context do
begin
colormaplen := GetLongint(Stream);
if colormaplen = 768 then
begin
// load color map
SetLength(colormap, 3);
Stream.Read(colormap[0][0], 768);
end
else
begin
SetLength(colormap, 0);
Stream.Seek(colormaplen, soCurrent);
end;
end;
end;
procedure ReadResource(context: TPSDReaderContext; ID: word; Data: pbyte; Size: longint);
var
resinfo: PPSDResolutionInfo;
thumbinfo: PPSDThumbnailInfo;
ms: TIEMemStream;
dummyParams: TIOParams;
dummyProgress: TProgressRec;
dummyAbort: boolean;
ss: AnsiString;
begin
with context do
case ID of
$03ED: // Resolution information
begin
if Size >= sizeof(TPSDResolutionInfo) then
begin
resinfo := PPSDResolutionInfo(Data);
with resinfo^ do
begin
hRes := IESwapDWord(hRes);
vRes := IESwapDWord(vRes);
IOParams.DpiX := trunc(hRes / 65536);
IOParams.DpiY := trunc(vRes / 65536);
end;
end;
end;
$0417: // Transparency index (Photoshop 6.0)
begin
transpindex := IESwapWord(pword(Data)^);
end;
$0404: // IPTC-NAA
begin
IOParams.IPTC_Info.LoadFromStandardBuffer(Data, Size);
end;
$040F: // ICC Profile (Photoshop 5.0)
begin
IOParams.InputICCProfile.LoadFromBuffer(Data, Size);
hasICC := true;
end;
$040C: // Thumbnail (Photoshop 5.0)
begin
if Size >= sizeof(TPSDThumbnailInfo) then
begin
thumbinfo := PPSDThumbnailInfo(Data);
with thumbinfo^ do
begin
format := IESwapDWord(format);
width := IESwapDWord(width);
height := IESwapDWord(height);
widthbytes := IESwapDWord(widthbytes);
size := IESwapDWord(size);
compressedsize := IESwapDWord(compressedsize);
bitspixel := IESwapWord(bitspixel);
planes := IESwapWord(planes);
end;
inc(data, 28);
ms := TIEMemStream.Create(Data, Size-28);
if not assigned(IOParams.EXIF_Bitmap) then
IOParams.EXIF_Bitmap := TIEBitmap.Create();
dummyParams := TIOParams.Create( nil );
try
dummyProgress := NullProgressRec( dummyAbort );
ReadJpegStream(ms, nil, IOParams.EXIF_Bitmap, dummyParams, dummyProgress, false, false, false, false, true, true, -1, dummyParams.IsNativePixelFormat);
finally
dummyParams.Free();
ms.free;
end;
if IOParams.GetThumbnail and (MergedBitmap<>nil) then
begin
LoadLayers := false;
MergedBitmap.Assign( IOParams.EXIF_Bitmap );
thumbnailLoaded := true;
end;
end;
end;
$0424: // XMP
begin
SetLength( ss, Size );
Move( Data^, ss[1], Size );
IOParams.XMP_Info := ss;
end;
end;
end;
// Image resources section
procedure ReadImageResources(context: TPSDReaderContext);
var
resourceslen: longint;
Signature: array [0..3] of AnsiChar;
ID: smallint;
Name: AnsiString;
NameLen: smallint;
Size: longint;
Data: array of byte;
StreamSize: int64;
begin
with context do
begin
resourceslen := GetLongint(Stream);
StreamSize := Stream.Size;
// load known image resources
while resourceslen > 0 do
begin
if (Stream.Position and $1) <> 0 then
begin
Stream.Seek(1, soCurrent);
dec(resourceslen);
if resourceslen = 0 then
break;
end;
Stream.Read(Signature[0], 4);
dec(resourceslen, 4);
if not CompareMem(@Signature, @RESMAGIK, 4) then
break;
ID := GetSmallint(Stream);
NameLen := GetSmallint(Stream);
SetLength(Name, NameLen);
Stream.Read(Name[1], NameLen);
Size := GetLongint(Stream);
if (Size <= 0) or (Size > StreamSize) then
begin
dec(resourceslen, 2 + 2 + NameLen + 4);
break;
end;
SetLength(Data, Size);
Stream.Read(Data[0], Size);
ReadResource(context, ID, @Data[0], Size);
dec(resourceslen, 2 + 2 + NameLen + 4 + Size);
end;
Stream.Seek(resourceslen, soCurrent); // bypass unknown bytes
end;
end;
type
TAdjustment = record
Signature: array [0..3] of AnsiChar; // always 8BIM
Key: array [0..3] of AnsiChar;
Length: longint;
data: pbyte;
end;
TAdjustmentArray = array [0..MaxInt div 32] of TAdjustment;
PAdjustmentArray = ^TAdjustmentArray;
TSmallIntArray = array [0..MaxInt div 4] of SmallInt;
TLongIntArray = array [0..MaxInt div 8] of LongInt;
PSmallIntArray = ^TSmallIntArray;
PLongIntArray = ^TLongIntArray;
TTempLayerData = record
ChannelID: PSmallIntArray;
ChannelLen: PInt64Array;
layerTop, layerLeft, layerBottom, layerRight: longint;
numberChannels: smallint;
BlendMode: array [0..3] of AnsiChar;
Opacity: byte;
Clipping: byte;
Flags: byte;
layermask_Size: longint;
layermask_Top: longint;
layermask_Left: longint;
layermask_Bottom: longint;
layermask_Right: longint;
layermask_DefaultColor: byte;
layermask_Flags: byte;
Name: array [0..MAXLAYERNAME-1] of AnsiChar;
adjustmentCount: integer;
adjustment: PAdjustmentArray;
end;
PTempLayerData = ^TTempLayerData;
TArrayOfTempLayerData = array [0..MaxInt div 262144] of TTempLayerData;
PArrayOfTempLayerData = ^TArrayOfTempLayerData;
// Read layer and mask information section
procedure ReadLayerAndMaskInfo(context: TPSDReaderContext);
var
lpos1: int64;
layerslen: int64;
layersinfolen: int64;
li: longint;
b: byte;
layerscount: smallint;
i, j, c, k: integer;
compression: smallint;
cursize: integer;
sizes: TIEArrayOfDWord;
width, height: integer;
ExtraDataSize: longint;
LayersTemp: PArrayOfTempLayerData;
layer: TIELayer;
globalmaskLength: longint;
//globalmaskOverlayColorSpace: smallint;
globalmaskColorComponents: array [0..3] of smallint;
//globalmaskOpacity: smallint;
//globalmaskKind: byte;
begin
with context do
begin
if header.Version = 2 then
// PSB, read as 64 bit length
layerslen := GetInt64(Stream)
else
// PSD, read as 32 bit length
layerslen := GetLongint(Stream);
lpos1 := Stream.Position;
if layerslen > 0 then
begin
if header.Version = 2 then
// PSB, read as 64 bit length
layersinfolen := GetInt64(Stream)
else
// PSD, read as 32 bit length
layersinfolen := GetLongint(Stream);
layerscount := GetSmallint(Stream);
hasPremultipliedAlpha := layerscount < 0;
layerscount := abs(layerscount);
if ((layerscount > 1) and not LoadLayers) or (layers = nil) then
begin
// bypass layers
if header.Version = 2 then
// PSB, subtract 8 bytes
Stream.Seek(layerslen - 8 - 2, soCurrent)
else
// PSD, subtract 4 bytes
Stream.Seek(layerslen - 4 - 2, soCurrent);
exit;
end;
LayersTemp := AllocMem( sizeof(TTempLayerData) * layerscount );
for i := 0 to layerscount - 1 do
begin
// load layer parameters
LayersTemp[i].layerTop := GetLongint(Stream);
LayersTemp[i].layerLeft := GetLongint(Stream);
LayersTemp[i].layerBottom := GetLongint(Stream);
LayersTemp[i].layerRight := GetLongint(Stream);
LayersTemp[i].numberChannels := GetSmallint(Stream);
getmem(LayersTemp[i].ChannelID, sizeof(Smallint) * LayersTemp[i].numberChannels);
getmem(LayersTemp[i].ChannelLen, sizeof(int64) * LayersTemp[i].numberChannels);
for c := 0 to LayersTemp[i].numberChannels - 1 do
begin
LayersTemp[i].ChannelID[c] := GetSmallint(Stream);
if header.Version = 2 then
// PSB, read length as 64 bit
LayersTemp[i].ChannelLen[c] := GetInt64(Stream)
else
// PSD, read length as 32 bit
LayersTemp[i].ChannelLen[c] := GetLongint(Stream);
end;
Stream.Seek(4, soCurrent); // bypass blend mode signature (always 8BIM)
Stream.Read(LayersTemp[i].BlendMode[0], 4);
LayersTemp[i].Opacity := GetByte(Stream);
LayersTemp[i].Clipping := GetByte(Stream);
LayersTemp[i].Flags := GetByte(Stream);
Stream.Seek(1, soCurrent); // bypass filler
ExtraDataSize := GetLongint(Stream);
// layer mask / adjustment layer data
LayersTemp[i].layermask_Size := GetLongint(Stream);
if LayersTemp[i].layermask_Size > 0 then
begin
LayersTemp[i].layermask_Top := GetLongint(Stream);
LayersTemp[i].layermask_Left := GetLongint(Stream);
LayersTemp[i].layermask_Bottom := GetLongint(Stream);
LayersTemp[i].layermask_Right := GetLongint(Stream);
LayersTemp[i].layermask_DefaultColor := GetByte(Stream);
LayersTemp[i].layermask_Flags := GetByte(Stream);
Stream.Seek(2, soCurrent); // bypass padding
end;
dec(ExtraDataSize, LayersTemp[i].layermask_Size + 4);
// layer blending ranges data (bypass)
li := GetLongint(Stream);
dec(ExtraDataSize, li + 4);
Stream.Seek(li, soCurrent);
// layer name
b := GetByte(Stream);
Stream.Read(LayersTemp[i].Name[0], imin(b, MAXLAYERNAME - 1));
LayersTemp[i].Name[b] := #0;
dec(ExtraDataSize, 1 + b);
while (ExtraDataSize and $3) <> 0 do
begin
Stream.Seek(1, soCurrent); // pad to multiple of 4 bytes
dec(ExtraDataSize);
end;
// adjustment layer info tags
c := 0;
while ExtraDataSize > 0 do
begin
inc(LayersTemp[i].adjustmentCount);
ReallocMem(LayersTemp[i].adjustment, LayersTemp[i].adjustmentCount * sizeof(TAdjustment) );
Stream.Read(LayersTemp[i].adjustment[c].Signature, 4); // Signature '8BIM'
Stream.Read(LayersTemp[i].adjustment[c].Key, 4); // Key
LayersTemp[i].adjustment[c].Length := GetLongint(Stream); // length
getmem(LayersTemp[i].adjustment[c].Data, LayersTemp[i].adjustment[c].Length);
Stream.Read(LayersTemp[i].adjustment[c].Data^, LayersTemp[i].adjustment[c].Length);
dec(ExtraDataSize, 4 + 4 + 4 + LayersTemp[i].adjustment[c].Length);
inc(c);
end;
// bypass extradata (should not be present)
Stream.Seek(ExtraDataSize, soCurrent);
// fill TIELayer data
layer := TIEImageLayer.Create(nil, nil, false);
layers.Add(layer);
layer.PosX := LayersTemp[i].layerLeft;
layer.PosY := LayersTemp[i].layerTop;
//layer.Transparency := LayersTemp[i].Opacity; <-- old behavior
layer.Opacity := LayersTemp[i].Opacity / 255;
layer.Name := String( LayersTemp[i].Name );
layer.Visible := (LayersTemp[i].Flags and $2) = 0;
layer.Cropped := (LayersTemp[i].Clipping = 0);
end;
XProgress.val := 0;
XProgress.tot := 0;
XProgress.per1 := 0.0;
for i := 0 to layerscount - 1 do
inc(XProgress.tot, imax(LayersTemp[i].layerBottom - LayersTemp[i].layerTop, LayersTemp[i].layermask_Bottom - LayersTemp[i].layermask_Top) * LayersTemp[i].numberChannels);
k := 0; // index inside layers[] list
for i := 0 to layerscount - 1 do
begin
// load layer image
for c := 0 to LayersTemp[i].numberChannels - 1 do
begin
if (IOParams.PSD_SelectLayer <> '') and (LayersTemp[i].Name <> IOParams.PSD_SelectLayer) then
begin
// bypass channel (then by pass layer)
Stream.Seek(LayersTemp[i].ChannelLen[c], soCurrent);
end
else
begin
if (IOParams.PSD_SelectLayer <> '') and (LayersTemp[i].Name = IOParams.PSD_SelectLayer) then
begin
// XProgress.tot is invalid now, recalculate for this layer only
XProgress.tot := imax(LayersTemp[i].layerBottom - LayersTemp[i].layerTop, LayersTemp[i].layermask_Bottom - LayersTemp[i].layermask_Top) * LayersTemp[i].numberChannels;
end;
// load channel
if LayersTemp[i].ChannelID[c] = -2 then
begin
// this is the layer mask
layer := TIEImageLayer.Create(nil, nil, false);
layers.Insert(k + 1, layer);
layer.PosX := LayersTemp[i].layermask_Left;
layer.PosY := LayersTemp[i].layermask_Top;
layer.IsMask := true;
layer.Visible := false;
width := LayersTemp[i].layermask_Right - LayersTemp[i].layermask_Left;
height := LayersTemp[i].layermask_Bottom - LayersTemp[i].layermask_Top;
compression := GetSmallint(Stream);
SetLength(sizes, height);
if compression = 1 then
begin
// RLE compression, read row lengths
for j := 0 to height - 1 do
if header.Version = 2 then
// PSB, each row length is 32 bit
sizes[j] := GetDWord(Stream)
else
// PSD, each row length is 16 bit
sizes[j] := GetWord(Stream);
end
else
// uncompressed, calculate row lengths
for j := 0 to height - 1 do
sizes[j] := IEBitmapRowLen(width, header.Depth, 8);
cursize := 0;
ReadImageData(Stream, layer.Bitmap, width, height, 8, 1, nil, 0, compression, sizes, cursize, 0, @XProgress);
end
else
begin
// this is a channel or alpha channel
if TIELayer(layers[k]).IsMask then
inc(k);
layer := TIELayer(layers[k]);
width := LayersTemp[i].layerRight - LayersTemp[i].layerLeft;
height := LayersTemp[i].layerBottom - LayersTemp[i].layerTop;
compression := GetSmallint(Stream);
SetLength(sizes, height);
if compression = 1 then
begin
// RLE compression, read row lengths
for j := 0 to height - 1 do
if header.Version = 2 then
// PSB, each row length is 32 bit
sizes[j] := GetDWord(Stream)
else
// PSD, each row length is 16 bit
sizes[j] := GetWord(Stream);
end
else
for j := 0 to height - 1 do
sizes[j] := IEBitmapRowLen(width, header.Depth, 8);
cursize := 0;
ReadImageData(Stream, layer.Bitmap, width, height, header.Depth, header.mode, colormap, transpindex, compression, sizes, cursize, LayersTemp[i].ChannelID[c], @XProgress);
end;
end;
end;
inc(k);
end;
// free mem
for i := 0 to layerscount - 1 do
begin
freemem(LayersTemp[i].ChannelID);
freemem(LayersTemp[i].ChannelLen);
for j := 0 to LayersTemp[i].adjustmentCount - 1 do
freemem( LayersTemp[i].adjustment[j].data );
freemem( LayersTemp[i].adjustment );
end;
freemem(LayersTemp);
// remove empty layers
i := 0;
while i < layers.Count do
if TIELayer(layers[i]).Bitmap.IsEmpty() then
begin
TIELayer(layers[i]).Free();
layers.Delete(i);
end
else
inc(i);
// go at global layer mask info
Stream.Position := lpos1 + layersinfolen + 4;
globalmaskLength := GetLongint(Stream);
if globalmaskLength > 0 then
begin
(*globalmaskOverlayColorSpace := *)GetSmallint(Stream);
for i := 0 to 3 do
globalmaskColorComponents[i] := GetSmallint(Stream);
(*globalmaskOpacity := *)GetSmallint(Stream);
(*globalmaskKind := *)GetByte(Stream);
GetByte(Stream); // by pass
end;
// go to at end of layer and mask info
Stream.Position := lpos1 + layerslen;
end;
// remove zero size layers
if layers <> nil then
begin
i := 0;
while i < layers.Count do
if (TIELayer(layers[i]).Bitmap.Width = 0) or (TIELayer(layers[i]).Bitmap.Height = 0) then
begin
TIELayer(layers[i]).Free;
layers.Delete(i);
if (i < layers.Count - 1) and TIELayer(layers[i]).IsMask then
begin
// remove also the layer mask
TIELayer(layers[i]).Free;
layers.Delete(i);
end;
end
else
inc(i);
end;
end;
end;
// blocksize: the size of block to read from Stream
// outbuf: output uncompressed buffer
procedure ReadRow(Stream: TStream; compression: word; outbuf: pbyte; sizes: TIEArrayOfDWord; var cursize: integer; maxOutbufLen: dword);
var
i, j: dword;
rp: byte;
src: array of byte;
dst: pbyte;
blocksize: dword;
begin
blocksize := sizes[cursize];
case compression of
0: // RAW data
begin
Stream.Read(outbuf^, blocksize);
end;
1: // RLE
begin
SetLength(src, blocksize);
Stream.Read(src[0], blocksize);
dst := outbuf;
j := 0;
i := 0;
while i < blocksize do
begin
if (src[i] and $80) <> 0 then
begin
// repeater
rp := (not src[i]) + 2;
inc(i);
if j + rp > maxOutbufLen then
rp := maxOutbufLen - j;
inc(j, rp);
while rp > 0 do
begin
dst^ := src[i];
inc(dst);
dec(rp);
end;
inc(i);
end
else
begin
// copy
rp := src[i] + 1;
inc(i);
if j + rp > maxOutbufLen then
rp := maxOutbufLen - j;
inc(j, rp);
while rp > 0 do
begin
dst^ := src[i];
inc(dst);
inc(i);
dec(rp);
end;
end;
end;
end;
end;
{
according to Adobe specifiations row lengths should not be odd, but this seems in conflict with actual files
if (blocksize and $1) <> 0 then
Stream.Seek(1, soCurrent);
}
inc(cursize);
end;
procedure CopyRow8(bitmap: TIEBitmap; row: integer; channel: integer; channelcount: integer; width: integer; inrow: pbyte);
var
pb1, pb2: pbyte;
i: integer;
begin
pb1 := Bitmap.Scanline[row];
inc(pb1, channel);
pb2 := inrow;
for i := 0 to width - 1 do
begin
pb1^ := pb2^;
inc(pb1, channelcount);
inc(pb2);
end;
end;
procedure CopyRow16(bitmap: TIEBitmap; row: integer; channel: integer; channelcount: integer; width: integer; inrow: pbyte);
var
pw1, pw2: pword;
i: integer;
begin
pw1 := Bitmap.Scanline[row];
inc(pw1, channel);
pw2 := pword(inrow);
for i := 0 to width - 1 do
begin
pw1^ := IESwapWord(pw2^);
inc(pw1, channelcount);
inc(pw2);
end;
end;
procedure CopyRow16to8(bitmap: TIEBitmap; row: integer; channel: integer; channelcount: integer; width: integer; inrow: pbyte);
var
pb1: pbyte;
pw2: pword;
i: integer;
begin
pb1 := Bitmap.Scanline[row];
inc(pb1, channel);
pw2 := pword(inrow);
for i := 0 to width - 1 do
begin
pb1^ := pw2^ and $FF; // Same as "pb1^ := IESwapWord(pw2^) shr 8"
inc(pb1, channelcount);
inc(pw2);
end;
end;
procedure AdjustLab8(bitmap: TIEBitmap; row: integer; channel: integer; channelcount: integer; width: integer);
var
p: pshortint;
i: integer;
begin
p := Bitmap.Scanline[row];
inc(p, channel);
for i := 0 to width - 1 do
begin
p^ := pbyte(p)^ - 128;
inc(p, channelcount);
end;
end;
procedure AdjustPaletteTransp(Bitmap: TIEBitmap; row: integer; transpindex: integer; width: integer);
var
i: integer;
p, a: pbyte;
begin
if transpindex > -1 then
begin
p := Bitmap.Scanline[row];
a := Bitmap.AlphaChannel.Scanline[row];
for i := 0 to width - 1 do
begin
if p^ = transpindex then
a^ := 0
else
a^ := 255;
inc(p);
inc(a);
end;
end;
end;
procedure LoadAlpha(Stream: TStream; AlphaBitmap: TIEBitmap; width, height, depth: integer; compression: integer; sizes: TIEArrayOfDWord; var cursize: integer; rowbuf: pbyte; maxRowbufLen: dword);
var
i: integer;
begin
for i := 0 to height - 1 do
begin
ReadRow(Stream, compression, rowbuf, sizes, cursize, maxRowbufLen);
case depth of
8: CopyRow8(AlphaBitmap, i, 0, 1, width, rowbuf);
16: CopyRow16to8(AlphaBitmap, i, 0, 1, width, rowbuf);
end;
end;
AlphaBitmap.Full := false;
end;
// read image data section
procedure ReadImageData(Stream: TStream; Bitmap: TIEBitmap; width, height, depth, mode: integer; colormap: TColorMap; transpindex: integer; compression: smallint; sizes: TIEArrayOfDWord; var cursize: integer; channel: integer; progress: PProgressRec);
procedure DoProgress();
begin
if assigned(progress) and assigned(progress^.fOnProgress) then
begin
progress^.per2 := progress^.val / progress^.tot * 100;
if trunc(progress^.per1) <> trunc(progress^.per2) then
begin
progress^.per1 := progress^.per2;
progress^.fOnProgress(progress^.Sender, trunc(progress^.per1));
end;
inc(progress^.val);
end;
end;
var
rowbuf: TIEArrayOfByte;
i: integer;
rowlen: integer;
begin
SetLength(rowbuf, IEBitmapRowLen(width, depth, 8));
case depth of
1: // depth = 1
case mode of
0: // bitmap
begin
Bitmap.Allocate(width, height, ie1g);
if channel = 0 then
begin
rowlen := IEBitmapRowLen(width, 1, 8);
for i := 0 to height - 1 do
begin
ReadRow(Stream, compression, @rowbuf[0], sizes, cursize, length(rowbuf));
CopyRow8(Bitmap, i, 0, 1, rowlen, @rowbuf[0]);
_NegativeBuffer(Bitmap.Scanline[i], rowlen);
DoProgress();
end;
end;
end;
end;
8: // depth = 8
case mode of
1, 8, 7: // Gray Scale or duotone or multichannel (not very well supported)
begin
Bitmap.Allocate(width, height, ie8g);
if channel = 0 then
for i := 0 to height - 1 do
begin
ReadRow(Stream, compression, @rowbuf[0], sizes, cursize, length(rowbuf));
CopyRow8(Bitmap, i, 0, 1, width, @rowbuf[0]);
DoProgress();
end;
if (channel = 1) or (channel = -1) then
LoadAlpha(Stream, Bitmap.AlphaChannel, width, height, depth, compression, sizes, cursize, @rowbuf[0], length(rowbuf));
end;
2: // Indexed
begin
Bitmap.Allocate(width, height, ie8p);
if channel = 0 then
begin
for i := 0 to 255 do
Bitmap.Palette[i] := CreateRGB(colormap[0][i], colormap[1][i], colormap[2][i]);
for i := 0 to height - 1 do
begin
ReadRow(Stream, compression, @rowbuf[0], sizes, cursize, length(rowbuf));
CopyRow8(Bitmap, i, 0, 1, width, @rowbuf[0]);
AdjustPaletteTransp(Bitmap, i, transpindex, width);
DoProgress();
end;
end;
end;
3: // RGB
begin
Bitmap.Allocate(width, height, ie24RGB);
if (channel >= 0) and (channel < 3) then
for i := 0 to height - 1 do
begin
ReadRow(Stream, compression, @rowbuf[0], sizes, cursize, length(rowbuf));
CopyRow8(Bitmap, i, 2 - channel, 3, width, @rowbuf[0]);
DoProgress();
end;
if (channel = 3) or (channel = -1) then
LoadAlpha(Stream, Bitmap.AlphaChannel, width, height, depth, compression, sizes, cursize, @rowbuf[0], length(rowbuf));
end;
4: // CMYK
begin
Bitmap.Allocate(width, height, ieCMYK);
if (channel >= 0) and (channel < 4) then
for i := 0 to height - 1 do
begin
ReadRow(Stream, compression, @rowbuf[0], sizes, cursize, length(rowbuf));
CopyRow8(Bitmap, i, channel, 4, width, @rowbuf[0]);
DoProgress();
end;
if (channel = 4) or (channel = -1) then
LoadAlpha(Stream, Bitmap.AlphaChannel, width, height, depth, compression, sizes, cursize, @rowbuf[0], length(rowbuf));
end;
9: // Lab
begin
Bitmap.Allocate(width, height, ieCIELab);
if (channel >= 0) and (channel < 3) then
for i := 0 to height - 1 do
begin
ReadRow(Stream, compression, @rowbuf[0], sizes, cursize, length(rowbuf));
CopyRow8(Bitmap, i, channel, 3, width, @rowbuf[0]);
if (channel = 1) or (channel = 2) then
AdjustLab8(Bitmap, i, channel, 3, width);
DoProgress();
end;
if (channel = 3) or (channel = -1) then
LoadAlpha(Stream, Bitmap.AlphaChannel, width, height, depth, compression, sizes, cursize, @rowbuf[0], length(rowbuf));
end;
end;
16: // depth = 16
case mode of
1, 8: // Gray Scale or duotone
begin
Bitmap.Allocate(width, height, ie16g);
if channel = 0 then
for i := 0 to height - 1 do
begin
ReadRow(Stream, compression, @rowbuf[0], sizes, cursize, length(rowbuf));
CopyRow16(Bitmap, i, 0, 1, width, @rowbuf[0]);
DoProgress();
end;
if (channel = 1) or (channel = -1) then
LoadAlpha(Stream, Bitmap.AlphaChannel, width, height, depth, compression, sizes, cursize, @rowbuf[0], length(rowbuf));
end;
3: // RGB
begin
Bitmap.Allocate(width, height, ie48RGB);
if (channel >= 0) and (channel < 3) then
for i := 0 to height - 1 do
begin
ReadRow(Stream, compression, @rowbuf[0], sizes, cursize, length(rowbuf));
CopyRow16(Bitmap, i, channel, 3, width, @rowbuf[0]);
DoProgress();
end;
if (channel = 3) or (channel = -1) then
LoadAlpha(Stream, Bitmap.AlphaChannel, width, height, depth, compression, sizes, cursize, @rowbuf[0], length(rowbuf));
end;
4: // CMYK
begin
Bitmap.Allocate(width, height, ieCMYK);
if (channel >= 0) and (channel < 4) then
for i := 0 to height - 1 do
begin
ReadRow(Stream, compression, @rowbuf[0], sizes, cursize, length(rowbuf));
CopyRow16to8(Bitmap, i, channel, 4, width, @rowbuf[0]);
DoProgress();
end;
if (channel = 4) or (channel = -1) then
LoadAlpha(Stream, Bitmap.AlphaChannel, width, height, depth, compression, sizes, cursize, @rowbuf[0], length(rowbuf));
end;
9: // Lab
begin
Bitmap.Allocate(width, height, ieCIELab);
if (channel >= 0) and (channel < 3) then
for i := 0 to height - 1 do
begin
ReadRow(Stream, compression, @rowbuf[0], sizes, cursize, length(rowbuf));
CopyRow16to8(Bitmap, i, channel, 3, width, @rowbuf[0]);
if (channel = 1) or (channel = 2) then
AdjustLab8(Bitmap, i, channel, 3, width);
DoProgress();
end;
if (channel = 3) or (channel = -1) then
LoadAlpha(Stream, Bitmap.AlphaChannel, width, height, depth, compression, sizes, cursize, @rowbuf[0], length(rowbuf));
end;
end;
end;
end;
// output is a list of TIELayer (output must be a created list)
// note: to do "Preview" set boths LoadLayers and LoadMergedImage to False
procedure IEReadPSD(Stream: TStream; MergedBitmap: TIEBitmap; var IOParams: TIOParams; var Progress: TProgressRec; LoadLayers: boolean; layers: TList);
var
context: TPSDReaderContext;
compression: smallint;
cursize: integer;
sizes: TIEArrayOfDWord;
i: integer;
begin
context := TPSDReaderContext.Create();
try
context.Stream := Stream;
context.IOParams := IOParams;
context.Layers := layers;
context.LoadLayers := LoadLayers;
context.XProgress := Progress;
context.MergedBitmap := MergedBitmap;
context.hasICC := false;
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) and (Version <> 2)) 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.ImageCount := 1;
IOParams.Width := header.Columns;
IOParams.Height := header.Rows;
IOParams.OriginalWidth := header.Columns;
IOParams.OriginalHeight := 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) and (IOParams.PSD_SelectLayer = '') then
begin
compression := GetSmallint(Stream);
SetLength(sizes, header.Channels * header.Rows);
if compression = 1 then
begin
// RLE compression, read row lengths
for i := 0 to header.Channels * header.Rows - 1 do
if header.Version = 2 then
// PSB, each row length is 32 bit
sizes[i] := GetDWord(Stream)
else
// PSD, each row length is 16 bit
sizes[i] := GetWord(Stream);
end
else
// uncompressed, calculate row lengths
for i := 0 to header.Channels * header.Rows - 1 do
sizes[i] := IEBitmapRowLen(header.Columns, header.Depth, 8);
cursize := 0;
Progress.val := 0;
Progress.tot := header.Channels * header.Rows;
Progress.per1 := 0.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, @Progress);
end;
// process NativePixelFormat
if (layers <> nil) then
begin
for i := 0 to layers.Count - 1 do
with TIELayer(layers[i]) do
begin
if (Bitmap.PixelFormat <> ie1g) and not IsMask then
begin
if IOParams.IsNativePixelFormat then
begin
if assigned(IOParams) and assigned(IOParams.InputICCProfile) then
Bitmap.ColorProfile.Assign(IOParams.InputICCProfile);
end
else
begin
if hasICC and
IEGlobalSettings().EnableCMS and
(IOParams <> nil) and
assigned(IOParams.InputICCProfile) and
IOParams.InputICCProfile.IsValid and
not IOParams.InputICCProfile.IsApplied and
IOParams.OutputICCProfile.IsValid then
begin
IOParams.InputICCProfile.ConvertBitmap(Bitmap, ie24RGB, IOParams.OutputICCProfile);
end
else
begin
Bitmap.PixelFormat := ie24RGB;
end;
end;
end;
end;
end;
if assigned(MergedBitmap) then
if (MergedBitmap.PixelFormat <> ie1g) then
begin
if IOParams.IsNativePixelFormat then
begin
if assigned(IOParams) and assigned(IOParams.InputICCProfile) then
MergedBitmap.ColorProfile.Assign(IOParams.InputICCProfile);
end
else
begin
if hasICC and
IEGlobalSettings().EnableCMS and
(IOParams <> nil) and
assigned(IOParams.InputICCProfile) and
IOParams.InputICCProfile.IsValid and
not IOParams.InputICCProfile.IsApplied and
IOParams.OutputICCProfile.IsValid then
begin
IOParams.InputICCProfile.ConvertBitmap(MergedBitmap, ie24RGB, IOParams.OutputICCProfile);
end
else
begin
MergedBitmap.PixelFormat := ie24RGB;
end;
end;
end;
end;
if context.MergedBitmap <> MergedBitmap then
begin
MergedBitmap.Assign(context.MergedBitmap);
FreeAndNil(context.MergedBitmap);
end;
finally
context.Free();
end;
end;
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
// PSD Write
type
TPSDWriterContext = record
Stream: TStream;
IOParams: TIOParams;
layers: TList;
mergedImage: TIEBitmap;
mode: integer;
depth: integer;
Progress: TProgressRec;
end;
const
PIXELFORMAT2MODE: array [TIEPixelFormat] of integer = (1000, 0, 2, 1, 1, 3, 1000, 4, 3, 9, 3);
// 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;
// put 64 bit signed value
procedure PutInt64(Stream: TStream; value: int64);
begin
value := IESwapInt64(value);
Stream.Write(value, 8);
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;
// put 64 bit signed value at specified position, restoring the previous one when exits
procedure PutInt64At(Stream: TStream; position: int64; value: int64);
var
prev: int64;
begin
prev := Stream.Position;
Stream.Position := position;
value := IESwapInt64(value);
Stream.Write(value, 8);
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: TColorMap;
i: integer;
begin
with context do
begin
if mergedImage.PixelFormat = ie8p then
begin
// 256 values palette
PutLongint(Stream, 768);
SetLength(colormap, 3);
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);
end
else
begin
// empty section
PutLongint(Stream, 0);
end;
end;
end;
procedure WriteResource(Stream: TStream; ID: smallint; name: AnsiString; 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: TIOParams;
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 := TIOParams.Create( nil );
dummyProgress := NullProgressRec( 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);
try
if buflen > 0 then
WriteResource(Stream, $0404, '', buf, buflen);
finally
freemem(buf);
end;
// $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);
try
WriteResource(Stream, $040C, '', buf, buflen);
finally
freemem(buf);
end;
end;
// $0424 - XMP
if IOParams.XMP_Info <> '' then
WriteResource(Stream, $0424, '', PAnsiChar(IOParams.XMP_Info), length(IOParams.XMP_Info)); // 3.0.1
// align position
if (Stream.Position and $1) <> 0 then
PutByte(Stream, 0);
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 int64;
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 IOParams.PSD_LargeDocumentFormat then
begin
// PSB, 32 bit row length
if sizes <> nil then
PutLongintAt(Stream, pos2 + row * 4, cmplen)
else
PutLongintAt(Stream, pos2 + i * bitmapHeight * 4 + row * 4, cmplen);
end
else
begin
// PSD, 16 bit row length
if sizes <> nil then
PutSmallintAt(Stream, pos2 + row * 2, cmplen)
else
PutSmallintAt(Stream, pos2 + i * bitmapHeight * 2 + row * 2, cmplen);
end;
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);
try
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;
if IOParams.PSD_LargeDocumentFormat then
// PSB, 32 bit row length
Stream.Seek(Bitmap.AlphaChannel.Height * 4, soCurrent)
else
// PSD, 16 bit row length
Stream.Seek(Bitmap.AlphaChannel.Height * 2, soCurrent);
// write values
for row := 0 to Bitmap.AlphaChannel.Height - 1 do
begin
pb := Bitmap.AlphaChannel.Scanline[row];
actlen := 0;
case depth of
1:
begin
assert(false);
end;
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
if IOParams.PSD_LargeDocumentFormat then
// PSB, 64 bit size
PutInt64At(Stream, sizes[sizesIdx][k], Stream.Size - pos1) // included compression tag
else
// PSD, 32 bit size
PutLongintAt(Stream, sizes[sizesIdx][k], Stream.Size - pos1); // included compression tag
inc(k);
end;
// put color channels
channelCount := bitmap.ChannelCount;
bitmapWidth := bitmap.Width;
bitmapHeight := bitmap.Height;
bitmapPixelFormat := bitmap.PixelFormat;
if sizes = nil then
begin
PutSmallint(Stream, 1); // compression (for merged, out of channels loop)
// put blank row lengths
pos2 := Stream.Position;
if IOParams.PSD_LargeDocumentFormat then
// PSB, 32 bit row length
Stream.Seek(BitmapHeight * channelCount * 4, soCurrent)
else
// PSD, 16 bit row length
Stream.Seek(BitmapHeight * channelCount * 2, soCurrent);
end;
for i := 0 to channelCount - 1 do
begin
pos1 := Stream.Position;
if sizes <> nil then
begin
PutSmallint(Stream, 1); // compression (for layers)
// put blank row lengths
pos2 := Stream.Position;
if IOParams.PSD_LargeDocumentFormat then
// PSB, 32 bit row length
Stream.Seek(BitmapHeight * 4, soCurrent)
else
// PSd, 16 bit row length
Stream.Seek(BitmapHeight * 2, soCurrent);
end;
for row := 0 to bitmapHeight - 1 do
begin
pb := Bitmap.Scanline[row];
pw := pword(pb);
if bitmapPixelFormat = ie24RGB then
inc(pb, 2 - i)
else
inc(pb, i);
inc(pw, i);
case depth of
1:
begin
actlen := rl;
move(pb^, rowbuf^, actlen);
_NegativeBuffer(rowbuf, actlen);
end;
8:
begin
rb := rowbuf;
for col := 0 to bitmapWidth - 1 do
begin
rb^ := pb^;
inc(pb, channelCount);
inc(rb);
end;
actlen := rl;
end;
16:
begin
wb := pword(rowbuf);
for col := 0 to bitmapWidth - 1 do
begin
wb^ := IESwapWord(pw^);
inc(pw, channelCount);
inc(wb);
end;
actlen := rl;
end;
end;
WriteRow();
end;
// write channel size
if sizes <> nil then
begin
if IOParams.PSD_LargeDocumentFormat then
// PSB, 64 bit size
PutInt64At(Stream, sizes[sizesIdx][k], Stream.Size - pos1) // included compression tag
else
// PSD, 32 bit size
PutLongintAt(Stream, sizes[sizesIdx][k], Stream.Size - pos1); // included compression tag
end;
inc(k);
if doProgress and assigned(Progress.fOnProgress) then
Progress.fOnProgress(Progress.Sender, trunc(i / channelCount * 100));
end;
// put layer mask (always 8 bit?)
if layerMask <> nil then
begin
pos1 := Stream.Position;
PutSmallint(Stream, 1); // compression
// put blank row lengths
pos2 := Stream.Position;
if IOParams.PSD_LargeDocumentFormat then
// PSB, 32 bit row length
Stream.Seek(layerMask.Height * 4, soCurrent)
else
// PSD, 16 bit row length
Stream.Seek(layerMask.Height * 2, soCurrent);
// write values
for row := 0 to layerMask.Height - 1 do
begin
pb := layerMask.Scanline[row];
actlen := layerMask.Width;
move(pb^, rowbuf^, actlen);
WriteRow();
end;
// write channel size
if sizes <> nil then
begin
if IOParams.PSD_LargeDocumentFormat then
// PSB, 64 bit size
PutInt64At(Stream, sizes[sizesIdx][k], Stream.Size - pos1) // included compression tag
else
// PSD, 32 bit size
PutLongintAt(Stream, sizes[sizesIdx][k], Stream.Size - pos1); // included compression tag
end;
end;
finally
freemem(cmpbuf);
freemem(rowbuf);
end;
end; // end of with context
end;
procedure MakeLayerPSDCompatible(layer: TIEImageLayer; Mode: Integer; var Depth: Integer);
var
proc: TImageEnProc;
begin
if (mode = -1) or (mode = 1000) then
exit;
proc := TImageEnProc.Create(nil);
try
// change pixel format (if this is not a layer mask)
with layer do
begin
if not IsMask then
case mode of
0: // black/white
begin
depth := 1;
if Bitmap.PixelFormat <> ie1g then
Bitmap.PixelFormat := ie1g;
end;
1: // gray scale
begin
if (depth = 8) and (Bitmap.PixelFormat <> ie8g) then
Bitmap.PixelFormat := ie8g
else
if (depth = 16) and (Bitmap.PixelFormat <> ie16g) then
Bitmap.PixelFormat := ie16g;
end;
2: // indexed
begin
depth := 8;
if Bitmap.PixelFormat <> ie8p then
Bitmap.PixelFormat := ie8p;
end;
3: // RGB
begin
if (depth = 8) and (Bitmap.PixelFormat <> ie24RGB) then
Bitmap.PixelFormat := ie24RGB
else
if (depth = 16) and (Bitmap.PixelFormat <> ie48RGB) then
Bitmap.PixelFormat := ie48RGB;
end;
4: // CMYK
begin
depth := 8;
if Bitmap.PixelFormat <> ieCMYK then
Bitmap.PixelFormat := ieCMYK;
end;
9: // Lab
begin
depth := 8;
if Bitmap.PixelFormat <> ieCIELab then
Bitmap.PixelFormat := ieCIELab;
end;
end;
// now resize
if (Width <> Bitmap.Width) or (Height <> Bitmap.Height) then
begin
proc.AttachedIEBitmap := Bitmap;
if UseResampleFilter then
proc.Resample(Width, Height, ResampleFilter)
else
proc.Resample(Width, Height, rfNone);
end;
if mode <> 0 then
Bitmap.AlphaChannel; // each layer needs to have an alpha mask
end;
finally
proc.Free();
end;
end;
// in PSD layers have the same size of related bitmap
// in PSD layers have all the same pixel format
// this function make ImageEn layers compatible with PSD
procedure MakeAllLayersPSDCompatible(mergedImage: TIEBitmap; layers: TList);
var
i : integer;
mode, depth: integer;
begin
mode := -1;
depth := -1;
if mergedImage <> nil then
begin
mode := PIXELFORMAT2MODE[mergedImage.PixelFormat];
depth := mergedImage.BitCount div mergedImage.ChannelCount;
end;
if ( mode = -1 ) and ( layers.count > 0 ) then
begin
with TIELayer(layers[0]) do
begin
mode := PIXELFORMAT2MODE[Bitmap.PixelFormat];
depth := Bitmap.BitCount div Bitmap.ChannelCount;
end;
end;
for i := 0 to layers.Count - 1 do
if TIELayer(layers[i]) is TIEImageLayer then
MakeLayerPSDCompatible( TIEImageLayer( layers[i] ), mode, depth );
end;
procedure WriteLayers(var context: TPSDWriterContext);
var
sizepos: int64;
i, j, k: integer;
lyr, msk: TIELayer;
sizes: PSizes; // array of lsizes structure to store channels sizes for each layer
layermaskcount: integer; // number of layer masks
pos1: int64;
extradatasize: integer;
chcount: integer;
tempLayer: TIELayer; // used if layers.Count=0
doFreeLayer: Boolean;
begin
with context do
begin
sizepos := Stream.Position;
// dummy size value
if IOParams.PSD_LargeDocumentFormat then
// PSB, 64 bit size
PutInt64(Stream, 0)
else
// PSB, 32 bit size
PutLongint(Stream, 0);
// PSD cannot contain black/white layers
if ((layers.Count > 0) and (TIELayer(layers[0]).Bitmap.PixelFormat = ie1g)) or
((layers.Count = 0) and (MergedImage.PixelFormat = ie1g)) then
exit;
if layers.Count = 0 then
begin
tempLayer := TIEImageLayer.Create(nil, MergedImage, true);
TIEImageLayer( tempLayer ).fFreeBitmapOnDestroy := false;
layers.Add(tempLayer);
end
else
tempLayer := nil;
// count how much layer mask are present
layermaskcount := 0;
for i := 0 to layers.Count - 1 do
if TIELayer(layers[i]).IsMask then
inc(layermaskcount);
PutSmallint(Stream, layers.Count - layermaskcount); // layers count
getmem(sizes, sizeof(int64) * 6 * layers.Count);
try
doFreeLayer := False;
for i := 0 to layers.Count - 1 do
begin
lyr := TIELayer(layers[i]);
if not ( lyr is TIEImageLayer ) then
begin
// Convert non-image layers
lyr := TIEImageLayer.Create( lyr.fOwner, lyr );
MakeLayerPSDCompatible( TIEImageLayer( lyr), Mode, Depth );
doFreeLayer := True;
end;
if not lyr.IsMask then
begin
PutLongint(Stream, lyr.PosY); // Layer top
PutLongint(Stream, lyr.PosX); // Layer left
PutLongint(Stream, lyr.PosY + lyr.Bitmap.Height); // Layer bottom
PutLongint(Stream, lyr.PosX + lyr.Bitmap.Width); // Layer right
// channels count
chcount := lyr.Bitmap.ChannelCount;
if lyr.Bitmap.HasAlphaChannel then
inc(chcount);
if (i < layers.Count - 1) and (TIELayer(layers[i + 1]).IsMask) then
inc(chcount);
PutSmallint(Stream, chcount);
// channel length info
k := 0;
if lyr.Bitmap.HasAlphaChannel then
begin
// transparency mask
PutSmallint(Stream, -1); // -1 = transparency mask
sizes[i][k] := Stream.Position;
inc(k);
// dummy size
if IOParams.PSD_LargeDocumentFormat then
// PSB
PutInt64(Stream, 0)
else
// PSD
PutLongint(Stream, 0);
end;
for j := 0 to lyr.Bitmap.ChannelCount - 1 do
begin
// color channels
PutSmallint(Stream, j);
sizes[i][k] := Stream.Position;
inc(k);
// dummy size
if IOParams.PSD_LargeDocumentFormat then
// PSB
PutInt64(Stream, 0)
else
// PSD
PutLongint(Stream, 0);
end;
if (i < layers.Count - 1) and (TIELayer(layers[i + 1]).IsMask) then
begin
// layer mask
PutSmallint(Stream, -2);
sizes[i][k] := Stream.Position;
//inc(k);
// dummy size
if IOParams.PSD_LargeDocumentFormat then
// PSB
PutInt64(Stream, 0)
else
// PSD
PutLongint(Stream, 0);
end;
Stream.Write(AnsiString('8BIM'), 4); // Blend mode signature
Stream.Write(AnsiString('norm'), 4); // temporary: blend mode key
// Opacity
PutByte(Stream, trunc(lyr.Opacity * 255));
//PutByte(Stream, integer(not lyr.Cropped)); // Clipping
PutByte(Stream, 0); // it seems that photoshop doesn't support "1"!
// Flags
if lyr.Visible then
PutByte(Stream, 0)
else
PutByte(Stream, $2);
PutByte(Stream, 0); // Filler
// extra data size
pos1 := Stream.Position;
PutLongint(Stream, 0); // Extra data size (dummy value)
extradatasize := 0;
// Layer mask data
inc(extradatasize, 4);
if (i < layers.Count - 1) and (TIELayer(layers[i + 1]).IsMask) then
begin
PutLongint(Stream, 20); // Layer mask data size
msk := TIELayer(layers[i + 1]);
PutLongint(Stream, msk.PosY); // top
PutLongint(Stream, msk.PosX); // left
PutLongint(Stream, msk.PosY + msk.Bitmap.Height); // bottom
PutLongint(Stream, msk.PosX + msk.Bitmap.Width); // right
PutByte(Stream, 0); // default color
PutByte(Stream, 0); // flags
PutSmallint(Stream, 0); // padding (zeros)
inc(extradatasize, 20);
end
else
PutLongint(Stream, 0); // Layer mask data size (no layer mask)
// Layer blending ranges (not used)
PutLongint(Stream, 0); // zero size
inc(extradatasize, 4);
// Layer name
PutByte(Stream, length(lyr.Name)); // name size
Stream.Write(lyr.Name[1], length(lyr.Name)); // name
inc(extradatasize, 1 + length(lyr.Name));
// pad to multiple of 4 bytes
while (ExtraDataSize and $3) <> 0 do
begin
PutByte(Stream, 1);
inc(ExtraDataSize);
end;
// adjustment layer info tags (not used)
// just blank because this is tagged
// actual extra data asize
PutLongintAt(Stream, pos1, extradatasize);
end;
if doFreeLayer then
lyr.Free;
doFreeLayer := False;
end; // for each layer loop
// write pixel data
for i := 0 to layers.Count - 1 do
begin
lyr := TIELayer(layers[i]);
if not ( lyr is TIEImageLayer ) then
begin
// Convert non-image layers
lyr := TIEImageLayer.Create( lyr.fOwner, lyr );
MakeLayerPSDCompatible( TIEImageLayer( lyr), Mode, Depth );
doFreeLayer := True;
end;
if not lyr.IsMask then
begin
if (i < layers.Count - 1) and (TIELayer(layers[i + 1]).IsMask) then
WritePixelData(context, lyr.Bitmap, TIELayer(layers[i + 1]).Bitmap, sizes, i, false)
else
WritePixelData(context, lyr.Bitmap, nil, sizes, i, false);
end;
if doFreeLayer then
lyr.Free;
doFreeLayer := False;
if assigned(Progress.fOnProgress) then
Progress.fOnProgress(Progress.Sender, trunc(i / layers.Count * 100));
end;
finally
freemem(sizes);
if tempLayer <> nil then
begin
layers.Clear();
tempLayer.Free();
end;
end;
if IOParams.PSD_LargeDocumentFormat then
// PSB, 64 bit size
PutInt64At(Stream, sizepos, Stream.Size - sizepos - 8)
else
// PSD, 32 bit size
PutLongintAt(Stream, sizepos, Stream.Size - sizepos - 4);
end;
end;
procedure WriteGlobalMask(var context: TPSDWriterContext);
var
sizepos: int64;
begin
with context do
begin
sizepos := Stream.Position;
PutLongint(Stream, 0); // dummy size value
PutLongintAt(Stream, sizepos, Stream.Size - sizepos - 4);
end;
end;
// Write layer and mask information section
procedure WriteLayerAndMaskInfo(var context: TPSDWriterContext);
var
sizepos: int64;
begin
with context do
begin
sizepos := Stream.Position;
// dummy size value
if IOParams.PSD_LargeDocumentFormat then
// PSB, 64 bit size
PutInt64(Stream, 0)
else
// PSB, 32 bit size
PutLongint(Stream, 0);
if context.layers.Count > 0 then
begin
WriteLayers( context );
WriteGlobalMask(context);
if IOParams.PSD_LargeDocumentFormat then
// PSB, 64 bit size
PutInt64At(Stream, sizepos, Stream.Size - sizepos - 8)
else
// PSD, 32 bit size
PutLongintAt(Stream, sizepos, Stream.Size - sizepos - 4);
end;
end;
end;
// layers cannot be "nil". If you don't want save layers, just leave its size (Count) = 0
// mergedImage must be always present
procedure IEWritePSD(Stream: TStream; var IOParams: TIOParams; var Progress: TProgressRec; mergedImage: TIEBitmap; layers: TList);
var
context: TPSDWriterContext;
header: TPSDHeader;
begin
MakeAllLayersPSDCompatible(mergedImage, layers);
context.Stream := Stream;
context.IOParams := IOParams;
context.layers := layers;
context.mergedImage := mergedImage;
context.Progress := Progress;
with context do
begin
mode := PIXELFORMAT2MODE[mergedImage.PixelFormat];
depth := mergedImage.BitCount div mergedImage.ChannelCount;
if mode = 1000 then
begin
// pixel format not supported by PSD
Progress.Aborting^ := true;
exit;
end;
// prepare header
Move(MAGIK[0], header.Signature[0], 4);
if IOParams.PSD_LargeDocumentFormat then
// PSB (version = 2)
header.Version := IESwapWord(2)
else
// PSD (version = 1)
header.Version := IESwapWord(1);
FillChar(header.Reserved[0], 5, 0);
header.Channels := IESwapWord(mergedImage.ChannelCount);
header.Rows := IESwapDWord(mergedImage.Height);
header.Columns := IESwapDWord(mergedImage.Width);
header.Depth := IESwapWord(depth);
header.Mode := IESwapWord(mode);
// write header
Stream.Write(header, sizeof(TPSDHeader));
// write color mode data section (palette)
WriteColorMap(context);
// write image resources section
WriteImageResources(context);
// write Layer and mask information section
WriteLayerAndMaskInfo( context );
// write pixel data (merged image)
WritePixelData(context, mergedImage, nil, nil, 0, (layers.Count > 0));
end;
end;
{$endif} // IEINCLUDEPSD
end.