modinputboxpw.bas

1、以DLL形式提供医生工作站 2、 根据【检查项目】

Attribute VB_Name = "modInputBoxPW"
'  ============================================
    
  '模块中：
  Option Explicit
    
  '====   API   declarations   ============================
  Private Type CWPSTRUCT
                  lParam   As Long
                  wParam   As Integer
                  message   As Long
                  hwnd   As Long
  End Type
    
  Private Const WH_CALLWNDPROC = 4
  Private Const WM_CREATE = &H1
    
  Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) 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 GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
  Private Const EM_SETPASSWORDCHAR = &HCC           'pw   char   code   in   wp
  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
    
  '====   module   =========================================
    
  Private Const EDIT_CLASS = "Edit"           'classname   of   the   "TextBox"   in   an   InputBox   window
  Dim m_hWinHook     As Long     'stores   handle   to   the   installed   hook
    
  Public Function InputBoxPW(Prompt As String, Optional Title, Optional Default As String = "", Optional XPos, Optional YPos, Optional HelpFile As String = "", Optional Context As Long = 0) As String
          'Adds   PasswordChar   masking   to   the   standard   VB   InputBox.
          'All   args   and   return   identical   to   InputBox.
          Dim sTitle     As String
            
          If IsMissing(Title) Then
                  sTitle = App.Title
          Else
                  sTitle = Title
          End If
            
          'Bad   InputBox   arguments   can   cause   a   VB   runtime   error.
          'If   that   happens,we   want   to   know   about   it,   but   we   cannot
          'allow   VB   to   raise   the   error   while   the   hook   is   active   or   it
          'will   crash   the   IDE   and   cause   a   system   error.
          On Error GoTo EH_Proc
            
          'activate   the   hook...
          m_hWinHook = SetWindowsHookEx(WH_CALLWNDPROC, AddressOf CallWndProc, 0&, App.ThreadID)
            
          If IsMissing(XPos) Or IsMissing(YPos) Then
                  InputBoxPW = InputBox(Prompt, sTitle, Default, , , HelpFile, Context)
          Else
                  InputBoxPW = InputBox(Prompt, sTitle, Default, XPos, YPos, HelpFile, Context)
          End If
            
          'should   be   unhooked   by   now,   but   just   in   case...
          Unhook
            
          Exit Function     'done   (skip   error   handler)   ======>>>
    
EH_Proc:     'error   occurred   (bad   InputBox   argument)
          Unhook   'deactivate   hook
          'now   it's   safe   to   raise   the   error
          Err.Raise Err.Number
  End Function
    
  Private Function CallWndProc(ByVal ncode As Long, ByVal wParam As Long, Info As CWPSTRUCT) As Long
          Dim sCls     As String * 6
    
          'We   want   to   be   notified   when   Edit   (TextBox)   window   is   created.
          'WM_CREATE   is   sent   as   soon   as   it's   created,   but   before   it's   visible.
          If Info.message = WM_CREATE Then
                  'Other   windows   for   the   InputBox   are   also   being   created,
                  'but   we're   only   interested   in   the   Edit   window...
                  GetClassName Info.hwnd, sCls, 5
                  If left$(sCls, 4) = EDIT_CLASS Then             'It's   the   Edit   window
                          'set   it's   password   char..
                          SendMessage Info.hwnd, EM_SETPASSWORDCHAR, Asc("*"), ByVal 0
                          Unhook   'deactivate   hook
                  End If
          End If
  End Function
    
  Private Sub Unhook()
          If m_hWinHook <> 0& Then           'not   already   unhooked
                  'No   point   testing   return   value   here   because
                  'if   it   fails,   we'll   get   a   system   error   anyway   :-)
                  UnhookWindowsHookEx m_hWinHook
                  m_hWinHook = 0&       'indicate   unhooked
          End If
  End Sub