More Secrets

ホーム What's New アフターケア ダウンロード よくあるご質問 More Secrets
このページは 書籍 Delphi Graphic Secrets に書ききれなかった、Delphi のグラフィック・プログラミングのノウハウをアットランダムに紹介しています。

最終更新日: 2002/7/17

 

目次

  1. メタファイルのコピー
  2. TBitmap.Scanline を使う際の注意
  3. Canvasが消える?
  4. パターンマネージャ
  5. Canvasの寿命
  6. RGB-HLS変換
  7. TGraphic のコンストラクタ
  8. パスはリージョンに変換できる
  9. ビットマップのグレースケール化

1. メタファイルのコピー

既存のメタファイルに図形を追加したいことは結構あるのではないでしょうか? そのような場合、新たなメタファイルを作ってそこに古いメタファイルを描画し、さらに図形を追加描画すればうまく行きます。しかしそれには限度というものがあります。

簡単な試験をしてみましょう。

procedure TForm1.Button1Click(Sender: TObject);
var
  M1, M2: TMetafile;
  MC: TMetafileCanvas;
  i: Integer;
begin
  M1 := TMetafile.Create;
  MC := TMetafileCanvas.Create(M1, 0);
  MC.MoveTo(100, 100);
  MC.LineTo(200, 200);
  MC.Free;

  M1.SaveToFile('M.emf');

  for i := 1 to 10 do
  begin
    M2 := TMetafile.Create;
    MC := TMetafileCanvas.Create(M2, 0); // メタファイルのコピーを作る
    MC.Draw(0, 0, M1);
    MC.Free;
    M2.SaveToFile('M' + IntToStr(i) + '.emf'); // メタファイルを
                                               // M数字.emf という
                            // 名でセーブ
    M1.Assign(m2); // 新メタファイルを新たな M1 とする。
    M2.Free;
  end;
  M1.Free;
end;

上記のコードはまず、直線を一本だけ引いたメタファイルを作り、それを単純に、TMetafileCanvas の Draw メソッドでコピーを繰り返してゆくだけです。単純に考えると、同じメタファイルがたくさんできるように思えます。しかし実際は違います。

M.emf:   716バイト、 18レコード
M1.emf:  1704バイト、 61レコード
M2.emf: 2872バイト、108レコード
M3.emf: 4312バイト、 163レコード
M4.emf:  6296バイト、234レコード
  :

M9.emf: 78Kバイト、2413レコード
M10.emf: 149Kバイト, 4500レコード

というようにメタファイルの大きさが指数関数的に膨れ上がります。当然こうしてコピーが繰り返されたメタファイルを描画すると、線がたったの一本しかはいっていないのにもかかわらずとてつもなく遅くなります。

こうなる原因は、メタファイルの1レコードが、描画先のメタファイルに単純に1レコードで記録されるわけではないからです。EMF を再生するための PlayEmhMetafile API は、座標系の処理や必要な GDI オブジェクトの生成など、様々な処理を描画先の Canvas に行います。したがって、メタファイルを Draw メソッドで別のメタファイルに描くたびに、ある割合でレコード数が増えてしまうのです。結果としてレコード数はコピーを繰り返すと指数関数的に増えてしまいます。

もう結論はお分かりでしょう。メタファイルのコピーは数回が限度です。それ以上は莫大な資源の無駄を引き起こします。注意しましょう。

先頭に戻る

2. TBitmap.Scanline を使う際の注意

書籍では TBitmap の Scanline プロパティは DIB Section のスキャンラインの先頭を指すポインタを返すと書きました。これは事実ですが若干の注意事項があります。

TBitmap が DDB を保持している場合、ScanLineプロパティが参照されると TBitmap は 自動的にビットマップを DDB から DIB Section に変換し、その ScanLine のポインタを返します。ところが、TBitmap は DDB も保持しつづけます。ここでさらに ScanLine プロパティを参照すると、なんと TBitmap はまた最初から DDB→DIB Section の変換をやり直すのです!

このため、TBitmap が DDB を保持しているときは ScanLine プロパティは結局正常には動きません。

Scanline プロパティを使うときは PixelFormat プロパティか HandleType プロパティで TBitmap が DIB Section を持つように設定してから Scanline プロパティを使ってください。

先頭に戻る

3. Canvasが消える?

例えばPaintBoxの内容をフォームにコピーしたい時

