Ocultar la clave cuando es digitada

[MauriciodeAbreu]

Buenas tardes amigos.

Tengo una duda.

Estoy usando el siguiente codigo para colocarle clave de activacion a un boton que esta en la hoja de excel (el codigo funciona perfecto), pero no encuentro una manera de ocutar la clave cuando se ingresa.

Habra alguna forma de que no se vea lo que se digita ?

 

'Caja para el ingreso del Password para poder borrar ultimo registro
Dim PS As String
Dim PS2 As String
PS2 = "clave"
PS = InputBox("Por favor ingrese su Password")
If PS = PS2 Then
'Fin de la caja

Agradecido de antemano por vuestra ayuda

[tierra_pampa]

Hola @MauriciodeAbreu

En la propiedad "PasswordChar" ingresa un asterisco. Te dejo una img.

Qué tengas un buen día! Suerte!
 

[MauriciodeAbreu]

Muchas gracias por responder.

Pero no es ahi el inconveniente, subo archivo para que veas cual es el inconveniente.

Ejemplo.xlsmAgradecido de antemano

Ejemplo.xlsm

[Mauricio_ODN]

Hola @MauriciodeAbreu

Dejo este enlace dentro del foro:

Además te dejo mi aporte, espero que sea de utilidad, nos comentas, Saludos.!!

InputPaswordChar1.1.xlsm

[MauriciodeAbreu]

Gracias por responder.

Viendo tu archivo, recorde que olvide mencionar que mi sistema operativo y Office 2019 son de 64 bit. Pido disculpas por no haber avisado.

Creo haber corregido bien la primera parte,

 

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

Pero aqui se me tranca el serrucho.

Function InputBox(Prompt, Title) 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)
UnhookWindowsHookEx hHook

End Function

Te agradezco de antemano la ayuda.

 

Nota; Por cierto, vi el enlace que me dejaste, y entiendo que no se puede hacer lo que necesito con el inputbox, lo cual me parece una lastima.

Pero aunque valoro el codigo que me esas compartiendo, me surge una duda con respecto al imputbox,se le puede cambiar el color al texto¿? no para hacerlo, es solo curiosidad, prefiero ocultar la clave con asteriscos

[Mauricio_ODN]

Hace 1 hora, MauriciodeAbreu dijo:

mi sistema operativo y Office 2019 son de 64 bit

Va de nuevo, para 64 bits.

Nos comentas, Saludos.

InputPaswordChar1.2.xlsm

[MauriciodeAbreu]

Agradecido, pero..., al introducir la clave esta es visible, y la idea es que no sea visible.

[Mauricio_ODN]

Ummm, Entonces, tenemos un problema de entendimiento.

@MauriciodeAbreu, por que mejor nos compartes una imagen o dentro del mismo archivo a que te refieres con:

Hace 2 horas, MauriciodeAbreu dijo:

al introducir la clave esta es visible

Por que me incline a pensar que lo que necesitabas era el Passwordchar, para que la clave no estuviera visible en el Inputbox (Que es lo el archivo que te envié hace):

Si nos ayudas con eso, es más probable que respondemos tu consulta.

[MauriciodeAbreu]

Disculpa la demora, estoy llegando del trabajo.

Segun entiendo, a ti el segundo archivo (InputPaswordChar1.2) te oculta la clave, y coloca asteriscos, pero a mi no. 

Te envio captura de pantalla de la ejecucion del archivo (InputPaswordChar1.2), donde veras que en vez de asteriscos se ven los numeros.

 

Agradecido de antemano

 

[Abraham Valencia]

Hola

Tu Office es de 64 bits y en el archivo de ejemplo enviado hay varias funciones de la API de Windows que hay que modificar en las declaraciones. Modifica toda la parte que está entre la línea #If VBA7 Then y la línea #Else reemplazando por las siguientes:

Private Declare PtrSafe Function SetCurrentDirectoryA Lib "kernel32" (ByVal lpPathName As String) As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As LongPtr
Private Declare PtrSafe Function TerminateProcess Lib "kernel32" (ByVal hProcess As LongPtr, ByVal uExitCode As Long) As Long
Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal hObject As LongPtr) As Long
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 CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As LongPtr) As LongPtr
Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) 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

 

Yo prefiero usar Public, pero lo dejo en Private como te lo han mostrado. Saludos.

[MauriciodeAbreu]

Amigos, estoy muy agradecido con todos por tratar de ayudarme a resolver el dilema de ocultar la contraseña en el ImputBox.

Desafortunadamente ninguna de las soluciones me llevo al exito.

Pero, la buena noticia es que trasteando un poco en la red, encontre la solucion, y se las dejo por si alguien la necesita.

 

Option Explicit'----------------------------------
'API CONSTANTS FOR PRIVATE INPUTBOX
'----------------------------------

#If VBA7 Then
Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, _
ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias _
"GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
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 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

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

'----------------------------------
'PRIVATE PASSWORDS FOR INPUTBOX
'----------------------------------

'////////////////////////////////////////////////////////////////////
'Password masked inputbox
'Allows you to hide characters entered in a VBA Inputbox.
'
'Code written by Daniel Klann
'March 2003
'64-bit modifications developed by Alexey Tseluiko
'and Ryan Wells (wellsr.com)
'February 2019
'////////////////////////////////////////////////////////////////////

#If VBA7 Then
Public Function NewProc(ByVal lngCode As Long, ByVal wParam As Long, ByVal lParam As Long) As LongPtr
#Else
Public Function NewProc(ByVal lngCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If

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

Function InputBoxDK(Prompt, Title) As String
#If VBA7 Then
Dim lngModHwnd As LongPtr
#Else
Dim lngModHwnd As Long
#End If

Dim lngThreadID As Long
lngThreadID = GetCurrentThreadId
lngModHwnd = GetModuleHandle(vbNullString)
hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)
InputBoxDK = InputBox(Prompt, Title)
UnhookWindowsHookEx hHook
End Function

Adicionalmente dejo el link de la pagina de donde lo extraje, y el archivo con el codigo para que lo vean.

Solucion

Un abrazo, y de nuevo muchas gracias a todos.

Tema solucionado!

 

 

Inputbox funcionando.xlsm