Delphi Programming / Object Pascal
サイトのトップページへ リンクのページへ ロゴマーク
[掲載 2014年12月25日] [更新 2014年12月27日]　Delphi サンプルプログラム集
207_TRichEdit の背景を画像にする
動作確認等 Windows 7 U64(SP1) + Delphi XE(UP1) Pro
207_RichEdit_Background.zip　[2,434 KB]　2014年12月27日版 (EXE 同梱)



  • 2014年12月27日
  • 透明部分を持つ画像を背景に表示する場合，透明部分を TRichEdit の背景色にするようにした



リッチエディットコントロールの背景を画像にする


Delphi の TRichEdit コントロールの背景に画像を描画するテストプログラムです．
以下のページからダウンロードした TransparentRichEdit.pas のコードを元に，コンポーネントを作成して使用しています．Transparent となっていますが，透明な TRichEdit として利用できるわけではありません．透明化の処理のコードを利用して，背景に画像を表示します．

スクロールの際に，背景の画像はほとんどチラつきません．テキストの編集の際は，編集内容によってはチラつきが発生します．アルファチャンネル付きの画像等，透明部分がある JPEG, PNG, GIF 画像等は，透明な部分は Color プロパティの値の色で塗り潰すようにしています．



TRichEdit と同等，あるいは機能を拡張したコントロール，コンポーネントは，サードパーティからも多く提供されています．ネット上を検索してみてください．必ずしも RichEdit という名前が付いているとは限りませんっ．RichView 等の名前の場合もあります．また，Memo という名前が付いているコンポーネントでも，実際にはテキストの属性等が設定できるリッチエディットのこともあります．

サンプルの [206_TEdit や TMemo の背景を画像にする] で，TEdit, TMemo の背景に画像を表示していますが，TEdit, TMemo は，Windows のエディットコントロールを使用しています．
一方，TRichEdit は，Windows のリッチエディットコントロールを使用しています．基本的に，同じ方法は使用できません．



[備考]
TRichEdit に限らず，Windows 2000 以前の時代に開発されたものであれば，透明化の機能を実装したコンポーネントがネット上で入手できます．
Windows XP ではスキンというテーマが導入され，Windows Vista では描画の仕組みが大きく変わりました．そのため，Windows 2000 以前では期待通りに動作していた，背景の透明または半透明用のコンポーネント，あるいはネット上のサンプルコードの多くは，Windows XP 以降では期待通りに動作しない場合があります．
Delphi XE2 で導入された FireMonkey であれば，コントロールの透明度の設定が可能です．
VCL で開発する場合，コントロールの半透明化や透明化の実装が，本当に必要なのかを再検討する必要があるかも知れません．





01_作成したコンポーネントの基本テスト


作成したコンポーネントの基本的なテストです．基本的と言っても，画像を表示するだけですから，画像の設定方法だけです．
背景に表示する画像は，フォーム生成時に設定しています．


図1
設計時画面
  • コンポーネントを配置
  • その他のテスト用のボタンを配置
図2
EXE の起動直後の画面
図3
フォームのサイズを大きくしたところ
  • 背景の画像は，元のサイズなので，そのサイズを超えた部分は，元の TRichEdit の背景色となる
図4
背景画像を StretchDraw で描画した場合
図5
別の画像を背景の画像にする

リスト1
リッチエディットコントロールの背景を画像にするコンポーネントのテスト		 
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, plBackPictRichEdit, ComCtrls, JPEG;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    plRichEdit: TplBackPictRichEdit;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//  フォームに配置したTplBackPictRichEditの設定
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  i    : Integer;
  Pict : TWICImage;
begin
  if Assigned(plRichEdit) then begin
    plRichEdit.Font.Size := 15;

    //テスト用のテキストをセット
    plRichEdit.Lines.Clear;
    plRichEdit.Lines.BeginUpdate;
    for i := 0 to 19 do begin
      plRichEdit.Lines.Add('TplBackPictRichEdit');
    end;
    plRichEdit.Lines.EndUpdate;

    //背景画像用の画像を読み込む
    Pict := TWICImage.Create;
    try
      Pict.LoadFromFile('Cat.jpg');
      plRichEdit.BackPicture := TPicture(Pict);
    finally
      FreeAndNil(Pict);
    end;
  end;
