Boa tarde, Mikel Silveira Fraga e demais colegas. Sou novo no fórum em tenho aprendido muito com o fórum.Re: [RESOLVIDO] Erro atualização de código para 64bits
Mensagempor Mikel Silveira Fraga » Qua Out 12, 2016 8:45 pm
Alves, boa noite e seja bem vindo ao fórum.
Não conheço o seu modelo, mas geralmente, para esse tipo de código, é recomendado que seja colocado em módulos.
Teste e nos retorne. Abraços.
Fiz uma pesquisa no tópico "Botao Maximizar e Minimizar"(viewtopic.php?t=758#p4324), verifiquei que era necessário realizar a compatibilidade com o Excel 64 bits.
Então localizei esse tópico. Realizei as adaptações que acho que seriam necessárias.
Código: Selecionar todos
#If VBA7 Then 'Declaração de API´s para versões do MS Office 2010+.
#If Win64 Then 'Declaração para as versões 64 bits.
Public Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As LongLong, ByVal lpOperation As String, ByVal lpFile As String, ByVal _
lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As LongLong) As _
LongLong
Option Explicit
Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () As Long
Declare PtrSafe Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" ( _
ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
Declare PtrSafe Function SetWindowsHookEx Lib _
"user32" Alias "SetWindowsHookExA" (ByVal idHook As LongPtr, ByVal lpfn As LongPtr, _
ByVal hmod As LongPtr, ByVal dwThreadId As LongPtr) As Long
Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _
ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Type POINTAPI
X As LongPtr
Y As LongPtr
End Type
Type MSLLHOOKSTRUCT
pt As POINTAPI
mouseData As LongPtr
flags As LongPtr
time As LongPtr
dwExtraInfo As LongPtr
End Type
Const HC_ACTION = 0
Const WH_MOUSE_LL = 14
Const WM_MOUSEWHEEL = &H20A
Dim hhkLowLevelMouse, lngInitialColor As LongPtr
Dim udtlParamStuct As MSLLHOOKSTRUCT
Public intTopIndex As Integer
Function GetHookStruct(ByVal lParam As LongPtr) As MSLLHOOKSTRUCT
CopyMemory VarPtr(udtlParamStuct), lParam, LenB(udtlParamStuct)
GetHookStruct = udtlParamStuct
End Function
Function LowLevelMouseProc _
(ByVal nCode As LongPtr, ByVal wParam As LongPtr, ByVal lParam As LongPtr) 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
#Else 'Declaração para as versões 32 bits.
Public Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, ByVal _
lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As LongPtr) As _
LongPtr
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
#End If