uses PSDUnit; 
 
procedure TForm1.Button5Click(Sender: TObject); 
var 
  PSD: TPSDBitmap; 
begin 
  PSD := TPSDBitmap.create; 
  PSD.Loadfromfile('C:\Test.psd'); 
  Canvas.Draw(10, 10, PSD); 
  PSD.free; 
end; 
 
procedure TForm1.Button6Click(Sender: TObject); 
begin 
  Image3.Picture.Loadfromfile('C:\Test.psd'); 
end; 
 
procedure TForm1.Button7Click(Sender: TObject); 
var 
  PSD: TPSDBitmap; 
  FS: TFilestream; 
begin 
  PSD := TPSDBitmap.create; 
  FS := TFilestream.create('C:\Test.psd', fmOpenRead); 
  PSD.LoadFromStream(FS); 
  FS.Free; 
  Canvas.Draw(10, 10, PSD); 
  PSD.free; 
end;

unit PSDUnit; 
 
interface 
 
uses Windows, Graphics, Classes, SysUtils; 
 
type 
  TPSDBitmap = class(TBitmap) 
  private 
    FPalette: array[0..767] of Byte; 
    procedure MakePalette(BPS: Byte; Mode: Integer); 
  public 
    procedure LoadFromStream(Stream: TStream); override; 
  end; 
 
implementation 
 
type 
  PRGBWord = ^TRGBWord; 
  TRGBWord = record 
    R, G, B: Word; 
  end; 
  PCMYK16 = ^TCMYK16; 
  TCMYK16 = record 
    C, M, Y, K: Word; 
  end; 
  PCMYK = ^TCMYK; 
  TCMYK = packed record 
    C, M, Y, K: Byte; 
  end; 
  PRGB = ^TRGB; 
  TRGB = packed record 
    R, G, B: Byte; 
  end; 
  PBGR = ^TBGR; 
  TBGR = packed record 
    B, G, R: Byte; 
  end; 
  TPSDHeader = packed record 
    Signature: array[0..3] of AnsiChar; 
    Version: Word; 
    Reserved: array[0..5] of AnsiChar; 
    Channels: Word; 
    Rows, Columns: Cardinal; 
    Depth, Mode: Word; 
  end; 
  TPackbitsRLE = class 
    procedure Decode(var Source: Pointer; Dest: Pointer; 
      PackedSize, UnpackedSize: Integer); 
  end; 
 
const 
  PSD_COMPRESSION_NONE = 0; 
  PSD_COMPRESSION_RLE = 1; 
  PSD_BITMAP = 0; 
  PSD_GRAYSCALE = 1; 
  PSD_INDEXED = 2; 
  PSD_RGB = 3; 
  PSD_CMYK = 4; 
  PSD_DUOTONE = 8; 
  PSD_LAB = 9; 
 
function Max(I1, I2: Integer): Integer; 
asm 
  CMP EAX, EDX 
  JGE @Bottom 
  MOV EAX, EDX 
 @Bottom: 
end; 
 
function Min(I1, I2: Integer): Integer; 
asm 
  CMP EAX, EDX 
  JLE @Bottom 
  MOV EAX, EDX 
 @Bottom: 
end; 
 
procedure CIELAB2BGR(LSource, aSource, bSource: PByte; 
  Target: Pointer; BitsPerSample: Byte; Count: Cardinal); overload; 
var 
  FinalR, FinalG, FinalB: Integer; 
  L, A, B, X, Y, Z, T, N: Double; 
  PixelCount: Cardinal; 
  TargetPtr: PByte; 
  function H3(D: Double): Double; 
  begin 
    Result := D * D * D; 
  end; 
begin 
  TargetPtr := Target; 
  PixelCount := Count div 3; 
  while PixelCount > 0 do 
  begin 
    L := LSource^ / 2.55; 
    Inc(LSource); 
    A := ShortInt(aSource^); 
    Inc(aSource); 
    B := ShortInt(bSource^); 
    Inc(bSource); 
    N := (L + 16) / 116; 
    if L < 7.9996 then 
    begin 
      Y := L / 903.3; 
      X := A / 3893.5 + Y; 
      Z := Y - B / 1557.4; 
    end else begin 
      T := N + A / 500; 
      X := H3(T); 
      Y := H3(N); 
      T := N - B / 200; 
      Z := H3(T); 
    end; 
    FinalR := Round(MaxByte * (2.998 * X - 1.458 * Y - 0.541 * Z)); 
    FinalG := Round(MaxByte * (-0.952 * X + 1.893 * Y + 0.059 * Z)); 
    FinalB := Round(MaxByte * (0.099 * X - 0.198 * Y + 1.099 * Z)); 
    TargetPtr^ := Max(0, Min(MaxByte, FinalB)); 
    Inc(TargetPtr); 
    TargetPtr^ := Max(0, Min(MaxByte, FinalG)); 
    Inc(TargetPtr); 
    TargetPtr^ := Max(0, Min(MaxByte, FinalR)); 
    Inc(TargetPtr); 
    Dec(PixelCount); 
  end; 