Canvas.CopyRect(Clientrect, PaintBox1.Canvas, PaintBox1.ClientRect);

と書くことがあるでしょう。実はこの処理は動かないことがあります。

VCL ではコントロールのクライアント領域用のデバイスコンテキストは最大4個に制限されています。これは Windows 95 系列の Windows ではコントロール用の GetDCで取得したデバイスコンテキスト数が5個を越えると不正な動作をするからです。VCL は Controls ユニットの CanvasList変数でこれを管理していて、コントロールの デバイスコンテキスト数が4を越えようとすると、最も古く CanvasList に登録されたコントロールのデバイスコンテキストを 破棄します。

上のコードでは、CopyRect メソッドの内部動作において、フォームのデバイスコンテキストハンドルを取得後、PaintBox1 の Canvas のデバイスコンテキストが作成される可能性があり、従ってフォームのデバイスコンテキストが描画時に破棄されている可能性があります。

デバイスコンテキストの自動破棄はロックされている Canvas には適用されません。VCLはロックされていない別のデバイスコンテキストを削除しようと試みます。従って、

Canvas.Lock;
Canvas.CopyRect(Clientrect, PaintBox1.Canvas, PaintBox1.ClientRect);
Canvas.Unlock;

とすれば常に正常に動作します。

先頭に戻る

4. パターンマネージャ

Graphics ユニットには、フォントマネージャ、ペンマネージャ、ブラシマネージャがありますが、これに加えてパターンマネージャというものが有ります。これはブラシパターンの作ってくれるサービスです。

Graphics ユニットの

function AllocPatternBitmap(BkColor, FgColor: TColor): TBitmap;

を呼び出すと、BkColor, FgColor で市松模様になった 8x8 のビットマップが戻ります。VCLはこのブラシパターンをメニューや Drag&Dock の描画で使用しています。これはパレットをもたないビットマップですので、予約色以外の色は指定しないようにしてください。

AllocPatternBitmap には若干注意点があります。AllocPatternBitmapは作成したビットマップをキャッシュし、同じパターンをひとつしか作りません。AllocPatternBitmapが返すパターンビットマップはパターンマネージャが管理しています。ですからAllocPatternBitmapが返すビットマップをフリーしてはいけません。注意してください。

先頭に戻る

5. Canvasの寿命

TCanvas の Handle プロパティは デバイスコンテキストのハンドルです。書籍 Delphi Graphic Secrets では パレットの処理などでデバイスコンテキストのハンドルを使う処理を数多く紹介していますが、デバイスコンテキストハンドルの寿命について書き忘れていました。ここでデバイスコンテキストハンドルの寿命についてお話します。

VCL にはデバイスコンテキストにはいくつかの種類があります。

  1. フォームの OnPaint イベントの中でのフォームの Canvas やコントロールの Paintメソッドの中でのコントロールの Canvas 
  2. 上記以外の場合のフォームやコントロールのCanvas
  3. ビットマップ(TBitmap)のCanvas
  4. プリンタ(TPrinter)のcanvas
  5. メタファイルのCanvas(TMetafileCanvas)

このなかで問題となるのは、2と3です。これらをここでは「寿命の短い Canvas」 と呼ぶことにしましょう。

Windows 95系列の Windows ではご存知のように 64KB しかない小さな GDI ヒープの中に 各種の GDI オブジェクト(ペン、ブラシ、..etc))を作ります。全てのアプリケーションは GDIヒープを共用します。デバイスコンテキストもここに作られます。

デバイスコンテキストは GDI オブジェクトの中では比較的大きなものなので(数百バイト)、あまり多く作ると OS がクラッシュしてしまいます。

この問題に対処するため、VCL はデバイスコンテキストを減らす仕組みを持っています。

WIndows のアプリケーションはメッセージを受信して処理を行うわけですが、VCL ではウィンドウを持つコントロールは、メッセージを MainWndProc というメソッドで受け取って、そこから WndProcメソッドを呼び出してメッセージ処理を行います。メッセージ処理が終わると、MainWndProc メソッドは最後に

ロックされていないアプリケーションの全ての「寿命の短い Canvas」 のデバイスコンテキストを破棄します。

こうすることで、アプリケーションが保持しているデバイスコンテキストを必要最小限に保つわけです。

