// 背景に絵を敷き詰める例(for Delphi)
 
{
    スクロールボックスの背景にデスクトップの壁紙のように絵をならべて
  描画します。

    TScrollBoxBkBmp というコンポーネントを派生させる場合を想定したコ
  ードになっています。クラスメンバ（データと手続き）をコピーすれば、
  そのままフォーム（TForm）に流用できます。
}
unit ScrollBoxBkBmp;

interface

uses
  Windows, Messages, Classes, Graphics, Forms;

type
//  TForm1 = class(TForm)
  TScrollBoxBkBmp = class(TScrollBox)
  private
    FBitmap: TBitmap;
    procedure BitmapChanged(Sender: TObject);
    procedure SetBitmap(value: TBitmap);
    procedure WMEraseBkgnd(var Message: TMessage); message WM_ERASEBKGND;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Bitmap: TBitmap read FBitmap write SetBitmap;
  end;

procedure Register;

implementation

constructor TScrollBoxBkBmp.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FBitmap := TBitmap.Create;
  FBitmap.OnChange := BitmapChanged;
end;

destructor TScrollBoxBkBmp.Destroy;
begin
  FBitmap.Free;
  inherited Destroy;
end;

procedure TScrollBoxBkBmp.BitmapChanged(Sender: TObject);
begin
  Invalidate;
end;

procedure TScrollBoxBkBmp.SetBitmap(value: TBitmap);
begin
  FBitmap.Assign(value);
end;

procedure TScrollBoxBkBmp.WMEraseBkgnd(var Message: TMessage);
var
  R: TRect;
  x, y, w, h, OfsX, OfsY: Integer;
  hpalOld: HPALETTE;
  hdcSrc: HDC;
begin
  if FBitmap.Empty then
    inherited
  else
  begin
    Message.Result := 1;
    w := FBitmap.Width;
    h := FBitmap.Height;
    GetClipBox(Message.wParam, R);

    OfsX := HorzScrollBar.ScrollPos;
    OfsY := VertScrollBar.ScrollPos;
    OffsetRect(R, OfsX, OfsY);

    R.Left := R.Left div w;
    R.Right := (R.Right - 1) div w;
    R.Top := R.Top div h;
    R.Bottom := (R.Bottom - 1) div h;

    hdcSrc := FBitmap.Canvas.Handle;
    if(GetDeviceCaps(Message.wParam, BITSPIXEL) <= 8)and
      (FBitmap.Palette <> 0)then
    begin
      hpalOld := SelectPalette(Message.wParam, FBitmap.Palette, FALSE);
      try
        RealizePalette(Message.wParam);
        for y := R.Top to R.Bottom do
        for x := R.Left to R.Right do
          BitBlt(Message.wParam, w * x - OfsX, h * y - OfsY, w, h,
                 hdcSrc, 0, 0, SRCCOPY);
      finally
        SelectPalette(Message.wParam, hpalOld, FALSE);
      end;
    end
    else
    begin
      for y := R.Top to R.Bottom do
      for x := R.Left to R.Right do
        BitBlt(Message.wParam, w * x - OfsX, h * y - OfsY, w, h,
               hdcSrc, 0, 0, SRCCOPY);
    end;
    Message.Result := 1;
  end;
end;

procedure Register;
begin
  RegisterComponents('Samples', [TScrollBoxBkBmp]);
end;

end.

Original document by 河邦 正         氏 ID:(GCC02240)

ここにあるドキュメントは NIFTY SERVEの Delphi Users' Forum の16番会議室「玉石混淆みんなで作るSample蔵」に投稿されたサンプルです。これらのサンプルはボーランド株式会社がサポートする公式のものではありません。また、必ずしも動作が検証されているものではありません。これらのサンプルを使用したことに起因するいかなる損害も投稿者、およびフォーラムスタッフはその責めを負いません。使用者のリスクの範疇でご使用下さい。