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

名前

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

本文

D2だとPixelformat(ビットマップの色数を変更)が使えないようなので、
Pixelformatと同様な関数を作って見ました。

※D2を持ってないので動作確認は出来ていませんが、今度こそは大丈夫かなと思います。これでも、出来なかったらごめんなさい。

--------------------------------------------------------------------------------

type
  PBITMAPINFO_8BIT=^TBITMAPINFO_8BIT;
  TBITMAPINFO_8BIT=packed record
     bmiHeader   : TBITMAPINFOHEADER;           //通常のBITMAPINFOHEADER
     bmiColors   : array [0..255] of TRGBQUAD;  //カラーパレット領域を確保
end;

type
  PTagBitmap = ^TTagBitmap;
  TTagBitmap = packed record
    bmType: Longint;
    bmWidth: Longint;
    bmHeight: Longint;
    bmWidthBytes: Longint;
    bmPlanes: Word;
    bmBitsPixel: Word;
    bmBits: Pointer;
end;

//呼び出しを変更...特殊です(^^;
function GetDIBits(DC: HDC; Bitmap: HBitmap; StartScan, NumScans: UINT;
  Bits: Pointer;  BitInfo: pointer; Usage: UINT): Integer; stdcall; external gdi32 name 'GetDIBits';

//------------------------------------------------------------------------------
// 関数名 ChangePixel
// 用途   ビットマップの色数(ビット深度)を変更する
// 引数
//        BPP     ... 1     1bit画像に変換
//                ... 4     4bit画像に変換
//                ... 8     8bit画像に変換
//                ... 16    16bit画像に変換
//                ... 24    24bit画像に変換
//                ... 32    32bit画像に変換
//        hBMP    ... 対象のビットマップハンドル(関数終了後にこのハンドルは削除)
// 戻り値 変換後のビットマップハンドル
// 備考   サンプルなのであまりエラーチェックは行っていません(^^;
//------------------------------------------------------------------------------

function ChangePixel(BPP :BYTE ; hBMP :HBitmap):HBitmap;
Var
 hMem,hDCx2  : HDC ;
 _Size       : DWORD;
  buffer     : Pointer;
 bufferx2    : PByte;
 BMP         : TTagBitmap;       // クラスのTBITMAPではなく構造体のTBITMAP
 BI          : TBITMAPINFO_8BIT ;// TBITMAPINFOを使わないのはカラープレーン領域を確保するため
 BF          : TBITMAPFILEHEADER;
 MemoryStream : TMemoryStream;
 tmpBMP       : TBitmap;
begin

ZeroMemory(@BI,sizeof(TBITMAPINFO_8BIT));
  ZeroMemory(@BF,sizeof(TBITMAPFILEHEADER));
  GetObject(hBMP, sizeof(TTagBitmap), @BMP);

//BITMAPINFOの準備
  BI.bmiHeader.biSize       := 40;
  BI.bmiHeader.biWidth      := BMP.bmWidth;
  BI.bmiHeader.biHeight     := BMP.bmHeight;
  BI.bmiHeader.biPlanes     := 1;
  BI.bmiHeader.biBitCount   := BPP;
  BI.bmiHeader.biCompression:= BI_RGB;

//ビットマップデータサイズを算出
  _Size :=((BPP * BI.bmiHeader.biWidth + 31) div 32) * 4 * abs(BI.bmiHeader.biHeight);

//BITMAPFILEHEADERの準備
      BF.bfType     :=$4D42;

case BPP of
         1:   BF.bfOffBits  :=40+14+(4*2);
	 4:   BF.bfOffBits  :=40+14+(4*16);
	 8:   BF.bfOffBits  :=40+14+(4*256);
         else BF.bfOffBits  :=40+14;
      end;

BF.bfSize     := _Size+BF.bfOffBits;

GetMem(buffer,_Size);

try
      bufferx2:=PByte(Buffer) ;

//ここで色数を変更
          hDCx2 :=GetDC(0);
          hMem := CreateCompatibleDC(hDCx2);
          SelectObject(hMem,hBMP);
          GetDIBits(hMem, hBMP, 0,BMP.bmHeight,bufferx2,PBITMAPINFO(@BI), DIB_RGB_COLORS);
          DeleteDC(hMem) ;
          ReleaseDC(0,hDCx2);

MemoryStream:=TMemoryStream.Create;

MemoryStream.Write(BF,14);

case BPP of
                1:   MemoryStream.Write(BI,40+(4*2));
                4:   MemoryStream.Write(BI,40+(4*16));
                8:   MemoryStream.Write(BI,40+(4*256));
                else MemoryStream.Write(BI,40);
              end;

MemoryStream.Write(bufferx2^,_Size);
              MemoryStream.Position:=0;

tmpBMP :=TBitmap.Create;
              
              try
                 tmpBMP.LoadFromStream(MemoryStream);
              finally
                 Result:=tmpBMP.ReleaseHandle;
                 tmpBMP.free;
              end;

MemoryStream.Free;

finally
        FreeMem(buffer);
        DeleteObject(hBMP);
      end;
end;

//------------------------------------------------------------------------------
// 関数名 CreateBMP_1bit
// 用途   ヒストグラムを使用して2色(1bit)に減色
// 引数   hBMP    ... 対象のビットマップハンドル
// 戻り値 変換後のビットマップハンドル
//------------------------------------------------------------------------------
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;

//1bitに変換
   Result:=ChangePixel(1,SrcBitmap.ReleaseHandle) ;

SrcBitmap.free;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   image1.picture.bitmap.handle:=CreateBMP_1bit(image1.picture.bitmap.ReleaseHandle);
end;

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

戻る