カラーのBMPファイルを、モノクロBMPに変換するには？ (ID:1021)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

2色と256色に減色できるものをつくって見ました。
もしよろしければ、参考にして下さい。
※D2でも動くように作ってみたのでたぶん、動くと思います。

//ヒストグラムを使用して2色(1bit)に減色
function CreateBMP_1bit(hBMP: HBitmap): HBitmap;
  //RGBの平均値を算出
  function GetRGBAverage(Value :TColor):BYTE;
  Var
   R,G,B:BYTE;
  begin
     R:=(Value and $FF0000 shr 16);
     G:=(Value and $00FF00 shr 8);
     B:=(Value and $0000FF);
     Result:=Round((R+G+B)/ 3);
  end;
var
 X,Y,i      : integer;
 BufByte    : Byte;
 DoAutoMono : Boolean;
 MonoBuffer : Double	;
 Histgram   : array [0..255] of integer;
 Maxbyte,HistTotal,StartHistLoop,
 EndHistLoop,MainCount,nBlack,nWhite,
 nWidth,nHeight : integer;
 SrcBitmap  : TBitmap;
begin

SrcBitmap:=TBitmap.Create;
 SrcBitmap.Handle:=hBMP;

//初期化
   DoAutoMono :=false;
   nWidth     :=SrcBitmap.Width-1;
   nHeight    :=SrcBitmap.Height-1;
   FillChar(Histgram,Sizeof(Histgram),0);
   nBlack  :=0; nWhite  :=0; HistTotal := 0   ;
   StartHistLoop :=0;  EndHistLoop:=0;

//ヒストグラムを作成
   for Y := 0 to  nHeight do
   begin
      for X := 0 to nwidth  do
      begin
        BufByte:= GetRGBAverage(SrcBitmap.Canvas.Pixels[X,Y]);
        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((SrcBitmap.Width) * (SrcBitmap.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;

//イメージを2階調化
    for Y := 0 to  nHeight   do
    begin
      for X := 0 to nwidth  do
      begin
         BufByte:= GetRGBAverage(SrcBitmap.Canvas.Pixels[X,Y]);

if DoAutoMono then
         begin
           if (BufByte >= StartHistLoop) And (BufByte <= EndHistLoop) Then
              SrcBitmap.Canvas.Pixels[X,Y] := $00FFFFFF
           else
              SrcBitmap.Canvas.Pixels[X,Y] := 0;
         end
         else
         begin
            if BufByte>=128 then
               SrcBitmap.Canvas.Pixels[X,Y] := $00FFFFFF
            else
               SrcBitmap.Canvas.Pixels[X,Y] := 0;
         end;
      end;
    end;

//パレットなどを変更するのは面倒なので後はDelphiにまかせる
    SrcBitmap.Monochrome  :=True;   //使用するカラーテーブルをモノクロにする
    SrcBitmap.pixelformat :=pf1bit; //画像を2色(1bit)に変換
    SrcBitmap.Monochrome  :=false;  //カラーテーブルを"元に戻す"(これは要らないかも?)

Result:=SrcBitmap.ReleaseHandle;

SrcBitmap.free;
end;

//グレースケール256色に減色(手抜き版)
 function CreateBMP_8bit(hBMP :HBitmap) :HBitmap;
var
  i: Integer;
  LogPalette : TMaxLogPalette;
  SrcBitmap  : TBitmap;
begin
  SrcBitmap:=TBitmap.Create;
  SrcBitmap.Handle:=hBMP;
  SrcBitmap.pixelformat:=pf8bit;

FillChar(LogPalette, SizeOf(LogPalette), 0);
  LogPalette.palVersion := $300;

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;
  SrcBitmap.Palette := CreatePalette(PLogPalette(@LogPalette)^);

Result:=SrcBitmap. ReleaseHandle;
  SrcBitmap.free;
end;
 
使い方はこんな感じです。
procedure TForm1.Button1Click(Sender: TObject);
begin
 // image1.picture.bitmap.handle:=CreateBMP_1bit(image1.picture.bitmap.ReleaseHandle);
 // image1.picture.bitmap.handle:=CreateBMP_8bit(image1.picture.bitmap.ReleaseHandle);
end;

←解決時は質問者本人がここをチェックしてください。

戻る