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

解決

kk  2002-06-17 20:22:46  No: 1014

カラーのBMPファイルを、モノクロBMPに変換するにはどうすればよいでしょうか？
サーマルのプリンタから印字させたいのですがモノクロのほうが都合がいいので、
いろいろ試したのですがうまくいきません。
グラフィックソフトを使って変換させるしかないのでしょうか？
宜しくお願い致します。

にしの  2002-06-17 20:38:30  No: 1015

こちらのサイトにあるGraphic Effectに、グレースケールというサンプルがあります。
これではうまくいきませんでしたか？

kk  2002-06-17 21:01:05  No: 1016

すみません。私の環境はDelphi２．０なのですが、
こちらのGraphic Effectのプロジェクトを開こうとすると
エラーが起きてしまいます。２．０では無理ですか？

にしの  2002-06-17 21:41:15  No: 1017

まずは、ソースを見て想像してみてください。
EffectGrayScaleColor関数に、ビットマップのハンドルを与えると、新たに作成されたビットマップのハンドルが返されるようです。
もしかしたら、Delphi2では少し工夫が必要かもしれません。

やっていることは、１点ずつ、色を変換しているみたいです。

↓この部分

//NTSC系加重平均法を用いてグレースケール化
RGBColor:=Set255(
  Round(SrcRow[Col].rgbtRed   *0.289+
    SrcRow[Col].rgbtGreen *0.586+
    SrcRow[Col].rgbtBlue  *0.114 )));

//単純グレースケール化
//RGBColor:=Set255(
//             (SrcRow[Col].rgbtRed   +
//              SrcRow[Col].rgbtGreen +
//              SrcRow[Col].rgbtBlue ) div 3);

DestRow[Col].rgbtBlue :=RGBColor;
DestRow[Col].rgbtGreen:=RGBColor;
DestRow[Col].rgbtRed  :=RGBColor;

お助け隊  2002-06-18 11:36:16  No: 1018

D2では ScanLineが使えません。代わりに Pixelsを使うことになります。
ScanLineなら一瞬で変換されますが、Pixelsでは、変換速度が かなり遅くなってしまいます。
大きな画像では実用的ではないですね。

function EffectGrayScaleColor(hBMP: HBitmap): HBitmap;
var
  Row, Col : Integer;
  SrcRGB, RGB : TColor;
  R, G, B : Integer;
  SrcBitmap, DestBitmap : TBitmap;
begin
  SrcBitmap  := TBitmap.Create;
  DestBitmap := TBitmap.Create;
  SrcBitmap.Handle := hBMP;
//Set24bit(SrcBitmap,DestBitmap);
  DestBitmap.Width  := SrcBitmap.Width;
  DestBitmap.Height := SrcBitmap.Height;
  try
    for Row:=0 to SrcBitmap.Height-1 do begin
      for Col:=0 to SrcBitmap.Width-1 do begin
        //NTSC系加重平均法を用いてグレースケール化
        SrcRGB := SrcBitmap.Canvas.Pixels[Col,Row];
        R := Round((SrcRGB and $ff0000 shr 16) * 0.289);
        G := Round((SrcRGB and $00ff00 shr 8 ) * 0.586);
        B := Round((SrcRGB and $0000ff       ) * 0.114);
        RGB := R + G + B;
        DestBitmap.Canvas.Pixels[Col,Row] := (RGB shl 16) + (RGB shl 8) + RGB;
      end;
    end;
    Result := DestBitmap.ReleaseHandle;
  except
    Result := SrcBitmap.ReleaseHandle;
  end;
  SrcBitmap.Free ;
  DestBitmap.Free;
end;

kk  2002-06-19 20:14:52  No: 1019

上に解説していただいた
function EffectGrayScaleColor(hBMP: HBitmap): HBitmap;
で試しました。
色的には変換されているのですが、私の中でのイメージでは
ファイルのサイズもどーんと小さくなるっていうイメージなのですが。
Windowsのアクセサリの『ペイント』でカラーのビットマップを開いて
『キャンバスの色とサイズ』の中から白黒(B)を選ぶとモノクロに変換
されて、ファイルのサイズも小さくなりますよね？
白黒に変換して、さらにサイズも小さくするってことはできないのでしょうか？

よろしくお願い致します。

にしの  2002-06-19 21:28:00  No: 1020

２５６色のパレットを作って、それぞれ(0,0,0)〜(255,255,255)にし、上で変換した色(３バイトの組)を、１バイトに直せばできます。
もしかしたら、ちょっと工夫が必要かもしれません。

PixelFormatプロパティや、Monochromeプロパティがあるなら、それでうまくできるかもしれません。
# 未確認です。

papy  2002-06-20 00:35:33  No: 1021

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;

kk  2002-06-20 05:05:21  No: 1022

papyさん
pixelformat,pf1bitのところでエラーになってしまいます。
Delphi2.0ではサポートされていないのですかねぇ。
何かよい方法があればいいのですが。。。

にしの  2002-06-20 07:54:38  No: 1023

ファイル to ファイルで変換するという手もありますよ。
その場合、ヘッダを少し書き換えて、パレットを用意して、画像を３バイトごとに変換していけばOKです。
# １ラインが４バイトで割り切れない場合はパディング（詰め物）が必要だったと思います

papy  2002-06-21 05:54:48  No: 1024

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;

kk  2002-06-22 04:45:32  No: 1025

皆さんありがとうございました。
おかげで何とかなりそうです。

マルチポストはマナー違反ですよ  2002-06-22 08:51:34  No: 1026

DelphiGIG.comさんのとこにも「解決しました」って
報告しましょうね。

kk  2002-06-23 00:43:30  No: 1027

アドバイスを頂いた皆さんへ
申し訳ございませんでした。
以後気をつけますので、これからもよろしくお願い致します。

※返信する前に利用規約をご確認ください。

※Google reCAPTCHA認証からCloudflare Turnstile認証へ変更しました。






  このエントリーをはてなブックマークに追加