Delphi Programming / Object Pascal
サイトのトップページへ リンクのページへ ロゴマーク
[掲載 2005年10月04日] [更新 2014年02月07日] Delphi サンプルプログラム集
   
690_TImage へ文字列をキーから直接入力
動作確認等 Windows 7 U64(SP1) + Delphi XE Pro
Windows 7 U64(SP1) + Delphi XE5(UP2) Pro FireMonkey HD
690_TextOnImage.zip [6,137 KB] 2014年02月07日版(EXE同梱)



  • 2014年02月03日
  • テーマに対応した透明な TMemo コンポーネントを使用して更新
  • 2014年02月07日
  • ビットマップのサイズの注意と FireMonkey のサンプルを追加




01_透明な入力用コントロールを使用


TImage に追加描画するも文字列を,TImage 上で直接入力しているように見せるサンプルです.
TImage 上をクリックしたら,透明な TMemo を生成し,そこに入力します.その TMemo 以外の場所をクリックすると入力を終了して,入力した文字列を TImage の Canvas に描画します.

実用的にするには,更に工夫が必要です.このサンプルでは,入力コントロールである TMemo は折り返し表示していますが,TImage に描画する時は 1 行で描画しています.
TMemo の高さを自動的にフォントの高さと同じにするとか,入力した文字列の長さに TMemo の幅を合わせるとか,改行文字の処理等も必要となるかも知れません.


[備考]
このサンプルでは,透明な TMemo を使用していますが,個人的には,透明な入力コントロールを使用する必然性はないと思っています.コミュニティの場でのレス用に作成したため,そうなっているだけです.


図1
設計時画面
  • 入力用の TMemo は実行時に生成する
図2
IME を OFF にして入力中

上の図は日本語 IME を OFF にした状態で英数字を入力しているところです.入力中の文字列の背景が透明になっていることが分かります.
一方,下図は日本語 IME を ON にして日本語を入力しているところです.
TMemo の背景色は透明ですが,カナ漢字変換の入力中は,IME のウィンドウが表示されます.白はこのウィンドウの背景色です.


図3
日本語 IME での入力中の画面
  • カナ漢字変換システムの背景色になる
  • この背景色は変更できない

上の図で変換中の文字列を確定したのが下図です.このサンプルでは,改行しても 1 行で描画するようなコードとなっています.
この後の FireMonkey のサンプルでは,入力した文字列は,[Shift] + [Endter] で改行した場合,その改行文字も反映して TImage に描画されます.また,カナ漢字入力中も,カナ漢字ウィンドウが透過して,背景の画像が見えている状態となります.


図4
入力を確定した画面
  • 入力中は 2 行だったが 1 行となっている

