VB Tip: utilidade para Subclassing.

Olá.

Como prometido em alguns posts anteriores, achei uma utilidade para o subclassing nos formulários. Trata-se de conhecer comandos que levem a uma determinada ação.

Por exemplo: numa janela sem borda (BorderStyle=0) não há menu de contexto do sistema (aquele com opções da janela: ). E para fazer que o contexto do título funcione no nosso formulário customizado, devemos criar um menu para substituir o menu padrão do título. Para isso temos de saber o momento em que o usuário clica com o botão direito na janelinha do aplicativo na barra de tarefas. Daí vem o subclassing.

Escutando comandos para detectar chamada ao menu de contexto da janela

O projeto pronto (zipado) se encontra em https://skydrive.live.com/?cid=b278d5e7a71b5dca&sc=documents&nl=1&uc=1&id=B278D5E7A71B5DCA%21144 (pasta pessoal do Windows Live SkyDrive). Caso cair em alguma outra pasta, procure pela pasta Subclassing e pelo arquivo SubClassMenu.zip.
Dentro do arquivo zipado há o programa compilado, mas também há o código usado no subclassing criado, cujo código postarei abaixo por partes.

Iniciando o projeto

1º: Inicie um novo projeto Standard Exe.
2º: Vá em project > Add Module e adicione um módulo comum.
3º: No módulo, cole o seguinte código:
Public oldproc As Long Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Public Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Public Const WM_SYSCOMMAND = &H112 Public Const WM_CONTEXTMENU = &H7B Public Const SC_MOVE = &HF010& Public Const SC_SIZE = &HF000& 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 Public Type POINTAPI X As Long Y As Long End Type Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Public Const GWL_WNDPROC = (-4) Public Const WM_POPUPSYSTEMMENU = &H313 Public Function WProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long If Msg = WM_POPUPSYSTEMMENU Or Msg = WM_CONTEXTMENU Then Dim mc As New cMenu Dim h As Long h = mc.Create mc.Add h, 800, "--Menu--", 3 mc.Add h, 801, "", &H800 mc.Add h, 1, "Restaurar", IIf(Form1.WindowState <> 0, 0, 3) mc.Add h, 2, "Mover", IIf(Form1.WindowState <> 0, 3, 0) mc.Add h, 3, "Tamanho", IIf(Form1.WindowState <> 0, 3, 0) mc.Add h, 4, "Minimizar", IIf(Form1.WindowState <> vbMinimized, 0, 3) mc.Add h, 5, "Maximizar", IIf(Form1.WindowState <> vbMaximized, 0, 3) mc.Add h, 6, "", &H800& mc.Add h, 7, "Fechar" Dim pt As POINTAPI GetCursorPos pt Dim retval As Long retval = mc.Show(h, Form1.hwnd, pt.X, pt.Y) mc.Destroy h Set mc = Nothing Select Case retval Case 1 Form1.WindowState = vbNormal Case 2 SendMessage Form1.hwnd, WM_SYSCOMMAND, SC_MOVE, 0 Case 3 SendMessage Form1.hwnd, WM_SYSCOMMAND, SC_SIZE, 0 Case 4 Form1.WindowState = vbMinimized Case 5 Form1.WindowState = vbMaximized Case 7 Unload Form1 End Select WProc = 1 Else WProc = CallWindowProc(oldproc, hwnd, Msg, wParam, lParam) End If End Function
4º: Adicione uma classe, de nome cMenu.
5º: Na nova classe, cole o seguinte código:
Private Type POINTAPI X As Long Y As Long End Type Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Type MENUITEMINFO cbSize As Long fMask As Long fType As Long fState As Long wID As Long hSubMenu As Long hbmpChecked As Long hbmpUnchecked As Long dwItemData As Long dwTypeData As String cch As Long End Type Private Declare Function SetMenuItemBitmaps Lib "user32" _ (ByVal hMenu As Long, ByVal nPosition _ As Long, ByVal wFlags As Long, ByVal _ hBitmapUnchecked As Long, ByVal _ hBitmapChecked As Long) As Long Private Declare Function GetMenu Lib "user32" _ (ByVal hwnd As Long) As Long Private Declare Function GetMenuItemCount Lib "user32" _ (ByVal hMenu As Long) As Long Private Declare Function GetSubMenu Lib "user32" _ (ByVal hMenu As Long, ByVal nPos As Long) As Long Private Declare Function GetMenuItemInfo Lib "user32" _ Alias "GetMenuItemInfoA" _ (ByVal hMenu As Long, ByVal un As Long, _ ByVal b As Boolean, lpmii As MENUITEMINFO) As Long Private Declare Function SetMenuItemInfo Lib "user32" _ Alias "SetMenuItemInfoA" _ (ByVal hMenu As Long, ByVal uItem As Long, _ ByVal fByPosition As Long, lpmii As MENUITEMINFO) As Long Private Declare Function CreatePopupMenu Lib "user32" () As Long Private Declare Function TrackPopupMenu Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal X As Long, ByVal Y As Long, ByVal nReserved As Long, ByVal hwnd As Long, lprc As RECT) As Long Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long Private Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long Private hMenu As Long Private Const MIIM_STATE As Long = &H1 Private Const MIIM_ID As Long = &H2 Private Const MIIM_SUBMENU As Long = &H4 Private Const MIIM_CHECKMARKS As Long = &H8 Private Const MIIM_TYPE As Long = &H10 Private Const MIIM_DATA As Long = &H20 Private Const MFT_RADIOCHECK As Long = &H200 Private Const MFT_STRING As Long = &H0 Private Const RGB_STARTNEWCOLUMNWITHVERTBAR As Long = &H20 Private Const RGB_STARTNEWCOLUMN As Long = &H40 Private Const RGB_EMPTY As Long = &H100 Private Const RGB_VERTICALBARBREAK As Long = &H160 Private Const RGB_SEPARATOR As Long = &H800 Private Const MF_CHECKED = &H8& Private Const MF_APPEND = &H100& Private Const TPM_LEFTALIGN = &H0& Private Const MF_DISABLED = &H2& Private Const MF_GRAYED = &H1& Private Const MF_SEPARATOR = &H800& Private Const MF_STRING = &H0& Public Function Create() As Long On Error GoTo fim Create = CreatePopupMenu Exit Function fim: Create = CLng(False) End Function Public Function Count(ByVal menuh As Long) As Long GetMenuItemCount menuh End Function Public Function Show(ByVal menuh As Long, ByVal owner As Long, ByVal X As Double, ByVal Y As Double) As Long Dim rc As RECT Show = TrackPopupMenu(menuh, 256, X, Y, 0, owner, rc) End Function Public Sub Add(ByVal menuh As Long, ByVal pos As Long, ByVal Text As String, Optional ByVal Flags As Long = 0, Optional lpImage As StdPicture) On Error Resume Next AppendMenu menuh, Flags, pos, Text If lpImage Then SetMenuItemBitmaps menuh, pos, 0, lpImage, lpImage End Sub Public Sub Destroy(ByVal menuHandle As Long) On Error Resume Next DestroyMenu menuHandle End Sub

