Página 2 de 3

Re: [RESOLVIDO] Erro atualização de código para 64bits

Enviado: Sex Out 28, 2016 4:53 pm
por RODRIGOOC
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.
Boa tarde, Mikel Silveira Fraga e demais colegas. Sou novo no fórum em tenho aprendido muito com o fórum.
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
Ao exceutar as sugestões citadas acima, apresenta os erros printados.
Screen Shot 10-28-16 at 05.18 PM.JPG
Screen Shot 10-28-16 at 05.18 PM.JPG (39.85 KiB) Exibido 14090 vezes
Screen Shot 10-28-16 at 05.31 PM.JPG
Screen Shot 10-28-16 at 05.31 PM.JPG (38.92 KiB) Exibido 14090 vezes
Segundo minhas pesquisas realiza a alteração do "Application.Hinstance" para "Application.HinstancePtr", mas ocorre um erro.
Screen Shot 10-28-16 at 05.35 PM.JPG
Screen Shot 10-28-16 at 05.35 PM.JPG (37.69 KiB) Exibido 14090 vezes
Excel reinicia, não me deixando analisar o código.
Screen Shot 10-28-16 at 05.35 PM 001.JPG
Screen Shot 10-28-16 at 05.35 PM 001.JPG (88.38 KiB) Exibido 14090 vezes
Obrigado desde já.

Re: [RESOLVIDO] Erro atualização de código para 64bits

Enviado: Qua Nov 09, 2016 2:17 pm
por humbertops
Estou com este erro em uma macro, o rapaz que criou não está conseguindo resolver, tenho instalado o Office Profissional 2016 - 64 bits e com windows 10 pro instalado.

Segue o código com erro abaixo:

Option Explicit

Public Declare Function FindWindowA& Lib "user32" (ByVal lpClassName$, ByVal lpWindowName$)
Public Declare Function GetWindowLongA& Lib "user32" (ByVal hWnd&, ByVal nIndex&)
Public Declare Function SetWindowLongA& Lib "user32" (ByVal hWnd&, ByVal nIndex&, ByVal dwNewLong&)

' constantes

Public Const GWL_STYLE As Long = -16
Public Const WS_MINIMIZEBOX = &H20000
Public Const WS_MAXIMIZEBOX = &H10000
Public Const WS_FULLSIZING = &H70000

Public Sub InitMaxMin(mCaption As String, Optional Max As Boolean = True, Optional Min As Boolean = True _
, Optional Sizing As Boolean = True)
Dim hWnd As Long
hWnd = FindWindowA(vbNullString, mCaption)
If Min Then SetWindowLongA hWnd, GWL_STYLE, GetWindowLongA(hWnd, GWL_STYLE) Or WS_MINIMIZEBOX
If Max Then SetWindowLongA hWnd, GWL_STYLE, GetWindowLongA(hWnd, GWL_STYLE) Or WS_MAXIMIZEBOX
If Sizing Then SetWindowLongA hWnd, GWL_STYLE, GetWindowLongA(hWnd, GWL_STYLE) Or WS_FULLSIZING
End Sub

Re: [RESOLVIDO] Erro atualização de código para 64bits

Enviado: Qua Nov 09, 2016 9:44 pm
por Mikel Silveira Fraga
Humbertops, boa noite e seja bem vindo ao fórum.

Cara, veja se o código abaixo resolve seu problema:

Código: Selecionar todos

Public PtrSafe Declare Function FindWindowA& Lib "user32" (ByVal lpClassName$, ByVal lpWindowName$) LongLong
Public PtrSafe Declare Function GetWindowLongA& Lib "user32" (ByVal hWnd&, ByVal nIndex&) LongLong
Public PtrSafe Declare Function SetWindowLongA& Lib "user32" (ByVal hWnd&, ByVal nIndex&, ByVal dwNewLong&) LongLong
Com essa alteração acima, ele irá funcionar somente em versões do Office 64 Bits.

Caso precise que o mesmo arquivo funcione em outras versões do Office, teremos que modificar o código. Segue link abaixo com as orientações:
- VBA Tips - Compatibilidade entre as API 32-Bits (x86) e 64-Bits (x64) no VBA

Dúvidas, estamos a disposição.

Abraços e bom descanso.

Re: [RESOLVIDO] Erro atualização de código para 64bits

Enviado: Seg Dez 26, 2016 11:47 am
por AnanaisJr
Ola Amigos, estou com o mesmo problema em um projeto para abrir pagina da internet pelo o VBA, informando para atualizar o sistema para 64 bits, gostaria de ajuda:

Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
"URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal _
szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Public Function DownloadFilefromWeb(url As String, fileName As String) As Boolean
DownloadFilefromWeb = URLDownloadToFile(0, url, fileName, 0, 0)
End Function

Abraço a todos

Re: [RESOLVIDO] Erro atualização de código para 64bits

Enviado: Dom Mai 21, 2017 8:27 pm
por Nilmar
ESTOU COM O MESMO PROBLEMA:

Tentei substituir no meu código para que usuarios de 32bits e de 64 bits possam abrir a minha planilha normalmente, mas o código proposto não executa como deveria nas duas versões. Quero saber se podem me ajudar?

O código proposto:

#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

#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

#End If

#ElseIf VBA6 Then 'Declaração de API´s para versões do MS Office 2007-.

Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal _
lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As _
Long

#End If

AQUI O MEU CÓDIGO DE 32BITS