end; 
 
procedure CMYK2BGR(C, M, Y, K, Target: Pointer; BitsPerSample: Byte; 
  Count: Cardinal); overload; 
var 
  TargetPtr, C8, M8, Y8, K8: PByte; 
  C16, M16, Y16, K16: PWord; 
  I, R, G, B: Integer; 
begin 
  Count := Count div 4 - 1; 
  TargetPtr := Target; 
  case BitsPerSample of 
    8: begin 
        C8 := C; 
        M8 := M; 
        Y8 := Y; 
        K8 := K; 
        for I := 0 to Count do 
        begin 
          R := MaxByte - (C8^ - MulDiv(C8^, K8^, MaxByte) + K8^); 
          G := MaxByte - (M8^ - MulDiv(M8^, K8^, MaxByte) + K8^); 
          B := MaxByte - (Y8^ - MulDiv(Y8^, K8^, MaxByte) + K8^); 
          TargetPtr^ := Max(0, Min(MaxByte, B)); 
          Inc(TargetPtr); 
          TargetPtr^ := Max(0, Min(MaxByte, G)); 
          Inc(TargetPtr); 
          TargetPtr^ := Max(0, Min(MaxByte, R)); 
          Inc(TargetPtr); 
          Inc(C8); 
          Inc(M8); 
          Inc(Y8); 
          Inc(K8); 
        end; 
      end; 
    16: begin 
        C16 := C; 
        M16 := M; 
        Y16 := Y; 
        K16 := K; 
        for I := 0 to Count do 
        begin 
          R := MaxByte - 
            (C16^ - MulDiv(C16^, K16^, MaxWord) + K16^) shr 8; 
          G := MaxByte - 
            (M16^ - MulDiv(M16^, K16^, MaxWord) + K16^) shr 8; 
          B := MaxByte - 
            (Y16^ - MulDiv(Y16^, K16^, MaxWord) + K16^) shr 8; 
          TargetPtr^ := Max(0, Min(MaxByte, B)); 
          Inc(TargetPtr); 
          TargetPtr^ := Max(0, Min(MaxByte, G)); 
          Inc(TargetPtr); 
          TargetPtr^ := Max(0, Min(MaxByte, R)); 
          Inc(TargetPtr); 
          Inc(C16); 
          Inc(M16); 
          Inc(Y16); 
          Inc(K16); 
        end; 
      end; 
  end; 
end; 
 
procedure RGB2BGR(R, G, B, Target: Pointer; BitsPerSample: Byte; 
  Count: Cardinal); overload; 
var 
  TargetPtr, R8, G8, B8: PByte; 
  R16, G16, B16: PWord; 
begin 
  Count := Count div 3; 
  TargetPtr := Target; 
  case BitsPerSample of 
    8: begin 
        R8 := R; 
        G8 := G; 
        B8 := B; 
        while Count > 0 do 
        begin 
          TargetPtr^ := B8^; 
          Inc(B8); 
          Inc(TargetPtr); 
          TargetPtr^ := G8^; 
          Inc(G8); 
          Inc(TargetPtr); 
          TargetPtr^ := R8^; 
          Inc(R8); 
          Inc(TargetPtr); 
          Dec(Count); 
        end; 
      end; 
    16: begin 
        R16 := R; 
        G16 := G; 
        B16 := B; 
        while Count > 0 do 
        begin 
          TargetPtr^ := B16^ shr 8; 
          Inc(B16); 
          Inc(TargetPtr); 
          TargetPtr^ := G16^ shr 8; 
          Inc(G16); 
          Inc(TargetPtr); 
          TargetPtr^ := R16^ shr 8; 
          Inc(R16); 
          Inc(TargetPtr); 
          Dec(Count); 
        end; 
      end; 
  end; 
end; 
 
procedure TPackbitsRLE.Decode(var Source: Pointer; Dest: Pointer; 
  PackedSize, UnpackedSize: Integer); 
var 
  SourcePtr, TargetPtr: PByte; 
  N: SmallInt; 
begin 
  TargetPtr := Dest; 
  SourcePtr := Source; 
  while PackedSize > 0 do 
  begin 
    N := ShortInt(SourcePtr^); 
    Inc(SourcePtr); 
    Dec(PackedSize); 
    if N < 0 then 
    begin 
      if N = -128 then Continue; 
      N := 1 - N; 
      FillChar(TargetPtr^, N, SourcePtr^); 
      Inc(SourcePtr); 
      Inc(TargetPtr, N); 
      Dec(PackedSize); 
    end 
    else 
    begin 
      Move(SourcePtr^, TargetPtr^, N + 1); 
      Inc(TargetPtr, N + 1); 
      Inc(SourcePtr, N + 1); 
      Dec(PackedSize, N + 1); 
    end; 
  end; 
