[Resolvido]InputBox para senha *****

Olá, Baixei um exemplo de uma instrução para uma InputBox quaé chamada por um Comando e abre com
**** Asteristicos  para entrar a senha para deletar um registro.

Eu não sei se na mudança de versão da Access passou a dar esse erro quando vai executar a chamada.
Antes estava no Access 2010 e agora estou com o 2019.

Erro de Compilação
Tipos incompatíveis     na linha abaixo: AddressOf NewProc

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

Código:


 '// 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) ---->AddressOf NewProc

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


Tente usar esse modelo. Salve um código em módulo.
Use ele a bastante tempo e nunca deu problema

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
'////////////////////////////////////////////////////////////////////

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongLong, _
                                                ByVal ncode As LongLong, ByVal wParam As LongLong, lParam As Any) As LongLong
                                               
        Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias _
                                                "GetModuleHandleA" (ByVal lpModuleName As String) As LongLong
       
        Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _
                                            (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, _
                                            ByVal dwThreadId As Long) As LongPtr
       
        Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long
       
        Private Declare PtrSafe Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" _
                                            (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _
                                            ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
       
        Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" _
                                              (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
       
        Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () 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 LongPtr
       
        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
#Else
'API functions to be used
    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


Private Const EM_SETPASSWORDCHAR = &HCC
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
Private Const HC_ACTION = 0

#If VBA7 Then
    #If Win64 Then
        Private hHook As LongLong
    #Else
        Private hHook As LongPtr
    #End If
#Else
    Private hHook As Long
#End If


#If VBA7 Then
    #If Win64 Then
        Public Function NewProc(ByVal lngCode As Long, ByVal wParam As Long, ByVal lParam As Long) As LongLong
            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
       
                RetVal = GetClassName(wParam, strClassName, lngBuffer)
       
                If Left$(strClassName, RetVal) = "#32770" Then
       
                    SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0
                End If
            End If
       
            CallNextHookEx hHook, lngCode, wParam, lParam
        End Function
    #Else
        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
       
                RetVal = GetClassName(wParam, strClassName, lngBuffer)
       
                If Left$(strClassName, RetVal) = "#32770" Then
       
                    SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0
                End If
            End If
       
            CallNextHookEx hHook, lngCode, wParam, lParam
        End Function
    #End If
#Else
    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
   
            RetVal = GetClassName(wParam, strClassName, lngBuffer)
   
            If Left$(strClassName, RetVal) = "#32770" Then
   
                SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0
            End If
        End If
   
        CallNextHookEx hHook, lngCode, wParam, lParam
   
    End Function
#End If


#If VBA7 Then
    #If Win64 Then
        Public Function InputBoxDK(Prompt, Optional Title, Optional Default, Optional XPos, _
                                Optional YPos, Optional HelpFile, Optional Context) As String
            Dim lngModHwnd As LongLong, 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
    #Else
        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
    #End If
#Else
'API functions to be used
    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
#End If

Norimar boa tarde,

Minha sugestão é criar um formulário para esta função, que seja "PopUp" e "Janela Restrita", em conjunto com uma variável global do tipo Boolean.
Exemplo:

Código:


Private Sub cmdExcluir_Click()

    '-- ROTINA PARA ABRIR FORMULÁRIO DE SENHA ---------------------------------------------
    DoCmd.OpenForm "NOME_FORMULARIO_SENHA", acNormal
    
    '-- No Form_Load() do formulário de senha informar:
    '-- Por padrão, manter a variável global como FALSE (vgOK = FALSE)
    '-- vgOk = False
  

    '-- SE O USUÁRIO INFORMOU A SENHA CORRETA, muda a variável global para TRUE
    
    '--------------------------------------------------------------------------------------
  
    
    
    If vgOK = True Then
        '-- Instrução para exclusão do registro
        CurrentDb.Execute ("DELETE FROM NOME_TABELA WHERE ID = ID_DO_REGISTRO")
        MsgBox "Regsitro excluido com sucesso.", vbInformation, "Mensagem"
        
        '-- Retorna valor para FALSE
        vgOK = False
        
    End If

End Sub




Declaração da variavel global em algum módulo qualquer do teu sistema

Global vgOK As Boolean


Desta forma não é necessário o uso de API e também evita qualquer incompatibilidade entre versões 32 e 64.

Tente isso !!

Att,

Alexandre Fim

Olá,
como sugeriu o Alexandre,
eu também sugiro um formulário popup.

No meu canal do Youtube ensino a criar uma InputBox personalizada com senha, utilizando apenas formulário
e VBA, sem uso de APIs, que se comporta igual a já existente no Access.

Segue:



Bons estudos!

Grande @Marcelo David !!
Agora ficou "mastigado" para o @flecha...rss

Bom dia senhores!
flecha conseguiu chegar a algum resultado?

Obrigado a todos,
com essa coletânia de exemplos fornecida pelos colega
consegui resolver.


Vou estudar a do Marcelo que gostei muito.

Obrigado a todos!

Opa! Ótimo que deu certo!
Gratos pelo retorno!

Marcelo,
ficou assim no meu BTExcluir

Private Sub cmdExcluir_Click()
If InputBoxPWD("Excluir registro atual? Precisa SENHA !!", "Senha Nescessária!") = "1234" Then
DoCmd.RunCommand acCmdDeleteRecord

MsgBox "Registro apagado", vbInformation, "Excluído"
Else
MsgBox "Senha não Confere!!!"
Cancel = True
End If

End Sub

Quando eu clico em Excluir e executa a rotina, pergunta se quer excluir mesmo, SIM ou NÃO, certo ?
Quando NÃO abre o código erro em tempo de execução 2501, posso colocar um tratamento de erro para não informar
e cancelar e abortar mesmo ?

Olá!
Poderá tratar a senha errada e o "Não" do botão.

Possivelmente um Error Resume Next já resolva.

*Reabri o tópico. Quando resolver definitivamente, marque novamente como resolvido.

E se o assinto se desviar muito, crie um novo tópico e copiar as mensagens dessa nova
questão para o novo tópico, daí apagarei desse essas dúvidas.

Oi Marcelo, não estou conseguindo tratar o Não do Botão, pois ele sempre volta para as instruçoes
do InputBox.
Não interrompe a sequência.

Continua a executar os comandos do botão Excluir.

Private Sub cmdExcluir_Click()


On Error GoTo erro

If InputBoxPWD("Excluir registro atual? Precisa SENHA !!", "Senha Nescessária!") = "1234" Then
DoCmd.RunCommand acCmdDeleteRecord

MsgBox "Registro apagado", vbInformation, "Excluído"

Exit Sub

Else


MsgBox "Senha não Confere!!!"
Cancel = True

erro:
If Error = 2501 Then Cancel = True
End If

End Sub


Botão CANCELAR do From FrmInputBox

Private Sub btnCanc_Click()
MsgBox "Deseja Cancelar??", vbCritical, "Cancelada Operação"

DoCmd.Close acForm, "frminputbox", acSaveYes
Exit Sub



End Sub

Boa noite.

flecha escreveu:Botão CANCELAR do From FrmInputBox

Private Sub btnCanc_Click()
MsgBox "Deseja Cancelar??", vbCritical, "Cancelada Operação"

DoCmd.Close acForm, "frminputbox", acSaveYes
Exit Sub



End Sub

Não entendi esse código. O ImpuboxPWD, não deve ser alterada. Deve-se usar semelhente ao usa da original do Access.

*O Cancel = True é desnecessário no else.

Botão Excluir chama a InputBoxPWD abrindo o Form

Ai clico em Cancelar , ele cancela mas também passa pela mensagem de Senha não Confere!
Achei que deveria fechra o form InputBoxPWD e voltar para o Form que a chamou onde estão os registros!

Private Sub btnCanc_Click()

MsgBox "Deseja Cancelar??", vbCritical, "Cancelada Operação"

DoCmd.Close acForm, "frminputbox", acSaveYes

Exit Sub

End Sub

Dessa forma abre a pergunta se confirma o CANCELA, abre a mensagem pedindo a confirmação, clico em sim ai ele vem a mensagem de Senha não confere!
Ele prossegue como se tivesse preeenchido senha errada e clicado OK, mesmo estando o txtinput vazio.

Se eu clicar OK sem preencher senha sempre passa mela mensagem Senha não confere.

Botão EXCLUIR

Private Sub cmdExcluir_Click()
On Error GoTo erro

If InputBoxPWD("Excluir registro atual? Precisa SENHA !!", "Senha Nescessária!") = "1234" Then
   DoCmd.RunCommand acCmdDeleteRecord

   MsgBox "Registro apagado", vbInformation, "Excluído"

   Exit Sub

     Else
       MsgBox "Senha não Confere!!!"
           
   End If
   
erro:
If Error = 2501 Then Cancel = True


End Sub

Quando clico em EXCLUIR e cancelo no form frmInput abre a confirmação e mesmo assim mostra mensagem de Senha não confere.


Não estou entendendo!

Senhores, bom dia.

Apenas um pitaco. Segue abaixo a forma como é feita a exclusão em alguns sistemas que eu faço.

A rotina abaixo é feita com a senha de exclusão é a mesma de acesso ao sistema.


Private Sub bt_excluir_Click()
On Error GoTo fim

'módulo mdlinpubox para a senha de exclusão
On Error GoTo fim
Dim strSenhaUser As String, strSenhaAtual 'Senha do usuário gravada no bd
Dim strUsuario As Integer 'Senha digitada pelo usuário


strSenhaAtual = InputBoxDK("Digite a senha para a exclusão", "Senha", "******") 'Informa a senha a ser comparada
strSenhaUser = DLookup("[SENHA]", "USUARIOS", "[USER] = '" & Forms!login!USER & "'") 'Busco a senha real do usuário

If strSenhaAtual <> strSenhaUser Then 'Caso a senha digitada for diferente da senha do usuário, interrompo o código
MsgBox "Senha incorreta, tente novamente", vbInformation, Me.Caption
Exit Sub
End If



Dim numRecord As Integer
numRecord = InputBox("Informe o Nº do Cliente..:", Me.Caption)

If MsgBox("Deseja excluir o Cliente:" & vbCrLf & Me.Cliente & " ?", vbQuestion + vbYesNo, Me.Caption) = vbYes Then

Dim SQL As String
DoCmd.SetWarnings False
SQL = "DELETE * FROM tblcliente WHERE idcliente = " & numRecord

DoCmd.RunSQL SQL

MsgBox "Exclusão realizada com sucesso!", vbInformation, Me.Caption
DoCmd.GoToRecord , , acNewRec

Else
MsgBox " Ação cancelada pelo usuário", vbInformation, Me.Caption



End If
DoCmd.RunCommand acCmdRefresh

fim:
If Err.Number = 13 Then
MsgBox "Cliente não excluido !" & vbCrLf & " Ação cancelada pelo usuário.", vbInformation, Me.Caption
End If


End Sub

Estou colocando o Arquivo de teste
com 3 Botões de Deletar.

Boa tarde pessoal!

Flecha, refiz a InputBoxPWD exatamente como ensinei na videoaula e usei ela no código do botão excluir vermelho.

Código comentado.

*Os campos Cargo, Exercicio e Local  no seu formulário não tem na tabela11. Como eles provavelmente são chave estrangeira, precisa criar
os campos correspondentes.

Baixe aqui e teste por gentileza.

Obrigado a todos pelo empenho.

Agora vou fixar no meu BD.

Como diz um ai do forum:
Só sei que Nada Sei!

Opa, maravilha. Grato pelo retorno!