Private Declare Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function DrawMenuBar Lib "User32" (ByVal hwnd As Long) As Long
Public USUARIO As String
Public Senha As String
Public Nome As String
Public Tipo As String
Public NUsuario As String
Public SenhaNUser As String
Public ConfSenha As String
Public SenhaAdm As String
Public linha As Integer

Por favor, me ajudem a resolver essa dificuldade operacional. Aguardo vosso contato.

Nilmar Spoladori

Re: [RESOLVIDO] Erro atualização de código para 64bits

Enviado: Qua Mai 24, 2017 12:09 am
por Mikel Silveira Fraga
Nilmar, boa noite.

Cara, desculpa de demora em responder, mas esses dias tem sido bem corridos.

Substitua todo o código que você postou aqui pelo código abaixo:

Código: Selecionar todos

Option Explicit

#If VBA7 Then         ' Avalia as versões do Office 2010+
  #If Win64 Then      ' Arquitetura 64 Bits do Office
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongLong
    Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As LongLong
    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongLong
    Private Declare PtrSafe Function DrawMenuBar Lib "User32" (ByVal hwnd As Long) As LongLong
  #ElseIf Win32 Then  ' Arquitetura 32 Bits do Office
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare PtrSafe Function DrawMenuBar Lib "User32" (ByVal hwnd As Long) As Long
  #End If
#ElseIf VBA6 Then     ' Avalia as versões do Office 2007-
  Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
  Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  Private Declare Function DrawMenuBar Lib "User32" (ByVal hwnd As Long) As Long
#End If

Public USUARIO As String
Public Senha As String
Public Nome As String
Public Tipo As String
Public NUsuario As String
Public SenhaNUser As String
Public ConfSenha As String
Public SenhaAdm As String
Public linha As Integer
Dessa forma, deve funcionar em todos os sistemas. Teste e nos retorne.

Forte abraço.

Re: [RESOLVIDO] Erro atualização de código para 64bits

Enviado: Ter Jun 13, 2017 2:38 pm
por Mikel Silveira Fraga
Nilmar, boa tarde.

Estive fazendo uns testes (2010 e 2013) e consegui adaptar um código que vai atendê-lo melhor.

Código: Selecionar todos

Option Explicit

#If VBA7 Then         ' Avalia as versões do Office 2010+
  Private Declare PtrSafe Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  Private Declare PtrSafe Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
  Private Declare PtrSafe Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  Private Declare PtrSafe Function DrawMenuBar Lib "User32" (ByVal hwnd As Long) As Long
#ElseIf VBA6 Then     ' Avalia as versões do Office 2007-
  Private Declare Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  Private Declare Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
  Private Declare Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  Private Declare Function DrawMenuBar Lib "User32" (ByVal hwnd As Long) As Long
#End If

Public USUARIO As String
Public Senha As String
Public Nome As String
Public Tipo As String
Public NUsuario As String
Public SenhaNUser As String
Public ConfSenha As String
Public SenhaAdm As String
Public linha As Integer
Acredito que agora não teremos mais erros.

Teste e nos retorne.

Forte abraço.

Re: [RESOLVIDO] Erro atualização de código para 64bits

Enviado: Ter Jun 13, 2017 5:28 pm
por alexdias
Mikel, boa tarde, resolvi o erro do "PtrSafe" mas continuou dando problema conforme imagem em anexo,
se puder me esclarecer serei grato!

Re: [RESOLVIDO] Erro atualização de código para 64bits

Enviado: Ter Jun 13, 2017 10:08 pm
por Mikel Silveira Fraga
Alex Dias, boa noite e seja bem vindo ao fórum.

Cara, posso estar enganado, mas o erro entra no mesmo conceito do código anterior, porém para a função LowLeveMouseProc.

Sei que esses conjunto de rotinas serve para ativar o Scroll Button do Mouse nos controles ListBox e ComboBox.
Bem, sobre a rotina, não tenho como te explicar muita coisa, pois estudei pouco esse código e não cheguei a entender 100% do seu funcionamento. Tenho feito alguns trabalhos com esse tipo de código (API´s do Windows), mas este é mais complexo, se comparado com os que já utilizei anteriormente.

Dúvidas, envie o arquivo com esse código completo, pra que possa dar uma melhor orientada.

Fico no aguardo.

Re: [RESOLVIDO] Erro atualização de código para 64bits

Enviado: Dom Nov 26, 2017 10:26 am
por Sergiolgluz
Olá Mikel.
Tenho feito todos os procedimentos para rodar em 64 bit, todavia, quando teclo no botão pesquisar dá o Erro de compilação e diz que é impossível achar a biblioteca. Por favor, me dê auxílio.
Segue trecho do código:

Private Sub UserForm_Initialize()

With lstLista
.ColumnHeaders.Clear
.ListItems.Clear
.Gridlines = True
.View = 3
.FullRowSelect = True
' .ColumnHeaders.Add Text:="ID", Width:=20
' .ColumnHeaders.Add Text:="reclamante", Width:=60
' .ColumnHeaders.Add Text:="processo", Width:=120
' .ColumnHeaders.Add Text:="advogado", Width:=30
' .ColumnHeaders.Add Text:="reclamada", Width:=50
End With

'preenche o cboDirecao e seleciona o primeiro item
cboDirecao.Clear
cboDirecao.AddItem "Ascendente"
cboDirecao.AddItem "Descendente"
cboDirecao.ListIndex = 0

Call DefinePlanilhaDados
Call Populaterceiro
Call PopulaListBox(vbNullString, vbNullString, vbNullString, vbNullString, vbNullString)
End Sub