TOP > カテゴリ > フォーマット変換 >

Sun Raster RASファイルを変換する(Delphi)

Sun Raster RASファイルを読み込み、書き込む事のできるDelphiのソースコードです。クラスになっていますのでそのまま使用できます。

ソースコード

10年以上前に作成した古いコードで私すら覚えていないのですが、何かのお役に立てると嬉しいです。

//Sun Raster I/O Class
//
//Load 1/4/8/24/32bit
//Save 1/4/8/24/32bit
//

unit RasPack;

interface

uses
  Windows,Messages,SysUtils,Classes,Graphics;

type
  //32byte
  TRasHeader=packed record
   ras_magic    : DWORD;   //マジック
   ras_width    : DWORD;   //横幅
   ras_height   : DWORD;   //縦幅
   ras_depth    : DWORD;   //ビット深度 (1/4/8/24/32bit Only)
   ras_length   : DWORD;   //イメージデータの長さ(0の場合もある)
   ras_type     : DWORD;   //RAS   Types(ras_xxx参照)
   ras_maptype  : DWORD;   //Color Types(RMT_xxx参照)
   ras_maplength: DWORD;   //カラーパレットのサイズ
                           // ... 24/32bitの場合は0
                           // ... 1/4/8bitの場合はRGB値のカラーパレットのサイズ
end;        

type
  TRASImage = class(TBitmap)
  private
    function  GetPaletteCount:Integer;
    procedure SavePalette(Stream :TStream;Size:Integer);
    procedure ChangePalette(Stream:TStream;PaletteSize:Dword;Var LogPalette  : TMaxLogPalette);
    procedure Decode1bit(Stream:TStream;Ras:TRasHeader);
    procedure Decode4bit(Stream:TStream;Ras:TRasHeader);
    procedure Decode8bit(Stream:TStream;Ras:TRasHeader);
    procedure Encode1bit(Stream:TStream);
    procedure Encode4bit(Stream:TStream);
    procedure Encode8bit(Stream:TStream);
    procedure Encode24bit(Stream:TStream);
    procedure Encode32bit(Stream:TStream);
    procedure Decode24bit(Stream:TStream;Ras:TRasHeader);
    procedure Decode32bit(Stream:TStream;Ras:TRasHeader);
  public
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
  end;


type
 //24bit用ポインタ
 PRGBColor = ^TRGBColor;
 TRGBColor = array[0..32768-1] of TRGBTriple;
 //32bit用ポインタ
 PRGB32    =^TRGB32;
 TRGB32    = array[0..32768-1] of Dword;

const
  ras_old         =0;       //古いタイプ
  ras_standard    =1;       //標準タイプ(これ以外はもはや存在しない?)
  ras_byte_encoded=2;       //たぶん、圧縮タイプ
  ras_experimental=$FFFF;   //???

  //この部分はよくわからないがこれで大丈夫でしょう(^^;
  RMT_NONE        =0;
  RMT_EQUAL_RGB   =0;        //フルカラーベタイメージ(24/32bit)
  RMT_RAW         =1;        //カラーパレットを使用する(1/4/8bit)

  RASMAZIC       =$956AA659; //RASマジック


implementation


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


//////// インテルオーダー Dword編
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;

{---------}
{TRASImage}
{---------}

////////
function TRASImage.GetPaletteCount:Integer;
Var
 DIB      : TDIBSECTION;                     //DIB情報
begin
  Fillchar(DIB,Sizeof(TDIBSECTION),0);
  GetObject(handle,sizeof(TDIBSECTION),@DIB);
  Result:=DIB.dsBmih.biClrUsed;
end;

/////////
procedure TRASImage.SavePalette(Stream :TStream;size :Integer);
var
 i        : integer;
 DIB      : TDIBSECTION;                     //DIB情報
 R,G,B    : array [0..255] of BYTE ;
 nPalette : array [0..255] of TPALETTEENTRY;  //パレットエントリー