end;

//=============================================================================
//  画像をストレッチ描画して，クライアント領域全体に表示
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  if Assigned(plRichEdit) then begin
    plRichEdit.BackPictStretch := True;
  end;
end;

//=============================================================================
//  背景の画像を元のサイズで表示する
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  if Assigned(plRichEdit) then begin
    plRichEdit.BackPictStretch := False;
  end;
end;

//=============================================================================
//  背景に画像を表示しない
//=============================================================================
procedure TForm1.Button3Click(Sender: TObject);
begin
  if Assigned(plRichEdit) then begin
    plRichEdit.BackPicture := nil;
  end;
end;

//=============================================================================
//  別の画像を背景にする
//=============================================================================
procedure TForm1.Button4Click(Sender: TObject);
var
  Pict : TPicture;
begin
  if Assigned(plRichEdit) then begin
    Pict := TPicture.Create;
    try
      Pict.LoadFromFile('e316.bmp');
      plRichEdit.BackPicture := Pict;
    finally
      FreeAndNil(Pict);
    end;
  end;
end;

end.



02_コンポーネントを実行時に生成する場合


コンポーネントを実行時に生成して利用する場合の参考コードです．
テストの内容は，前項のサンプルと全く同じです．


図6
設計時画面
  • テスト用のボタンを配置
図7
EXE の起動直後の画面

リスト2
リッチエディットコントロールの背景を画像にするコンポーネントのテスト
コンポーネントを実行時に生成する場合		 
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, plBackPictRichEdit, JPEG;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private 宣言 }
    plRichEdit: TplBackPictRichEdit;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//  TplBackPictRichEditを生成して，背景に表示する画像を読み込み
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  Pict : TWICImage;
  i    : Integer;
begin
  //TplBackPictRichEditを生成
  plRichEdit := TplBackPictRichEdit.Create(Self);
  plRichEdit.Parent := Self;

  plRichEdit.Left    := 0;
  plRichEdit.Top     := Button1.Top + Button1.Height + 5;
  plRichEdit.Width   := Self.ClientWidth;
  plRichEdit.Height  := Self.ClientHeight - plRichEdit.Top;
  plRichEdit.Anchors := [akLeft, akTop, akRight, akBottom];

  plRichEdit.Font.Size := 14;
  plRichEdit.ScrollBars := ssVertical;

  //テスト用にテキストをセット
  plRichEdit.Lines.BeginUpdate;
  for i := 0 to 19 do
  begin
    plRichEdit.Lines.Add('TplBackPictRichEdit');
  end;
  plRichEdit.Lines.EndUpdate;

  //背景に描画する画像を指定
  plRichEdit.BackPicture := nil;
  plRichEdit.Update;
  Pict := TWICImage.Create;
  try
    Pict.LoadFromFile('Cat.jpg');
    plRichEdit.BackPicture := TPicture(Pict);
  finally
    FreeAndNil(Pict);
  end;
end;

//=============================================================================
//  画像をストレット描画する
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  if Assigned(plRichEdit) then begin
    plRichEdit.BackPictStretch := True;
  end;
end;

//=============================================================================
//  背景の画像を元のサイズで表示する
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  if Assigned(plRichEdit) then begin
    plRichEdit.BackPictStretch := False;
  end;
end;

//=============================================================================
//  背景に画像を表示しない
//=============================================================================
procedure TForm1.Button3Click(Sender: TObject);
begin
  if Assigned(plRichEdit) then begin
    plRichEdit.BackPicture := nil;
  end;
end;

//=============================================================================
//  別の画像を背景にする
//=============================================================================
procedure TForm1.Button4Click(Sender: TObject);
var
  Pict : TPicture;
begin
  if Assigned(plRichEdit) then begin
    Pict := TPicture.Create;
    try
      Pict.LoadFromFile('e316.bmp');
      plRichEdit.BackPicture := Pict;
    finally
      FreeAndNil(Pict);
    end;
  end;