end; 
 
procedure TPSDBitmap.MakePalette(BPS: Byte; Mode: Integer); 
var 
  Pal: TMaxLogPalette; 
  EntryCount: Word; 
  hpal: HPALETTE; 
  I: Integer; 
begin 
  case BPS of 
    1: EntryCount := 1; 
    4: EntryCount := 15; 
  else 
    EntryCount := MaxByte; 
  end; 
  Pal.palVersion := $300; 
  Pal.palNumEntries := 1 + EntryCount; 
  case BPS of 
    1: begin 
        Pal.palPalEntry[0].peRed := MaxByte; 
        Pal.palPalEntry[0].peGreen := MaxByte; 
        Pal.palPalEntry[0].peBlue := MaxByte; 
        Pal.palPalEntry[0].peFlags := 0; 
        Pal.palPalEntry[1].peRed := 0; 
        Pal.palPalEntry[1].peGreen := 0; 
        Pal.palPalEntry[1].peBlue := 0; 
        Pal.palPalEntry[1].peFlags := 0; 
      end; 
  else 
    case Mode of 
      PSD_DUOTONE, 
        PSD_GRAYSCALE: 
        for I := 0 to EntryCount do 
        begin 
          Pal.palPalEntry[I].peRed := I; 
          Pal.palPalEntry[I].peGreen := I; 
          Pal.palPalEntry[I].peBlue := I; 
          Pal.palPalEntry[I].peFlags := 0; 
        end; 
    else 
      for I := 0 to EntryCount do 
      begin 
        Pal.palPalEntry[I].peRed := FPalette[I]; 
        Pal.palPalEntry[I].peGreen := FPalette[256 + I]; 
        Pal.palPalEntry[I].peBlue := FPalette[512 + I]; 
        Pal.palPalEntry[I].peFlags := 0; 
      end; 
    end; 
  end; 
  hpal := CreatePalette(PLogPalette(@Pal)^); 
  if hpal <> 0 then Palette := hpal; 
end; 
 
procedure TPSDBitmap.LoadFromStream(Stream: TStream); 
  function SwapLong(Value: Cardinal): Cardinal; 
  asm 
  BSWAP EAX 
  end; 
  procedure SwapShort(P: PWord; Count: Cardinal); 
  asm 
 @Top: 
  MOV CX, [EAX] 
  XCHG CH, CL 
  MOV [EAX], CX 
  ADD EAX, 2 
  DEC EDX 
  JNZ @Top 
  end; 
var 
  Compression: Word; 
  Header: TPSDHeader; 
  Decoder: TPackbitsRLE; 
  RLELength: array of Word; 
  RawBuffer, Buffer: Pointer; 
  Run1, Run2, Run3, Run4: PByte; 
  ChannelSize, BPS, Y, Count, W3, BW, HCMCS: Integer; 
