[Resolvido]Alterar modulo para rodar em 32 e 64 bits

Bom dia,

Copiei esse modulo ele funciona perfeitamente, mas quando executo no Office 64 bits dá erro, alguém pode me dizer onde devo alterá-lo para conseguir executar em 64 bits também.

Obrigado

Código:


Option Compare Database
'////////////////////////////////////////////////////////////////////
'Password masked inputbox
'Allows you to hide characters entered in a VBA Inputbox.
'
'Code written by Daniel Klann
'http://www.danielklann.com/
'March 2003

'// Kindly permitted to be amended
'// Amended by Ivan F Moala
'// http://www.xcelfiles.com
'// April 2003
'// Works for Xl2000+ due the AddressOf Operator
'////////////////////////////////////////////////////////////////////

'******************** CALL FROM FORM *********************************
' Dim pwd As String
'
' pwd = InputBoxDK("Please Enter Password Below!", "Database Administration Security Form.")
'
' 'If no password was entered.
' If pwd = "" Then
' MsgBox "You didn't enter a password! You must enter password to 'enter the Administration Screen!" _
' , vbInformation, "Security Warning"
' End If
'**************************************



'API functions to be used

#If VBA7 Then
'Linhas com ptrSafe
Public Declare PtrSafe 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

#Else
'Linhas normais
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



Private Declare Function CallNextHookEx _
Lib "User32" ( _
ByVal hHook As Long, _
ByVal ncode As Long, _
ByVal wParam As Long, _
LParam As Any) _
As Long

Private Declare Function GetModuleHandle _
Lib "kernel32" _
Alias "GetModuleHandleA" ( _
ByVal lpModuleName As String) _
As Long

Private 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

Private Declare Function UnhookWindowsHookEx _
Lib "User32" ( _
ByVal hHook As Long) _
As Long

Private Declare Function SendDlgItemMessage _
Lib "User32" Alias "SendDlgItemMessageA" ( _
ByVal hDlg As Long, _
ByVal nIDDlgItem As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal LParam As Long) _
As Long

Private Declare Function GetClassName _
Lib "User32" _
Alias "GetClassNameA" ( _
ByVal hwnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) _
As Long

Private Declare Function GetCurrentThreadId _
Lib "kernel32" () _
As Long

'Constants to be used in our API functions
Private Const EM_SETPASSWORDCHAR = &HCC
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
Private Const HC_ACTION = 0

Private hHook As Long

Public Function NewProc(ByVal lngCode As Long, _
ByVal wParam As Long, _
ByVal LParam As Long) As Long

Dim RetVal
Dim strClassName As String, lngBuffer As Long

If lngCode < HC_ACTION Then
NewProc = CallNextHookEx(hHook, lngCode, wParam, LParam)
Exit Function
End If

strClassName = String$(256, " ")
lngBuffer = 255

If lngCode = HCBT_ACTIVATE Then 'A window has been activated
RetVal = GetClassName(wParam, strClassName, lngBuffer)
If Left$(strClassName, RetVal) = "#32770" Then 'Class name of the Inputbox
'This changes the edit control so that it display the password character *.
'You can change the Asc("*") as you please.
SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0
End If
End If

'This line will ensure that any other hooks that may be in place are
'called correctly.
CallNextHookEx hHook, lngCode, wParam, LParam

End Function

'// Make it public = avail to ALL Modules
'// Lets simulate the VBA Input Function
Public Function InputBoxDK(Prompt As String, Optional Title As String, _
Optional Default As String, _
Optional Xpos As Long, _
Optional Ypos As Long, _
Optional Helpfile As String, _
Optional Context As Long) As String

Dim lngModHwnd As Long, lngThreadID As Long

'// Lets handle any Errors JIC! due to HookProc> App hang!
On Error GoTo ExitProperly
lngThreadID = GetCurrentThreadId
lngModHwnd = GetModuleHandle(vbNullString)

hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)
If Xpos Then
InputBoxDK = InputBox(Prompt, Title, Default, Xpos, Ypos, Helpfile, Context)
Else
InputBoxDK = InputBox(Prompt, Title, Default, , , Helpfile, Context)
End If

