OS MELHORES VÍDEOS

 

Pesquisar

sexta-feira, 9 de agosto de 2013

Botão Minimizar, Maximizar e Rest. Tamanho no Formulário.

Vou mostrar através deste matéria, como criar esses botões, como mostra a figura abaixo, no formulário.



Assista o Vídeo






Esse 1º Código é para ser inserido em um Módulo.


Option Explicit

Private Declare Function GetForegroundWindow Lib "user32" () As Long

Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" ( _
    ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
    ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)

Declare Function SetWindowsHookEx Lib _
"user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, _
ByVal hmod As Long, ByVal dwThreadId As Long) As Long

Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _
ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long

Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long

Type POINTAPI
  X As Long
  Y As Long
End Type

Type MSLLHOOKSTRUCT
    pt As POINTAPI
    mouseData As Long
    flags As Long
    time As Long
    dwExtraInfo As Long
End Type

Const HC_ACTION = 0
Const WH_MOUSE_LL = 14
Const WM_MOUSEWHEEL = &H20A

Dim hhkLowLevelMouse, lngInitialColor As Long
Dim udtlParamStuct As MSLLHOOKSTRUCT
Public intTopIndex As Integer


Function GetHookStruct(ByVal lParam As Long) As MSLLHOOKSTRUCT

   CopyMemory VarPtr(udtlParamStuct), lParam, LenB(udtlParamStuct)
    
   GetHookStruct = udtlParamStuct
    
End Function

Function LowLevelMouseProc _
(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

    On Error Resume Next

    If (nCode = HC_ACTION) Then
        
        If wParam = WM_MOUSEWHEEL Then
            
            LowLevelMouseProc = True
            
            'ATENÇÃO: Troque o nome do seu Userform
            With UserForm1
                
                'ROLAR PARA CIMA
                If GetHookStruct(lParam).mouseData > 0 Then
                    .ScrollTop = intTopIndex - 10
                    intTopIndex = .ScrollTop
                Else
                'ROLAR PARA BAIXO
                    .ScrollTop = intTopIndex + 10
                    intTopIndex = .ScrollTop
                End If
                
            End With
            
        End If
        
        Exit Function
        
    End If

    UnhookWindowsHookEx hhkLowLevelMouse
    LowLevelMouseProc = CallNextHookEx(0, nCode, wParam, ByVal lParam)
End Function

Sub Hook_Mouse()
    If hhkLowLevelMouse <> 0 Then
        UnhookWindowsHookEx hhkLowLevelMouse
    End If
        
    hhkLowLevelMouse = SetWindowsHookEx _
    (WH_MOUSE_LL, AddressOf LowLevelMouseProc, Application.Hinstance, 0)

End Sub

Sub UnHook_Mouse()

    If hhkLowLevelMouse <> 0 Then UnhookWindowsHookEx hhkLowLevelMouse
    
End Sub





Esse 2º Código é para ser inserido em um Formulário.


Option Explicit

Private Sub UserForm_Initialize()
Dim hWnd As Long

    'Vai para o topo do formulário
    ScrollTop = 0
    
    'Define os botões minimizar e maximizar do form
    hWnd = FindWindow(vbNullString, UserForm1.Caption)
    SetWindowLong hWnd, -16, &H20000 Or &H10000 Or &H84C80080
End Sub

Private Sub UserForm_Scroll(ByVal ActionX As MSForms.fmScrollAction, ByVal ActionY As MSForms.fmScrollAction, ByVal RequestDx As Single, ByVal RequestDy As Single, ByVal ActualDx As MSForms.ReturnSingle, ByVal ActualDy As MSForms.ReturnSingle)
    'Evento do trackball do mouse
    intTopIndex = ScrollTop
    Call Hook_Mouse
End Sub


Private Sub UserForm_Terminate()
    Call UnHook_Mouse
End Sub

Private Sub UserForm_Deactivate()
    Call UnHook_Mouse
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Call UnHook_Mouse
End Sub




14 comentários:

  1. Ótimo código mas só funciona com um Userform em mais de um ele trava.

    ResponderExcluir
  2. Oi amoigo mauito bom mesmo !!!
    Mais so uma duvida
    Como eu faço para colocar ele para windows 7 64 bits
    porque ele esta como 32 bits
    da uma fortça amigo...

    ResponderExcluir
    Respostas
    1. Geyzonx, Para 64bits

      substitua na API´s

      declare
      por
      declare ptrsafe.

      e melhor!
      Caso queira utilizar para os 2 sistemas.

      na declaração da API´s começo por:

      #if win64 then

      'coloque as API´s com "ptrsafe"

      #else

      'coloque as API´s sem o "ptrsafe", ou seja como estão no código acima.

      #end if

      Isso garante a utilização do código para os 2 sistemas.

      Aproveitando o ensejo, parabéns pelo código.

      Atenciosamente,

      Excluir
    2. afffffffff Nao ajudou muito com procedimento em 64 bits. pode ser mais especifico?

      Excluir
  3. rapaz deu certo mas as imagens nao aumentam junto com a janela
    oq fazer

    ResponderExcluir
  4. ÓTIMO. PARABÉNS PELO CÓDIGO. ESTAVA MESMO PRECISANDO DISSO. E MUITO OBRIGADO PELA GENEROSIDADE EM DIVIDIR SEUS CONHECIMENTOS CONOSCO.

    ResponderExcluir
  5. Ajustei para os dois funcionou. Agora dando erro

    Sub Hook_Mouse()

    If hhkLowLevelMouse <> 0 Then
    UnhookWindowsHookEx hhkLowLevelMouse
    End If

    hhkLowLevelMouse = SetWindowsHookEx _
    (WH_MOUSE_LL, AddressOf LowLevelMouseProc, Application.Hinstance, 0)

    End Sub

    Está dando erro de compilação: tipos incompatíveis. Está marcando a parte abaixo
    AddressOf LowLevelMouseProc




    ResponderExcluir
    Respostas
    1. Também deu este erro quando copiei o código. Então removi esta parte e funcionou

      Excluir
  6. não estar dando certo, pode mim ajudar??
    sempre aparece a seguinte msg "sub" ou "function" não difinida

    o que faço???

    ResponderExcluir
    Respostas
    1. Provavelmente você não substituiu o nome do form no evento initialize e no módulo

      Excluir
  7. Ao colocar o script no Private Sub UserForm_Initialize() bloquea a tela, como sair dessa? alguem sabe?

    ResponderExcluir
  8. Ao colocar o script no Private Sub UserForm_Initialize() bloquea a tela, como sair dessa? alguem sabe?

    ResponderExcluir