USUÁRIO:      SENHA:        SALVAR LOGIN ?    Adicione o VBWEB na sua lista de favoritos   Fale conosco 

 

  Dicas

  Visual Basic    (Forms/MDI)

Título da Dica:  Criando um Form no Formato da Imagem Desejada
Postada em 14/8/2000 por Webmaster      Clique aqui para enviar email para o autor  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
 


CyberWEB Network Ltda.    © Copyright 2000-2024   -   Todos os direitos reservados.
Powered by HostingZone - A melhor hospedagem para seu site
Topo da página