ExitProperly:
UnhookWindowsHookEx hHook

End Function

Olá, uma busca aqui no forum e encontra vários artigos.
Veja o link abaixo do nosso grande mestre Avelino:
http://www.usandoaccess.com.br/tutoriais/configurar-api-access-de-64-e-32-bits-ptrsafe.asp?id=1#inicio
Abraço

Já alterei em um monte de lugar e não consigo fazer rodar.

Podem me ajudar

Que erro é que está a dar?
Qual a versao do SO?
Qual a versao do office ?

Veja recomendação do Mestre Avelino para desenvolvimento:
http://maximoaccess.forumeiros.com/t19710-migracao-access-2003-para-2013#145640

(actualização) Em especial esta parte

O erro é O Código deve ser atualizado para uso em 64 bits. Analise e atualize as instruções Declare e, em seguida, marque-as com o atributo PtrSafe.

O SO é Windows 7

O Office é 2010 32 Bits, no Office 64 bits dá erro.

Obrigado

Com a licença de todos pude verificar que existem alguns Public Declare PtrSafe, eles devem ser assim como descrevi

Código:

Option Compare Database
'////////////////////////////////////////////////////////////////////
'Password masked inputbox
'Allows you to hide characters entered in a VBA Inputbox.
'
'Code written by Daniel Klann
'http://www.danielklann.com/
'March 2003

'// Kindly permitted to be amended
'// Amended by Ivan F Moala
'// http://www.xcelfiles.com
'// April 2003
'// Works for Xl2000+ due the AddressOf Operator
'////////////////////////////////////////////////////////////////////

'******************** CALL FROM FORM *********************************
' Dim pwd As String
'
' pwd = InputBoxDK("Please Enter Password Below!", "Database Administration Security Form.")
'
' 'If no password was entered.
' If pwd = "" Then
' MsgBox "You didn't enter a password! You must enter password to 'enter the Administration Screen!" _
' , vbInformation, "Security Warning"
' End If
'**************************************



'API functions to be used

#If VBA7 Then
'Linhas com ptrSafe
Public Declare PtrSafe 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

#Else
'Linhas normais
Public Declare PtrSafe 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



Private Declare PtrSafe Function CallNextHookEx _
Lib "User32" ( _
ByVal hHook As Long, _
ByVal ncode As Long, _
ByVal wParam As Long, _
LParam As Any) _
As Long

Private Declare PtrSafe Function GetModuleHandle _
Lib "kernel32" _
Alias "GetModuleHandleA" ( _
ByVal lpModuleName As String) _
As Long

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

Private Declare PtrSafe Function UnhookWindowsHookEx _
Lib "User32" ( _
ByVal hHook As Long) _
As Long

Private Declare PtrSafe Function SendDlgItemMessage _
Lib "User32" Alias "SendDlgItemMessageA" ( _
ByVal hDlg As Long, _
ByVal nIDDlgItem As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal LParam As Long) _
As Long

Private Declare PtrSafe  Function GetClassName _
Lib "User32" _
Alias "GetClassNameA" ( _
ByVal hwnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) _
As Long

Private Declare PtrSafe Function GetCurrentThreadId _
Lib "kernel32" () _
As Long

'Constants to be used in our API functions
Private Const EM_SETPASSWORDCHAR = &HCC
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
Private Const HC_ACTION = 0

Private hHook As Long

Public PtrSafe Function NewProc(ByVal lngCode As Long, _
ByVal wParam As Long, _
ByVal LParam As Long) As Long

Dim RetVal
Dim strClassName As String, lngBuffer As Long

If lngCode < HC_ACTION Then
NewProc = CallNextHookEx(hHook, lngCode, wParam, LParam)
Exit Function
End If

strClassName = String$(256, " ")
lngBuffer = 255

If lngCode = HCBT_ACTIVATE Then 'A window has been activated
RetVal = GetClassName(wParam, strClassName, lngBuffer)
If Left$(strClassName, RetVal) = "#32770" Then 'Class name of the Inputbox
'This changes the edit control so that it display the password character *.
'You can change the Asc("*") as you please.
SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0
End If
End If

