Delphi Tips & Tricks

//与えられたビットマップからリージョンを作成する関数
function CreateRgnFromBitmap(SrcBM :TBitmap; TransColor :TColor):HRGN;
var
  BM         :TBitmap;
  ms         :TMemoryStream;
  R          :TRect;
  x,y,StartX :integer;
  pScan      :PWordArray;
  RgnHeader  :TRgnDataHeader;
begin
  Result :=HRGN(0);
  //ストリーム内にリージョン情報を格納していきます
  ms :=TMemoryStream.Create;
  try
   with RgnHeader do begin
       dwSize   :=Sizeof(TRgnDataHeader);
       iType    :=RDH_RECTANGLES;
       nCount   :=0;
       nRgnSize :=0;
       rcBound  :=Rect(0, 0, SrcBM.Width, SrcBM.Height);
    end;
    //まずリージョンデータヘッダーを書き込み
    ms.WriteBuffer(RgnHeader,Sizeof(TRgnDataHeader));

    BM :=TBitmap.Create;
    try
      BM.Assign(SrcBM);
      if BM.Empty then Exit;
      //モノクロ化します。非透過色が黒
      BM.Mask(TransColor);
      //ScanLineしやすいようにピクセル形式を直します
      BM.PixelFormat :=pf15bit;

      //ここからScanLineによる解析とTRectデータの作成　･･･�@
      for y :=0 to BM.Height-1 do begin
        pScan :=BM.ScanLine[y];
        StartX :=-1;
        for x :=0 to BM.Width-1 do begin
          //非透過色(黒)なら
          if pScan[x] =0 then begin
           if StartX =-1 then
              StartX :=x;
          end
          //透過色なら
          else begin
         if StartX <> -1 then
          begin
              R.Left   :=StartX;
              R.Top    :=y;
              R.Right  :=x;
              R.Bottom :=y+1;
              //Rectをストリームに書き込む
              ms.WriteBuffer(R, Sizeof(TRect));
              Inc(RgnHeader.nCount);
              StartX :=-1;
             end;
          end;
        end; //for x...
        //ビットマップの右端スキャンして StartX <>-1 のままなら
        //(ビットマップの右端が非透過色なら)
        if StartX <> -1 then
        begin
          R.Left   :=StartX;
          R.Top    :=y;
          R.Right  :=BM.Width;
          R.Bottom :=y +1;

          ms.WriteBuffer(R,Sizeof(TRect));
          Inc(RgnHeader.nCount);
        end;
       end; //for y...
       //ストリーム内ヘッダーの矩形数のパラメータを加算
       PRgnDataHeader(ms.Memory).nCount :=RgnHeader.nCount;
       //ストリーム内のデータからリージョンを作成
       Result :=ExtCreateRegion(nil, ms.Size,
                                PRgnData(ms.Memory)^);
     finally
      BM.Free;
     end;
  finally
   ms.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Rgn :HRGN;
  R   :TRect;
  BM  :TBitmap;
begin
  if OpenDialog1.Execute then begin
  if LowerCase(ExtractFileExt(OpenDialog1.FileName)) ='.bmp' then
    BM :=TBitmap.Create;
    try
    BM.LoadFromFile(OpenDialog1.FileName);
     if not BM.Empty  then
     begin
       Rgn :=CreateRgnFromBitmap(BM, BM.TransparentColor);
       try
      if Rgn <> 0 then begin
         //ビットマップをTimageに読み込みます
         with image1 do begin
          AutoSize :=true;
          Picture.LoadFromFile(OpenDialog1.FileName);
          Left :=0; Top  :=0;
         end;
         //リージョンをクライアント領域に平行移動します ･･･�A
         //Form のBorderStyleが bsNoneなら不要です
         R.TopLeft := ClientToScreen(Point(-Left, -Top));
         OffsetRgn(Rgn, R.Left, R.Top);
         //リージョンをウィンドウに適用します
         SetWindowRgn(Handle, Rgn, True);
       end;
       finally
        DeleteObject(Rgn); //リージョンを解放
       end;
     end;
    finally
     BM.Free;
    end;
   end;
  end;
end;