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

Portable Bitmap PBM/PGM/PPMファイルを変換する(Delphi)

Portable Bitmap PBM/PGM/PPMファイルを読み込み、書き込む事のできるDelphiのソースコードです。クラスになっていますのでそのまま使用できます。

ソースコード

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

//Portable Bitmap I/O Class
//
//Load 1bit(PBM) Ascii/Bainary 8bit(PGM) Ascii/Bainary 24bit(PPM) Ascii/Bainary
//Save 1bit(PBM) Ascii/Bainary 8bit(PGM) Ascii/Bainary 24bit(PPM) Ascii/Bainary
//

{$WARNINGS OFF}
unit PNMPack;

interface

uses
  Windows,Messages,SysUtils,Classes,Graphics;

type
 TSaveMode=(smPBM,smPGM,smPPM);

type
  TBWImage = class(TBitmap)
  private
   procedure BlackWhite;
  protected
  public
   procedure Assign(Source: TPersistent); override;
   procedure SaveToStream(Stream:TStream); override;
  end;

type
  TPNMImage = class(TBitmap)
  private
    FSaveMode  : TSaveMode;
    FBinaryMode: Boolean;
    FSoftname  : String;
    procedure CreateGrayScalePalette(BW: Boolean);
    function  _GetWidth(Stream:TStream):integer;
    function  _GetHeight(Stream:TStream):integer;
    procedure ReadPBM_Ascii(MemoryStream :TMemoryStream);
    procedure ReadPGM_Ascii(MemoryStream:TMemoryStream;Size:integer);
    procedure ReadPPM_Ascii(MemoryStream:TMemoryStream;Size:integer);
    procedure ReadPBM_Binary(Stream :TStream;Size:integer);
    procedure ReadPGM_Binary(Stream :TStream;Size:integer);
    procedure ReadPPM_Binary(Stream :TStream;Size:integer);
    procedure SavePBM_Ascii(Stream :TStream);
    procedure SavePGM_Ascii(Stream :TStream);
    procedure SavePPM_Ascii(Stream :TStream);
    procedure SavePBM_Binary(Stream :TStream);
    procedure SavePGM_Binary(Stream :TStream);
    procedure SavePPM_Binary(Stream :TStream);
  public
    constructor Create;override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    property  SaveMode   : TSaveMode read FSaveMode Write FSaveMode  ;
    property  BinaryMode : Boolean  read FBinaryMode Write FBinaryMode;
    property  SoftName   : String  read FSoftname  write FSoftname;
  end;

type
 PRGBColor = ^TRGBColor;
 TRGBColor = array[0..32768-1] of TRGBTriple;

implementation


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


{--------}
{TBWImage}
{--------}

/////////
procedure TBWImage.BlackWhite;
var
 X,Y,i      : integer;
 Colors     : PRGBColor;
 BufByte    : Byte;
 DoAutoMono : Boolean;
 MonoBuffer : Double	;
 Histgram   : array [0..255] of integer;
 Maxbyte,HistTotal,StartHistLoop,
 EndHistLoop,MainCount,nBlack,nWhite,
 nWidth,nHeight : integer;
