|
|
|
|
|
|
|
|
Dicas
|
|
|
Visual Basic (Forms/MDI)
|
|
 |
Título da Dica: Criando um Form no Formato da Imagem Desejada
|
 |
|
|
|
Postada em 14/8/2000 por Webmaster
webmaster@vbweb.com.br
'No módulo:
Public Declare Function SetWindowRgn Lib "user32" _
(ByVal hwnd As Long, ByVal hRgn As Long, _
ByVal bRedraw As Boolean) As Long
Public Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Public Declare Function ReleaseCapture Lib _
"user32" () As Long
Public Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
lParam As Any) As Long
Private Declare Function CreateCompatibleDC Lib _
"gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib _
"gdi32" (ByVal hdc As Long, ByVal hObject _
As Long) As Long
Private Declare Function GetObject Lib "gdi32" _
Alias "GetObjectA" (ByVal hObject As _
Long, ByVal nCount As Long, lpObject As _
Any) As Long
Private Declare Function CreateRectRgn Lib _
"gdi32" (ByVal X1 As Long, ByVal Y1 As _
Long, ByVal X2 As Long, ByVal Y2 As Long) _
As Long
Private Declare Function CombineRgn Lib "gdi32" _
(ByVal hDestRgn As Long, ByVal hSrcRgn1 _
As Long, ByVal hSrcRgn2 As Long, ByVal _
nCombineMode As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" _
(ByVal hdc As Long) As Long
Private Declare Function GetPixel Lib "gdi32" _
(ByVal hdc As Long, ByVal X As Long, _
ByVal Y As Long) As Long
Public Const WM_NCLBUTTONDOWN As Long = &HA1
Public Const HTCAPTION As Long = 2
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Public Function GetBitmapRegion(cPicture As _
StdPicture, cTransparent As Long)
Dim hRgn As Long, tRgn As Long
Dim X As Integer, Y As Integer, X0 As Integer
Dim hdc As Long, BM As BITMAP
'Cria um novo DC, então procuramos a imagem
hdc = CreateCompatibleDC(0)
If hdc Then
'Coloca o novo DC na Imagem
SelectObject hdc, cPicture
'Pega as dimensões e cria uma nova região
'de retangulo
GetObject cPicture, Len(BM), BM
hRgn = CreateRectRgn(0, 0, BM.bmWidth, BM._
bmHeight)
'Inicia procurando a imagem de cima para
'baixo
For Y = 0 To BM.bmHeight
For X = 0 To BM.bmWidth
'Procura uma linha de píxeis não
'transparentes
While X <= BM.bmWidth And GetPixel(hdc, _
X, Y) <> cTransparent
X = X + 1
Wend
'Marca o Início da linha de píxeis não
'transparentes
X0 = X
'Procura uma linha com Píxeis
'transparentes
While X <= BM.bmWidth And GetPixel(hdc, _
X, Y) = cTransparent
X = X + 1
Wend
'Cria uma nova região que corresponda à
'linha dos píxeis transparentes e então
'remove ele da região principal
If X0 < X Then
tRgn = CreateRectRgn(X0, Y, X, Y + 1)
CombineRgn hRgn, hRgn, tRgn, 4
'Libera a memória usada para a nova
'região temporária
DeleteObject tRgn
End If
Next X
Next Y
'Volta ao endereço de memória da imagem pronta
GetBitmapRegion = hRgn
'Libera memória apagando a imagem
DeleteObject SelectObject(hdc, cPicture)
End If
'Libera memória apagando o DC criado
DeleteDC hdc
End Function
A função GetBitmapRegion pede dois parâmetros: a figura e uma cor a ser apagada. Se o fundo da sua figura for preto, você pode usar a constante vbBlack e apagar toda a cor preta da figura. Lembrando que se a cor estiver dentro da figura, ela será apagada também, deixando o form transparente naquele lugar.
'Coloque a imagem na propriedade Picture do Form
'e, no Form_Load:
Private Sub Form_Load()
Dim hRgn As Long
If hRgn Then DeleteObject hRgn
hRgn = GetBitmapRegion(Me.Picture, vbBlack)
SetWindowRgn Me.hwnd, hRgn, True
End Sub
|
|
|
|
|