このデバイスコンテキストの自動破棄は、デバイスコンテキストを Canvas のメソッドやプロパティを介して使っている場合は問題にはなりません。Canvas はデバイスコンテキストが必要になると作り直し、適切に設定しなおすので、処理の途中でデバイスコンテキストが破棄されても、そのことを Canvas の利用者は感知しなくてよいからです。

しかし、Canvas のデバイスコンテキストハンドル(Handleプロパティ)を直接使う場合は話が違ってきます。

例えば、デバイスコンテキストにパレットやリージョンを選択して描画処理を行っている時、その処理の中でメモコントロールのプロパティなどを弄るとメッセージが発生することがあります。するとその瞬間にデバイスコンテキストは破棄されてしまいます。もちろんコントロールにメッセージを SendMessage API で送ったりしてもいけません(PerFormメソッドは一応大丈夫ですが、他のメッセージを生み出す危険性があります)。

書籍の中で説明したパレットの実体化処理もやり方によっては問題を起こします。

SelectPalette の第2パラメータを False にしてパレットを選択し実体化すると、それがフォアグラウンド実体化になった場合、WM_PALETTECHANGED メッセージが発生することがあります。ですから、パレットがデバイスコンテキストに選択され実体化した瞬間、デバイスコンテキストが消滅してしまうという事態になります。書籍の中でパレットを使って描画する際、 SelectPalette の第2パラメータに True を指定するように書いたのはこういう理由もあるからなのです。

以上のように、寿命の短い Canvasのデバイスコンテキストハンドルを直接使うには細心の注意が必要です。その必要が無いなら避けてください。必要なら、最小限にとどめるようにしましょう。

先頭に戻る

6. RGB-HLS 変換

Delphi 6 には密かにグラフィック用として GraphUtil.pas というユニットが追加されています。基本的には ActionToolBar 用なのですが、この中に RGB-HLS変換のルーチンが入っています。このユニットはヘルプに載っていません。

色を HLS で表すと、もう少し濃い目にとか、もう少し明るめにとかいった色の調整が楽にできます。ActionToolBar はこれを利用して、ハイライトカラーや影用の色を基準となる色から作っています。これらの関数、手続きはアプリケーションからでも利用できます。

function GetHighLightColor(const Color: TColor): TColor;
基準となる色からハイライト用の色を作ります。
function GetShadowColor(const Color: TColor): TColor;
基準となる色から影用の色を作ります。
procedure ColorRGBToHLS(clrRGB: COLORREF; var Hue, Luminance, Saturation: Word);
RGBをHLSに変換します。
function ColorHLSToRGB(Hue, Luminance, Saturation: Word): TColorRef;
HLSをRGBに変換します。
function ColorAdjustLuma(clrRGB: TColorRef; n: Integer; fScale: BOOL): TColorRef;
色の明るさを調整します。(n は L の変化量、パラメータ fScale は使われていません)

尚、H, L, S は 0〜240の値をとるように設計されています。

先頭に戻る

7. TGraphic のコンストラクタ

Delphi Graphic Secrets の「 3-6 カスタムグラフィックスクラスの作成」では取り上げませんでしたが、Graphics ユニットの TGraphic のコンストラクタが protected になっているという問題は、いろいろな場で取り上げられ批判されてきました。

なぜこれが問題なのかというと、TGraphic はグラフィッククラスの抽象クラスで、グラフィッククラスは仮想コンストラクタを使って多態的にインスタンスを作れるように設計されているからです。

例えば、TPicture の Graphic プロパティにグラフィックを代入すると、グラフィックの「コピー」が Graphic プロパティに代入されます。これが可能なのは、代入するグラフィックと同じ型のグラフィックを TPicture 内に生成することが可能なためで、これには仮想コンストラクタの利用が必要不可欠なのです。

仮想コンストラクタを使うにはその元締めとなる抽象クラスに public な仮想コンストラクタが必要です。Graphicsユニット内ではコンストラクタの可視性が無視されるので問題は起きませんが、Graohicsユニットの外では public になっていないと仮想コンストラクタは使えず、多態的にグラフィックを生成することができません。つまり、TPicture の Graphic プロパティと同等の使い勝手を実現することが Graphic ユニットの外ではできないのです。これは困った制約で、プログラマを長年困らせてきました。

幸いなことに Delphi 6 では TGraphic のコンストラクタが public になり、この Delphi 発売以来の不具合が終結しました。多くのプログラマがほっとしたのではないかと思います。