リスト1
TImage へ文字列をキーから直接入力しているように見せるサンプル
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls, plTransMemo;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Panel1: TPanel;
    Image1: TImage;
    FontDialog1: TFontDialog;
    procedure FormDestroy(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure FormClick(Sender: TObject);
  private
    { Private 宣言 }
     EditInput : TplTransMemo;
     EditFont  : TFont;
     PtInput   : TPoint;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

//=============================================================================
//  フォーム表示開始時の処理
//
//  (1) テスト用の画像をImage1に表示
//      Image1のCavnasに描画する(Assiginだと追加描画不可)
//  (2) テストでFontを変更したいので,EditFontというオブジェクトを生成
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
var
  APict: TPicture;
begin
  //入力用コントロールをImage1内とするためParent用のPanelをFormに配置
  //その上にImage1を配置
  Image1.Align := alClient;

  //そのImage1にテスト用の画像を表示
  APict := TPicture.Create;
  try
    APict.LoadFromFile('nmlogo.bmp');
    Image1.Canvas.StretchDraw(Image1.BoundsRect, APict.Graphic);
  finally
    FreeAndNil(APict);
  end;

  //EditFontの初期値
  EditFont      := TFont.Create;
  EditFont.Size := 20;
end;

//=============================================================================
//  オブジェクトは使い終わったら破棄
//=============================================================================
procedure TForm1.FormDestroy(Sender: TObject);
begin
  FreeAndNil(EditInput);
  FreeAndNil(EditFont);
end;

//=============================================================================
//  文字に使用するFontを指定
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  FontDialog1.Font.Assign(EditFont);
  if FontDialog1.Execute then begin
    if EditFont = nil then EditFont := TFont.Create;
    EditFont.Assign(FontDialog1.Font);
  end;
end;

//=============================================================================
//  Form1とImage1のOnClick共有イベント処理
//
//  実用的にするには,入力した文字列の描画位置や折り返し描画等の工夫が必要
//  文字列入力の際も,入力文字の長さや高さに応じて,入力コントロール(TMemo)の
//  サイズ変更等の工夫が必要と思われる
//=============================================================================
procedure TForm1.FormClick(Sender: TObject);
begin
  //Image1をクリックしたら新規の文字列入力
  if (Sender is TImage) or (Sender is TForm) then begin
    //生成済みのコントロールがあれば破棄
    if EditInput <> nil then begin
      if EditInput.Text <> '' then begin
        Image1.Canvas.Brush.Style := bsClear;
        Image1.Canvas.Font.Assign(EditInput.Font);
        Image1.Canvas.TextOut(PtInput.x, PtInput.y, EditInput.Text);
      end;
      FreeAndNil(EditInput);
    end;

    if (Sender is TImage) then begin
      //透明なメモ作成.1行入力専用
      //右端で折返すが折返し部分はImageに描画しない
      EditInput := TplTransMemo.Create(Self);

      EditInput.WantReturns := False;
      EditInput.BorderStyle := bsNone;
      EditInput.Parent      := Panel1;

      //それは現在のマウス位置から
      GetCursorPos(PtInput);

      PtInput          := Image1.ScreenToClient(PtInput);
      EditInput.Left   := PtInput.x;
      EditInput.Top    := PtInput.y;
      EditInput.Font   := EditFont;
      EditInput.Width  := 100;
      EditInput.Height := 100;

      EditInput.Show;
      EditInput.SetFocus;
    end;
  end;
end;

end.




02_透明な TMemo コンポーネント


本ページのサンプルは,掲載当初,COSMIC TOWER (パンタグラフさん) の [背景透明化可能 拡張エディト&メモ] を使用していました.このコンポーネントは,XP テーマ,Windows Vista 以降のテーマを有効にしたプロジェクトでは透明になりません.
そこで 2014年02月03日の更新では,stack overflow にあるコードを利用しています.下のコードがそのコードです.コンポーネントの名前を変更し,文字列の描画開始位置を (0, 0) にして,上のサンプル専用としています.

このコンポーネントを実際に透明な TMemo として使用する場合,文字列の入力に際,チラつきが発生します.親コントロール等の DoubleBuffered を True にすることで軽減はできますが,完全に抑えることはできません.



リスト2
上のサンプルで使用した透明な TMemo コンポーネント
unit plTransMemo;

interface

uses
 Messages, Controls, StdCtrls, classes;

const TMWM_SpecialInvalidate = WM_USER+1111;

type
  TplTransMemo = class(TMemo)
  private
    procedure SpecialInvalidate(var Message:TMessage); message TMWM_SpecialInvalidate;
    procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL;
    procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
    procedure WMSetText(var Message:TWMSetText); message WM_SETTEXT;
    procedure CNCTLCOLOREDIT(var Message:TWMCTLCOLOREDIT); message CN_CTLCOLOREDIT;
    procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure WMMouseWheel(var Message: TWMMouseWheel); message WM_MOUSEWHEEL;
  public
    constructor Create(AOwner: TComponent); override;
  end;

procedure Register;

implementation

uses Windows, Graphics;

{ TplTransMemo }

//-----------------------------------------------------------------------------
//  生成時の処理
//  コンポーネントスタイルの設定
//-----------------------------------------------------------------------------
constructor TplTransMemo.Create(AOwner: TComponent);
begin
  inherited;
  ControlStyle := [csCaptureMouse,
                   csDesignInteractive,
                   csClickEvents,
                   csSetCaption,
                   csOpaque,
                   csDoubleClicks,
                   csReplicatable,
                   csNoStdEvents];
end;

//-----------------------------------------------------------------------------
//  CreateParamメソッド処理
//  コンポーネントデザインの設定
//-----------------------------------------------------------------------------
procedure TplTransMemo.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.ExStyle := Params.ExStyle
                    or      WS_EX_TRANSPARENT
                    and not WS_EX_WINDOWEDGE
                    and not WS_EX_STATICEDGE
                    and not WS_EX_DLGMODALFRAME
                    and not WS_EX_CLIENTEDGE;
end;

//-----------------------------------------------------------------------------
//  CN_CTLCOLOREDITメッセージ処理
//  このメッセージは描画直前のエディットコントロール(TEdit,TMemo等)に送られる
//  このメッセージの処理で背景色やテキストの色を変更できる
//  NULL_BRUSHは空のBrush(透明)
//-----------------------------------------------------------------------------
procedure TplTransMemo.CNCTLCOLOREDIT(var Message: TWMCTLCOLOREDIT);
begin
  //文字列の描画背景色
  SetBkMode(Message.ChildDC, TRANSPARENT);
  //NULL_BRUSHのオブジェクトを取得して戻り値とする
  Message.Result := GetStockObject(NULL_BRUSH);
end;

//-----------------------------------------------------------------------------
//  WM_KEYDOWNメッセージ処理
//-----------------------------------------------------------------------------
procedure TplTransMemo.WMKeyDown(var Message: TWMKeyDown);
begin
  SendMessage(Handle, TMWM_SpecialInvalidate, 0, 0);
  inherited;
  PostMessage(Handle, TMWM_SpecialInvalidate, 0, 0);
end;

//-----------------------------------------------------------------------------
//  WM_SETTEXTメッセージ処理
//-----------------------------------------------------------------------------
procedure TplTransMemo.WMSetText(var Message: TWMSetText);
begin
  inherited;
  if not (csDesigning in ComponentState) then begin
    PostMessage(Handle, TMWM_SpecialInvalidate, 0, 0);
  end;
end;

//-----------------------------------------------------------------------------
//  WM_HSCROLLメッセージ処理
//-----------------------------------------------------------------------------
procedure TplTransMemo.WMHScroll(var Message: TWMHScroll);
begin
  inherited;
  PostMessage(Handle, TMWM_SpecialInvalidate, 0, 0);
end;

//-----------------------------------------------------------------------------
//  WM_VSCROLLメッセージ処理
//-----------------------------------------------------------------------------
procedure TplTransMemo.WMVScroll(var Message: TWMVScroll);
begin
  SendMessage(Handle, TMWM_SpecialInvalidate, 0, 0);
  inherited;
  PostMessage(Handle, TMWM_SpecialInvalidate, 0, 0);
end;

//-----------------------------------------------------------------------------
//  WM_MOUSEWHEELメッセージ処理
//-----------------------------------------------------------------------------
procedure TplTransMemo.WMMouseWheel(var Message: TWMMouseWheel);
begin
  SendMessage(Handle, TMWM_SpecialInvalidate, 0, 0);
  inherited;
  PostMessage(Handle, TMWM_SpecialInvalidate, 0, 0);
end;

//-----------------------------------------------------------------------------
//  再描画用のコード
//  コントロールのInvalidate代替え処理コード
//  WM_PAINTで処理すると,キャレット等全ての描画も行われるためにチラツク
//-----------------------------------------------------------------------------
procedure TplTransMemo.SpecialInvalidate(var Message: TMessage);
var
  LRect : TRect;
begin
  if (Parent <> nil) then begin
    Perform(EM_SETMARGINS, EC_LEFTMARGIN or EC_RIGHTMARGIN, MakeLParam(0, 0));

    LRect             := ClientRect;
    LRect.TopLeft     := Parent.ScreenToClient(ClientToScreen(LRect.TopLeft));
    LRect.BottomRight := Parent.ScreenToClient(ClientToScreen(LRect.BottomRight));

    InvalidateRect(Parent.Handle, @LRect, true);
    RedrawWindow(Handle, nil, 0, RDW_FRAME + RDW_INVALIDATE);
  end;
end;

//-----------------------------------------------------------------------------
//  WM_ERASEBKGNDメッセージ処理
//  バックグラウンドの描画はしない
//-----------------------------------------------------------------------------
procedure TplTransMemo.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  Message.Result := 1;
end;

//-----------------------------------------------------------------------------
//  コンポーネント登録情報
//-----------------------------------------------------------------------------
procedure Register;
begin
  RegisterComponents('Samples', [TplTransMemo]);
end;

end.




03_TImage のビットマップのサイズとリサイズ  -  追加描画の注意


下図は,本サンプルの EXE を起動した後,フォームをリサイズして実行した結果です.
フォームのリサイズと共に TImage もリサイズするようになっています.
ビットマップ画像は StretchDraw していますから,表示画像のサイズもリサイズします.しかし,入力を確定すると,入力位置とは違う位置に文字列が表がされていることがわかります.

この現象は,マウスクリックで決めた入力位置が,元のビットマップの位置であることで発生します.入力を確定すると,表示サイズが大きくなっています.そこで,その倍率だけ,実際に描画される位置がずれるために発生します.


図5
フォームをリサイズして入力
  • 入力中の画面
図6
入力を確定した結果
  • 描画位置がずれている

上の現象は,TImage に画像をストレッチ描画しても,元のビットマップのサイズは変わらないことが原因です.このことを確認したのが下図です.
上のサンプルにボタンを追加して,リサイズした時の TImage.Bitamp の高さを取得していますが,リサイズしても,TImage が内部で保持しているビットマップの高さは変わりません.

しかし,表示されている画像のサイズは大きくなっています.TImage は,この表示を行うために,内部でオフスクリーンビットマップと呼ばれるビットマップを生成し,リサイズの表示が終わると破棄しますが,元々のビットマップは変更しません.このオフスクリーンビットマップは内部で使用されるだけです.外部からはアクセスできません.
この現象を回避するためには,TImage のサイズが変更されたら,元のビットマップもリサイズして描画し直す必要があります.
この後の FireMonkey のサンプルでは,この現象を回避するためのコードを追加しています.もちろん,上の VCL のサンプルでも,同じ方法で同様の処理が可能です.


図7
EXE の起動直後のビットマップの高さ
図8
リサイズ後のビットマップの高さ
  • リサイズ前と同じ値となっている

リスト3
TImage で表示しているビットマップの高さを取得して表示するコード
procedure TForm1.Button2Click(Sender: TObject);
var
  bmpHeight : Integer;
begin
  bmpHeight := Image1.Picture.Bitmap.Height;
  MessageBox(Handle, PChar(IntToStr(bmpHeight)), 'サイズ ( 高さ )', MB_OK);
end;




04_FireMonkey のサンプルコード


最初のサンプルの FireMonkey 版です.
最初のサンプルでは入力用のコントロールである TMemo の背景を透明にするために,専用のコンポーネントを作成して使用しました.FireMonkey ではそのようなコントロールを作成する必要はありません.プロパティやスタイル等の設定で透明度が設定でき,透明にも半透明にもできます.

上の記事で説明したリサイズの問題にも対応したコードも追加しています.
VCL では TImage の TCanvas に何かを描画すると,自動的にその描画内容に応じたサイズのビットマップが生成されます.この仕様は TImage を操作する際に曖昧さがありました.
FireMonkey では,明示的に TImage.Bitmap を生成します.この生成したビットマップの Canvas に描画します.明示的にビットマップを生成しなくても TImage.Canvas には描画可能ですが,TImage のビットマップには,外部からアクセスできません.この時,実際には TImage には描画メソッド類で描画した内容が表示されますが,これは,オフスクリーンビットマップの仕事です.


[備考]
TBitmap.CopyFromBitmap 関数は,受け取る側のビットマップのサイズが,コピー元のビットマップを格納できるだけの領域がないと失敗するようです.特に,受け取る側の位置を指定する場合は注意が必要かも知れません.このサンプルでは,コピー元も受け取る側のビットマップサイズが同じなので,問題はないようです.



図9
設計時画面
  • 入力用の TMemo は実行時に生成する
図10
入力中の画面

リスト4
TImage へ文字列をキーから直接入力しているように見せる FireMonkey 版のサンプル
unit Unit1;

interface

uses
  System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
  FMX.Types, FMX.Graphics, FMX.Controls, FMX.Forms, FMX.Dialogs, FMX.StdCtrls,
  FMX.Objects, System.UIConsts, FMX.Layouts, FMX.Memo;

type
  TForm1 = class(TForm)
    Image1: TImage;
    Panel1: TPanel;
    procedure FormShow(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Single);
  private
    { private 宣言 }
    srcBitmap : TBitmap;
    EditInput : TMemo;
    procedure ResizeBitmapOfTImage;
  public
    { public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.fmx}

//=============================================================================
//  フォーム表示開始時の処理
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
var
  srcRect : TRectF;
  dstRect : TRectF;
begin
  EditInput := nil;
  srcBitmap := nil;

  //ストレッチ描画
  Image1.WrapMode := TImageWrapMode.iwStretch;
  //描画用のビットマップを生成
  Image1.Bitmap := TBitmap.Create(Trunc(Image1.Width), Trunc(Image1.Height));

  //ビットマップ画像を読み出してTImageに描画
  srcBitmap := TBitmap.CreateFromFile('nmlogo.bmp');

  srcRect := RectF(0, 0, srcBitmap.Width, srcBitmap.Height);
  dstRect := RectF(0, 0, Image1.Width, Image1.Height);

  //ビットマップをTImageに描画
  //WrapModeをiwStretchにしているのでStretchDrawとなる
  Image1.Bitmap.Canvas.BeginScene();
  Image1.Bitmap.Canvas.DrawBitmap(srcBitmap, srcRect, dstRect, 1.0, False);
  Image1.Bitmap.Canvas.EndScene;
end;

//=============================================================================
//  フォーム破棄時の処理
//=============================================================================
procedure TForm1.FormDestroy(Sender: TObject);
begin
  FreeAndNil(srcBitmap);
end;

//=============================================================================
//  Image1とPanelのOnMouseDownイベント処理
//  claBlack等の定数名の使用にはSystem.UIConstsが必要
//=============================================================================
procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Single);
var
  Background : TFmxObject;
  textRect   : TRectF;