'This line will ensure that any other hooks that may be in place are
'called correctly.
CallNextHookEx hHook, lngCode, wParam, LParam

End Function

'// Make it public = avail to ALL Modules
'// Lets simulate the VBA Input Function
Public Function InputBoxDK(Prompt As String, Optional Title As String, _
Optional Default As String, _
Optional Xpos As Long, _
Optional Ypos As Long, _
Optional Helpfile As String, _
Optional Context As Long) As String

Dim lngModHwnd As Long, lngThreadID As Long

'// Lets handle any Errors JIC! due to HookProc> App hang!
On Error GoTo ExitProperly
lngThreadID = GetCurrentThreadId
lngModHwnd = GetModuleHandle(vbNullString)

hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)
If Xpos Then
InputBoxDK = InputBox(Prompt, Title, Default, Xpos, Ypos, Helpfile, Context)
Else
InputBoxDK = InputBox(Prompt, Title, Default, , , Helpfile, Context)
End If

ExitProperly:
UnhookWindowsHookEx hHook


Atualizai veja se vai funcionar.

Essa parte está ficando em vermelho e dá erro de compilação

Public PtrSafe Function NewProc(ByVal lngCode As Long, _
ByVal wParam As Long, _
ByVal LParam As Long) As Long

Retire o PtrSafe e tente novamente

No office 32 bits roda, no 64 da erro de compilação.

Essa parte que está entre os asteriscos está ficando amarelo com: erro de compilação: tipos incompatíveis.

Esse código ficando em azul.  está na linha onde o início é hHook =  "AddressOf NewProc"


'// Make it public = avail to ALL Modules
'// Lets simulate the VBA Input Function

'*****************************************************************
Public Function InputBoxDK(Prompt As String, Optional Title As String, _
Optional Default As String, _
Optional Xpos As Long, _
Optional Ypos As Long, _
Optional Helpfile As String, _
Optional Context As Long) As String
'*****************************************************************
Dim lngModHwnd As Long, lngThreadID As Long

'// Lets handle any Errors JIC! due to HookProc> App hang!
On Error GoTo ExitProperly
lngThreadID = GetCurrentThreadId
lngModHwnd = GetModuleHandle(vbNullString)

hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)
If Xpos Then
InputBoxDK = InputBox(Prompt, Title, Default, Xpos, Ypos, Helpfile, Context)
Else
InputBoxDK = InputBox(Prompt, Title, Default, , , Helpfile, Context)
End If

ExitProperly:
UnhookWindowsHookEx hHook

End Function

Olá, veja a referencia e comentários se ajuda:

http://msdn.microsoft.com/en-us/library/windows/desktop/ms644990(v=vs.85).aspx

Olá Mestre Avelino, obrigado pela ajuda.



No meu teste esta a dar Type mismatch, efetivamente, vai ser necessário ajustar as variaveis long.
Na minha opinião, criando a condição conforme exemplificado na imagem da mensagem nº 4, ficando assim a funcionar para 32 ou 64 bit.
Abraço

Boa noite a todos, estou tendo o mesmo problema, sempre funcionou no access 32 agora no 64 esta gerando erro, após colocar ptrsafe gera erro na linha AddressOf NewProc.

consegui fazer funcionar depois de muito procurar na internet juntei várias partes de instruções e ficou assim:

Código:

Option Compare Database

Option Explicit
'////////////////////////////////////////////////////////////////////
'Password masked inputbox
'Allows you to hide characters entered in a VBA Inputbox.
'
'Code written by Daniel Klann
'March 2003
'////////////////////////////////////////////////////////////////////