begin
  Fillchar(nPalette,Sizeof(TPALETTEENTRY)*256,0);
  Fillchar(R,256,0); Fillchar(G,256,0); Fillchar(B,256,0);
  Fillchar(DIB,Sizeof(TDIBSECTION),0);
  GetObject(handle,sizeof(TDIBSECTION),@DIB);
  GetPaletteEntries (palette,0,DIB.dsBmih.biClrUsed,nPalette);
  For i :=0 to  DIB.dsBmih.biClrUsed-1 do
  begin
    R[i]:=nPalette[i].peRed;
    G[i]:=nPalette[i].peGreen;
    B[i]:=nPalette[i].peBlue;
  end;
  //RRR GGG BBB で保存する            4b
  Stream.Write(R,Size);
  Stream.Write(G,Size);
  Stream.Write(B,Size);
end;

/////////
procedure TRASImage.ChangePalette(Stream:TStream;PaletteSize:Dword;Var LogPalette  : TMaxLogPalette);
Var
 i           : Integer;
 R,G,B       : array [0..255] of BYTE;
 MemoryStream :TMemoryStream;
begin
   //パレット生成
   ZeroMemory(@LogPalette, SizeOf(LogPalette));
   ZeroMemory(@R,256);ZeroMemory(@G,256);ZeroMemory(@B,256);
   LogPalette.palVersion := $300;
   LogPalette.palNumEntries := (PaletteSize div 3);

   Stream.Position:=32;
   MemoryStream :=TMemoryStream.Create;
   MemoryStream.CopyFrom(Stream,PaletteSize);
   MemoryStream.Position :=0;

   //PSD Like Palettes(rrr ggg bbbのように格納されている)
   MemoryStream.Read(R,PaletteSize div 3);
   MemoryStream.Read(G,PaletteSize div 3);
   MemoryStream.Read(B,PaletteSize div 3);

   for I := 0 to (PaletteSize div 3)-1 do
   begin
     LogPalette.palPalEntry[I].peBlue  :=B[i];
     LogPalette.palPalEntry[I].peGreen :=G[i];
     LogPalette.palPalEntry[I].peRed   :=R[i];
   end;
   MemoryStream.Free;
end;

/////////
procedure TRASImage.Decode1bit(Stream:TStream;Ras:TRasHeader);
Var
 X,Y : integer;
 Line8,SrcRow   : PByte;
 MemoryStream   : TMemoryStream;
 LogPalette     : TMaxLogPalette;
 Buffer         : Pointer;
 Size           : Integer;
begin
  //1bitデコーダ
  Pixelformat:=pf1bit;

  //2の倍数でない時は丸める(これはたぶんSunOSが16ビットマシンのせい?)
  size:=((1 * Width + 15) div 16) * 2 * Height;
  //パレット取得
  ChangePalette(Stream,Ras.ras_maplength,LogPalette);

  MemoryStream :=TMemoryStream.Create;
  Stream.Position:=32+6;
  MemoryStream.CopyFrom(Stream,size);
  MemoryStream.Position :=0;

  //パレット作成
  Palette := CreatePalette(PLogPalette(@LogPalette)^);

  GetMem(Buffer,size);
try
  Line8 :=Pbyte(Buffer);
  Move(MemoryStream.Memory^,Line8^,size);
  MemoryStream.Free;

  for Y := 0 to Height-1 do
  begin
     SrcRow :=ScanLine[Y];
     for X := 0 to (Width div 8)-1  do
     begin
        SrcRow^ := Line8^;
        Inc(SrcRow); inc(Line8);
     end;
     if (Width mod 2<>0) then
     begin
       SrcRow^:=Line8^;
       Inc(Line8);
     end;
  end ;
finally
   FreeMem(Buffer);
end;
end;

/////////
procedure TRASImage.Decode4bit(Stream:TStream;Ras:TRasHeader);
Var
 X,Y     : integer;
 SrcRow  : Pbytearray;
 Line8   : PByte;
 MemoryStream : TMemoryStream;
 Buffer       : Pointer;
 LogPalette   : TMaxLogPalette;
 Size         : Integer;