end;

end.



03_TRichEdit の背景をパターンブラシ状にする


このコンポーネントは，背景の画像を WM_ERASEBKGND メッセージ内で描画しています．
このメッセージ内でブラシを指定して描画すると，非常にチラつきが激しくなります．そこで，本サンプルでは，1 つの画像から，パターンブラシのビットマップを作成し，それを背景に描画します．



図8
設計時画面
図9
EXE の起動直後の画面

リスト3
TRichEdit の背景をパターンブラシ状にする		 
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, plBackPictRichEdit, ComCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    plRichEdit: TplBackPictRichEdit;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
    procedure CreateLike_PatternBrush;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  i : Integer;
begin
  if Assigned(plRichEdit) then begin
    plRichEdit.Font.Size := 15;

    //テスト用にテキストをセット
    plRichEdit.Lines.Clear;
    plRichEdit.Lines.BeginUpdate;
    for i := 0 to 19 do begin
      plRichEdit.Lines.Add('TplBackPictRichEdit');
    end;
    plRichEdit.Lines.EndUpdate;

    //パターンブラシもどきを作成
    CreateLike_PatternBrush;
  end;
end;

//=============================================================================
//  背景に画像を表示しない
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  if Assigned(plRichEdit) then begin
    plRichEdit.BackPicture := nil;
  end;
end;

//=============================================================================
//  背景に画像を表示する
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  if Assigned(plRichEdit) then begin
    CreateLike_PatternBrush;
  end;
end;

//-----------------------------------------------------------------------------
//  パターンブラシもどきの画像を作成
//-----------------------------------------------------------------------------
procedure TForm1.CreateLike_PatternBrush;
var
  LBitmap : TBitmap;
  TempBmp : TBitmap;
  Pict    : TWICImage;
begin
  if Assigned(plRichEdit) then begin
    LBitmap := TBitmap.Create;
    TempBmp := TBitmap.Create;
    Pict    := TWICImage.Create;
    try
      Pict.LoadFromFile('e316.bmp');
      TempBmp.Assign(Pict);

      LBitmap.SetSize(Screen.Width, Screen.Height);
      LBitmap.Canvas.Brush.Style  := bsClear;
      LBitmap.Canvas.Brush.Bitmap := TempBmp;
      LBitmap.Canvas.Pen.Color    := clWhite;
      LBitmap.Canvas.Rectangle(0, 0, LBitmap.Width, LBitmap.Height);
      plRichEdit.BackPicture := TPicture(LBitmap);
    finally
      FreeAndNil(TempBmp);
      FreeAndNil(LBitmap);
      FreeAndNil(Pict);
    end;
  end;
end;

end.



04_TRichEdit の背景をハッチブラシ状にする


このコンポーネントは，背景の画像を WM_ERASEBKGND メッセージ内で描画しています．
このメッセージ内でブラシを指定して描画すると，非常にチラつきが激しくなります．そこで，本サンプルでは，1 つの画像から，ハッチブラシのビットマップを作成し，それを背景に描画します．


図10
設計時画面
図11
EXE の起動直後の画面

リスト4
TRichEdit の背景をハッチブラシ状にする		 
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, plBackPictRichEdit, ComCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    plRichEdit: TplBackPictRichEdit;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
    procedure CreateLike_HatchBrush;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  i : Integer;
begin
  if Assigned(plRichEdit) then begin
    plRichEdit.Font.Size := 15;

    //テスト用にテキストをセット
    plRichEdit.Lines.Clear;
    plRichEdit.Lines.BeginUpdate;
    for i := 0 to 19 do begin
      plRichEdit.Lines.Add('TplBackPictRichEdit');
    end;
    plRichEdit.Lines.EndUpdate;

    //ハッチブラシもどきを作成
    CreateLike_HatchBrush;
  end;
end;

//=============================================================================
//  背景に画像を表示しない
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  if Assigned(plRichEdit) then begin
    plRichEdit.BackPicture := nil;
  end;
end;