A classe acima eu irei explicar no próximo artigo, ainda hoje, mas a função dele é criar menus e manipulá-los.
6º: Volte ao form1 criado por padrão pelo VB, e adicione o seguinte código no load do form:
Private Sub Form_Load() oldproc = SetWindowLong(Me.hwnd, GWL_WNDPROC, AddressOf WProc) End Sub
7º: Execute o programa. Ao clicar com o botão direito do mouse no título da janela você verá que o mesmo irá exibir o nosso menu customizado e não mais o menu padrão da janela. Isso é útil para janelas com BorderStyle 0 (borderless form).

Considerações finais

O Subclassing tem ilimitadas funcionalidades, seja para criar um título customizado sem usar picturebox, seja para, como vimos acima, criar um menu próprio de janela, ou também para obter quando o formulário foi abandonado ou foi focalizado pelo usuário (pois o lostfocus e gotfocus nativos dos formulários do VB não funcionam..).
É isso aí, pessoal. No próximo artigo, irei explicar a classe acima, de menus, e disponibilizá-la, seja em cls ou em dll.
Até o próximo artigo.

Visual Basic Tip: Detectando colisões entre dois objetos

Olá. Neste artigo vou disponibilizar uma função interessante: a função para detectar colisões entre dois objetos retangulares. Ele funciona com shapes, pictureboxes, images e até mesmo com coordenadas virtuais (variáveis).

Tal função é:
Public Function DetectCollision(ax, ay, aw, ah, bx, by, bw, bh) cx = (bx + bw >= ax) And (ax + aw >= bx) cy = (by + bh >= ay) And (ay + ah >= by) DetectCollision = (cx And cy) End Function

Irei explicar todos os atributos com um exemplo: imagine dois pictureboxes Pict1 e Pict2. Onde quer que eles estejam, a função vai determinar se um está sobre/sob o outro, mesmo que por um mísero ponto dos dois. Em outras palavras, ele vai determinar se existe uma intersecção entre os dois objetos. Sendo assim, o código para estas duas pictureboxes do exemplo seria:

dim Colisao as boolean
Colisao = DetectCollision(Pict1.left, Pict1.top, pict1.width, pict1.height, pict2.left, pict2.top, pict2.width, pict2.height)

Como pode-se ver, há a necessidade de se passar não só a posição dos dois mas também o tamanho de ambos. Lembrando que os quatro primeiros atributos são do primeiro objeto e os outros quatro, do segundo. Nesta ordem: posição horizontal do primeiro objeto, posição vertical do primeiro objeto, largura do primeiro objeto, altura do primeiro objeto, posição horizontal do segundo objeto, posição vertical do segundo objeto, largura do segundo objeto e altura do segundo objeto.

É isso pessoal.
Em breve estarei divulgando a nova versão do MultiSystem. Atualmente estou desenvolvendo os jogos. Ele vai ter jogo de Tetris (já desenvolvido e funcionando legal, com música e tudo), Pac-man (em desenvolvimento) e outros que vier em mente.
Fiquem atentos!