// Muito bom para se usar como Skins...

unit

ProjetoX_Screen; interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls, DBCtrls; type

TFormScreen = class

(TForm) ImgFundo: TImage; procedure

FormCreate(Sender: TObject); public

{ Public declarations } MyRegion : HRGN; function

BitmapToRegion(hBmp: TBitmap; TransColor: TColor): HRGN; end

; var

FormScreen: TFormScreen; implementation

{$R *.DFM} {===========================molda o formato do formulrio no bitmap} function

TFormScreen.BitmapToRegion(hBmp: TBitmap; TransColor: TColor): HRGN; const

ALLOC_UNIT = 100; var

MemDC, DC: HDC; BitmapInfo: TBitmapInfo; hbm32, holdBmp, holdMemBmp: HBitmap; pbits32 : Pointer; bm32 : BITMAP; maxRects: DWORD; hData: HGLOBAL; pData: PRgnData; b, CR, CG, CB : Byte; p32: pByte; x, x0, y: integer; p: pLongInt; pr: PRect; h: HRGN; begin

Result := 0; if

hBmp <> nil

then

begin

{ Cria um Device Context onde ser armazenado o Bitmap } MemDC := CreateCompatibleDC(0); if

MemDC <> 0 then

begin

{ Cria um Bitmap de 32 bits sem compresso } with

BitmapInfo.bmiHeader do

begin

biSize := sizeof(TBitmapInfoHeader); biWidth := hBmp.Width; biHeight := hBmp.Height; biPlanes := 1; biBitCount := 32; biCompression := BI_RGB; biSizeImage := 0; biXPelsPerMeter := 0; biYPelsPerMeter := 0; biClrUsed := 0; biClrImportant := 0; end

; hbm32 := CreateDIBSection(MemDC, BitmapInfo, DIB_RGB_COLORS, pbits32,0, 0); if

hbm32 <> 0 then

begin

holdMemBmp := SelectObject(MemDC, hbm32); { Calcula quantos bytes por linha o bitmap de 32 bits ocupa. } GetObject(hbm32, SizeOf(bm32), @bm32); while

(bm32.bmWidthBytes mod

4) > 0 do

inc(bm32.bmWidthBytes); DC := CreateCompatibleDC(MemDC); { Copia o bitmap para o Device Context } holdBmp := SelectObject(DC, hBmp.Handle); BitBlt(MemDC, 0, 0, hBmp.Width, hBmp.Height, DC, 0, 0, SRCCOPY); { Para melhor performance, ser utilizada a funo ExtCreasteRegion para criar o HRGN. Esta funo recebe uma estrutura RGNDATA. Cada estrutura ter 100 retngulos por padro (ALLOC_UNIT) } maxRects := ALLOC_UNIT; hData := GlobalAlloc(GMEM_MOVEABLE, sizeof(TRgnDataHeader) + SizeOf(TRect) * maxRects); pData := GlobalLock(hData); pData^.rdh.dwSize := SizeOf(TRgnDataHeader); pData^.rdh.iType := RDH_RECTANGLES; pData^.rdh.nCount := 0; pData^.rdh.nRgnSize := 0; SetRect(pData^.rdh.rcBound, MaxInt, MaxInt, 0, 0); { Separa o pixel em suas cores fundamentais } CR := GetRValue(ColorToRGB(TransColor)); CG := GetGValue(ColorToRGB(TransColor)); CB := GetBValue(ColorToRGB(TransColor)); { Processa os pixels bitmap de baixo para cima, j que bitmaps so verticalmente invertidos. } p32 := bm32.bmBits; inc(PChar(p32), (bm32.bmHeight - 1) * bm32.bmWidthBytes); for

y := 0 to

hBmp.Height-1 do

begin

{ Processa os pixels do bitmap da esquerda para a direita } x := -1; while

x+1 < hBmp.Width do

begin

inc(x); { Procura por uma faixa contnua de pixels no transparentes } x0 := x; p := PLongInt(p32); inc(PChar(p), x * SizeOf(LongInt)); while