//=============================================================================
//  背景に画像を表示する
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  if Assigned(plRichEdit) then begin
    CreateLike_HatchBrush;
  end;
end;

//-----------------------------------------------------------------------------
//  ハッチブラシもどきの画像を作成
//-----------------------------------------------------------------------------
procedure TForm1.CreateLike_HatchBrush;
var
  LBitmap : TBitmap;
begin
  if Assigned(plRichEdit) then begin
    LBitmap := TBitmap.Create;
    try
      LBitmap.SetSize(Screen.Width, Screen.Height);
      LBitmap.Canvas.Brush.Style  := bsCross;
      LBitmap.Canvas.Brush.Color  := $00FFE7B5;
      LBitmap.Canvas.Pen.Color    := clWhite;
      LBitmap.Canvas.Rectangle(0, 0, LBitmap.Width, LBitmap.Height);
      plRichEdit.BackPicture := TPicture(LBitmap);
    finally
      FreeAndNil(LBitmap);
    end;
  end;
end;

end.



05_背景に画像を表示できる TRichEdit コンポーネント


本ページのサンプルで使用したコンポーネントのソースコードです．
透明部分を持つ JPEG, PNG, GIF 画像等は．透明部分は Color プロパティの値で塗り潰すようになっています．
このコンポーネントは，自身の DoubleBuffered プロパティを True にすると，テキストが正常に表示できなくなります．



凡例 ■ published
□ public
▲ ReadOnly

□ BackPicture TPicture 背景に描画する画像のオブジェクト
□ BackPictStretch Boolean 元のサイズで描画するのか，ストレッチ描画するかの指定
デフォルトは False で，元のサイズで描画する



リスト5
背景を画像にできる TRichEdit コンポーネント		 
unit plBackPictRichEdit;

interface

uses
  Windows, Messages, SysUtils, Classes, Controls, StdCtrls, ComCtrls,
  Graphics, forms;

type
  TplBackPictRichEdit = class (TRichEdit)
  private
    procedure SetBackPicture(const Value: TPicture);
    procedure SetBackPictStretch(const Value: Boolean);
  protected
    FCanvas          : TControlCanvas;
    FBitmap          : TBitmap;
    FBackPicture     : TPicture;
    FBackPictStretch : Boolean;
    FBackPictFlag    : Boolean;
    procedure CreateWnd; override;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property BackPicture     : TPicture read FBackPicture     write SetBackPicture;
    property BackPictStretch : Boolean  read FBackPictStretch write SetBackPictStretch;
  published
  end;

procedure Register;

implementation

{ TplBackPictRichEdit }

//-----------------------------------------------------------------------------
//  コンポーネントのコンストラクタ
//  背景に画像を描画する際に使用するTCanvasを生成
//  その画像用のTPictureオブジェクトを生成
//-----------------------------------------------------------------------------
constructor TplBackPictRichEdit.Create(AOwner: TComponent);
begin
  inherited;
  FCanvas := TControlCanvas.Create;
  FBackPicture := TPicture.Create;
  FBackPictStretch := False;
  FBackPictFlag    := False;

  FBitmap := TBitmap.Create;
  FBitmap.Transparent := False;
end;

//-----------------------------------------------------------------------------
//  コンポーネントのデストラクタ
//-----------------------------------------------------------------------------
destructor TplBackPictRichEdit.Destroy;
begin
  FBitmap.Free;
  FBackPicture.Free;
  FCanvas.Free;
  inherited;
end;

//-----------------------------------------------------------------------------
//  CreateWnd処理
//  CreateWndはウィンドウが生成される時に実行されるメソッド
//-----------------------------------------------------------------------------
procedure TplBackPictRichEdit.CreateWnd;
var
  ExtStyle : Cardinal;
begin
  inherited;

  if not (csDesigning in ComponentState) then begin
    ExtStyle := GetWindowLong(Handle, GWL_EXSTYLE);
    if FBackPicture.Graphic = nil then begin
      SetWindowLong(Handle, GWL_EXSTYLE, ExtStyle and not WS_EX_TRANSPARENT);
    end else begin
      SetWindowLong(Handle, GWL_EXSTYLE, ExtStyle or WS_EX_TRANSPARENT);
    end;
  end;