begin
 if Empty then Exit;
 DoAutoMono :=false;
 nWidth :=Width-1;
 nHeight:=Height-1;
 nBlack  :=0;
 nWhite  :=0;
 HistTotal := 0   ;
 StartHistLoop :=0;EndHistLoop:=0;
 pixelformat:=pf24bit;
 FillChar(Histgram,Sizeof(Histgram),0);
 for Y := 0 to  nHeight   do
 begin
    Colors:=ScanLine[Y];
    for X := 0 to nwidth  do
    begin
       BufByte:= Round((Colors[X].rgbtRed+Colors[X].rgbtGreen+Colors[X].rgbtBlue)/3 );
       Histgram[Bufbyte] := Histgram[Bufbyte] +1;
     end;
 end;
 for i := 0 to 255 do
 begin
    if (i<=$7F) And (Histgram[i]<>0) then  inc(nBlack);
    if (i>=$80) And (Histgram[i]<>0) then  inc(nWhite);
 end;
 if (nBlack =0) or (nWhite =0) then
     DoAutoMono:=True
 else
 begin
   if nBlack<nWhite then
   begin
      MonoBuffer:= nWhite/ nBlack;
      if MonoBuffer>2.50  then DoAutoMono:=True ;
   end
   else
   begin
      MonoBuffer:= nBlack/nWhite;
      if MonoBuffer>2.50  then DoAutoMono:=True ;
   end;
 end;
 if DoAutoMono then
 begin
    MainCount:=0;
    Maxbyte:=0;
    for i:=0 to 255 do
    begin
       If Histgram[i] > Maxbyte Then
       begin
           Maxbyte := Histgram[i] ;
           MainCount := i ;
       end;
    end;
    StartHistLoop :=MainCount;
    EndHistLoop   := StartHistLoop or 1 ;
    While HistTotal < Round((Width) * (height) / 2)   do
    begin
       If (StartHistLoop >= $00) And (StartHistLoop <= $FF) Then
       begin
           HistTotal := HistTotal + Histgram[StartHistLoop]  ;
           StartHistLoop := StartHistLoop - 1 ;
       end;
       If (EndHistLoop >= $00) And (EndHistLoop <= $FF) Then
       begin
           HistTotal := HistTotal + Histgram[EndHistLoop] ;
           EndHistLoop := EndHistLoop + 1;
       End;
    end;
  end;
  for Y := 0 to  nHeight   do
  begin
    Colors:=ScanLine[Y];
    for X := 0 to nwidth  do
    begin
       BufByte:= Round((Colors[X].rgbtRed+Colors[X].rgbtGreen+Colors[X].rgbtBlue)/3 ) ;
       if DoAutoMono then
       begin
         if (BufByte >= StartHistLoop) And (BufByte <= EndHistLoop) Then
         begin
            Colors[X].rgbtRed   :=$FF;
            Colors[X].rgbtGreen :=$FF;
            Colors[X].rgbtBlue  :=$FF;
         end
         else
         begin
             Colors[X].rgbtRed   :=$00;
             Colors[X].rgbtGreen :=$00;
             Colors[X].rgbtBlue  :=$00;
          end;
         end
         else
         begin
          if BufByte>=128 then
          begin
             Colors[X].rgbtRed   :=$FF;
             Colors[X].rgbtGreen :=$FF;
             Colors[X].rgbtBlue  :=$FF;
           end
           else
           begin
             Colors[X].rgbtRed   :=$00;
             Colors[X].rgbtGreen :=$00;
             Colors[X].rgbtBlue  :=$00;
           end;
         end;
        end;

  end;
  Monochrome  :=True;
  pixelformat :=pf1bit;
end;

/////////
procedure TBWImage.SaveToStream(Stream:TStream);
begin
  BlackWhite;
  inherited  SaveToStream(Stream);
end;

/////////
procedure TBWImage.Assign(Source: TPersistent);
begin
  inherited  Assign(Source);
  BlackWhite;
end;

{---------}
{TPNMImage}
{---------}

///////////
constructor TPNMImage.Create;
begin
  inherited Create;
  FBinaryMode :=True;
  FSaveMode   :=smPBM;
  FSoftname   :='Created by GraphicConvert-Library';
end;

////////
function TPNMImage._GetWidth(Stream:TStream):integer;
Var
 Buf   : char;
 _Width : String;
begin
 _Width :='';
 Stream.read(Buf,1);
 if Buf <> #10 then  raise Exception.Create('PBM/PGM/PPMファイルではありません。');
 Stream.read(Buf,1);
 if Buf <>'#' then  raise Exception.Create('PBM/PGM/PPMファイルではありません。');
 repeat
   Stream.Read(Buf,1);
 until Buf= #10;
 repeat
   Stream.Read(Buf,1);
   if Buf=' ' then Break;
   _Width :=_Width+Buf;
 until Buf=' ';

 Result:=Strtoint(_Width);
end;

////////
function TPNMImage._GetHeight(Stream:TStream):integer;
Var
 Buf    : char;
 _Height : String;
begin
 _Height :='';
 repeat
   Stream.Read(Buf,1);
   if Buf=#10 then Break;
   _Height :=_Height+Buf;
 until Buf=#10;
 Stream.Position :=Stream.Position;
 Result:=Strtoint(_Height);
end;

/////////
procedure TPNMImage.CreateGrayScalePalette(BW: Boolean);
var
  i: Integer;
  LogPalette: TMaxLogPalette;
