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

//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.

最新の記事

 音楽・DTM・作曲  2025年10月23日
シンセVのノイズを一発で除去する
 音楽・DTM・作曲  2025年10月03日
ボーカルの歯擦音、破擦音、摩擦音、破裂音などのノイズ軽減、ノイズを削除する [Synthesizer V / Vocoflex]
 Windows  2025年09月08日
WindowsでSafariブラウザを使用してWebサイトのデザイン、レイアウトを手動で確認する[iPhone/iPad/Mac/Playwright]
 音楽・DTM・作曲  2025年07月03日
音楽制作(DTM)のPC移行でやること [プラグインのアクティベート、ディアクティベート、アンインストール]
 Windows  2025年01月19日
Windows11で「ブルースクリーン」を直す方法 [24H2/23H2]

人気の記事 (毎週月曜日～)

1位	WAVEファイルを作成する(C++)
2位	EXE/DLLファイルを分析・解析する
3位	MIDIファイルを作成する(Delphi)

Webアプリ

このブログのマスターが作成した無料ツールです。

 Free  疾風 - ときかぜ - (オープンソース)
ブラウザで写真などの画像を編集する

 Free  PDFデザイナー (オープンソース)
ブラウザでPDFファイルを編集(結合、分割、抽出、回転、しおり等)する

 Free  複数画像のPDF変換
ブラウザで複数の画像を1つのPDFファイルにまとめる

 Free  PDFのテキスト変換
ブラウザでPDFファイルをテキストに変換する

 Free  PDFの画像変換
ブラウザでPDFファイルを画像に変換する

 Free  Exifの確認と削除 (オープンソース)
カメラで撮影した画像ファイル(JPEG)に潜むGPSなどのExif情報を確認、削除する (ブラウザ/スマホ対応)

 Free  エクセルのCSV変換
ブラウザでエクセルをCSVに変換する(一括変換も可能)

 Free  GIFアニメの作成 (オープンソース)
ブラウザで画像からGIFアニメを作成する

 Free  動画のGIFアニメ変換
ブラウザで動画ファイルをGIFアニメへ変換する

 Free  アイコンエディタ
ブラウザでアイコンを作成、読み込み、編集する

 Free  複数画像のAVI変換 (オープンソース)
ブラウザで画像/音声を動画ファイル(AVI)に変換する

 Free  Webカメラ動画変換
ブラウザで映像/音声を動画ファイル(AVI)に変換する

 Free  音声形式の変換 (オープンソース)
ブラウザでMP3/OGG/AAC/FLAC/WAVなどの音声ファイルをWaveファイルに変換する

 Free  Waveファイルで効果音作成 ♪
ブラウザでWaveファイルの効果音を作成する

 Free  Waveフォーマット変換 (オープンソース)
ブラウザで8/16/24/32bitの相互変換。サンプリング周波数、チャンネルを変更する

 Free  音声の結合 / 抽出 / 削除 (オープンソース)
ブラウザでWaveファイルを結合、抽出、削除する

 Free  Waveファイルの解析 (オープンソース)
ブラウザで全体の波形、再生時間、ビットレート、WaveFomat構造体を解析して表示する

 Free  波形データと周波数スペクトル
ブラウザでマイクやパソコン内で流れている音声、MP3/OGG/WAVなどのファイルの周波数を解析する

 Free  双2次フィルタ(BiquadFilter)
ブラウザで音声の特定周波数をカット/増幅/減衰する

 Free  絶対音感
ブラウザでマイクやパソコン内で流れている音声のドレミなどの音階をリアルタイムに表示する (スマホ対応)

 Free  音声録音くん
ブラウザでマイクやパソコン内で流れている音声をMP3/WAVE形式で保存する

 Free  iResEditor (オープンソース)
ブラウザでEXE/DLLファイルのリソースを編集する

 Free  Webの逆アセンブラ
ブラウザでEXE/DLLファイルを逆アセンブルする

※その他にも「プチラボ」でアプリを多数公開しています。

3Dゲーム

このブログのマスターが作成した無料ゲームです。

短時間で遊べるファンタジーのオンラインRPG風

ほのぼの癒し系のスマホアプリ

パズルゲーム

ナンプレのドン！

スマートフォン

このブログのマスターが作成したアプリです。

お主の画像減色 カメラの写真や画像ファイルを「高品質に減色」する

お主は誰だ。 AI(人工知能)が「あなたの顔はどんな芸能人、有名人に似てるか」を判定する顔診断アプリ (女性向け)

AI(人工知能)

おもちゃのAI研究室 イラストの自動着色などのAIアプリの研究室(学習用)

めえめえ(自動作曲システム) ブラウザで歌詞を入力するだけで自動作曲する(簡易版) ※オリジナルの作詞・作曲はYouTubeで公開中

ロボット

このブログのマスターが作成したロボットです。(試作機)

ロボットアーム

二足歩行ロボット

四足歩行ロボット