begin
  //1bitデコーダ
  Pixelformat:=pf4bit;

  //2の倍数でない時は丸める(これはたぶんSunOSが16ビットマシンのせい?)
  size:=((4 * Width + 15) div 16) * 2 * Height;

  //パレット生成
  ChangePalette(Stream,Ras.ras_maplength,LogPalette);

  MemoryStream :=TMemoryStream.Create;
  MemoryStream.CopyFrom(Stream,Size);
  MemoryStream.Position :=0;

  //パレット作成
  Palette := CreatePalette(PLogPalette(@LogPalette)^);

  GetMem(Buffer,Size);
try
  Line8 :=Pbyte(Buffer);
  Move(MemoryStream.Memory^,Line8^,Size);
  MemoryStream.Free;
  For Y :=0 to Height-1 do
  begin
     SrcRow :=ScanLine[Y];
     For X :=0 to (Width div 2)-1 do
     begin
       SrcRow[X]:=Line8^;
       inc(Line8);
     end;
     if (Width mod 2<>0) then
     begin
      SrcRow[Width div 2]:=Line8^;
      Inc(Line8);
     end;
  end;
finally
   FreeMem(Buffer);
end;

end;

/////////
procedure TRASImage.Decode8bit(Stream:TStream;Ras:TRasHeader);
Var
 Row,Col : integer;
 SrcRow  : PBytearray;
 Line8   : PByte;
 Buffer  : Pointer;
 MemoryStream : TMemoryStream;
 LogPalette   : TMaxLogPalette;
 size         : Integer;
begin
  //8bitデコーダ
  Pixelformat:=pf8bit;

  //2の倍数でない時は丸める(これはたぶんSunOSが16ビットマシンのせい?)
  size:=((8 * Width + 15) div 16) * 2 * Height ;

  //パレットの生成
  ChangePalette(Stream,Ras.ras_maplength,LogPalette);

  MemoryStream :=TMemoryStream.Create;
  Stream.Position:=32+Ras.ras_maplength;
  MemoryStream.CopyFrom(Stream,size);
  MemoryStream.Position :=0;

  //パレット変換
  DeleteObject(ReleasePalette);
  //これはダメ。パレットがおかしい
  Palette := CreatePalette(PLogPalette(@LogPalette)^);

  //Bitsデータ生成
  GetMem(Buffer,size);

try
  Line8 :=PByte(Buffer);
  Move(MemoryStream.Memory^,Line8^,size);
  MemoryStream.Free;

  For Row :=0 to Height-1 do
  begin
      SrcRow :=ScanLine[Row];
      For Col :=0 to Width-1 do
      begin
        SrcRow[Col]:=Line8^;
        Inc(Line8);
      end;
      if (Width mod 2<>0) then Inc(Line8);
  end;
finally
   FreeMem(Buffer);
end;

end;

/////////
procedure TRASImage.Decode24bit(Stream:TStream;Ras:TRasHeader);
Var
 Row,Col : integer;
 SrcRow  : PRGBColor;
 Line8   : PByte;
 MemoryStream : TMemoryStream;
 Buffer       : Pointer;
 size         : Integer;
begin
  //24bitデコーダ
  Pixelformat:=pf24bit;

  //2の倍数でない時は丸める(これはたぶんSunOSが16ビットマシンのせい?)
  size:=((24 * Width + 15) div 16) * 2 * Height ;

  MemoryStream :=TMemoryStream.Create;
  MemoryStream.CopyFrom(Stream,size);
  MemoryStream.Position :=0;
  GetMem(Buffer,size);