begin
  FillChar(LogPalette, SizeOf(LogPalette), 0);
  LogPalette.palVersion := $300;
  if BW then
  begin
    LogPalette.palNumEntries := 2;
    LogPalette.palPalEntry[0].peBlue := 255;
    LogPalette.palPalEntry[0].peGreen := 255;
    LogPalette.palPalEntry[0].peRed := 255;
  end
  else
  begin
    LogPalette.palNumEntries := 256;
    for i := 0 to 255 do
    begin
      LogPalette.palPalEntry[i].peBlue := i;
      LogPalette.palPalEntry[i].peGreen := i;
      LogPalette.palPalEntry[i].peRed := i;
    end;
  end;
  Palette := CreatePalette(PLogPalette(@LogPalette)^);
end;

/////////
procedure TPNMImage.ReadPBM_Ascii(MemoryStream :TMemoryStream);

      procedure AsciitoBinary(Var MemoryStream:TMemoryStream) ;
      var
         _Size ,i : integer;
         Buffer   : Pointer;
         Line     : Pbyte;
         Pixel_1,Pixel_0    : Byte;
       begin
            _Size :=MemoryStream.size;
             GetMem(Buffer,_Size);
            Line :=PByte(Buffer) ;
            Move(MemoryStream.Memory^,Line^,_Size);
            MemoryStream.size :=0; MemoryStream.Position:=0;
            Pixel_1 :=1; Pixel_0:=0;
            for i :=1 to _Size do
            begin
               case Line^ of
               $30 :MemoryStream.Write(Pixel_0,1);
               $31 :MemoryStream.Write(Pixel_1,1);
               end  ;
               inc(Line);
            end;
            FreeMem(Buffer);
            MemoryStream.size :=MemoryStream.size;
        end;
Var
 BufByte : Byte;
 Line8   : PByte;
 X,Y     : integer;
 _Mod,_Width,_Height :integer;
 Buffer  : Pointer;
 Line    : PByte;
begin
   _Mod:= (Width mod 8);
   _Width :=Width;
   _Height :=Height-1;
   AsciitoBinary(MemoryStream);
   MemoryStream.position:=0;
   GetMem(Buffer,MemoryStream.size);
   Line :=PByte(Buffer);
   Move(MemoryStream.memory^,Line^,MemoryStream.Size);
try
   for Y := 0 to _Height do
   begin
       Line8 := ScanLine[Y];
       BufByte := 0;
       for X := 1 to _Width do
       begin
           BufByte := (BufByte shl 1) or (Line^ and 1);
           inc(Line);
           if (X mod 8) = 0 then
           begin
             Line8^ := BufByte;
             Inc(Line8);BufByte := 0;
           end;
       end;
       if _Mod <> 0 then Line8^ := BufByte shl (8 - (Width mod 8));
   end;
except
   FreeMem(Buffer);
   raise Exception.Create('イメージデータが不正です。');
end;
   FreeMem(Buffer);
end;

/////////
procedure TPNMImage.ReadPGM_Ascii(MemoryStream:TMemoryStream;Size:integer);
var
  _Size ,i       : integer;
  Buffer,Buffer2 : Pointer;
  Line8,Lines    : PByte;
  Line           : PByte;
  Y,Count        : integer;
  nWidth,nHeight : integer;
  BufByte        : array[0..2] of Byte ;
begin
  Count :=0;
  nWidth :=Width; nHeight :=Height-1;
  FillChar(BufByte,3,0);
  _Size :=Size;
  GetMem(Buffer,_Size);
  Line :=PByte(Buffer) ;
  GetMem(Buffer2,_Size);
  Line8 :=PByte(Buffer2) ;
  Move(MemoryStream.Memory^,Line^,_Size);
try
  for i :=1 to _Size do
  begin
     if Line^ in [$30,$31,$32,$33,$34,$35,$36,$37,$38,$39] then
     begin
         case  Count of
           0 : BufByte[0]:=Line^-$30;
           1 : BufByte[1]:=Line^-$30;
           2 : BufByte[2]:=Line^-$30;
         end;
         inc(Count);
     end
     else
     begin
        if Count<>0 then
        begin
            Case Count of
             1 :  Line8^:= BufByte[0]  ;
             2 :  Line8^:= BufByte[0]*10+BufByte[1]  ;
             3 :  Line8^:= BufByte[0]*100+BufByte[1]*10+BufByte[2]  ;
            end;
            Inc(Line8);
            Count:=0;
            FillChar(BufByte,3,0);
        end;
     end;
     inc(Line);
  end;
  if Count<>0 then
  begin
     Case Count of
        1 :  Line8^:= BufByte[0]  ;
        2 :  Line8^:= BufByte[0]*10+BufByte[1]  ;
        3 :  Line8^:= BufByte[0]*100+BufByte[1]*10+BufByte[2]  ;
     end;
  end;