x < hBmp.Width do

begin

b := GetBValue(p^); if

(b = CR) then

begin

b := GetGValue(p^); if

(b = CG) then

begin

b := GetRValue(p^); if

(b = CB) then

break; end

; end

; inc(PChar(p), SizeOf(LongInt)); inc(x); end

; if

x > x0 then

begin

{ Adiciona o intervalo de pixels [(x0, y),(x, y+1)] como um novo retngulo na regio. } if

pData^.rdh.nCount >= maxRects then

begin

GlobalUnlock(hData); inc(maxRects, ALLOC_UNIT); hData := GlobalReAlloc(hData, SizeOf(TRgnDataHeader) + SizeOf(TRect) * maxRects, GMEM_MOVEABLE); pData := GlobalLock(hData); Assert(pData <> NIL

); end

; pr := @pData^.Buffer[pData^.rdh.nCount * SizeOf(TRect)]; SetRect(pr^, x0, y, x, y+1); if

x0 < pData^.rdh.rcBound.Left then

pData^.rdh.rcBound.Left := x0; if

y < pData^.rdh.rcBound.Top then

pData^.rdh.rcBound.Top := y; if

x > pData^.rdh.rcBound.Right then

pData^.rdh.rcBound.Left := x; if

y+1 > pData^.rdh.rcBound.Bottom then

pData^.rdh.rcBound.Bottom := y+1; inc(pData^.rdh.nCount); { No Windows98, a funo ExtCreateRegion() pode falhar se o nmero de retngulos for maior que 4000. Por este motivo, a regio deve ser criada por partes com menos de 4000 retngulos. Neste caso, foram padronizadas regies com 2000 retngulos. } if

pData^.rdh.nCount = 2000 then

begin

h := ExtCreateRegion(NIL

, SizeOf(TRgnDataHeader) + (SizeOf(TRect) * maxRects), pData^); Assert(h <> 0); { Combina a regio parcial, recm criada, com as anteriores } if

Result <> 0 then

begin

CombineRgn(Result, Result, h, RGN_OR); DeleteObject(h); end

else

Result := h; pData^.rdh.nCount := 0; SetRect(pData^.rdh.rcBound, MaxInt, MaxInt, 0, 0); end

; end

; end

; Dec(PChar(p32), bm32.bmWidthBytes); end

; { Cria a regio geral } h := ExtCreateRegion(NIL

, SizeOf(TRgnDataHeader) + (SizeOf(TRect) * maxRects), pData^); Assert(h <> 0); if

Result <> 0 then

begin

CombineRgn(Result, Result, h, RGN_OR); DeleteObject(h); end

else

Result := h; { Com a regio final completa, o bitmap de 32 bits pode ser removido da mem¾ria, com todos os outros ponteiros que foram criados.} GlobalFree(hData); SelectObject(DC, holdBmp); DeleteDC(DC); DeleteObject(SelectObject(MemDC, holdMemBmp)); end

; end

; DeleteDC(MemDC); end

; end

; procedure

TFormScreen.FormCreate(Sender: TObject); begin

{carregue uma imagem na TImage ImgFundo} {redesenha o formulario no formato do ImgFundo} MyRegion := BitmapToRegion(imgFundo.Picture.Bitmap,imgFundo.Canvas.Pixels[0,0]); SetWindowRgn(Handle,MyRegion,True

); end

; Para os outros formulrios basta declarar as

seguintes linhas na procedure

FormCreate procedure

TFormXXXXXX.FormCreate(Sender: TObject); begin

{carregue uma imagem na TImage ImgFundo} {redesenha o formulario no formato do ImgFundo} FormScreen.MyRegion := FormScreen.BitmapToRegion(imgFundo.Picture.Bitmap, imgFundo.Canvas.Pixels[0,0]); SetWindowRgn(Handle,FormScreen.MyRegion,True

); end

;

:

Copyright 2023 - All Rights Reserved - www.delphirus.com