begin
  //TPanel上(このサンプルではTImage以外)
  if (Sender is TPanel) or (Sender is TImage) then begin
    if (EditInput <> nil) then begin
      if (EditInput.Text <> '') then begin
        Image1.Bitmap.Canvas.BeginScene();

        //TImage.Bitmap.Canvasのフォントを設定して描画領域を設定
        Image1.Bitmap.Canvas.Font.Size  := EditInput.Font.Size;
        Image1.Bitmap.Canvas.Fill.Color := EditInput.FontColor;

        textRect.Left   := EditInput.Position.X;
        textRect.Top    := EditInput.Position.Y;
        textRect.Width  := Image1.Bitmap.Canvas.TextWidth(EditInput.Text);
        textRect.Height := Image1.Bitmap.Canvas.TextHeight(EditInput.Text);

        //TImage.Bitmap.Canvasに,TMemoに入力した文字列を描画
        Image1.Bitmap.Canvas.FillText(textRect,
                                      EditInput.Text,
                                      False,
                                      1.0,
                                      [TFillTextFlag.ftRightToLeft],
                                      TTextAlign.taTrailing,
                                      TTextAlign.taLeading);
        Image1.Bitmap.Canvas.EndScene;
        FreeAndNil(EditInput);
      end;
      FreeAndNil(EditInput);
    end;

    //TImage上だったらTMemoを生成して文字列の入力モードにする
    if (Sender is TImage) then begin
      //TImageのサイズと表示するビットマップのサイズを同じにする
      ResizeBitmapOfTImage;

      EditInput        := TMemo.Create(Self);
      EditInput.Parent := Image1;

      //フォントのサイズと色を実行時に設定可能にする
      EditInput.StyledSettings := EditInput.StyledSettings -
                                    [TStyledSetting.ssSize] -
                                    [TStyledSetting.ssFontColor];

      EditInput.Position.X := X;
      EditInput.Position.Y := Y;
      EditInput.Font.Size  := 25.0;
      EditInput.FontColor  := claBlack;
      EditInput.Width      := 200;
      EditInput.Height     := 100;

      EditInput.SetFocus;

      //バックグラウンドのオブジェクトを取得して透明度を指定
      Background := EditInput.FindStyleResource('background');
      if Assigned(Background) then begin
        TControl(Background).Opacity := 0.5;
        TControl(Background).Padding.Rect := RectF(0, 0, 0, 0);
      end;
    end;
  end;