end;

//-----------------------------------------------------------------------------
//  BackPicture(TPicture)プロパティの設定用メソッド
//-----------------------------------------------------------------------------
procedure TplBackPictRichEdit.SetBackPicture(const Value: TPicture);
begin
  FBackPicture.Assign(Value);
  if not (csDesigning in ComponentState) then begin
    FBitmap.Assign(nil);
    if FBackPictStretch then begin
      FBitmap.SetSize(FBackPicture.Width, FBackPicture.Height);
    end else begin
      FBitmap.SetSize(Screen.Width, Screen.Height);
    end;
    FBitmap.Canvas.Brush.Color := Color;
    FBitmap.Canvas.FillRect(FBitmap.Canvas.ClipRect);
    FBitmap.Canvas.Draw(0, 0, FBackPicture.Graphic);

    FBackPictFlag := True;
    RecreateWnd;
  end;
end;

//-----------------------------------------------------------------------------
//  BackPictStretchプロパティの設定用メソッド
//  ストレッチで描画するか，元のサイズで描画するかの指定
//-----------------------------------------------------------------------------
procedure TplBackPictRichEdit.SetBackPictStretch(const Value: Boolean);
begin
  FBackPictStretch := Value;
  if not (csDesigning in ComponentState) then begin
    FBitmap.Assign(nil);
    if FBackPictStretch then begin
      FBitmap.SetSize(FBackPicture.Width, FBackPicture.Height);
    end else begin
      FBitmap.SetSize(Screen.Width, Screen.Height);
    end;
    FBitmap.Canvas.Brush.Color := Color;
    FBitmap.Canvas.FillRect(FBitmap.Canvas.ClipRect);
    FBitmap.Canvas.Draw(0, 0, FBackPicture.Graphic);

    FBackPictFlag := True;
    RecreateWnd;
  end;
end;

//-----------------------------------------------------------------------------
//  WM_ERASEBKGNDメッセージ処理
//  リージョンの更新が必要な領域を更新し，画像を描画する
//  この処理のため，DoubleBufferedをTrueにするとテキストが正常に表示されない
//
//  背景を塗り潰してから画像を描画すれば透明部分がなくなる
//  すると，透明部分がある画像でも，テキストの編集でテキストの描画が乱れない
//  ただし，スクロールの際に画像がチラつく場合がある
//  そこで，あらかじめ画像を描画したビットマップを表示するようにしている
//-----------------------------------------------------------------------------
procedure TplBackPictRichEdit.WMEraseBkgnd(var Message: TWMEraseBkgnd);
var
  LRect      : TRect;
  Rgn        : HRGN;
  ToBeErased : Boolean;
  Flags : Cardinal;
begin
  if (FBackPicture.Graphic = nil) and (csDesigning in ComponentState) then begin
    inherited;
    exit;
  end;

  FCanvas.Handle := Message.DC;
  Message.Result := 1;

  //更新が必要なリージョンの最小矩形領域の取得
  ToBeErased := False;
  if not GetUpdateRect(Handle, LRect, ToBeErased) then begin
    LRect := Rect(0, 0, ClientWidth, ClientHeight);
  end;
  Rgn := CreateRectRgn(LRect.Left, LRect.Top, LRect.Right, LRect.Bottom);
  SelectClipRgn(FCanvas.Handle, Rgn);

  if FBackPictStretch then begin
    FCanvas.StretchDraw(ClientRect, FBitmap);
  end else begin
    FCanvas.Draw(0, 0, FBitmap);
  end;

  //RDW_FRAMEを指定して非クライアント領域を再描画
  //画像が変わった時に，1回たけ実行する
  if (FBackPictFlag) and Visible then begin
    FBackPictFlag := False;
    Flags := RDW_ERASE or RDW_INVALIDATE or RDW_FRAME;
    RedrawWindow(Handle, nil, 0, Flags);
  end;
end;

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

end.