Transparent-Function auch für Win-Versionen unter Win2000?

[turboPASCAL]

Transparent ja aber ohne Alphablending. Stichwort(e): [oh]CreateRegion, CreateRegionEx, CombineRgn[/oh]

Diese Procedur kann eine "Unförmige" Form aus einem Bitmap erstellen. Optim. auf NonVCL, ab Windowsversion 95

Delphi-Quellcode:

//  BitmapToRegion :
//
//  Author:  Jean-Edouard Lachand-Robert 
//           ([url]http://www.geocities.com/Paris/LeftBank/1160/resume.htm[/url]), June 1998.
//           Sergei Stolyarov cancel{a}gorodok.net [url]http://web.ict.nsc.ru/~cancel/delphi[/url]
//
//  hBmp              : Bitmap
//  dwWndWidth        : Rückgabewert des Bitmaps (Width) zB. setzen der Fensterbreite
//  dwWndHeight       : Rückgabewert des Bitmaps (Height) zB. setzen der Fensterhöhe
//  cTransparentColor : RGB-Wert der farbe die Transparent werden soll
//  cTolerance        : Toleranzwert  für die Transparente Farbe

const ALLOC_UNIT = 100;

function min(x,y : DWORD) : DWORD;
begin
  if x<y then result := x else result := y;
end;

function BitmapToRegion(hBmp : HBITMAP; var dwWndWidth: DWORD; var dwWndHeight: DWORD;
  cTransparentColor : COLORREF = 0; cTolerance : COLORREF = $101010) : HRGN;
var
  rgn, h : HRGN;
  hMemDC, hDC : THANDLE;
  bm, bm32 : BITMAP;
  RGB32BITSBITMAPINFO : BITMAPINFOHEADER;
  hbm32, holdBmp, holdBmp2 : HBITMAP;
  pbits32 : Pointer;
  maxRects, x, y, x0 : DWORD;
  hData : THANDLE;
  pData : PRgnData;
  lr, lg, lb, hr, hg, hb : BYTE;
  p32 : PBYTE;
  b : byte;
  p : PDWORD;
  pr : PRECT;