except
  FreeMem(Buffer);
  FreeMem(Buffer2);
  raise Exception.Create('イメージデータが不正です。');
end;
  FreeMem(Buffer);
try
    Dec(Line8,(Width*Height)-1);
    for Y := 0 to nHeight do
    begin
      Lines := ScanLine[Y];
      Move(Line8^,Lines^,nWidth);
      inc(Line8,nWidth);
    end;
except
  FreeMem(Buffer2);
  raise Exception.Create('イメージデータが不正です。');
end;
  FreeMem(Buffer2);

end;

/////////
procedure TPNMImage.ReadPPM_Ascii(MemoryStream:TMemoryStream;Size:integer);
var
  _Size ,i       : integer;
  Buffer,Buffer2 : Pointer;
  Line,Line8     : PByte;
  X,Y,Count      : integer;
  nWidth,nHeight : integer;
  BufByte        : array[0..2] of Byte ;
  Line24         : PRGBColor;
begin
  Count :=0;
  nWidth :=Width-1; nHeight :=Height-1;
  FillChar(BufByte,3,0);
  _Size :=Size;
  GetMem(Buffer,_Size);
  Line  :=PByte(Buffer) ;
  GetMem(Buffer2,Width*Height*3);
  Line8  :=PByte(Buffer2) ;
  Move(MemoryStream.Memory^,Line^,_Size);
try
  for i :=1 to _Size do
  begin
     if Line^ in [$30,$31,$32,$33,$34,$35,$36,$37,$38,$39] then
     begin
         case  Count of
           0 : BufByte[0]:=Line^-$30;
           1 : BufByte[1]:=Line^-$30;
           2 : BufByte[2]:=Line^-$30;
         end;
         inc(Count);
     end
     else
     begin
        if Count<>0 then
        begin
            Case Count of
             1 :  Line8^:= BufByte[0]  ;
             2 :  Line8^:= BufByte[0]*10+BufByte[1]  ;
             3 :  Line8^:= BufByte[0]*100+BufByte[1]*10+BufByte[2]  ;
            end;
            inc(Line8);
            Count:=0;
            FillChar(BufByte,3,0);
        end;
     end;
     inc(Line);
  end;
  if Count<>0 then
  begin
      Case Count of
             1 :  Line8^:= BufByte[0]  ;
             2 :  Line8^:= BufByte[0]*10+BufByte[1]  ;
             3 :  Line8^:= BufByte[0]*100+BufByte[1]*10+BufByte[2]  ;
      end;
  end;
except
  FreeMem(Buffer);
  FreeMem(Buffer2);
  raise Exception.Create('イメージデータが不正です。');
end;
  FreeMem(Buffer);
  MemoryStream.Position:=0;
  Dec(Line8,(Width*Height*3)-1);
try
   for Y := 0 to nHeight do
   begin
        Line24 := ScanLine[Y];
        for X := 0 to nWidth do
        begin
           Line24[X].rgbtred :=Line8^;
           inc(Line8);
           Line24[X].rgbtgreen  :=Line8^;
           inc(Line8);
           Line24[X].rgbtblue:=Line8^;
           inc(Line8);
        end;
    end ;
except
  FreeMem(Buffer2);
  raise Exception.Create('イメージデータが不正です。');
end;
  FreeMem(Buffer2);
end;

/////////
procedure TPNMImage.ReadPBM_Binary(Stream :TStream;Size:integer);
Var
 Y,X :integer;
 Buffer :Pointer;
 Line8,Line : Pbyte;
 MemoryStream :TMemoryStream;
 nWidth,nHeight,_mod :integer;
begin
  MemoryStream :=TMemoryStream.Create;
  MemoryStream.CopyFrom(Stream,size);
  MemoryStream.Position :=0;
  GetMem(Buffer,Size);
  Line :=Pbyte(Buffer);
  Move(MemoryStream.Memory^,Line^,size);
  MemoryStream.Free;
  nWidth := (Width div 8)-1;
  nHeight:= Height-1;
  _mod   := (Width mod  8);

try
    for Y := 0 to nHeight do
    begin
        Line8 := ScanLine[Y];
        for X := 0 to nWidth  do
        begin
           Line8^ := Line^;
           Inc(Line8);
           inc(Line);
        end;
        if _mod <> 0 then
        begin
           Line8^ := Line^;
           inc(Line);
        end;
    end ;
