Convert Bitmap to PSD

procedure BMPToPSD(BMP:TBitmap;SaveFileName: String);
  type
   PRGBColor = ^TRGBColor;
   TRGBColor = array[0..32768-1] of TRGBTriple;
  type
    TPSDHeader = packed record
      Signature : array[0..3] of Char;
      Version   : Word;
      Reserved  : array[0..5] of Byte;
      Channels  : Word;
      Rows      : DWord;
      Columns   : DWord;
      Depth     : Word;
      Mode      : Word;
  end;

  function IntelOder_word(Buffer :word):word;
  begin
   Result :=(Buffer AND $00FF) shl 8 ;
   Result :=Result+(Buffer AND $FF00) shr 8  ;
  end;

  function IntelOder_Dword(Buffer :Dword):Dword;
  begin
   Result   :=(Buffer AND $000000FF) shl 24 ;
   Result   :=Result or ((Buffer AND $0000FF00) shl 8) ;
   Result   :=Result or ((Buffer AND $00FF0000) shr 8) ;
   Result   :=Result or ((Buffer AND $FF000000) shr 24)  ;
  end;

Var
 PSD      : TPSDHeader ;
 Section  : Integer;
 Compress : Word;
 Stream   : TMemoryStream;
 Row,COl  : Integer;
 SrcRow   : PRGBColor;
 Buffer   : Pointer;
 Lines    : PBYTE;
begin

 if BMP.Empty then raise Exception.Create('TBitmapƒIƒuƒWƒFƒNƒg‚ɃCƒ**[ƒW‚ª“ü‚Á‚Ä‚¢‚È‚¢‚æ*B');
 if BMP.Pixelformat<>pf24bit then BMP.Pixelformat:=pf24bit;

 Stream:=TMemoryStream.Create;

 ZeroMemory(@PSD,sizeof(TPSDHeader));
 Section       :=0;

 PSD.Signature :='8BPS';
 PSD.Version   :=IntelOder_word(1);
 PSD.Rows      :=IntelOder_Dword(BMP.Height);
 PSD.Columns   :=IntelOder_Dword(BMP.Width);
 PSD.Depth     :=IntelOder_word(8) ;
 PSD.Channels  :=IntelOder_word(3);
 PSD.Mode:=IntelOder_word(3);

 Stream.write(PSD,sizeof(TPSDHeader));
 Stream.write(Section,4);
 Stream.write(Section,4);
 Stream.write(Section,4);

 Compress:=0;
 Stream.write(Compress,2);

 //RRR GGG BBB 
 GetMem(Buffer,BMP.Width*BMP.Height);
 try
   Lines:=Buffer;
   //RRR
   for Row := 0 to BMP.Height - 1 do
   begin
     SrcRow:=  BMP.ScanLine[Row];
     for Col:= 0 to  BMP.Width -1 do
     begin
       Lines^:=SrcRow[Col].rgbtRed;
       inc(Lines);
     end;
   end;
   Dec(Lines,BMP.Width*BMP.Height);
   Stream.Write(Lines^,BMP.Width*BMP.Height);
 finally
  FreeMem(Buffer);
 end;

 //BBB
 GetMem(Buffer,BMP.Width*BMP.Height);
 try
   Lines:=Buffer;
   for Row := 0 to BMP.Height - 1 do
   begin
    SrcRow:=  BMP.ScanLine[Row];
    for Col:= 0 to  BMP.Width -1 do
    begin
      Lines^:=SrcRow[Col].rgbtGreen;
      inc(Lines);
    end;
   end;
   Dec(Lines,BMP.Width*BMP.Height);
   Stream.Write(Lines^,BMP.Width*BMP.Height);
 finally
  FreeMem(BUffer);
 end;

 //GGG
 GetMem(Buffer,BMP.Width*BMP.Height);

 try
   Lines:=Buffer;
   for Row := 0 to BMP.Height - 1 do
   begin
     SrcRow:=  BMP.ScanLine[Row];
     for Col:= 0 to  BMP.Width -1 do
     begin
      Lines^:=SrcRow[Col].rgbtBlue;
      inc(Lines);
    end;
   end;
   Dec(Lines,BMP.Width*BMP.Height);
   Stream.Write(Lines^,BMP.Width*BMP.Height);
 finally
  FreeMem(Buffer);
 end;

 Stream.SavetoFile(SaveFileName);
 Stream.free;
end;

Beispiel :

procedure TForm1.Button1Click(Sender: TObject);
var bmp : TBitmap;
begin
  bmp := TBitmap.Create;
  if OpenDialog1.Execute then
  begin
    try
    bmp.LoadFromFile(OpenDialog1.FileName);
    BMPToPSD(bmp, OpenDialog1.FileName + '.psd');
    finally
    bmp.Free;
    end;
  end;
end;