end;

//=============================================================================
//  TImageのビットマップのサイズをTImageと同じサイズにするための処理
//=============================================================================
procedure TForm1.ResizeBitmapOfTImage;
var
  tempBitmap : TBitmap;
  srcRect    : TRectF;
  dstRect    : TRectF;
begin
  tempBitmap := TBitmap.Create;
  try
    //現在表示しているビットマップのサイズを取得
    tempBitmap.Width  := Image1.Bitmap.Width;
    tempBitmap.Height := Image1.Bitmap.Height;

    //tempBitmapに現在表示しているビットマップを取り出す
    srcRect := RectF(0, 0, tempBitmap.Width, tempBitmap.Height);
    tempBitmap.CopyFromBitmap(Image1.Bitmap, srcRect.Round, 0, 0);

    //新しいビットマップはImage1と同じサイズにする
    Image1.Bitmap.Width  := Trunc(Image1.Width);
    Image1.Bitmap.Height := Trunc(Image1.Height);

    Image1.Bitmap.Canvas.BeginScene();
    Image1.Bitmap.Canvas.Clear(0);

    //描画先のサイズとビットマップのサイズを同じにしてTImageに描画
    dstRect := RectF(0, 0, Image1.Width, Image1.Height);
    Image1.Bitmap.Canvas.DrawBitmap(tempBitmap, srcRect, dstRect, 1.0);
    Image1.Bitmap.Canvas.EndScene();
  finally
    FreeAndNil(tempBitmap);
  end;