except
 Freemem(Buffer);
 raise Exception.Create('イメージデータが不正です。');
end;
 Freemem(Buffer);
end;

/////////
procedure TPNMImage.ReadPGM_Binary(Stream :TStream;Size:integer);
Var
 Y :integer;
 Buffer :Pointer;
 Line8,Line : Pbyte;
 MemoryStream :TMemoryStream;
 nWidth,nHeight  : integer;
begin
  MemoryStream :=TMemoryStream.Create;
  MemoryStream.CopyFrom(Stream,size);
  MemoryStream.Position :=0;
  GetMem(Buffer,Size);
  Line :=Pbyte(Buffer);
  Move(MemoryStream.Memory^,Line^,size);
  MemoryStream.Free;
  nWidth  :=Width;
  nHeight :=Height-1;
try
    for Y := 0 to nHeight do
    begin
      Line8 := ScanLine[Y];
      Move(Line^,Line8^,nWidth);
      inc(Line,nWidth);
    end;
except
 Freemem(Buffer);
 raise Exception.Create('イメージデータが不正です。');
end;
 Freemem(Buffer);
end;

/////////
procedure TPNMImage.ReadPPM_Binary(Stream :TStream;Size:integer);
Var
 Y,X :integer;
 Line24 : PRGBColor;
 Line8  : pbyte;
 MemoryStream :TMemoryStream;
 Buffer :Pointer;
 nWidth,nHeight :integer;
begin
  MemoryStream :=TMemoryStream.Create;
  MemoryStream.CopyFrom(Stream,size);
  MemoryStream.Position :=0;
  GetMem(Buffer,Size);
  Line8 :=Pbyte(Buffer);
  Move(MemoryStream.Memory^,Line8^,size);
  MemoryStream.Free;
  nWidth  :=Width-1;
  nHeight :=Height-1;
try
    for Y := 0 to nHeight do
    begin
        Line24 := ScanLine[Y];
        for X := 0 to nWidth do
        begin
           Line24[X].rgbtred   :=Line8^;
           inc(Line8);
           Line24[X].rgbtGreen :=Line8^;
           inc(Line8);
           Line24[X].rgbtBlue  :=Line8^;
           inc(Line8);
        end;
    end ;
except
 Freemem(Buffer);
 raise Exception.Create('イメージデータが不正です。');
end;
 Freemem(Buffer);
end;

/////////
procedure TPNMImage.SavePBM_Ascii(Stream :TStream);
Var
 X,Y          : integer;
 Lines        : pRGBColor;
 StringStream : TStringStream;
 Count        : integer;
 Buf          : String;
 BMP          : TBitmap;
 BW           : TBWImage;
 _Width,_Height :integer;
begin
  BMP :=TBitmap.Create;
  BMP.Assign(Self);
  if BMP.PixelFormat<>pf1bit then
  begin
    BW :=TBWImage.Create;
    BW.Assign(BMP);
    BMP.Assign(BW);
    BW.Free;
  end;
  BMP.PixelFormat :=pf24bit;
  Count        := 0; _Width :=Width-1; _Height :=Height-1;
  StringStream := TStringStream(Stream);
  buf :='P1'#10+'# '+Softname+#10 + inttostr(Width)+' '+inttostr(Height)+#10;
try
  for Y := 0 to _Height do
  begin
    Lines:=BMP.ScanLine[Y];
    for X := 0 to _Width do
    begin
     inc(Count);
     if (Lines[X].rgbtRed<=128 )   And  (Lines[X].rgbtGreen<=128 ) And (Lines[X].rgbtBlue<=128 )  then
     begin
           if Count<35 then
            buf:=buf+'1 '
           else
           begin
            buf:=buf+'1'#10;
            Count:=0;
           end;
      end
      else
      begin
           if Count<35 then
            buf:=buf+'0 '
           else
           begin
            buf:=buf+'0'#10;
            COunt:=0;
           end;
      end;
     end;
  end;
  StringStream.WriteString(buf);
  BMP.Free;
 except
 end;

end;

/////////
procedure TPNMImage.SavePBM_Binary(Stream :TStream);
Var
 X,Y          : integer;
 Lines        : PByte;
 StringStream : TStringStream;
 Buf          : String;
 BMP          : TBitmap;
 BW           : TBWImage;
 Buffer       : Pointer;
 Line8        : PByte;
 _DecCount    : integer;
 _Mod,_Height,_Width :integer;