try
  Line8 :=Pbyte(Buffer);
  Move(MemoryStream.Memory^,Line8^,size);
  MemoryStream.Free;

  for Row := 0 to Height-1 do
  begin
     SrcRow := ScanLine[Row];
     for Col := 0 to Width-1 do
     begin
        SrcRow[Col].rgbtBlue  :=Line8^;
        inc(Line8);
        SrcRow[Col].rgbtGreen :=Line8^;
        inc(Line8);
        SrcRow[Col].rgbtRed  :=Line8^;
        inc(Line8);
     end;
     if (Width mod 2<>0) then  inc(Line8);
  end ;
Finally
   FreeMem(Buffer);
end;
end;

/////////
procedure TRASImage.Decode32bit(Stream:TStream;Ras:TRasHeader);
Var
 Row,Col : integer;
 SrcRow  : PRGB32;
 Line32  : PDWORD;
 MemoryStream :TMemoryStream;
 Buffer :Pointer;
begin
  //32itデコーダ
  Pixelformat:=pf32bit;

  MemoryStream :=TMemoryStream.Create;
  MemoryStream.CopyFrom(Stream,Width*Height*4);
  MemoryStream.Position :=0;
  GetMem(Buffer,Width*Height*4);
try
  Line32 :=PDWORD(Buffer);
  Move(MemoryStream.Memory^,Line32^,Width*Height*4);
  MemoryStream.Free;

  for Row := 0 to Height-1 do
    begin
        SrcRow := ScanLine[Row];
        for Col := 0 to Width-1 do
        begin
           SrcRow[Col] :=Line32^;
           inc(Line32);
        end;
    end ;
finally
   FreeMem(Buffer);
end;
end;

/////////
procedure TRASImage.Encode1bit(Stream:TStream);
Var
 Ras     : TRasHeader;
 Row,Col : integer;
 SrcRow  : PByteArray;
 Line8   : PBYte;
 Buffer  : Pointer;
 Size    : Integer;
begin
  Pixelformat:=pf1bit;

  //RASヘッダー生成
  Ras.ras_magic    :=RASMAZIC;
  Ras.ras_width    :=IntelOder_Dword(Width);
  Ras.ras_height   :=IntelOder_Dword(Height);
  Ras.ras_depth    :=IntelOder_Dword(1);
  Ras.ras_length   :=0;
  Ras.ras_type     :=IntelOder_Dword(ras_standard);
  Ras.ras_maptype  :=IntelOder_Dword(RMT_RAW);
  Ras.ras_maplength:=IntelOder_Dword(GetPaletteCount*3);

  size:=((1 * Width + 15) div 16) * 2 * Height ;
  GetMem(Buffer,size);
  Line8 :=Pbyte(Buffer);
try
  for Row := 0 to Height-1 do
  begin
     SrcRow := ScanLine[Row];
     for Col := 0 to (Width div 8)-1  do
     begin
        Line8^:=SrcRow[Col] ;
        inc(Line8);
     end;
     if (Width mod 2<>0) then
     begin
      Line8^:=SrcRow[Width div 8] ;
      inc(Line8);
     end;
  end ;
  Dec(Line8,Size);
  Stream.Write(Ras,sizeof(TRasHeader));
  SavePalette(Stream,2);
  Stream.Write(Line8^,size);
finally
  FreeMem(Buffer);
end;
end;

/////////
procedure TRASImage.Encode4bit(Stream:TStream);
Var
 Ras     : TRasHeader;
 Row,Col : integer;
 SrcRow  : PByteArray;
 Line8   : PBYte;
 Buffer  : Pointer;
 Size    : Integer;
begin
  Pixelformat:=pf4bit;

  //RASヘッダー生成
  Ras.ras_magic    :=RASMAZIC;
  Ras.ras_width    :=IntelOder_Dword(Width);
  Ras.ras_height   :=IntelOder_Dword(Height);
  Ras.ras_depth    :=IntelOder_Dword(4);
  Ras.ras_length   :=0;
  Ras.ras_type     :=IntelOder_Dword(ras_standard);
  Ras.ras_maptype  :=IntelOder_Dword(RMT_RAW);
  Ras.ras_maplength:=IntelOder_Dword(GetPaletteCount*3);

  size:=((4 * Width + 15) div 16) * 2 * Height ;
  GetMem(Buffer,size);
  Line8 :=Pbyte(Buffer);