Delphi 6 で TGraphic のコンストラクタが public になっていることを前提にしたプログラムは Delphi 5 ではコンパイルエラーにならない上、奇妙な振る舞いをします。Delphi 5 以前の版をお使いの方は今後ご注意ください。DHGL は今のところこの点に依存したコードはありません。

先頭に戻る

8. パスはリージョンに変換できる

Delphi Graphic Secrets では取り上げませんでしたが、パスはリージョンに変換できます。これには様々な応用がありますが、グラデーション付きの文字列を描く例を紹介しましょう。

uses PathUtils, RegionUtils, TextUtils;

procedure TForm1.Button1Click(Sender: TObject);
var
  Region: TRegion;
  y: Integer;
  TextHeight: Integer;
  TextStart: Integer;
  TextWidth: Integer;
const Str = 'DELPHI';
      TextStartPoint: TPoint = (X: 50; Y:50);
begin
  // 文字を (0, 0) を起点にしてパスに描く
  Canvas.Font.Size := 100;
  Canvas.Brush.Style := bsClear;
  Canvas.Font.Style := [fsItalic, fsBold];
  BeginPath(Canvas.Handle);
  Canvas.TextOut(0, 0, Str);
  EndPath(Canvas.Handle);

  // TextStartPoint を最初の文字セルの起点とし、
  // 文字が描画される領域を計算する。
  // TextStart: 文字列の最も左端の座標
  // TextWidth: 文字列の高さ TextHeight: 文字列の幅
  TextHeight := Canvas.TextHeight(Str);
  TextStart := TextStartPoint.x - GetTextAAdjust(Canvas, Str);
  TextWidth := Canvas.TextWidth(Str) +
               GetTExtAAdjust(Canvas, Str) +
               GetTextCAdjust(Canvas, Str);

  Region := TRegion.Create;
  try
    // パスをリージョンの変換する
    Region.Handle := PathToRegion(Canvas.Handle);
    // リージョンの位置を文字列の描画位置に合わせる
    Region.Move(TextStartPoint.x, TextStartPoint.y);
    // 文字列の形にクリッピングする。
    SelectClipRgn(Canvas.Handle, Region.Handle);

    // 文字列を囲む矩形領域にグラデーションを描く
    for y := TextStartPoint.y to TextStartPoint.y + TextHeight-1 do
    begin
      Canvas.Pen.Color := RGB((y - TextStartPoint.y) * 255 div TextHeight,
                              (y - TextStartPoint.y) * 255 div TextHeight,
                              100);
      Canvas.MoveTo(TextStart, y);
      Canvas.LineTo(TextStart + TextWidth, y);
    end;

  finally
    Region.Free;
  end;
end;

これを実行すると下の図のようになります。

コードを若干説明しておきましょう。コードでは、まず、パスに'Delphi' という文字列を描き、PathToRegion API でリージョンに変換します。PathToRegion API はパスの閉じた図形の中身をリージョンにします。

こうして作成されたリージョンをアプリケーション定義クリッピングリージョンにしてその上に矩形のグラデーションを描けば上の図のようにグラデーションが付いた文字が描けるわけです。