end;

end.




05_FireMonkey におけるコントロールの透明半透明化


上のサンプルの記事で,コントロールの透明度が変更可能なことを書きました.
その透明度の変更動作を確認するためのサンプルです.

このサンプルでは,TPanel の透明度は,そのものズバリの Opacity というプロパティで設定しています.一方, TEdit は文字列を描画する背景のコントロールの透明度を設定します.そこで,バックグラウンドのオブジェクトを取得し,そのオブジェクトに対して Opacity プロパティの値を設定するようにしています.
色の付いているパネルの色は,設計時に,ポップアップメニューから [カスタムスタイルの編集] で設定しています.フォーム場合,[カスタムスタイルの編集] ダイアログを表示しなくても,オブジェクトインスペクタの Fill プロパティで背景色や背景画像の設定が可能です.


図11
設計時画面
  • 透明度を設定する TTrackBar を配置
  • TEdit と TPanel を 2 つ配置
図12
EXE 起動直後
図13
透明度を変更した結果

リスト5
FireMonkey におけるコントロールの透明半透明化
unit Unit1;

interface

uses
  System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
  FMX.Types, FMX.Graphics, FMX.Controls, FMX.Forms, FMX.Dialogs, FMX.StdCtrls,
  FMX.Objects, System.UIConsts, FMX.Layouts, FMX.Edit;

