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