【タイトル】ドロップしたビットマップに合わせてフォームを変形します


　エクスプローラからビットマップファイルをドロップすると、ビット
マップ透過色部分を抜いた形にフォームを変形して、ビットマップを表示
します。

　下記のソースコードは Delphi4 用です。SetRgnFromBitmap 関数の最後
の引数（Repaint: Boolean）に設定してある‘デフォルト値’の設定を削
除して関連部分を調整すれば Delphi3 等でも使えるはずです。

　ビットマップからリージョンを作成する部分については、当会議室
（Sample蔵）の #195（市丸 剛氏）と #330（YSS氏）のコードを参考に
させていただいています。両氏に感謝いたします。


【サンプルの実行例】
　メニューの [ファイル(F)][アプリケーションの新規作成(T)] で雛形を
作成して、メインフォームに TImage、TPopupMenu を１個ずつ置きます。

　Image1 にデフォルトのビットマップ（左下隅が透過色）をロード（し
なくても大丈夫ですが）します。

　PopupMenu1 にメニューデザイナーで [終了(&eXit)] の項目を追加して
その OnClick イベントハンドラ Form1.eXit1Click）を作成します。

　オブジェクトインスペクタで下記のプロパティの設定をします。
  Image1.Visible = FALSE
　Form1.PopupMenu = PopupMenu1

　後は、下記のサンプルコードをコピーして実行（[F9]）します。

　実行中にビットマップをドロップすると、左下を透過色にしてフォー
ムが変形して、ビットマップを表示します。


// ここから Unit1.pas の丸写しです。
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, ShellApi, Menus;

type
  TForm1 = class(TForm)
    Image1: TImage;
    PopupMenu1: TPopupMenu;
    eXit1: TMenuItem;
    procedure eXit1Click(Sender: TObject);
  private
    FPoint: TPoint;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd);
      message WM_ERASEBKGND;
    procedure WMDropFiles(var Message: TWMDropFiles);
      message WM_DROPFILES;
  protected
    procedure CreateWnd; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  public
    procedure UpdateRegionByBitmap;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

// ビットマップからリージョンを作成します
function CreateRgnFromBitmap(Src: TBitmap;
   TransparentColor: TColor): HRGN;
var
  Stream: TMemoryStream;
var
  Bitmap: TBitmap;
  pLine: PWORD;
  x, y, StartPos: Integer;
  R: TRect;
begin
  Result := HRGN(0);
  Bitmap := TBitmap.Create;
  try
    // 元のビットマップから複製を作ってマスク化します
    Bitmap.Assign(Src);
    if not Bitmap.Empty then
    begin
      Stream := TMemoryStream.Create;
      try
        Stream.SetSize(sizeof(TRGNDATAHEADER));
        with PRgnDataHeader(Stream.Memory)^ do
        begin
          dwSize := sizeof(TRGNDATAHEADER);
          iType := RDH_RECTANGLES;
          nCount := 0;
          nRgnSize := 0;
          rcBound := RECT(0, 0, Bitmap.Width, Bitmap.Height);
        end;
        Stream.Position := sizeof(TRGNDATAHEADER);

        // マスク（モノクロ）にします
        Bitmap.Mask(TransparentColor);

        // ScanLine からデータが取りやすいように 2bytes/pixel にします
        Bitmap.PixelFormat := pf15bit;

        for y := 0 to Bitmap.Height - 1 do
        begin
          pLine := Bitmap.ScanLine[y];
          StartPos := -1;
          for x := 0 to Bitmap.Width - 1 do
          begin
            if(StartPos < 0)and(pLine^ = 0)then
              StartPos := x;
            if(StartPos >= 0)then
            begin
              if(pLine^ <> 0)then
              begin
                R.Left := StartPos;
                R.Right := x;
                R.Top := y;
                R.Bottom := R.Top + 1;

                Stream.Write(R, sizeof(TRect));
                Inc(PRgnDataHeader(Stream.Memory)^.nCount);

                StartPos := -1;
              end
              else if x = (Bitmap.Width - 1)then
              begin
                R.Left := StartPos;
                R.Right := x + 1;
                R.Top := y;
                R.Bottom := R.Top + 1;

                // RECT を書き込むたびにメモリストリームのリサイズが
                // 行われるので、その分、非効率的ですが Delphi4 では
                // 実用スピードです（たぶん Delphi3 でも大丈夫）
                Stream.Write(R, sizeof(TRect));
                Inc(PRgnDataHeader(Stream.Memory)^.nCount);

                StartPos := -1;
              end;
            end;
            Inc(pLine);
          end;
        end; // for y := ...
        Result := ExtCreateRegion(nil, Stream.Size, 
                                  PRgnData(Stream.Memory)^);
        if Result = 0 then
          Result := CreateRectRgn(0, 0, Bitmap.Width, Bitmap.Height);
      finally
        Stream.Free;
      end;
    end;
  finally
    Bitmap.Free;
  end;