begin
  BMP :=TBitmap.Create;
  BMP.Assign(Self);
  if BMP.PixelFormat<>pf1bit then
  begin
    BW :=TBWImage.Create;
    BW.Assign(BMP);
    BMP.Assign(BW);
    BW.Free;
  end;
  _Mod:=(BMP.Width mod 8);
  _Width :=(BMP.Width div 8) -1;
  _Height :=BMP.Height-1;
  _DecCount :=0;
  StringStream := TStringStream(Stream);
  Buf :='P4'+#10+'# '+Softname+#10 +inttostr(Width)+' '+inttostr(Height)+#10;
  StringStream.WriteString(Buf);
  Stream :=TStream(StringStream);
  GetMem(Buffer,Round((Width*Height)/8)+1);
  Line8:=PByte(Buffer);
try
  for Y := 0 to _Height  do
  begin
     Lines := BMP.ScanLine[Y];
     for X := 0 to _Width do
     begin
         Line8^:= not Lines^  ;
         Inc(Lines); inc(Line8);  inc(_DecCount);
     end;
     if _Mod <> 0 then
     begin
        Line8^:=not Lines^ ;
        inc(Line8); inc(_DecCount);
     end;
  end;
  Dec(Line8, _DecCount);
  Stream.Write(Line8^,_DecCount);
finally
  BMP.Free;
  FreeMEm(Buffer);
end;

end;

/////////
procedure TPNMImage.SavePGM_Ascii(Stream :TStream);
Var
 X,Y           : integer;
 Lines8        : Byte;
 Lines         : pRGBColor;
 StringStream  : TStringStream;
 Buf           : string;
 BMP           : TBItmap;
 Count ,bufcount        : integer;
 _Pos           : integer;
 nWidth,nHeight :integer;
begin
  BMP :=TBitmap.Create;
  BMP.Assign(Self);
  BMP.PixelFormat  := pf24bit;
  StringStream     := TStringStream(Stream);
  nWidth  :=BMP.Width-1;
  nHeight :=BMP.Height-1;
  buf :='P2'#10+'# '+Softname+#10 +inttostr(Width)+' '+inttostr(Height)+#10+'255' +#10 ;
  StringStream.Writestring(Buf);
  _Pos :=Length(Buf)   ;
  buf :='';
  Bufcount :=_Pos;
  Count :=1;
 try
  for Y := 0 to nHeight do
  begin
    Lines:=BMP.ScanLine[Y];
    for X := 0 to nWidth do
    begin
        if _Pos <>bufcount then  buf :=buf+' ' ;

        if bufcount>_Pos+(67*Count) then
        begin
          buf:=buf+#10;
          inc(Count);
        end;
         Lines8 :=Round((Lines[X].rgbtred +Lines[X].rgbtBlue+Lines[X].rgbtGreen) /3) ;
         Buf :=buf+inttostr(Lines8);
         bufcount :=bufCount+sizeof(buf);
      end;
   StringStream.Writestring(buf);
   buf:='';
  end;
  finally
   BMP.FRee;
  end;
end;

/////////
procedure TPNMImage.SavePGM_Binary(Stream :TStream);
Var
 X,Y          : integer;
 Lines8       : Byte;
 Lines        : pRGBColor;
 StringStream : TStringStream;
 Buf          : string;
 BMP          : TBItmap;
 bufStream    : TMemoryStream  ;
 nWidth,nHeight  : integer;
begin
  bufStream :=TMemoryStream .Create;
  bufStream.Position :=0;
  BMP :=TBitmap.Create;
  BMP.Assign(Self);
   nWidth  :=BMP.Width-1;
  nHeight :=BMP.Height-1;
  BMP.PixelFormat  := pf24bit;
  StringStream     := TStringStream(Stream);
  buf :='P5'#10+'# '+Softname+#10 +inttostr(Width)+' '+inttostr(Height)+#10+'255' +#10 ;
  StringStream.WriteString(buf);
  buf:='';
  Stream :=TStream(StringStream);
 try
  for Y := 0 to nHeight  do
  begin
    Lines:=BMP.ScanLine[Y];
    for X := 0 to nWidth do
    begin
        Lines8 :=Round((Lines[X].rgbtred +Lines[X].rgbtBlue+Lines[X].rgbtGreen) /3) ;
        bufStream.Write(Lines8,1);
    end;
  end;
    Stream.CopyFrom(BufStream,0);
  finally
   BMP.FRee;
   bufStream.Free;
 end;