try
  for Row := 0 to Height-1 do
  begin
     SrcRow := ScanLine[Row];
     for Col := 0 to (Width div 2)-1  do
     begin
        Line8^:=SrcRow[Col] ;
        inc(Line8);
     end;
     if (Width mod 2<>0) then
     begin
      Line8^:=SrcRow[Width div 2] ;
      inc(Line8);
     end;
  end ;
  Dec(Line8,Size);
  Stream.Write(Ras,sizeof(TRasHeader));
  SavePalette(Stream,16);
  Stream.Write(Line8^,size);
finally
  FreeMem(Buffer);
end;
end;

/////////
procedure TRASImage.Encode8bit(Stream:TStream);
Var
 Ras     : TRasHeader;
 Row,Col : integer;
 SrcRow  : PByteArray;
 Line8   : PBYte;
 Buffer  : Pointer;
 Size    : Integer;
begin
  Pixelformat:=pf8bit;

  //RASヘッダー生成
  Ras.ras_magic    :=RASMAZIC;
  Ras.ras_width    :=IntelOder_Dword(Width);
  Ras.ras_height   :=IntelOder_Dword(Height);
  Ras.ras_depth    :=IntelOder_Dword(8);
  Ras.ras_length   :=0;
  Ras.ras_type     :=IntelOder_Dword(ras_standard);
  Ras.ras_maptype  :=IntelOder_Dword(RMT_RAW);
  Ras.ras_maplength:=IntelOder_Dword(GetPaletteCount*3);;

  size:=((8 * Width + 15) div 16) * 2 * Height ;
  GetMem(Buffer,size);
  Line8 :=Pbyte(Buffer);
try
  for Row := 0 to Height-1 do
  begin
     SrcRow := ScanLine[Row];
     for Col := 0 to Width-1 do
     begin
        Line8^:=SrcRow[Col] ;
        inc(Line8);
     end;
     if (Width mod 2<>0) then  inc(Line8);
  end ;
  Dec(Line8,Size);
  Stream.Write(Ras,sizeof(TRasHeader));
  SavePalette(Stream,256);
  Stream.Write(Line8^,size);
finally
  FreeMem(Buffer);
end;
end;

/////////
procedure TRASImage.Encode24bit(Stream:TStream);
Var
 Ras:TRasHeader;
 Row,Col : integer;
 SrcRow  : PRGBColor;
 Line8   : PByte;
 Buffer  : Pointer;
 Size    : Integer;
begin
  //エンコード24bit
  Pixelformat:=pf24bit;

  //RASヘッダー生成
  Ras.ras_magic    :=RASMAZIC;
  Ras.ras_width    :=IntelOder_Dword(Width);
  Ras.ras_height   :=IntelOder_Dword(Height);
  Ras.ras_depth    :=IntelOder_Dword(24);
  Ras.ras_length   :=0;
  Ras.ras_type     :=IntelOder_Dword(ras_standard);
  Ras.ras_maptype  :=0;
  Ras.ras_maplength:=0;

  size:=((24 * Width + 15) div 16) * 2 * Height ;
  GetMem(Buffer,size);
  Line8 :=Pbyte(Buffer);
try
  for Row := 0 to Height-1 do
  begin
     SrcRow := ScanLine[Row];
     for Col := 0 to Width-1 do
     begin
        Line8^:=SrcRow[Col].rgbtBlue  ;
        inc(Line8);
        Line8^:=SrcRow[Col].rgbtGreen ;
        inc(Line8);
        Line8^:=SrcRow[Col].rgbtRed  ;
        inc(Line8);
     end;
     if (Width mod 2<>0) then  inc(Line8);
  end ;
  Dec(Line8,Size);
  Stream.Write(Ras,sizeof(TRasHeader));
  Stream.Write(Line8^,size);