begin
  rgn := 0;
  if hBmp<>0 then begin
    hMemDC := CreateCompatibleDC(0);
    if (hMemDC <> 0) then begin
      GetObject(hBmp, sizeof(bm), @bm);

      RGB32BITSBITMAPINFO.biSize := sizeof(BITMAPINFOHEADER);
      RGB32BITSBITMAPINFO.biWidth := bm.bmWidth;
      RGB32BITSBITMAPINFO.biHeight := bm.bmHeight;
      dwWndWidth := bm.bmWidth;
      dwWndHeight := bm.bmHeight;

      RGB32BITSBITMAPINFO.biPlanes := 1;
      RGB32BITSBITMAPINFO.biBitCount := 32;
      RGB32BITSBITMAPINFO.biCompression := BI_RGB;
      RGB32BITSBITMAPINFO.biSizeImage := 0;
      RGB32BITSBITMAPINFO.biXPelsPerMeter := 0;
      RGB32BITSBITMAPINFO.biYPelsPerMeter := 0;
      RGB32BITSBITMAPINFO.biClrUsed := 0;
      RGB32BITSBITMAPINFO.biClrImportant := 0;

      hbm32 := CreateDIBSection(hMemDC, PBITMAPINFO(@RGB32BITSBITMAPINFO)^,
                 DIB_RGB_COLORS, pbits32, 0, 0);

      if (hbm32 <> 0) then begin
        holdBmp := SelectObject(hMemDC, hbm32);

        hDC := CreateCompatibleDC(hMemDC);
        if (hDC <> 0) then begin
          GetObject(hbm32, sizeof(bm32), @bm32);
          while (bm32.bmWidthBytes mod 4 <> 0) do
            inc(bm32.bmWidthBytes);

          holdBmp2 := SelectObject(hDC, hBmp);
          BitBlt(hMemDC, 0, 0, bm.bmWidth, bm.bmHeight, hDC, 0, 0, SRCCOPY);

          maxRects := ALLOC_UNIT;
          hData := GlobalAlloc(GMEM_MOVEABLE, sizeof(RGNDATAHEADER) + (sizeof(TRECT) * maxRects));
          pData := GlobalLock(hData);

          pData^.rdh.dwSize := sizeof(RGNDATAHEADER);
          pData^.rdh.iType := RDH_RECTANGLES;
          pData^.rdh.nCount := 0;
          pData^.rdh.nRgnSize := 0;
          SetRect(pData^.rdh.rcBound, MAXLONG, MAXLONG, 0, 0);

          lr := GetRValue(cTransparentColor);
          lg := GetGValue(cTransparentColor);
          lb := GetBValue(cTransparentColor);
          hr := min($ff, lr + GetRValue(cTolerance));
          hg := min($ff, lg + GetGValue(cTolerance));
          hb := min($ff, lb + GetBValue(cTolerance));

          p32 := PBYTE(DWORD(bm32.bmBits) + (DWORD(bm32.bmHeight) - 1) * DWORD(bm32.bmWidthBytes));
          for y := 0 to bm.bmHeight-1 do begin

            x := 0;
            while x<DWORD(bm.bmWidth) do begin
              x0 := x;
              p := PDWORD(p32);
              inc(p, x);
              while x < DWORD(bm.bmWidth) do begin
                p^ := RGB(GetBValue(p^), GetGValue(p^), GetRValue(p^));
                b := GetRValue(p^);
                if (b >= lr) and (b <= hr) then begin
                  b := GetGValue(p^);
                  if (b >= lg) and (b <= hg) then begin
                    b := GetBValue(p^);
                    if (b >= lb) and (b <= hb) then
                      break;
                  end;
                end;//if (b >= lr) and (b <= hr)
                inc(p);
                inc(x);
              end;

              if (x > x0) then begin
                if (pData^.rdh.nCount >= maxRects) then begin
                  GlobalUnlock(hData);
                  inc(maxRects, ALLOC_UNIT);
                  hData := GlobalReAlloc(hData, sizeof(RGNDATAHEADER) +
                             (sizeof(TRECT) * maxRects), GMEM_MOVEABLE);
                  pData := GlobalLock(hData);
                end;

                pr := PRECT(@pData^.Buffer);
                inc(pr, pData^.rdh.nCount);

                SetRect(pr^, x0, y, x, y+1);
                if x0 < DWORD(pData^.rdh.rcBound.left) then
                  pData^.rdh.rcBound.left := x0;
                if y < DWORD(pData^.rdh.rcBound.top) then
                  pData^.rdh.rcBound.top := y;
                if x > DWORD(pData^.rdh.rcBound.right) then
                  pData^.rdh.rcBound.right := x;
                if y+1 > DWORD(pData^.rdh.rcBound.bottom) then
                  pData^.rdh.rcBound.bottom := y+1;
                inc(pData^.rdh.nCount);

                if pData^.rdh.nCount = 200 then begin
                  h := ExtCreateRegion(nil, sizeof(RGNDATAHEADER) + sizeof(TRECT) * maxRects, PRGNDATA(pData)^);
                  if Rgn <> 0 then begin
                    CombineRgn(Rgn, Rgn, h, RGN_OR);
                    DeleteObject(h);
                  end//if Rgn <> 0
                  else
                    Rgn := h;
                   pData^.rdh.nCount := 0;
                   SetRect(pData^.rdh.rcBound, MAXLONG, MAXLONG, 0, 0);
                 end(*if pData^.rdh.nCount = 2000*) else

              end;//if (x > x0)
              inc(x);
            end;//while x<bm.bmWidth

            dec(p32, bm32.bmWidthBytes);
          end;//for y := 0 to bm.bmHeight-1

          h := ExtCreateRegion(nil, sizeof(RGNDATAHEADER) + (sizeof(TRECT) * maxRects), PRGNDATA(pData)^);
          if (Rgn <> 0) then begin
            CombineRgn(Rgn, Rgn, h, RGN_OR);
            DeleteObject(h);
          end
          else
            Rgn := h;

          SelectObject(hDC, holdBmp2);
          DeleteDC(hDC);
          GlobalFree(hData);
        end;

        DeleteObject(SelectObject(hMemDC, holdBmp));
      end;

      DeleteDC(hMemDC);
    end;

  end;
  result := rgn;
end;

Aufruf:

Delphi-Quellcode:

var
  rgn: HRGN;
  hBmp: hBitmap;  // in der VCL: TBitmap.Handle
  h, w: Integer;

Procedure ...
begin
  // NonVCL:
  hBmp := LoadImage(...
  rgn := BitmapToRegion(hBmp, w, h, RGB(255,0,255) {clFuchsia}, 0);

  // VCL:
  rgn := BitmapToRegion(ImageX.Picture.Bitmap.Handle, W, H, RGB(255,0,255) {clFuchsia}, 0);

  SetWindowRgn(hwnd,  Rgn, TRUE);
end;

DeleteObject(Rgn); nicht vergessen im Destroy aufzurufen...