end;


//PPM のASCIIコード保存
procedure TPNMImage.SavePPM_Ascii(Stream :TStream);
Var
 X,Y             : integer;
 Lines8          : Byte;
 Lines           : pRGBColor;
 StringStream    : TStringStream;
 Buf             : String;
 BMP             : TBItmap;
 Count,bufcount  : integer;
 Pos             : integer;
 nWidth,nHeight  : integer;
begin
  BMP :=TBitmap.Create;
  BMP.Assign(Self);
  BMP.PixelFormat  := pf24bit;
  StringStream     := TStringStream(Stream);
  nWidth  :=BMP.Width-1;
  nHeight :=BMP.Height-1;
  buf :='P3'#10+'# '+Softname+#10 +inttostr(Width)+' '+inttostr(Height)+#10+'255' +#10 ;
  StringStream.Writestring(buf);
  Pos :=length(buf)   ;
  buf :='';
  bufcount :=pos;
  Count :=1;
try
  for Y := 0 to nHeight do
  begin
    Lines:=BMP.ScanLine[Y];
    for X := 0 to nWidth do
    begin
       if Pos <>bufcount then buf :=buf+' ' ;
       if bufcount>Pos+(23*Count) then
       begin
         buf :=buf+#10;
         inc(Count);
       end;
         Lines8 :=Lines[X].rgbtRed ;
         Buf :=buf+inttostr(Lines8);
         Buf :=Buf+' ';

         Lines8 :=Lines[X].rgbtGreen ;
         Buf :=buf+inttostr(Lines8);
         Buf :=Buf+' ';

         Lines8 :=Lines[X].rgbtBlue ;
         Buf :=buf+inttostr(Lines8);
         bufcount :=bufCount+sizeof(buf);
     end;
   StringStream.Writestring(buf);
   buf:='';
  end;
   BMP.FRee;
 except
 end;

end;

/////////
procedure TPNMImage.SavePPM_Binary(Stream :TStream);
Var
 X,Y          : integer;
 Lines        : pRGBColor;
 StringStream : TStringStream;
 Buf          : String;
 BMP          : TBItmap;
 bufStream    : TMemoryStream ;
begin
  bufStream :=TMemoryStream .Create;
  bufStream.Position :=0;
  BMP :=TBitmap.Create;
  BMP.Assign(Self);
  BMP.PixelFormat  := pf24bit;
  StringStream     := TStringStream(Stream);
  buf :='P6'#10+'# '+Softname+#10 +inttostr(Width)+' '+inttostr(Height)+#10+'255' +#10 ;
  StringStream.WriteString(buf);
  buf :='';
  Stream :=TMemoryStream(StringStream);
 try
  for Y := 0 to BMP.Height - 1 do
  begin
    Lines:=BMP.ScanLine[Y];

    for X := 0 to Width-1 do
    begin
       bufStream.Write(Lines[X].rgbtred,1);
       bufStream.Write(Lines[X].rgbtgreen,1);
       bufStream.Write(Lines[X].rgbtBlue,1);
    end;
  end;
    Stream.CopyFrom(BufStream,0);
 finally
   BMP.FRee;
   bufStream.Free;
 end;
end;

/////////
procedure TPNMImage.SaveToStream(Stream: TStream);
begin
  if (FSaveMode =smPBM) AND (BinaryMode)     then
    SavePBM_Binary(Stream)   ;
  if (FSaveMode =smPBM) AND (not BinaryMode) then
    SavePBM_Ascii(Stream)   ;

  if (FSaveMode =smPGM) AND (BinaryMode)     then
    SavePGM_Binary(Stream)   ;
  if (FSaveMode =smPGM) AND (not BinaryMode) then
    SavePGM_Ascii(Stream)   ;

  if (FSaveMode =smPPM) AND (BinaryMode)     then
    SavePPM_Binary(Stream)   ;
  if (FSaveMode =smPPM) AND (not BinaryMode) then
   SavePPM_Ascii(Stream)   ;
end;

/////////
procedure TPNMImage.LoadFromStream(Stream: TStream);
var
  Buffer : char ;
  Pixel  : Byte;
  Count  : integer;
  MemoryStream : TMemoryStream ;
