Hide Password in Input Box (1 Viewer)

isladogs · May 17, 2018

Hello and welcome to the forum.
What is the code? Unless I'm blind there are no posts here with code by Daniel Klann

However I do have masked input box code somewhere. I would need to check if it works in 64-bit as I haven't used it for a while

swenger · May 17, 2018

The code was posted in the beginning of this thread. post #4 which I was replying to which is why I didn't repost it

isladogs · May 17, 2018

It would have helped if you had referred us to post #4 originally

I've just checked & I have the exact same code by Daniel Klann though I haven't used it for several years

I updated the APIs to work in 64-bit several years ago but the function still didn't work. I never got around to fixing it either. Seems I'm not alone in that respect.

As only a few of my users had 64-bit, my work-round was to check bitness & use the standard input box for those users. Nobody ever complained!

If I get time, I'll look later tonight but in the meantime, you might want to look at this site for info on conversion to 64-bit
http://codekabinett.com/rdumps.php?Lang=2&targetDoc=windows-api-declaration-vba-64-bit

If you do succeed, please post your solution

swenger · May 18, 2018

Thanks for the link. It worked. Is all I need to do was insert PtrSafe

So instead of ...Declare Function... I changed it to

...Declare PtrSafe Function ....

isladogs · May 19, 2018

swenger said:
Thanks for the link. It worked. Is all I need to do was insert PtrSafe

So instead of ...Declare Function... I changed it to

...Declare PtrSafe Function ....

Really!?!

I just tried the code again & still can't get it to work
I do have the extra complication of having to use conditional formatting to get declarations to work on 32-bit & 64-bit.
But that's beside the point - I've updated all the declarations and the code compiles.
However, I still can't get it to work in 64-bit.

On testing the code fails on this line in InputBoxDK function

Code:

hHook = SetWindowsHookEx(WH_CBT, [COLOR="Red"]AddressOf NewProc[/COLOR], lngModHwnd, lngThreadID)

I get a type mismatch error in AddressOf NewProc

Looking at earlier posts, kvracing had similar code and the same error

So if you've got it to work in 64-bit, please could you post the entire updated code
- Declarations / NewProc function & InputBoxDK function

Many thanks in advance

swenger · May 22, 2018

Code:

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
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 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  'Hope someone can use it!

riti90 · May 22, 2018

That's a functional code I used to use on 64bit

Code:

Option Compare Database
 
Option Explicit

#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 Long
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
 
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 As String, Optional Title As String, _
                           Optional Default As String, _
                           Optional Xpos As LongPtr, _
                           Optional Ypos As LongPtr, _
                           Optional Helpfile As String, _
                           Optional Context As LongPtr) As String

    Dim lngModHwnd As LongPtr, 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

Sub TestDKInputBox()
    Dim x

    x = InputBoxDK("Type your password here.", "Password Required")
    If x = "" Then End
    If x <> "yourpassword" Then
        MsgBox "You didn't enter a correct password."
        End
    End If

    MsgBox "Welcome Creator!", vbExclamation

End Sub

and this on command click event

Code:

Private Sub Command1_Click()

Call TestDKInputBox

End Sub

Regards,

Margarit

isladogs · May 22, 2018

@swenger
Are you aware that the code you posted won't even compile in 64-bit Access?
If you try to run it, the code fails at exactly the same place as I mentioned before! AddressOf NewProc

@riti90
You are a STAR! I've tested it in 64-bit and it works perfectly. Many thanks

I've compared your code & my own version which failed in 64-bit
The only difference was your code defines the datatype for each argument in NewProc.
I added that to mine & it still fails at AddressOf NewProc ...

No idea why :banghead:

Anyway, I've just replaced my module code in its entirety & it now works in my own databases.

I've just got one other bit of code I never succeeded in converting to 64-bit....
See https://www.access-programmers.co.uk/forums/showthread.php?t=295062
If you'd like a challenge & could convert that for me as well, I'd be eternally grateful ... pushing my luck I know

