48
« Último mensaje por xavi en Marzo 30, 2020, 11:21:55 pm »
Palabras clave: inputbox, extendido, inputboxex, limitar, caracteres, API
Autor: Happy / Abril 2004
Extraído de: Access y VBA
Objetivo:
Rescato este módulo de Happy de abril de 2004 (suministrado por javier.mil ya que yo no lo encontraba) para añadir funcionalidad a un InputBox. El propio módulo incluye los comentarios del autor.
En un módulo independiente:
Option Compare Database
Option Explicit
'******************************************************
'
' InputBoxEx
'
' Función que amplía el InputBox de VBA, confiriéndole
' diferentes estilos (contenidos en la enumeración
' StyleInputBox). También, en su último argumento (MaxChar)
' podemos limitar el número de caracteres que se podrán
' introducir.
'
' Uso:
'
' Function InputBoxEx( _
' Prompt, _ véase en la ayuda InputBox
' [Title], _ " "
' [Default], _ " "
' [XPos], _ " "
' [YPos], _ " "
' [HelpFile], _ " "
' [Context] _ " "
' [Style] _ ------> cualquiera de los valores de la enumeración StyleInputBox
' [MaxChar])------> si su valor es diferente de 0 marca el límite de
' caracteres admitidos por el InputBox
'
' Ejemplo: (muestra un InputBox para introducir contraseñas, con el límite de
' 10 caracteres)
'
' Contraseña = InputBoxEx("Mensaje", "Titulo", , , , , , SPassword, 10)'
' Autor: Juan M. Afan de Ribera
' Abril 2004
'
' Saludos :-)
' happy
'*********************************************************************
' estilos del InputBoxEx
Public Enum StyleInputBox
SNone ' InputBox normal
SPassword ' máscara oculta
SNumber ' sólo números
SLowerCase ' sólo minúsculas
SUpperCase ' sólo mayúsculas
End Enum
Private Declare Function FindWindowEx Lib "user32" _
Alias "FindWindowExA" _
(ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Declare Function GetForegroundWindow Lib "user32" () 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 SetTimer Lib "user32" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long) As Long
Private Const GWL_STYLE = (-16)
' constantes con los estilos de
' controles 'EDIT'
Private Const ES_UPPERCASE = &H8
Private Const ES_LOWERCASE = &H10
Private Const ES_PASSWORD = &H20
Private Const ES_NUMBER = &H2000
' mensaje para establecer el caracter que se mostrará
' como máscara para el InputBoxEx tipo contraseña
Private Const EM_SETPASSWORDCHAR = &HCC
' constante que contiene el carácter que se mostrará
' (este valor puede ser cualquier otro, en este caso
' he escogido el típico asterisco)
Private Const KEY_MASK = 42& ' "*"
' mensaje para establecer el número máximo de
' caracteres permitidos
Private Const EM_LIMITTEXT = &HC5
Private SInputBox As StyleInputBox
Private hInputBox As Long
Private cChar As Long
Public Function InputBoxEx( _
Prompt, _
Optional Title, _
Optional Default, _
Optional XPos, _
Optional YPos, _
Optional HelpFile, _
Optional Context, _
Optional Style As StyleInputBox = SNone, _
Optional MaxChar As Long) As String
' si no hay ningún otro InputBoxEx abierto...
If hInputBox = 0 Then
' Creamos un timer que se ejecutará a la décima de segundo
Call SetTimer(Access.hWndAccessApp, 0&, 100, AddressOf TimerProc)
SInputBox = Style
cChar = MaxChar
' llamamos al InputBox de manera normal
On Error GoTo AnularTimer
InputBoxEx = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context)
End If
Exit Function
AnularTimer:
' si ha habido algún error, se cancela la operación
Call KillTimer(Access.hWndAccessApp, 0&)
MsgBox "Error: " & Err.Number & vbCrLf & Err.Description
End Function
Private Sub TimerProc( _
ByVal hwnd As Long, _
ByVal uMsg As Long, _
ByVal idEvent As Long, _
ByVal dwTime As Long)
Dim hEdit As Long
Dim CurStyle As Long
' localizamos el manipulador de la ventana activa
' (se supone que es la ventana del InputBox)
hInputBox = GetForegroundWindow
' localizamos el manipulador de la caja de texto
' del InputBox
hEdit = FindWindowEx(hInputBox, 0&, "EDIT", vbNullString)
' obtenemos los estilos de la caja de texto ...
CurStyle = GetWindowLong(hEdit, GWL_STYLE)
Select Case SInputBox
Case SPassword ' tipo password
' le decimos a la caja de texto cuál será el carácter
' que aparecerá en vez de lo que teclee el usuario
Call SendMessage(hEdit, EM_SETPASSWORDCHAR, KEY_MASK, 0&)
' y le añadimos el estilo de introducción de contraseñas
CurStyle = CurStyle Or ES_PASSWORD
Case SNumber ' tipo número
CurStyle = CurStyle Or ES_NUMBER
Case SLowerCase ' tipo minúsculas
CurStyle = CurStyle Or ES_LOWERCASE
Case SUpperCase ' tipo mayúsculas
CurStyle = CurStyle Or ES_UPPERCASE
End Select
If cChar > 0 Then
Call SendMessage(hEdit, EM_LIMITTEXT, cChar, 0&)
End If
' cambiamos el estilo
Call SetWindowLong(hEdit, GWL_STYLE, CurStyle)
' desactivamos el timer para que sólo se ejecute esta vez
Call KillTimer(Access.hWndAccessApp, 0&)
hInputBox = 0
End Sub
Mensajes recientes