begin
   Handle := 0; Count:=0;
   Stream.Read(Buffer,1);
   if Buffer <> 'P' then raise Exception.Create('このファイルはPBM/PGM/PPMフォーマットではありません。');
   Stream.Read(Buffer,1);
   Case Strtoint(Buffer) of
     //PBM Ascii
     1:
        begin
            PixelFormat := pf1Bit;
            Width  := _GetWidth(Stream);
            Height := _GetHeight(Stream);
            if (Width <=0) or (Height <=0) then raise Exception.Create('イメージのサイズが不正です。');
            CreateGrayScalePalette(True);
            MemoryStream :=TMemoryStream.Create;
            MemoryStream.CopyFrom(Stream,Stream.size-Stream.position);
            MemoryStream.Position:=0;
            ReadPBM_Ascii(MemoryStream);
            MemoryStream.Free;
        end;
     //PGM Ascii
     2: begin
            PixelFormat := pf8Bit;
            Width  := _GetWidth(Stream);
            Height := _GetHeight(Stream);
            if (Width <=0) or (Height <=0) then raise Exception.Create('イメージのサイズが不正です。');
            CreateGrayScalePalette(False);
            repeat
              Stream.Read(Pixel,1);
              if Pixel =$0A then Break;
              inc(Count);
              if Count=100 then raise Exception.Create('このファイルは読込めません。');
            Until Pixel=-1;
            MemoryStream :=TMemoryStream.Create;
            MemoryStream.CopyFrom(Stream,Stream.size-Stream.position);
            MemoryStream.Position:=0;
            ReadPGM_Ascii(MemoryStream,MemoryStream.size);
            MemoryStream.Free;
         end;
     //PPM Ascii
     3:  begin
            PixelFormat := pf24Bit;
            Width  := _GetWidth(Stream);
            Height := _GetHeight(Stream);
            if (Width <=0) or (Height <=0) then raise Exception.Create('イメージのサイズが不正です。');
            repeat
             Stream.Read(Pixel,1);
             if Pixel =$0A then Break;
             inc(Count);
             if Count=100 then raise Exception.Create('このファイルは読込めません。');
            Until Pixel=-1;
            MemoryStream :=TMemoryStream.Create;
            MemoryStream.CopyFrom(Stream,Stream.size-Stream.position);
            MemoryStream.Position:=0;
            ReadPPM_Ascii(MemoryStream,MemoryStream.size);
            MemoryStream.FRee;
          end;
     //PBM Binary
     4:  begin
            PixelFormat := pf1Bit;
            Width  := _GetWidth(Stream);
            Height := _GetHeight(Stream);
            if (Width <=0) or (Height <=0) then raise Exception.Create('イメージのサイズが不正です。');
            CreateGrayScalePalette(True);
            ReadPBM_Binary(Stream,Stream.size-Stream.Position);
         end;
     //PGM Binary
     5:  begin
            PixelFormat := pf8Bit;
            Width  := _GetWidth(Stream);
            Height := _GetHeight(Stream);
            if (Width <=0) or (Height <=0) then raise Exception.Create('イメージのサイズが不正です。');
            CreateGrayScalePalette(false);
            Count :=0;
            repeat
             Stream.Read(Pixel,1);
             if Pixel =$0A then Break;
             inc(Count);
             if Count=100 then raise Exception.Create('このファイルは読込めません。');
            Until Pixel=-1;
            ReadPGM_Binary(Stream,Stream.Size-Stream.Position);
         end;
     //PPM Binary
     6:  begin
            PixelFormat := pf24Bit;
            Width  := _GetWidth(Stream);
            Height := _GetHeight(Stream);
            if (Width <=0) or (Height <=0) then raise Exception.Create('イメージのサイズが不正です。');
            Count :=0;
            repeat
              Stream.Read(Pixel,1);
              if Pixel =$0A then Break;
              inc(Count);
              if Count=100 then raise Exception.Create('このファイルは読込めません。');
            Until Pixel=-1;
            ReadPPM_Binary(Stream,Stream.Size-Stream.Position);
          end;
     else
      raise Exception.Create('このファイルは読込めません。');
   end;
end;

initialization
  TPicture.RegisterFileFormat('ppm', 'Portable Pixelmap', TPNMImage);
  TPicture.RegisterFileFormat('pgm', 'Portable Graymap', TPNMImage);
  TPicture.RegisterFileFormat('pbm', 'Portable Bitmap', TPNMImage);
finalization
  TPicture.UnregisterGraphicClass(TPNMImage);

end.





関連記事



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