type
  TForm1 = class(TForm)
    TrackBar1: TTrackBar;
    Panel1: TPanel;
    StyleBook1: TStyleBook;
    Panel2: TPanel;
    Edit1: TEdit;
    procedure FormShow(Sender: TObject);
    procedure TrackBar1Change(Sender: TObject);
  private
    { private 宣言 }
  public
    { public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.fmx}

//=============================================================================
//  フォームの表示開始時の処理
//  claSilver等の定数名にはusesにSystem.UIConstsが必要
//  System.UIConstsを使用しなくともTAlphaColorRec.Silverでも設定可能
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
begin
  Edit1.TextAlign     := TTextAlign.taCenter;
  Edit1.VertTextAlign := TTextAlign.taCenter;
  Edit1.Text          := 'テスト文字列';
  //フォントのサイズと色を実行時に設定可能にする
  Edit1.StyledSettings := Edit1.StyledSettings - [TStyledSetting.ssSize]
                                               - [TStyledSetting.ssFontColor];
  Edit1.Font.Size      := 20;
  Edit1.FontColor      := claGreen;

  TrackBar1.Value := 100;
end;

//=============================================================================
//  TrackBar1のOnChangeイベント処理
//  透明度の設定
//=============================================================================
procedure TForm1.TrackBar1Change(Sender: TObject);
var
  Background : TFmxObject;
begin
  //Panel2の透明度の設定
  Panel2.Opacity := TrackBar1.Value / 100;

  //Edit1コントロールの透明度の設定
  //バックグラウンドのオブジェクトを取得して設定
  Background := Edit1.FindStyleResource('background');
  if Assigned(Background) then begin
    TControl(Background).Opacity := TrackBar1.Value / 100;
  end;
end;

end.




06_FireMonkey における画像の透過処理と画像形式の変換


「透明」のついでに,次は,TImage 等の描画用コントロールにビットマップ画像を描画する際に,指定の色を「透明」にして「透過」するサンプルです.
ここで透過処理したビットマップは,アルファチャンネル付きのビットマップ画像となります.

VCL では Delphi 2009 でアルファチャンネルの機能が実装されましたが,FireMonkey でもアルファチャンネルの機能が実装されました.アルファチャンネルは,色の透明度を指定できる機能です.透明度を意味する値をアルファ値と言います.FireMonkey は,アルファチャンネル付きの画像を正常に扱えるようになったと言えます.
その代わりかどうかは分かりませんが,Windows 独自のビットマップの「透過色」を指定する機能はなくなったのかも知れません.

アルファチャンネル付きの画像は,色の値が 0 のピクセルを透過表示します.
したがって,透過したいピクセルの色の値を 0 にすればいいことになります.下のコードでは指定の座標の色と同じ色のピクセルを透過する関数を作成しています.この関数を使用して,ディスクから読み込んだ画像の一部を透過表示します.
ピクセルの処理には PAlphaColorArray という関数を使用して,色の情報を全てバイト配列に確保してから操作しています.GetPixel, SetPixel 関数も使用できますが,これらの関数は,ピクセルにアクセスする度に PAlphaColorArray と同じような処理をするために,対象ピクセル数が多くなると処理に相当な時間がかかるようになります.


[備考 1]
FireMonkey の色の定数名には,例えば赤は,VCL が clRed であるのに対して claRed と,cl の後にアルファ値を意味する a が付いています.