finally
  FreeMem(Buffer);
end;
end;

/////////
procedure TRASImage.Encode32bit(Stream:TStream);
Var
 Ras     : TRasHeader;
 Row,Col : integer;
 SrcRow  : PRGB32;
 Line32  : PDword;
 Buffer  : Pointer;
 Size    : Integer;
begin
  //エンコード32bit
  Pixelformat:=pf32bit;

  //RASヘッダー生成
  Ras.ras_magic    :=RASMAZIC;
  Ras.ras_width    :=IntelOder_Dword(Width);
  Ras.ras_height   :=IntelOder_Dword(Height);
  Ras.ras_depth    :=IntelOder_Dword(32);
  Ras.ras_length   :=0;
  Ras.ras_type     :=IntelOder_Dword(ras_standard);
  Ras.ras_maptype  :=0;
  Ras.ras_maplength:=0;

  size:=((32 * Width + 15) div 16) * 2 * Height ;
  GetMem(Buffer,size);
  Line32 :=PDword(Buffer);
try
  for Row := 0 to Height-1 do
  begin
     SrcRow := ScanLine[Row];
     for Col := 0 to Width-1 do
     begin
        Line32^:=SrcRow[Col]  ;
        inc(Line32);
     end;
  end ;
  Dec(Line32,Width*Height);
  Stream.Write(Ras,sizeof(TRasHeader));
  Stream.Write(Line32^,size);
finally
  FreeMem(Buffer);
end;
end;

/////////
procedure TRASImage.SaveToStream(Stream: TStream);
begin
  if PixelFormat =pf1bit then Encode1bit(Stream)
  else if PixelFormat =pf4bit then  Encode4bit(Stream)
  else if PixelFormat =pf8bit then  Encode8bit(Stream)
  else if PixelFormat =pf32bit then  Encode32bit(Stream)
  else Encode24bit(Stream);
end;

/////////
procedure TRASImage.LoadFromStream(Stream: TStream);
Var
 Ras :TRasHeader;
begin
  ZeroMemory(@Ras,sizeof(TRasHeader));
  Stream.Read(Ras,sizeof(TRasHeader));

  //リトルエンディアン->ビックエンディアン変換
  Ras.ras_width    :=IntelOder_Dword(Ras.ras_width);
  Ras.ras_height   :=IntelOder_Dword(Ras.ras_height);
  Ras.ras_depth    :=IntelOder_Dword(Ras.ras_depth);
  Ras.ras_length   :=IntelOder_Dword(Ras.ras_length);
  Ras.ras_type     :=IntelOder_Dword(Ras.ras_type);
  Ras.ras_maptype  :=IntelOder_Dword(Ras.ras_maptype);
  Ras.ras_maplength:=IntelOder_Dword(Ras.ras_maplength);

  //マジックが不正ならば終了
  if Ras.ras_magic<>RASMAZIC    then raise Exception.Create('RASファイルではありません。');
  //ファイル形式の確認
  if Ras.ras_type<>ras_standard then raise Exception.Create('対応していない形式です。');
  //サイズ設定
  Width:=Ras.ras_width;
  Height:=Ras.ras_height;
  //ファイルの読み込み
  case Ras.ras_depth of
   1 :Decode1bit(Stream,Ras);
   4 :Decode4bit(Stream,Ras);
   8 :Decode8bit(Stream,Ras);
   24:Decode24bit(Stream,Ras);
   32:Decode32bit(Stream,Ras);
   else
   begin
    Assign(nil);
    raise Exception.Create('対応していない形式です。');
   end;
  end;
end;

initialization
  TPicture.RegisterFileFormat('ras', 'SUN Raster', TRASImage);
finalization
  TPicture.UnregisterGraphicClass(TRASImage);

end.





関連記事



公開日:2015年01月07日 最終更新日:2015年02月18日
記事NO:00085