end;

// フォームをビットマップに合わせて変形します
function SetRgnFromBitmap(Form: TForm; Bitmap: TBitmap;
  Repaint: Boolean = TRUE): Boolean;
var
  hrgnNew: HRGN;
  R: TRect;
begin
  Result := FALSE;
  // ビットマップからリージョンを作って
  hrgnNew := CreateRgnFromBitmap(Bitmap, Bitmap.TransparentColor);
  if Integer(hrgnNew) = 0 then Exit;
  if GetRgnBox(hrgnNew, R) <> NULLREGION then
  begin
    // リージョンをクライアント領域にずらします
    R.TopLeft := Form.ClientToScreen(Point(-Form.Left, -Form.Top));
    OffsetRgn(hrgnNew, R.Left, R.Top);

    // リージョンをフォームに適用します
    Result := SetWindowRgn(Form.Handle, hrgnNew, Repaint);
  end
  else
  begin
    DeleteObject(hrgnNew);
  end;
end;

{ TForm1 }

// エクスプローラからのドロップ受け入れの設定と、デフォルトのビット
// マップが Image1 にある場合にフォームを変形します
procedure TForm1.CreateWnd;
begin
  inherited CreateWnd;
  DragAcceptFiles(Handle, TRUE);
  UpdateRegionByBitmap;
end;

// フォームのキャプションが見えなくなるので、別なクリック＆移動手段
// を提供するため（だけ）です
procedure TForm1.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited MouseDown(Button, Shift, X, Y);
  FPoint := Point(X, Y);
end;

// フォームのキャプションが見えなくなるので、別なクリック＆移動手段
// を提供するため（だけ）です
procedure TForm1.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  inherited MouseMove(Shift, X, Y);
  if GetKeyState(VK_LBUTTON) < 0 then
    SetBounds(Left + X - FPoint.x, Top + Y - FPoint.y, Width, Height);
end;

procedure TForm1.UpdateRegionByBitmap;
begin
  with Image1.Picture do
  if Bitmap.Empty then
    SetWindowRgn(Handle, HRGN(0), TRUE)
  else
  begin
    if not SetRgnFromBitmap(Self, Bitmap) then
      SetWindowRgn(Handle, HRGN(0), TRUE);
    ClientWidth := Bitmap.Width;
    ClientHeight:= Bitmap.Height;
    Repaint;
  end;
end;

// エクスプローラからのドロップを受けるメッセージハンドラです
procedure TForm1.WMDropFiles(var Message: TWMDropFiles);
var
  Count: Integer;
  pFileName: PChar;
begin
  try
    Count := DragQueryFile(Message.Drop, $ffffffff, nil, 0);
    if Count > 1 then
      ShowMessage('ドロップするファイルは１個にしてください。')
    else
    begin
      Count := DragQueryFile(Message.Drop, 0, nil, 0) + 1;
      pFileName := AllocMem(Count);
      try
        DragQueryFile(Message.Drop, 0, pFileName, Count);
        Image1.Picture.Bitmap.LoadFromFile(pFileName);
        UpdateRegionByBitmap;
      finally
        FreeMem(pFileName);
      end;
    end;
  finally
    DragFinish(Message.Drop);
  end;
end;

// ビットマップを表示する部分です
// Paint メソッドをオーバーライドしても良いのですが、チラツキを
// 少し減らすための措置です
procedure TForm1.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  with Image1.Picture do
  if Bitmap.Empty then
    inherited
  else
    // クライアント領域の大きさをビットマップに合わせているので
    // これで充分のはずです。
    // 極端に小さいビットマップでは隙間ができる場合も有り得ます。
    BitBlt(Message.DC, 0, 0, Bitmap.Width, Bitmap.Height,
      Bitmap.Canvas.Handle, 0, 0, SRCCOPY);
end;

// キャプションが見えなくなるので、マウスによる終了手段をポップアップ
// メニューで作っています。[Alt]+[F4] や [Alt]+[Space] で良ければこの
// 部分は要りません。
procedure TForm1.eXit1Click(Sender: TObject);
begin
  Close;
end;

end.
// ここまでが Unit1.pas です。

                1999/01/31、河邦 正（GCC02240@nifty.ne.jp）

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

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