begin 
  with Stream do 
  begin 
    ReadBuffer(Header, SizeOf(Header)); 
    with Header do begin 
      if Signature <> '8BPS' then 
        raise Exception.Create('Das ist keine PSD-Datei'); 
      if Swap(Version) <> 1 then 
        raise Exception.Create('Diese Datei wird nicht unterstützt'); 
      Channels := Swap(Channels); 
      Rows := SwapLong(Rows); 
      Columns := SwapLong(Columns); 
      Depth := Swap(Depth); 
      Mode := Swap(Mode); 
    end; 
    case Header.Mode of 
      PSD_BITMAP: PixelFormat := pf1Bit; 
      PSD_DUOTONE, PSD_GRAYSCALE, PSD_INDEXED: PixelFormat := pf8Bit; 
    else PixelFormat := pf24Bit; 
    end; 
    ReadBuffer(Count, SizeOf(Count)); 
    Count := SwapLong(Count); 
    if Header.Mode in [PSD_BITMAP, PSD_GRAYSCALE, PSD_INDEXED] then 
    begin 
      if Header.Mode = PSD_INDEXED then ReadBuffer(FPalette, Count); 
      MakePalette(Header.Depth, Header.Mode); 
    end; 
    Width := Header.Columns; 
    Height := Header.Rows; 
    W3 := Width + Width + Width; 
    ReadBuffer(Count, SizeOf(Count)); 
    Count := SwapLong(Count); 
    Seek(Count, soFromCurrent); 
    ReadBuffer(Count, SizeOf(Count)); 
    Count := SwapLong(Count); 
    Seek(Count, soFromCurrent); 
    RawBuffer := nil; 
    ReadBuffer(Compression, SizeOf(Compression)); 
    Compression := Swap(Compression); 
    if Compression = 1 then 
    begin 
      Decoder := TPackbitsRLE.Create; 
      SetLength(RLELength, Header.Rows * Header.Channels); 
      ReadBuffer(RLELength[0], 2 * Length(RLELength)); 
      SwapShort(@RLELength[0], Header.Rows * Header.Channels); 
    end 
    else 
      Decoder := nil; 
    try 
      case Header.Mode of 
        PSD_BITMAP, PSD_DUOTONE, PSD_GRAYSCALE, PSD_INDEXED: 
          begin 
            if Assigned(Decoder) then 
            begin 
              Count := 0; 
              for Y := 0 to Height - 1 do Inc(Count, RLELength[Y]); 
              GetMem(RawBuffer, Count); 
              ReadBuffer(RawBuffer^, Count); 
              Run1 := RawBuffer; 
              for Y := 0 to Height - 1 do 
              begin 
                Count := RLELength[Y]; 
                Decoder.Decode(Pointer(Run1), ScanLine[Y], Count, Width); 
                Inc(Run1, Count); 
              end; 
              FreeMem(RawBuffer); 
            end 
            else 
              for Y := 0 to Height - 1 do 
                ReadBuffer(ScanLine[Y]^, Width); 
          end; 
        PSD_RGB, PSD_CMYK, PSD_LAB: 
          begin 
            BPS := Header.Depth shr 3; 
            BW := BPS * Width; 
            ChannelSize := BW * Height; 
            HCMCS := Header.Channels * ChannelSize; 
            GetMem(Buffer, HCMCS); 
            if Assigned(Decoder) then 
            begin 
              Count := 0; 
              for Y := 0 to High(RLELength) do 
                Inc(Count, RLELength[Y]); 
              Count := Count * BPS; 
              GetMem(RawBuffer, Count); 
              Run1 := RawBuffer; 
              ReadBuffer(RawBuffer^, Count); 
              Decoder.Decode(RawBuffer, Buffer, Count, HCMCS); 
              FreeMem(RawBuffer); 
            end else begin 
              ReadBuffer(Buffer^, HCMCS); 
              if BPS = 2 then 
                SwapShort(Buffer, HCMCS div 2); 
            end; 
            case Header.Mode of 
              PSD_RGB: 
                begin 
                  Run1 := Buffer; 
                  Run2 := Run1; 
                  Inc(Run2, ChannelSize); 
                  Run3 := Run2; 
                  Inc(Run3, ChannelSize); 
                  for Y := 0 to Height - 1 do 
                  begin 
                    RGB2BGR(Run1, Run2, Run3, Scanline[Y], Header.Depth, W3); 
                    Inc(Run1, BW); 
                    Inc(Run2, BW); 
                    Inc(Run3, BW); 
                  end; 
                end; 
              PSD_CMYK: 
                begin 
                  Run1 := Buffer; 
                  for Y := 1 to 4 * ChannelSize do 
                  begin 
                    Run1^ := MaxByte - Run1^; 
                    Inc(Run1); 
                  end; 
                  Run1 := Buffer; 
                  Run2 := Run1; 
                  Inc(Run2, ChannelSize); 
                  Run3 := Run2; 
                  Inc(Run3, ChannelSize); 
                  Run4 := Run3; 
                  Inc(Run4, ChannelSize); 
                  for Y := 0 to Height - 1 do 
                  begin 
                    CMYK2BGR(Run1, Run2, Run3, Run4, ScanLine[Y], 
                      Header.Depth, 4 * Width); 
                    Inc(Run1, BW); 
                    Inc(Run2, BW); 
                    Inc(Run3, BW); 
                    Inc(Run4, BW); 
                  end; 
                end; 
              PSD_LAB: 
                begin 
                  Run1 := Buffer; 
                  Inc(Run1, ChannelSize); 
                  for Y := 1 to 2 * ChannelSize do 
                  begin 
                    Run1^ := Run1^ - 128; 
                    Inc(Run1); 
                  end; 
                  Run1 := Buffer; 
                  Run2 := Run1; 
                  Inc(Run2, ChannelSize); 
                  Run3 := Run2; 
                  Inc(Run3, ChannelSize); 
                  for Y := 0 to Height - 1 do 
                  begin 
                    CIELAB2BGR(Run1, Run2, Run3, ScanLine[Y], Header.Depth, W3); 
                    Inc(Run1, BW); 
                    Inc(Run2, BW); 
                    Inc(Run3, BW); 
                  end; 
                end; 
            end; 
          end; 
      end; 
    finally 
      Decoder.Free; 
    end; 
  end; 
end; 
 
initialization 
  TPicture.RegisterFileFormat('PSD', 'PSD - Adobe Photoshop', TPSDBitmap); 
 
finalization 
  TPicture.UnRegisterGraphicClass(TPSDBitmap); 
 
end.