'API functions to be used
#If VBA7 Then
    Private Declare PtrSafe Function CallNextHookEx Lib "User32" (ByVal hHook As Long, _
ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long

    Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long

    Private Declare PtrSafe Function SetWindowsHookEx Lib "User32" Alias "SetWindowsHookExA" _
    (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As Long, _
    ByVal dwThreadId As Long) As Long

    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "User32" (ByVal hHook As Long) As Long

    Private Declare PtrSafe Function SendDlgItemMessage Lib "User32" Alias "SendDlgItemMessageA" _
    (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _
    ByVal wParam As Long, ByVal lParam As Long) As Long

    Private Declare PtrSafe Function GetClassName Lib "User32" Alias "GetClassNameA" (ByVal hwnd As Long, _
    ByVal lpClassName As String, _
    ByVal nMaxCount As Long) As Long

    Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long

    Declare PtrSafe Function apiGetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
    Declare PtrSafe Function apiGetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long

#Else
    Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _
                                                          ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
   
    Private Declare Function GetModuleHandle Lib "kernel32" Alias _
                                            "GetModuleHandleA" (ByVal lpModuleName As String) As Long
   
    Private 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
   
    Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
   
    Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" _
                                                (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _
                                                ByVal wParam As Long, ByVal lParam As Long) As Long
   
    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" _
                                          (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
   
    Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
#End If
'~~> Constants to be used in our API functions
Private Const EM_SETPASSWORDCHAR = &HCC
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
Private Const HC_ACTION = 0

'este procedimento aparentemente faz funcionar em 32 e 64, porém no 64 só funcionou sem IF na última linha
'#If VBA7 Then
'    Private hHook As LongPtr
'#Else
'    Private hHook As Long
'#End If
    Private hHook As Long

Public Function NewProc(ByVal lngCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim RetVal
Dim strClassName As String, lngBuffer As Long

If lngCode < HC_ACTION Then
NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam)
Exit Function
End If

strClassName = String$(256, " ")
lngBuffer = 255

If lngCode = HCBT_ACTIVATE Then 'A window has been activated

RetVal = GetClassName(wParam, strClassName, lngBuffer)

If Left$(strClassName, RetVal) = "#32770" Then 'Class name of the Inputbox

'This changes the edit control so that it display the password character *.
'You can change the Asc("*") as you please.
SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0
End If

End If

'This line will ensure that any other hooks that may be in place are
'called correctly.
CallNextHookEx hHook, lngCode, wParam, lParam

End Function

Public Function InputBoxDK(Prompt, Optional title, Optional Default, Optional XPos, _
Optional YPos, Optional HelpFile, Optional Context) As String
Dim lngModHwnd As Long, lngThreadID As Long

lngThreadID = GetCurrentThreadId
lngModHwnd = GetModuleHandle(vbNullString)

hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)

InputBoxDK = InputBox(Prompt, title, Default, XPos, YPos, HelpFile, Context)
UnhookWindowsHookEx hHook

End Function




o único problema ainda não resolvido foi que não aparece asterisco ao digitar a senha, para este problema alguém tem alguma solução?

Claudemir,

estarei lançando um artigo amanhã, com uma solução no próprio Access. Sem uso de Api's.

Cadastre-se no meu site para receber o meu newsletter

Aguarde

Boa noite Avelino, não apressando vi o artigo
[Removido o link - Não é permitido links externos]

Mas não achei, conseguiu solução para este caso?

Grato

Olá, o link que postou estava errado e foi eliminado por ser link externo.
Verifique na mensagem nº 10 do tópico abaixo o link correcto:
https://www.maximoaccess.com/t28022-funcionar-em-32-e-64-bits-addressof-newproc-com-erro

Abraço

Boa tarde à todos, obrigado ahteixeira pela orientação das regras e dica. Me ajudou a melhorar.

Olá a todos,
O que foi aqui apresentado como solução foi aplicada no tópico abaixo:
https://www.maximoaccess.com/t344-login-com-mascara-de-password-na-inputbox

Abraço

Obrigado à todos por solucionar esta questão

Olá a todos,
Obrigado pelo retorno.

Para os membros menos atentos, o nosso colega Avelino Sampaio também apresentou outra solução para o mesmo problema, que podem consultar na mensagem nº 10 do tópico abaixo:
https://www.maximoaccess.com/t28022-resolvido-funcionar-em-32-e-64-bits-addressof-newproc-com-erro