riti90 · May 23, 2018

ridders said:
I've just got one other bit of code I never succeeded in converting to 64-bit....
See https://www.access-programmers.co.uk/forums/showthread.php?t=295062
If you'd like a challenge & could convert that for me as well, I'd be eternally grateful ... pushing my luck I know

Hi Colin,

I am sure that you just didn't have the time to work on that because I'm not a professional (I'm just a newbie that likes MS Access Programming) and you are much more than that. I figured it out how to fix that issue after a couple of hours digging.

Would you mind to check this code please?

Code:

Option Compare Database
Option Explicit

Private mlngIcon As Long
Private mstrHeading As String
Private mstrMessage As String

Private Const APP_SYSTRAY_ID = 999

Private Const NOTIFYICON_VERSION = &H3

Private Const NIF_MESSAGE = &H1
Private Const NIF_ICON = &H2
Private Const NIF_TIP = &H4
Private Const NIF_STATE = &H8
Private Const NIF_INFO = &H10

Private Const NIM_ADD = &H0
Private Const NIM_MODIFY = &H1
Private Const NIM_DELETE = &H2
Private Const NIM_SETFOCUS = &H3
Private Const NIM_SETVERSION = &H4
Private Const NIM_VERSION = &H5

Private Const NIS_HIDDEN = &H1
Private Const NIS_SHAREDICON = &H2

Private Const NIIF_NONE = &H0
Private Const NIIF_INFO = &H1
Private Const NIIF_WARNING = &H2
Private Const NIIF_ERROR = &H3
Private Const NIIF_GUID = &H5
Private Const NIIF_ICON_MASK = &HF
Private Const NIIF_NOSOUND = &H10
   
Private Const WM_USER = &H400
Private Const NIN_BALLOONSHOW = (WM_USER + 2)
Private Const NIN_BALLOONHIDE = (WM_USER + 3)
Private Const NIN_BALLOONTIMEOUT = (WM_USER + 4)
Private Const NIN_BALLOONUSERCLICK = (WM_USER + 5)

Private Const NOTIFYICONDATA_V1_SIZE As Long = 88
Private Const NOTIFYICONDATA_V2_SIZE As Long = 488
Private Const NOTIFYICONDATA_V3_SIZE As Long = 504
Private NOTIFYICONDATA_SIZE As Long

Private Type GUID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(7) As Byte
End Type

#If VBA7 Then
Private Type NOTIFYICONDATA
  cbSize As Long
  hwnd As LongPtr
  uID As Long
  uFlags As Long
  uCallbackMessage As Long
  hIcon As LongPtr
  szTip As String * 128
  dwState As Long
  dwStateMask As Long
  szInfo As String * 256
  uTimeoutAndVersion As Long
  szInfoTitle As String * 64
  dwInfoFlags As Long
  guidItem As GUID
End Type
#Else
Private Type NOTIFYICONDATA
  cbSize As Long
  hwnd As Long
  uID As Long
  uFlags As Long
  uCallbackMessage As Long
  hIcon As Long
  szTip As String * 128
  dwState As Long
  dwStateMask As Long
  szInfo As String * 256
  uTimeoutAndVersion As Long
  szInfoTitle As String * 64
  dwInfoFlags As Long
  guidItem As GUID
#End If


#If VBA7 Then

Private Declare PtrSafe Function Shell_NotifyIcon Lib "shell32.dll" _
   Alias "Shell_NotifyIconA" _
  (ByVal dwMessage As LongPtr, _
   lpData As NOTIFYICONDATA) As LongPtr

Private Declare PtrSafe Function GetFileVersionInfoSize Lib "version.dll" _
   Alias "GetFileVersionInfoSizeA" _
  (ByVal lptstrFilename As String, _
   lpdwHandle As Long) As Long

Private Declare PtrSafe Function GetFileVersionInfo Lib "version.dll" _
   Alias "GetFileVersionInfoA" _
  (ByVal lptstrFilename As String, _
   ByVal dwHandle As LongPtr, _
   ByVal dwLen As LongPtr, _
   lpData As Any) As Long
   
Private Declare PtrSafe Function VerQueryValue Lib "version.dll" _
   Alias "VerQueryValueA" _
  (pBlock As Any, _
   ByVal lpSubBlock As String, _
   lpBuffer As Any, _
   nVerSize As Long) As LongPtr

Private Declare PtrSafe Sub CopyMemory Lib "kernel32" _
   Alias "RtlMoveMemory" _
  (Destination As Any, _
   Source As Any, _
   ByVal Length As LongPtr)
#Else
Private Declare Function Shell_NotifyIcon Lib "shell32.dll" _
   Alias "Shell_NotifyIconA" _
  (ByVal dwMessage As Long, _
   lpData As NOTIFYICONDATA) As Long

Private Declare Function GetFileVersionInfoSize Lib "version.dll" _
   Alias "GetFileVersionInfoSizeA" _
  (ByVal lptstrFilename As String, _
   lpdwHandle As Long) As Long

Private Declare Function GetFileVersionInfo Lib "version.dll" _
   Alias "GetFileVersionInfoA" _
  (ByVal lptstrFilename As String, _
   ByVal dwHandle As Long, _
   ByVal dwLen As Long, _
   lpData As Any) As Long
   
Private Declare Function VerQueryValue Lib "version.dll" _
   Alias "VerQueryValueA" _
  (pBlock As Any, _
   ByVal lpSubBlock As String, _
   lpBuffer As Any, _
   nVerSize As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" _
   Alias "RtlMoveMemory" _
  (Destination As Any, _
   Source As Any, _
   ByVal Length As Long)
#End If

Private Const WM_GETICON = &H7F
                                 
Private Const WM_SETICON = &H80
Private Const IMAGE_BITMAP = 0
Private Const IMAGE_ICON = 1
Private Const IMAGE_CURSOR = 2
Private Const LR_LOADFROMFILE = &H10
                                          
Private Const ICON_SMALL = 0&
Private Const ICON_BIG = 1&

#If VBA7 Then

Private Declare PtrSafe Function apiLoadImage Lib "user32" _
   Alias "LoadImageA" _
   (ByVal hInst As LongPtr, _
   ByVal lpszName As String, _
   ByVal uType As LongPtr, _
   ByVal cxDesired As LongPtr, _
   ByVal cyDesired As LongPtr, _
   ByVal fuLoad As LongPtr) _
   As Long

Private Declare PtrSafe Function apiSendMessageLong Lib "user32" _
   Alias "SendMessageA" _
   (ByVal hwnd As LongPtr, _
   ByVal wMsg As Long, _
   ByVal wParam As LongPtr, _
   ByVal lParam As LongPtr) _
   As LongPtr
#Else
Private Declare Function apiLoadImage Lib "user32" _
   Alias "LoadImageA" _
   (ByVal hInst As Long, _
   ByVal lpszName As String, _
   ByVal uType As Long, _
   ByVal cxDesired As Long, _
   ByVal cyDesired As Long, _
   ByVal fuLoad As Long) _
   As Long

Private Declare Function apiSendMessageLong Lib "user32" _
   Alias "SendMessageA" _
   (ByVal hWnd As Long, _
   ByVal wMsg As Long, _
   ByVal wParam As Long, _
   ByVal lParam As Long) _
   As Long
#End If
Private Const SHGFI_ICON = &H100
Private Const SHGFI_DISPLAYNAME = &H200
Private Const SHGFI_TYPENAME = &H400
Private Const SHGFI_ATTRIBUTES = &H800
Private Const SHGFI_ICONLOCATION = &H1000

Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const MAX_PATH = 260

Private Type SHFILEINFO
   hIcon As LongPtr
   iIcon As LongPtr
   dwAttributes As LongPtr
   szDisplayName As String * MAX_PATH
   szTypeName As String * 80
End Type

#If VBA7 Then
Private Declare PtrSafe Function apiSHGetFileInfo Lib "shell32.dll" _
   Alias "SHGetFileInfoA" _
   (ByVal pszPath As String, _
    ByVal dwFileAttributes As LongPtr, _
    psfi As SHFILEINFO, _
    ByVal cbSizeFileInfo As LongPtr, _
    ByVal uFlags As LongPtr) _
    As LongPtr
        
Private Declare PtrSafe Function apiDestroyIcon Lib "user32" _
   Alias "DestroyIcon" _
   (ByVal hIcon As LongPtr) _
   As LongPtr
#Else
Private Declare Function apiSHGetFileInfo Lib "shell32.dll" _
   Alias "SHGetFileInfoA" _
   (ByVal pszPath As String, _
    ByVal dwFileAttributes As Long, _
    psfi As SHFILEINFO, _
    ByVal cbSizeFileInfo As Long, _
    ByVal uFlags As Long) _
    As Long
        
Private Declare Function apiDestroyIcon Lib "user32" _
   Alias "DestroyIcon" _
   (ByVal hIcon As Long) _
   As Long
#End If

Private psfi As SHFILEINFO

Private Const SW_HIDE = 0
Private Const SW_SHOWNORMAL = 1
Private Const SW_SHOWMINIMIZED = 2
Private Const SW_SHOWMAXIMIZED = 3

#If VBA7 Then
Private Declare PtrSafe Function apiShowWindow Lib "user32" _
   Alias "ShowWindow" _
   (ByVal hwnd As LongPtr, _
   ByVal nCmdShow As LongPtr) _
   As LongPtr
#Else
Private Declare Function apiShowWindow Lib "user32" _
   Alias "ShowWindow" _
   (ByVal hWnd As Long, _
   ByVal nCmdShow As Long) _
   As Long
#End If

Private Sub ShellTrayAdd()
   
   Dim nID As NOTIFYICONDATA
   
   If NOTIFYICONDATA_SIZE = 0 Then SetShellVersion
   
   With nID
   
      .cbSize = NOTIFYICONDATA_SIZE
      .hwnd = Application.hWndAccessApp
      
      .uID = APP_SYSTRAY_ID
      .uFlags = NIF_MESSAGE Or NIF_ICON Or NIF_TIP
      .dwState = NIS_SHAREDICON
      .hIcon = fSetIcon(GetAppIcon)
      
      .szTip = "DHLGM Message Service" & vbNullChar
      .uTimeoutAndVersion = NOTIFYICON_VERSION
      
   End With
   
   Call Shell_NotifyIcon(NIM_ADD, nID)
   
   Call Shell_NotifyIcon(NIM_SETVERSION, nID)
       
End Sub

Private Sub ShellTrayRemove()

   Dim nID As NOTIFYICONDATA
   
   If NOTIFYICONDATA_SIZE = 0 Then SetShellVersion
      
   With nID
      .cbSize = NOTIFYICONDATA_SIZE
      .hwnd = Application.hWndAccessApp
      .uID = APP_SYSTRAY_ID
   End With
   
   Call Shell_NotifyIcon(NIM_DELETE, nID)
   Call apiDestroyIcon(nID.hIcon)
End Sub

Private Sub ShellTrayModifyTip(nIconIndex As Long)

   Dim nID As NOTIFYICONDATA

   If NOTIFYICONDATA_SIZE = 0 Then SetShellVersion
   
   With nID
      .cbSize = NOTIFYICONDATA_SIZE
      .hwnd = Application.hWndAccessApp
      .uID = APP_SYSTRAY_ID
      .uFlags = NIF_INFO
      .dwInfoFlags = nIconIndex
      
      .szInfoTitle = mstrHeading & vbNullChar
      .szInfo = mstrMessage & vbNullChar
   End With

   Call Shell_NotifyIcon(NIM_MODIFY, nID)

End Sub

Private Sub SetShellVersion()

   Select Case True
      Case IsShellVersion(6)
         NOTIFYICONDATA_SIZE = NOTIFYICONDATA_V3_SIZE
      
      Case IsShellVersion(5)
         NOTIFYICONDATA_SIZE = NOTIFYICONDATA_V2_SIZE
      
      Case Else
         NOTIFYICONDATA_SIZE = NOTIFYICONDATA_V1_SIZE
   End Select

End Sub

Private Function IsShellVersion(ByVal version As LongPtr) As Boolean

   Dim nBufferSize As Long
   Dim nUnused As Long
   Dim lpBuffer As LongPtr
   Dim nVerMajor As Integer
   Dim bBuffer() As Byte
   
   Const sDLLFile As String = "shell32.dll"
   
   nBufferSize = GetFileVersionInfoSize(sDLLFile, nUnused)
   
   If nBufferSize > 0 Then
    
      ReDim bBuffer(nBufferSize - 1) As Byte
    
      Call GetFileVersionInfo(sDLLFile, 0&, nBufferSize, bBuffer(0))
    
      If VerQueryValue(bBuffer(0), "\", lpBuffer, nUnused) = 1 Then
         
         CopyMemory nVerMajor, ByVal lpBuffer + 10, 2
        
         IsShellVersion = nVerMajor >= version
      
      End If
    
   End If
  
End Function

Private Function GetSelectedOptionIndex() As LongPtr

    GetSelectedOptionIndex = 2
                            
End Function

Public Property Get Icon() As btIcon
    Icon = mlngIcon
End Property

Public Property Let Icon(ByVal lngIcon As btIcon)
    mlngIcon = lngIcon
End Property

Public Property Get Heading() As String
    Heading = mstrHeading
End Property

Public Property Let Heading(ByVal strHeading As String)
    mstrHeading = strHeading
End Property

Public Property Get Message() As String
    Message = mstrMessage
End Property

Public Property Let Message(ByVal strMessage As String)
    mstrMessage = strMessage
End Property

Public Sub Show()
       Call ShellTrayAdd
       ShellTrayModifyTip mlngIcon
End Sub

Public Sub Hide()
   ShellTrayRemove
End Sub

Private Function fSetIcon(strIconPath As String) As Long
Dim hIcon As Long
   hIcon = apiLoadImage(0&, strIconPath, IMAGE_ICON, 16&, 16&, LR_LOADFROMFILE)
   If hIcon Then
      fSetIcon = hIcon
   End If
End Function

Public Function GetAppIcon() As String
    Dim dbs As DAO.Database, prp As Property
    Const conPropNotFoundError = 3270
    On Error GoTo GetAppIcon_Error
   
    Beep
    Set dbs = CurrentDb
    GetAppIcon = dbs.Properties("AppIcon")

ExitHere:
   Exit Function

GetAppIcon_Error:

    Select Case Err.Number
    Case 3270 'PropertyC Not Found
        'db doesn't have an associated icon - no message needed
       ' MsgBox "Current Database needs to have a custom icon", vbCritical, "No Icon Found"
        Resume ExitHere
    Case Else
        MsgBox "An Unexpected Error has occured please inform IT Support Error " & Err.Number & " " & Err.Description & " in procedure GetAppIcon of Class Module BalloonTooltip", vbCritical, "db2"
        Resume ExitHere
    End Select
    'Debug Only
    Resume

End Function

Thank You,
Margarit

isladogs · May 24, 2018

Hi Margarit

Well I am impressed.
I really didn't expect you to take up the challenge ... and it very nearly worked as supplied
The code you suggested compiled successfully in 64-bit but on opening the main form, Access still crashed.

However I made a few minor changes to the code & got it working perfectly in 64-bit. Hooray....

The changes needed to your code were to the following
a) IsShellVersion - updated to work in both bitnesses
b) GetSelectedOptionIndex - the original code was fine
c) Private Type SHFILEINFO - the original code was fine