[備考 2]
画像全体やコントロール全体の透明度は,アルファ値を変えることで変更することができますが,実際にはそのような操作はほとんど必要ありません.TCanvaa の描画用のメソッド類の多くは,透明度を指定する引数があります.
コントロールに描画するのではなく,半透明の画像を保存したい場合は,直接アルファ値を変更した画像を作成する必要があるかも知れません.

[備考 3]
JPEG 画像は透過処理できません.JPEG 画像にはアルファチャンネルという概念はありません.
JPEG 2000 形式の画像では可能なようですが,筆者は確認していません.

[備考 4]
参考リンクの [FireMonkey で使えるコンポーネントは?] の記事には,各コンポーネントの簡単な説明と Delphi のオンラインヘルプへのリンクがあります.


図14
設計時画面
  • TButton を 2 つと TImage を 1 つを配置
図15
Button1 をクリック
図16
Button2 をクリック
  • 各画像の左上 (0, 0) のピクセルと同じ色の部分を透明化して描画
図17
2 番目の画像を半透明に
  • DrawBitmap 関数で透明度を 0.5 にした場合

透過処理した画像を保存して,アルファチャンネル付きビットマップ画像の表示をサポートしていないコントロールで表示します.すると,下図のように,透明な部分は黒く表示されます.
Delphi 2009 以降の TImage は,アルファイチャンネル付きのビットマップ画像を表示する機能があります.

2014年現在,アルファチャネル付きのビットマップ画像をサポートしている Windows 用のアプリケーションは多くはありません.Photoshop はサポートしています.Delphi 製のアプリですが,IconFX というアプリもサポートしています.
サポートしているアプリケーションが少ないのは歴史的な理由もあるようです.元々,拡張子が BMP の狭義の意味の現在のビットマップ画像形式は,Windows 用として生まれました.透過を実装するために「透過色」が採用されています.これは,指定の色を描画しないことを意味しています.アルファチャンネルにおける透過とは基本的に考え方が違います.

FireMonkey の場合,TBitmap が扱える画像形式であれば読み込んで TImage に表示できます.
保存する時は,拡張子を指定すると,該当拡張子の画像形式で保存されます.透過処理したビットマップ画像を PNG または GIF 画像として保存すると,透過処理した部分は透明となります.


図18
透過処理をしたビットマップ画像の表示
  • アルファイチャンネル付きのビットマップ画像を表示する機能がないコントロールの場合
  • 透明部分は黒く表示される
図19
PNG 形式で保存した画像を表示
  • 透過処理部分は透明となる
  • GIF 形式の画像で保存した場合も同じ

リスト6
指定した座標値の色と同じ色の透明化と,画像形式の変換
unit Unit1;

interface