但し、Delphi Graphic Secrets で説明したように、文字を囲む矩形領域を求めるのは厄介な仕事です。イタリック体の文字は、Canvas.TextWidth が示す幅より文字幅が大きくなることがあるからです。しかし、これは DHGL の TextUtils ユニットにある GetTextAAdjust, GetTextCAdjust を使えば簡単に補正量を求めることができます。これを使って、上のコードでは、描く矩形の位置の計算を行っています。これは DHGL が無いとやっかいな作業です(^^

先頭に戻る

9. ビットマップのグレースケール化

ビットマップを256階調のグレースケールに変換するにはいくつかの方式が有ります。

  1. NTSC 加重平均法: 色のR, G, B値を人間の目の感度に従って加重平均をグレースケールの明るさにする方式
  2. 中間値法: 色の R, G, B値のうち最も大きな値と最も小さな値の中間値をグレースケールの明るさとする方式。
  3. 単純平均法: 色の R, G, B 値の平均をグレースケールの明るさにする方式

この3つの方式と、ビデオドライバにグレースケール化を任す方式の計4種類の方式でグレースケール化を行った例を以下に示します。

左上が原画像。その右隣が、ビデオドライバがグレースケール化を行った結果で、その右隣が NTSC加重平均法の結果です。

2段目は、それぞれ中間値法、単純平均法の結果です。

NTSC方式以外では、青が明るくなりすぎる傾向があり、また中間値法と単純平均法はコントラストが弱くなる傾向があるようです。NTSC方式が最も優れているようです。

上記4方式を実現する関数 ColorToGraySimple(ドライバに任す), ColorToGrayNTSC(NTSC加重平均法), ColorToGrayMed(中間値法), ColorToGrayAve(単純平均法)を含むユニット ColorToGray.pas を以下に示します。

これらの関数は任意の形式のビットマップをグレースケール化し、256階調グレースケールパレットを持つ 8bpp のビットマップを返します。

TBitmap用とTBigBitmap 用の両方の関数が含まれていますのでご活用ください。

unit ColorToGray;

interface

uses Windows, Graphics, BigBitmap;

// ビデオドライバに頼る(^^; 一番速い
function ColorToGrayScaleSimple(ColorBitmap: TBitmap): TBitmap; overload;
// NTSC 加重平均法 最も品質が良さそう
function ColorToGrayScaleNTSC(ColorBitmap: TBitmap): TBitmap; overload;
// 中間値法 なんかのっぺりとした画像になるみたいです。あまりよくない
function ColorToGrayScaleMed(ColorBitmap: TBitmap): TBitmap; overload;
// 単純平均法  青が明るくなりすぎます。ちょっとよくない
function ColorToGrayScaleAve(ColorBitmap: TBitmap): TBitmap; overload

// ビデオドライバに頼る(^^; 一番速い
function ColorToGrayScaleSimple(ColorBitmap: TBigBitmap): TBigBitmap; overload;
// NTSC 加重平均法 最も品質が良さそう
function ColorToGrayScaleNTSC(ColorBitmap: TBigBitmap): TBigBitmap; overload;
// 中間値法 なんかのっぺりとした画像になるみたいです。あまりよくない
function ColorToGrayScaleMed(ColorBitmap: TBigBitmap): TBigBitmap; overload;
// 単純平均法  青が明るくなりすぎます。ちょっとよくない
function ColorToGrayScaleAve(ColorBitmap: TBigBitmap): TBigBitmap; overload


implementation

// グレースケールパレットを作る
function CreateMonochromePalette: HPALETTE;
var
  i: Integer;
  LogPalette: TMaxLogPalette;
begin
  with LogPalette do begin
    palNumEntries := 256; palVersion := $0300;
    for i := 0 to 255 do begin
      palPalEntry[i].peRed := 255-i;
      palPalEntry[i].peGreen := 255-i;
      palPalEntry[i].peBlue := 255-i;
      palPalEntry[i].peFlags := 0;
    end;
  end;
  Result := CreatePalette(PLogPalette(@LogPalette)^);
end;

// ビデオドライバに頼る(^^; 一番速い
function ColorToGrayScaleSimple(ColorBitmap: TBitmap): TBitmap;
var
  SourceBitmap: TBitmap;
begin
  SourceBitmap := TBitmap.Create;
  try
    SourceBitmap.Assign(ColorBitmap);
    SourceBitmap.PixelFormat := pf24bit;

    Result := TBitmap.Create;
    try
      Result.PixelFormat := pf8Bit;
      Result.Width := SourceBitmap.Width;
      Result.Height := SourceBitmap.Height;

      Result.Palette := CreateMonochromePalette;
      Result.Canvas.Draw(0, 0, SourceBitmap);
    except
      Result.Free;
      raise;
    end;
  finally
    SourceBitmap.Free;
  end;
end;

// NTSC 加重平均法 最も品質が良さそう
function ColorToGrayScaleNTSC(ColorBitmap: TBitmap): TBitmap;
type
  TTriple = packed record B, G, R: Byte; end;
  PTriple = ^TTriple;
var SourceBitmap: TBitmap;
    x, y: Integer;
    pSource: PTriple;
    pDest: PByte;
begin
  SourceBitmap := TBitmap.Create;
  try
    SourceBitmap.Assign(ColorBitmap);
    SourceBitmap.PixelFormat := pf24bit;

    Result := TBitmap.Create;
    try
      Result.PixelFormat := pf8Bit;
      Result.Width := SourceBitmap.Width;
      Result.Height := SourceBitmap.Height;

      Result.Palette := CreateMonochromePalette;

      for y := 0 to SourceBitmap.Height-1 do begin
        pSource := SourceBitmap.ScanLine[y];
        pDest := Result.ScanLine[y];

        for x := 0 to SourceBitmap.Width-1 do begin
          pDest^ := round(255 - pSource.R * 0.298912 -
                                pSource.G * 0.586611 -
                                pSource.B * 0.114478);
          Inc(pSource); Inc(pDest);
        end;
      end;
    except
      Result.Free;
      raise;
    end;
  finally
    SourceBitmap.Free;
  end;
end;

// 中間値法 なんかのっぺりとした画像になるみたいです。あまりよくない
function ColorToGrayScaleMed(ColorBitmap: TBitmap): TBitmap;
type
  TTriple = packed record B, G, R: Byte; end;
  PTriple = ^TTriple;
var SourceBitmap: TBitmap;
    x, y: Integer;
    pSource: PTriple;
    pDest: PByte;
    Max,Min: Byte;
begin
  SourceBitmap := TBitmap.Create;
  try
    SourceBitmap.Assign(ColorBitmap);
    SourceBitmap.PixelFormat := pf24bit;

    Result := TBitmap.Create;
    try
      Result.PixelFormat := pf8Bit;
      Result.Width := SourceBitmap.Width;
      Result.Height := SourceBitmap.Height;

      Result.Palette := CreateMonochromePalette;

      for y := 0 to SourceBitmap.Height-1 do begin
        pSource := SourceBitmap.ScanLine[y];
        pDest := Result.ScanLine[y];

        for x := 0 to SourceBitmap.Width-1 do begin
          with pSource^ do begin
            Max := R; Min := R;
            if G > Max then Max := G;
            if B > Max then Max := B;
            if G < Min then Min := G;
            if B < Min then Min := B;
          end;
          pDest^ := 255 - (Max + Min) div 2;
          Inc(pSource); Inc(pdest);
        end;
      end;
    except
      Result.Free;
      raise;
    end;
  finally
    SourceBitmap.Free;
  end;
end;

// 単純平均法  青が明るくなりすぎますね。ちょっとよくない
function ColorToGrayScaleAve(ColorBitmap: TBitmap): TBitmap;
type
  TTriple = packed record B, G, R: Byte; end;
  PTriple = ^TTriple;
var SourceBitmap: TBitmap;
    x, y: Integer;
    pSource: PTriple;
    pDest: PByte;
begin
  SourceBitmap := TBitmap.Create;
  try
    SourceBitmap.Assign(ColorBitmap);
    SourceBitmap.PixelFormat := pf24bit;

    Result := TBitmap.Create;
    try
      Result.PixelFormat := pf8Bit;
      Result.Width := SourceBitmap.Width;
      Result.Height := SourceBitmap.Height;

      Result.Palette := CreateMonochromePalette;

      for y := 0 to SourceBitmap.Height-1 do begin
        pSource := SourceBitmap.ScanLine[y];
        pDest := Result.ScanLine[y];

        for x := 0 to SourceBitmap.Width-1 do begin
          pDest^ := 255 - (pSource.R + pSource.G + pSource.B) div 3;
          Inc(pSource); Inc(pDest);
        end;
      end;
    except
      Result.Free;
      raise;
    end;
  finally
    SourceBitmap.Free;
  end;
end;

// ビデオドライバに頼る(^^; 一番速い
function ColorToGrayScaleSimple(ColorBitmap: TBigBitmap): TBigBitmap;
var
  SourceBitmap: TBigBitmap;
begin
  SourceBitmap := TBigBitmap.Create;
  try
    SourceBitmap.PixelFormat := bbpf24bit;
    SourceBitmap.Width := ColorBitmap.Width;
    SourceBitmap.Height := ColorBitmap.Height;
    SourceBitmap.Canvas.Draw(0, 0, ColorBitmap);

    Result := TBigBitmap.Create;
    try
      Result.PixelFormat := bbpf8Bit;
      Result.Width := SourceBitmap.Width;
      Result.Height := SourceBitmap.Height;

      Result.Palette := CreateMonochromePalette;
      Result.Canvas.Draw(0, 0, SourceBitmap);
    except
      Result.Free;
      raise;
    end;
  finally
    SourceBitmap.Free;
  end;
end;

// NTSC 加重平均法 最も品質が良さそう
function ColorToGrayScaleNTSC(ColorBitmap: TBigBitmap): TBigBitmap;
type
  TTriple = packed record B, G, R: Byte; end;
  PTriple = ^TTriple;
var SourceBitmap: TBigBitmap;
    x, y: Integer;
    pSource: PTriple;
    pDest: PByte;
begin
  SourceBitmap := TBigBitmap.Create;
  try
    SourceBitmap.PixelFormat := bbpf24bit;
    SourceBitmap.Width := ColorBitmap.Width;
    SourceBitmap.Height := ColorBitmap.Height;
    SourceBitmap.Canvas.Draw(0, 0, ColorBitmap);

    Result := TBigBitmap.Create;
    try
      Result.PixelFormat := bbpf8Bit;
      Result.Width := SourceBitmap.Width;
      Result.Height := SourceBitmap.Height;

      Result.Palette := CreateMonochromePalette;

      for y := 0 to SourceBitmap.Height-1 do begin
        pSource := SourceBitmap.ScanLine[y];
        pDest := Result.ScanLine[y];

        for x := 0 to SourceBitmap.Width-1 do begin
          pDest^ := round(255 - pSource.R * 0.298912 -
                                pSource.G * 0.586611 -
                                pSource.B * 0.114478);
          Inc(pSource); Inc(pDest);
        end;
      end;
    except
      Result.Free;
      raise;
    end;
  finally
    SourceBitmap.Free;
  end;
end;

// 中間値法 なんかのっぺりとした画像になるみたいです。あまりよくない
function ColorToGrayScaleMed(ColorBitmap: TBigBitmap): TBigBitmap;
type
  TTriple = packed record B, G, R: Byte; end;
  PTriple = ^TTriple;
var SourceBitmap: TBigBitmap;
    x, y: Integer;
    pSource: PTriple;
    pDest: PByte;
    Max,Min: Byte;
begin
  SourceBitmap := TBigBitmap.Create;
  try
    SourceBitmap.PixelFormat := bbpf24bit;
    SourceBitmap.Width := ColorBitmap.Width;
    SourceBitmap.Height := ColorBitmap.Height;
    SourceBitmap.Canvas.Draw(0, 0, ColorBitmap);

    Result := TBigBitmap.Create;
    try
      Result.PixelFormat := bbpf8Bit;
      Result.Width := SourceBitmap.Width;
      Result.Height := SourceBitmap.Height;

      Result.Palette := CreateMonochromePalette;

      for y := 0 to SourceBitmap.Height-1 do begin
        pSource := SourceBitmap.ScanLine[y];
        pDest := Result.ScanLine[y];

        for x := 0 to SourceBitmap.Width-1 do begin
          with pSource^ do begin
            Max := R; Min := R;
            if G > Max then Max := G;
            if B > Max then Max := B;
            if G < Min then Min := G;
            if B < Min then Min := B;
          end;
          pDest^ := 255 - (Max + Min) div 2;
          Inc(pSource); Inc(pdest);
        end;
      end;
    except
      Result.Free;
      raise;
    end;
  finally
    SourceBitmap.Free;
  end;
end;

// 単純平均法  青が明るくなりすぎますね。ちょっとよくない
function ColorToGrayScaleAve(ColorBitmap: TBigBitmap): TBigBitmap;
type
  TTriple = packed record B, G, R: Byte; end;
  PTriple = ^TTriple;
var SourceBitmap: TBigBitmap;
    x, y: Integer;
    pSource: PTriple;
    pDest: PByte;
begin
  SourceBitmap := TBigBitmap.Create;
  try
    SourceBitmap.PixelFormat := bbpf24bit;
    SourceBitmap.Width := ColorBitmap.Width;
    SourceBitmap.Height := ColorBitmap.Height;
    SourceBitmap.Canvas.Draw(0, 0, ColorBitmap);

    Result := TBigBitmap.Create;
    try
      Result.PixelFormat := bbpf8Bit;
      Result.Width := SourceBitmap.Width;
      Result.Height := SourceBitmap.Height;

      Result.Palette := CreateMonochromePalette;

      for y := 0 to SourceBitmap.Height-1 do begin
        pSource := SourceBitmap.ScanLine[y];
        pDest := Result.ScanLine[y];

        for x := 0 to SourceBitmap.Width-1 do begin
          pDest^ := 255 - (pSource.R + pSource.G + pSource.B) div 3;
          Inc(pSource); Inc(pDest);
        end;
      end;
    except
      Result.Free;
      raise;
    end;
  finally
    SourceBitmap.Free;
  end;
end;


end.

先頭に戻る inserted by FC2 system