The working version is attached - I've also added the updated version to the sample databases area.
As the balloon tooltips feature is also used in my 'Attention Seeking example database, that's also been updated

Many thanks again - this problem had defeated several experienced developers

ino_mart · Mar 4, 2020

All

I converted the code so it is now usable in both 32bit and 64bit of MsAccess

isladogs · Mar 4, 2020

Thanks ... but are you aware that it had already been converted successfully almost two years ago by riti90 in post #27

ino_mart · Mar 4, 2020

isladogs said:
Thanks ... but are you aware that it had already been converted successfully almost two years ago by riti90 in post #27

Actually I was aware, but now others will have a MDB which will work immediately without changing any code. That was my purpose but I did not describe this well.

smtazulislam · Aug 8, 2021

riti90 said:
Sub TestDKInputBox()
Dim x

x = InputBoxDK("Type your password here.", "Password Required")
If x = "" Then End
If x <> "yourpassword" Then
MsgBox "You didn't enter a correct password."
End
End If

MsgBox "Welcome Creator!", vbExclamation

End Sub

[/CODE]

and this on command click event

Code:

Private Sub Command1_Click() Call TestDKInputBox End Sub

Why it is not working ?

Code:

Dim x As String
    x = InputBoxDK("Type your password here.", "Password Required")
    If x = "" Then End
    If x <> DLookup("*", "Users", "UserName = '" & me.txtUserName & " ' And "Password = '" & x & "' ")   Then
        MsgBox "You didn't enter a correct password."
    Exit Sub
    Else
        DoCmd.OpenForm "form2", acNormal
    End If

isladogs · Aug 8, 2021

smtazulislam said:
Why it is not working ?

What does that mean exactly? What does happen?
Did you copy the entire code needed for InputBoxDK?

Have a look at the code on my website

Masked Input Box

This article contains an updated version of the masked input box code and works in 32-bit and 64-bit Access

www.isladogs.co.uk

EDIT: You have a syntax error in the DLookup line. It should be as shown below with no quote mark before Password:

Rich (BB code):

If x<>DLookup("*", "Users", "UserName = '" & me.txtUserName & "' And Password = '" & x & "'")

Cotswold · Aug 8, 2021

Hi K99, Maybe you would you get the result you need if you changed the field colours,
setting the ForeColor to be the same as the BackColor?

smtazulislam · Aug 8, 2021

I tried my self. not work. Can have a review for where I did mistake.

isladogs · Aug 8, 2021

I will ask again. What does 'not work' mean in this case?

smtazulislam · Aug 8, 2021

isladogs said:
I will ask again. What does 'not work' mean in this case?

When I enter the password then my form2 is not open.
Runtime Error 3075...

Edit: / I would try to if my password is incorrect then have a "message "
And if password is correct then open "form2"

isladogs · Aug 8, 2021

Try this

Code:

If x<>DLookup("Passwrord", "Users", "UserName = '" & me.txtUserName & "'") Then

However, even if you get it working, just using a password input mask in your table is completely insecure as it is very easy to remove making all passwords visible. I did that so I knew what password to enter. I didn't get error 3075 and the form opened with the correct password. However it didn't block an incorrect password.

I can't spare any more time on this now but I don't think what you are trying to do is secure enough to use.

Strongly recommend you replace all your code and use strong encryption if you must store passwords. For example, see

Password Login

This utility has been provided to manage user passwords and also keep a user session log

www.isladogs.co.uk

Hide Password in Input Box (1 Viewer)

MVP / VIP

New member

MVP / VIP

New member

MVP / VIP

New member

Registered User.

MVP / VIP

Registered User.

MVP / VIP

Attachments

Registered User.

Attachments

MVP / VIP

Registered User.

Member

MVP / VIP

Active member

Member

Attachments

MVP / VIP

Member

MVP / VIP

Similar threads

Users who are viewing this thread