uses
  System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
  FMX.Types, FMX.Graphics, FMX.Controls, FMX.Forms, FMX.Dialogs, FMX.StdCtrls,
  FMX.Objects, System.UIConsts;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Image1: TImage;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { private 宣言 }
  public
    { public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses System.IOUtils;

{$R *.fmx}

//-----------------------------------------------------------------------------
//  指定座標の色と同じ色のピクセルを透過するビットマップ画像に変換
//  Bitmap : 変換元のビットマップ画像
//  RefX   : 画像内でのX座標値(左端が0)
//  RefY   : 画像内でのY座標値(上端が0)
//  PAlphaColorArrayは
//    aBitmapData.GetPixel(X, Y);
//    aBitmapData.SetPixel(X, Y, TAlphaColor);
//  よりも高速処理が可能
//  色の値は上位バイトから順に,アルファ値,赤,緑,青(ARGB)となっている
//-----------------------------------------------------------------------------
procedure TranslateColorBitmap(Bitmap: TBitmap; RefX, RefY: Integer);
var
  aRefColor    : TAlphaColor;
  aPixelColor  : TAlphaColor;
  aBitMapData  : TBitmapData;
  X            : Integer;
  Y            : Integer;
  pColorArray  : PAlphaColorArray;
  PixelOffset  : Integer;
  LineStartPos : Integer;
begin
  //ビットマップのデータを取得
  //以後はこのpBitmapDataを操作する
  if Bitmap.Map(TMapAccess.maWrite, aBitMapData) then begin
    //指定座標値の色を取得
    aRefColor := aBitMapData.GetPixel(RefX, RefY) and $00FFFFFF;

    //ビットマップのピクセルデータの配列を取得
    pColorArray := PAlphaColorArray(aBitMapData.Data);
    PixelOffset := aBitMapData.Pitch div SizeOf(TAlphaColor);

    for Y := 0 to Trunc(Bitmap.Height) - 1 do begin
      //Y行目の先頭位置
      LineStartPos := Y * PixelOffset;

      for X := 0 to Trunc(Bitmap.Width) - 1 do begin
        //座標(X, Y)の色を取得
        aPixelColor := pColorArray[LineStartPos + X] and $00FFFFFF;
        if aPixelColor = aRefColor then begin
          pColorArray[LineStartPos + X] := $0;
        end;
      end;
    end;
    Bitmap.Unmap(aBitMapData);
  end;
end;

//=============================================================================
//  ディスクからビットマップ画像を読み込んでTImageに描画
//  透過処理なし
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  FilePath   : String;
  srcBitmap1 : TBitmap;
  srcBitmap2 : TBitmap;
  srcRect    : TRectF;
  dstRect    : TRectF;
begin
  Image1.Bitmap.Assign(nil);

  //ディスクから画像を読み込んでビットマップを生成
  FilePath      := '503.bmp';
  srcBitmap1    := TBitmap.CreateFromFile(FilePath);
  srcBitmap2    := TBitmap.CreateFromFile(FilePath);
  //TImageのビットマップを生成
  Image1.Bitmap := TBitmap.Create(Trunc(Image1.Width), Trunc(Image1.Height));
  try
    Image1.Bitmap.Canvas.BeginScene();

    //最初の画像の描画領域を設定して描画
    srcRect := TRectF.Create(0.0, 0.0, srcBitmap1.Width, srcBitmap1.Height);
    dstRect := TRectF.Create(0, 0, srcBitmap1.Width, srcBitmap1.Height);
    OffsetRect(dstRect, 30, 10);
    Image1.Bitmap.Canvas.DrawBitmap(srcBitmap1, srcRect, dstRect, 1.0);

    //次の画像の描画領域を設定して描画
    OffsetRect(dstRect, 30, 30);
    Image1.Bitmap.Canvas.DrawBitmap(srcBitmap2, srcRect, dstRect, 1.0);

    Image1.Bitmap.Canvas.EndScene();
  finally
    FreeAndNil(srcBitmap1);
    FreeAndNil(srcBitmap2);
  end;
end;

//=============================================================================
//  ディスクからビットマップ画像を読み込んでTImageに描画
//  透過処理あり
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  FilePath   : String;
  srcBitmap1 : TBitmap;
  srcBitmap2 : TBitmap;
  srcRect    : TRectF;
  dstRect    : TRectF;
begin
  Image1.Bitmap.Assign(nil);

  //ディスクから画像を読み込んでビットマップを生成
  FilePath      := '503.bmp';
  srcBitmap1    := TBitmap.CreateFromFile(FilePath);
  srcBitmap2    := TBitmap.CreateFromFile(FilePath);
  //TImageのビットマップを生成
  Image1.Bitmap := TBitmap.Create(Trunc(Image1.Width), Trunc(Image1.Height));
  try
    Image1.Bitmap.Canvas.BeginScene();

    //最初の画像の描画領域を設定して描画
    srcRect := TRectF.Create(0.0, 0.0, srcBitmap1.Width, srcBitmap1.Height);
    dstRect := TRectF.Create(0, 0, srcBitmap1.Width, srcBitmap1.Height);
    OffsetRect(dstRect, 30, 10);

    //画像の左上の色と同じ色を透過処理
    TranslateColorBitmap(srcBitmap1, 0, 0);
    Image1.Bitmap.Canvas.DrawBitmap(srcBitmap1, srcRect, dstRect, 1.0);


    //次の画像の描画領域を設定して描画
    OffsetRect(dstRect, 30, 30);

    //画像の左上の色と同じ色を透過処理
    TranslateColorBitmap(srcBitmap2, 0, 0);
    Image1.Bitmap.Canvas.DrawBitmap(srcBitmap2, srcRect, dstRect, 1.0);

    Image1.Bitmap.Canvas.EndScene();

    //拡張子を変えて,各種画像形式で保存
    //TPathの使用にはusesにSystem.IOUtilsが必要
    FilePath := TPath.ChangeExtension(FilePath, '.jpg');
    srcBitmap2.SaveToFile(FilePath);
    FilePath := TPath.ChangeExtension(FilePath, '.png');
    srcBitmap2.SaveToFile(FilePath);
    FilePath := TPath.ChangeExtension(FilePath, '.gif');
    srcBitmap2.SaveToFile(FilePath);
  finally
    FreeAndNil(srcBitmap1);
    FreeAndNil(srcBitmap2);
  end;
end;

end.