home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 4_2005-2006.ISO / data / Zips / PassBox___201883982006.psc / PassBox / Controls / PassBox.ctl
Text File  |  2006-09-08  |  36KB  |  893 lines
  1. VERSION 5.00
  2. Begin VB.UserControl PassBox 
  3.    AutoRedraw      =   -1  'True
  4.    BackColor       =   &H80000010&
  5.    ClientHeight    =   540
  6.    ClientLeft      =   0
  7.    ClientTop       =   0
  8.    ClientWidth     =   2460
  9.    BeginProperty Font 
  10.       Name            =   "Tahoma"
  11.       Size            =   8.25
  12.       Charset         =   0
  13.       Weight          =   400
  14.       Underline       =   0   'False
  15.       Italic          =   0   'False
  16.       Strikethrough   =   0   'False
  17.    EndProperty
  18.    ScaleHeight     =   36
  19.    ScaleMode       =   3  'Pixel
  20.    ScaleWidth      =   164
  21.    Begin VB.Label Label1 
  22.       AutoSize        =   -1  'True
  23.       BackStyle       =   0  'Transparent
  24.       Caption         =   "PassBox Control"
  25.       BeginProperty Font 
  26.          Name            =   "Tahoma"
  27.          Size            =   8.25
  28.          Charset         =   0
  29.          Weight          =   700
  30.          Underline       =   0   'False
  31.          Italic          =   0   'False
  32.          Strikethrough   =   0   'False
  33.       EndProperty
  34.       Height          =   195
  35.       Left            =   180
  36.       TabIndex        =   0
  37.       Top             =   180
  38.       Visible         =   0   'False
  39.       Width           =   1365
  40.    End
  41. End
  42. Attribute VB_Name = "PassBox"
  43. Attribute VB_GlobalNameSpace = False
  44. Attribute VB_Creatable = True
  45. Attribute VB_PredeclaredId = False
  46. Attribute VB_Exposed = False
  47. '***************************************************************************************
  48. ' Control:   PassBox
  49. ' Date:      08/09/2006
  50. ' Author:    BioHazardMX
  51. ' Purpose:   PassBox UserControl module
  52. ' Version:   0.8
  53. ' Requires:  OleGuids.tlb (IDE only)
  54. '***************************************************************************************
  55. ' ChangeLog:
  56. ' [Version 0.8]
  57. '  * New CueBanner and BalloonTip support under WinXP!
  58. '  * Fixed bug with MouseMove event and Button mask
  59. '  * Fixed bug with BackColor and ForeColor not applying at startup
  60. '  * Minimum Height is now restricted to 19 pixels (like VB TextBoxes)
  61. ' [Version 0.7]
  62. '  * Code re-arranged and commented
  63. '  * Added standard events
  64. '  * Fixed bug with scrollbars showing in single line mode
  65. '  * Added Back-Fore color properties
  66. '  * Fixed bug with Shift mask in WM_KEYDOWN-UP
  67. ' [Version 0.6]
  68. '  * This was the first public version (uploaded to planetsourcecode.com)
  69. '  * Fixed bug with Enter key and IPAO
  70. '  * Added "Can..." properties
  71. '  * Fixed bug in Get/Set SelLength
  72. ' [Version 0.5]
  73. '  * New IPAO for focus (fixed Tab key issues)
  74. '  * New "Locked" property
  75. ' [Version 0.4]
  76. '  * Fixed bug with "Text" property, no more crashes (using GetWindowTextLength)
  77. ' [Version 0.3]
  78. '  * Fixed repeated AttachMessage causing an "Message Already Handled" message box
  79. '  * Added scrollbars for multiline mode
  80. '  * Fixed multiline & password styles, now can't be mixed
  81. ' [Version 0.2]
  82. '  * Added Single line AutoHScroll mode
  83. '  * Added Multiline mode
  84. '  * Fixed subclassing error with WM_KEYUP and Tab key
  85. ' [Version 0.1]
  86. '  * First version, basic Password edit control
  87. '***************************************************************************************
  88.  Option Explicit
  89. '***************************************************************************************
  90. ' Constants
  91. '***************************************************************************************
  92. '---Window Messages
  93. Private Const WM_MOUSEACTIVATE As Long = &H21
  94. Private Const WM_CLEAR As Long = &H303
  95. Private Const WM_CHAR As Long = &H102
  96. Private Const WM_USER As Long = &H400
  97. Private Const WM_SETFONT As Long = &H30
  98. Private Const WM_SETTEXT As Long = &HC
  99. Private Const WM_GETTEXT As Long = &HD
  100. Private Const WM_SETFOCUS As Long = &H7
  101. Private Const WM_KILLFOCUS As Long = &H8
  102. Private Const WM_KEYDOWN As Long = &H100
  103. Private Const WM_KEYUP As Long = &H101
  104. Private Const WM_LBUTTONDBLCLK As Long = &H203
  105. Private Const WM_LBUTTONDOWN As Long = &H201
  106. Private Const WM_LBUTTONUP As Long = &H202
  107. Private Const WM_MOUSEMOVE As Long = &H200
  108. Private Const WM_RBUTTONDBLCLK As Long = &H206
  109. Private Const WM_RBUTTONDOWN As Long = &H204
  110. Private Const WM_RBUTTONUP As Long = &H205
  111. Private Const WM_COMMAND As Long = &H111
  112. '---Window Styles
  113. Private Const WS_CHILD As Long = &H40000000
  114. Private Const WS_BORDER As Long = &H800000
  115. Private Const WS_TABSTOP As Long = &H10000
  116. Private Const WS_VISIBLE As Long = &H10000000
  117. Private Const WS_CHILDWINDOW As Long = (WS_CHILD)
  118. Private Const WS_EX_CLIENTEDGE As Long = &H200&
  119. Private Const WS_EX_NOPARENTNOTIFY As Long = &H4&
  120. '---Edit Messages
  121. Private Const EM_CANPASTE As Long = (WM_USER + 50)
  122. Private Const EM_CANREDO As Long = (WM_USER + 85)
  123. Private Const EM_CANUNDO As Long = &HC6
  124. Private Const EM_GETLIMITTEXT As Long = (WM_USER + 37)
  125. Private Const EM_GETSEL As Long = &HB0
  126. Private Const EM_LIMITTEXT As Long = &HC5
  127. Private Const EM_REPLACESEL As Long = &HC2
  128. Private Const EM_SETLIMITTEXT As Long = EM_LIMITTEXT
  129. Private Const EM_SETSEL As Long = &HB1
  130. Private Const EM_UNDO As Long = &HC7
  131. Private Const EM_GETPASSWORDCHAR As Long = &HD2
  132. Private Const EM_SETPASSWORDCHAR As Long = &HCC
  133. Private Const ECM_FIRST As Long = &H1500
  134. Private Const EM_SETCUEBANNER As Long = (ECM_FIRST + 1)
  135. Private Const EM_GETCUEBANNER As Long = (ECM_FIRST + 2)    '// Set the cue banner with the lParm = LPCWSTR
  136. Private Const EM_SHOWBALLOONTIP As Long = (ECM_FIRST + 3)     '// Show a balloon tip associated to the edit control
  137. Private Const EM_HIDEBALLOONTIP As Long = (ECM_FIRST + 4)
  138. '---Edit Styles
  139. Private Const ES_CENTER As Long = &H1&
  140. Private Const ES_LEFT As Long = &H0&
  141. Private Const ES_LOWERCASE As Long = &H10&
  142. Private Const ES_MULTILINE As Long = &H4&
  143. Private Const ES_NUMBER As Long = &H2000&
  144. Private Const ES_READONLY As Long = &H800&
  145. Private Const ES_RIGHT As Long = &H2&
  146. Private Const ES_UPPERCASE As Long = &H8&
  147. Private Const ES_PASSWORD As Long = &H20&
  148. Private Const ES_AUTOHSCROLL As Long = &H80&
  149. Private Const ES_AUTOVSCROLL As Long = &H40&
  150. Private Const ES_WANTRETURN As Long = &H1000&
  151. '---Edit Notification Messages
  152. Private Const EN_CHANGE As Long = &H300
  153. Private Const EN_ERRSPACE As Long = &H500
  154. Private Const EN_HSCROLL As Long = &H601
  155. Private Const EN_KILLFOCUS As Long = &H200
  156. Private Const EN_SELCHANGE As Long = &H702
  157. Private Const EN_SETFOCUS As Long = &H100
  158. Private Const EN_VSCROLL As Long = &H602
  159. '---Misc API Constants
  160. Private Const MK_ALT As Long = &H20
  161. Private Const MK_CONTROL As Long = &H8
  162. Private Const MK_LBUTTON As Long = &H1
  163. Private Const MK_MBUTTON As Long = &H10
  164. Private Const MK_RBUTTON As Long = &H2
  165. Private Const MK_SHIFT As Long = &H4
  166. Private Const VK_TAB As Long = &H9
  167. Private Const MA_NOACTIVATE As Long = 3
  168. Private Const GWL_EXSTYLE As Long = -20
  169. Private Const GWL_STYLE As Long = -16
  170. '---LOGFONT Constants
  171. Private Const LOGPIXELSX As Long = &H58
  172. Private Const LOGPIXELSY As Long = &H5A
  173. Private Const LF_FACESIZE As Long = &H20
  174. Private Const FW_NORMAL As Long = &H190
  175. Private Const FW_BOLD As Long = &H2BC
  176. Private Const FF_DONTCARE As Long = &H0
  177. Private Const DEFAULT_PITCH As Long = &H0
  178. Private Const DEFAULT_CHARSET As Long = &H1
  179. Private Const DEFAULT_QUALITY As Long = &H0
  180. Private Const DRAFT_QUALITY As Long = &H1
  181. Private Const PROOF_QUALITY As Long = &H2
  182. Private Const NONANTIALIASED_QUALITY As Long = &H3
  183. Private Const ANTIALIASED_QUALITY As Long = &H4
  184. '---Autocomplete Flags
  185. Private Const SHACF_DEFAULT As Long = &H0
  186. Private Const SHACF_FILESYSTEM As Long = &H1
  187. Private Const SHACF_URLHISTORY As Long = &H2
  188. Private Const SHACF_URLMRU As Long = &H4
  189. Private Const SHACF_USETAB As Long = &H8
  190. Private Const SHACF_URLALL As Long = (SHACF_URLHISTORY Or SHACF_URLMRU)
  191. Private Const SHACF_FILESYS_ONLY As Long = &H10
  192. Private Const SHACF_FILESYS_DIRS As Long = &H20
  193. Private Const SHACF_AUTOSUGGEST_FORCE_ON As Long = &H10000000
  194. Private Const SHACF_AUTOSUGGEST_FORCE_OFF As Long = &H20000000
  195. Private Const SHACF_AUTOAPPEND_FORCE_ON As Long = &H40000000
  196. Private Const SHACF_AUTOAPPEND_FORCE_OFF As Long = &H80000000
  197. Private Const S_OK = 0
  198. '---Scrollbar Styles
  199. Private Const SB_BOTH As Long = 3
  200. Private Const SB_HORZ As Long = 0
  201. Private Const SB_VERT As Long = 1
  202. '***************************************************************************************
  203. ' User Defined Types
  204. '***************************************************************************************
  205. '---LOGFONT
  206. Private Type LOGFONT
  207.   lfHeight As Long
  208.   lfWidth As Long
  209.   lfEscapement As Long
  210.   lfOrientation As Long
  211.   lfWeight As Long
  212.   lfItalic As Byte
  213.   lfUnderline As Byte
  214.   lfStrikeOut As Byte
  215.   lfCharSet As Byte
  216.   lfOutPrecision As Byte
  217.   lfClipPrecision As Byte
  218.   lfQuality As Byte
  219.   lfPitchAndFamily As Byte
  220.   lfFaceName(LF_FACESIZE) As Byte
  221. End Type
  222. '---EDITBALLOONTIP
  223. Private Type EDITBALLOONTIP
  224.   cbStruct As Long
  225.   pszTitle As Long
  226.   pszText As Long
  227.   ttiIcon As Long
  228. End Type
  229. '---OSVERSIONINFO
  230. Private Type OSVERSIONINFO
  231.   dwVersionInfoSize As Long
  232.   dwMajorVersion As Long
  233.   dwMinorVersion As Long
  234.   dwBuildNumber As Long
  235.   dwPlatformId As Long
  236.   szCSDVersion(0 To 127) As Byte
  237. End Type
  238. '***************************************************************************************
  239. ' Enumerations
  240. '***************************************************************************************
  241. Public Enum BalloonTipIconConstants
  242.   TTI_NONE = 0
  243.   TTI_INFO = 1
  244.   TTI_WARNING = 2
  245.   TTI_ERROR = 3
  246. End Enum
  247. '***************************************************************************************
  248. ' API Declares
  249. '***************************************************************************************
  250. '---General API Declarations
  251. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
  252. Private Declare Function CreateFontIndirect Lib "GDI32.dll" Alias "CreateFontIndirectA" (ByRef lpLogFont As LOGFONT) As Long
  253. Private Declare Function CreateWindowEx Lib "User32.dll" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hwndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, ByRef lpParam As Any) As Long
  254. Private Declare Function DeleteObject Lib "GDI32" (ByVal hObject As Long) As Long
  255. Private Declare Function DestroyWindow Lib "User32.dll" (ByVal hWnd As Long) As Long
  256. Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hwndParent As Long, ByVal hwndChildAfter As Long, ByVal lpszClass As String, ByVal lpszWindow As String) As Long
  257. Private Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Integer
  258. Private Declare Function GetDC Lib "User32.dll" (ByVal hWnd As Long) As Long
  259. Private Declare Function GetDeviceCaps Lib "GDI32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
  260. Private Declare Function GetFocus Lib "User32.dll" () As Long
  261. Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInfo As OSVERSIONINFO) As Long
  262. Private Declare Function GetWindowLong Lib "User32.dll" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
  263. Private Declare Function GetWindowText Lib "User32.dll" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
  264. Private Declare Function GetWindowTextLength Lib "User32.dll" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As Long
  265. Private Declare Function LockWindowUpdate Lib "User32.dll" (ByVal hWndLock As Long) As Long
  266. Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
  267. Private Declare Function SelectObject Lib "GDI32" (ByVal hDC As Long, ByVal hObject As Long) As Long
  268. Private Declare Function SendMessage Lib "User32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
  269. Private Declare Function SendMessageLong Lib "User32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  270. Private Declare Function SendMessageString Lib "User32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
  271. Private Declare Function SendMessageLongW Lib "user32" Alias "SendMessageW" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  272. Private Declare Function SendMessageW Lib "user32" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
  273. Private Declare Function SetBkColor Lib "GDI32.dll" (ByVal hDC As Long, ByVal crColor As Long) As Long
  274. Private Declare Function SetBkMode Lib "GDI32.dll" (ByVal hDC As Long, ByVal nBkMode As Long) As Long
  275. Private Declare Function SetFocus Lib "User32.dll" (ByVal hWnd As Long) As Long
  276. Private Declare Function SetFocusAPI Lib "user32" Alias "SetFocus" (ByVal hWnd As Long) As Long
  277. Private Declare Function SetWindowLong Lib "User32.dll" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  278. Private Declare Function SetWindowPos Lib "User32.dll" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cX As Long, ByVal cY As Long, ByVal wFlags As Long) As Long
  279. Private Declare Function SetWindowText Lib "User32.dll" Alias "SetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String) As Long
  280. Private Declare Function SHAutoComplete Lib "SHLWAPI.dll" (ByVal hWndEdit As Long, ByVal dwFlags As Long) As Long
  281. Private Declare Function ShowScrollBar Lib "User32.dll" (ByVal hWnd As Long, ByVal wBar As Long, ByVal bShow As Long) As Long
  282. '***************************************************************************************
  283. ' Variables, Classes and Implements
  284. '***************************************************************************************
  285. '---Misc Variables
  286. Private lTxtWnd As Long
  287. Private lhWnd As Long
  288. Private lhDC As Long
  289. Private lWidth As Long
  290. Private lHeight As Long
  291. Private lPtr As Long
  292. Private lStyle As Long
  293. Private lFont As LOGFONT
  294. Private hFont As Long
  295. Private bRunning As Boolean
  296. Private tIPAOHookStruct As IPAOHookStruct
  297. '---Property Variables
  298. Private lBackColor As Long
  299. Private lForeColor As Long
  300. Private lSBars As Long
  301. Private sText As String
  302. Private sPassChar As String
  303. Private bEnabled As Boolean
  304. Private bMultiLine As Boolean
  305. Private bLocked As Boolean
  306. Private bPassword As Boolean
  307. Private sCueBanner As String
  308. Private sTipTitle As String
  309. Private sTipText As String
  310. '---Implements
  311. Implements ISubclass
  312. '***************************************************************************************
  313. ' Events
  314. '***************************************************************************************
  315. Public Event Click()
  316. Public Event DblClick()
  317. Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  318. Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  319. Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  320. Public Event KeyDown(KeyCode As Integer, Shift As Integer)
  321. Public Event KeyPress(KeyAscii As Integer)
  322. Public Event KeyUp(KeyCode As Integer, Shift As Integer)
  323. Public Event Change()
  324. '***************************************************************************************
  325. ' Subclassing
  326. '***************************************************************************************
  327. '---MsgResponse Let
  328. Private Property Let ISubclass_MsgResponse(ByVal RHS As EMsgResponse)
  329.   '...'
  330. End Property
  331. '---MsgResponse Get
  332. Private Property Get ISubclass_MsgResponse() As EMsgResponse
  333.   ISubclass_MsgResponse = emrPreprocess
  334. End Property
  335. '---WindowProc
  336. Private Function ISubclass_WindowProc(ByVal hWnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  337. Dim lButton As MouseButtonConstants
  338. Dim lShift As ShiftConstants
  339. Dim iKeyCode As Integer, lNotify As Long
  340.   Select Case iMsg
  341.    '------------------------------------------------------------------------------
  342.    'Implement focus.  Code taken from vbAccelerator.com
  343.     Case WM_SETFOCUS
  344.       If (lTxtWnd = hWnd) Then
  345.         'The control itself
  346.          Dim pOleObject                  As IOleObject
  347.          Dim pOleInPlaceSite             As IOleInPlaceSite
  348.          Dim pOleInPlaceFrame            As IOleInPlaceFrame
  349.          Dim pOleInPlaceUIWindow         As IOleInPlaceUIWindow
  350.          Dim pOleInPlaceActiveObject     As IOleInPlaceActiveObject
  351.          Dim PosRect                     As RECT
  352.          Dim ClipRect                    As RECT
  353.          Dim FrameInfo                   As OLEINPLACEFRAMEINFO
  354.          Dim grfModifiers                As Long
  355.          Dim AcceleratorMsg              As Msg
  356.         'Get in-place frame and make sure it is set to our in-between
  357.         'implementation of IOleInPlaceActiveObject in order to catch
  358.         'TranslateAccelerator calls
  359.          Set pOleObject = Me
  360.          Set pOleInPlaceSite = pOleObject.GetClientSite
  361.          pOleInPlaceSite.GetWindowContext pOleInPlaceFrame, pOleInPlaceUIWindow, VarPtr(PosRect), VarPtr(ClipRect), VarPtr(FrameInfo)
  362.          CopyMemory pOleInPlaceActiveObject, tIPAOHookStruct.ThisPointer, 4
  363.          pOleInPlaceFrame.SetActiveObject pOleInPlaceActiveObject, vbNullString
  364.          If Not pOleInPlaceUIWindow Is Nothing Then
  365.            pOleInPlaceUIWindow.SetActiveObject pOleInPlaceActiveObject, vbNullString
  366.          End If
  367.          CopyMemory pOleInPlaceActiveObject, 0&, 4
  368.       Else
  369.         'The user control:
  370.          SetFocusAPI lhWnd
  371.       End If
  372.     Case WM_MOUSEACTIVATE
  373.       If GetFocus() <> lhWnd And GetFocus() <> lTxtWnd Then
  374.          SetFocusAPI UserControl.hWnd
  375.          ISubclass_WindowProc = MA_NOACTIVATE
  376.          Exit Function
  377.       Else
  378.          ISubclass_WindowProc = CallOldWindowProc(hWnd, iMsg, wParam, lParam)
  379.       End If
  380.    'End Implement focus.
  381.    '------------------------------------------------------------------------------
  382.    Case WM_LBUTTONDOWN, WM_RBUTTONDOWN
  383.      If iMsg = WM_LBUTTONDOWN Then lButton = vbLeftButton
  384.      If iMsg = WM_RBUTTONDOWN Then lButton = vbRightButton
  385.      If wParam <> 0 Then
  386.        If wParam = (wParam And MK_ALT) Then lShift = vbAltMask
  387.        If wParam = (wParam And MK_SHIFT) Then lShift = vbShiftMask
  388.        If wParam = (wParam And MK_CONTROL) Then lShift = vbCtrlMask
  389.      End If
  390.      RaiseEvent MouseDown(CInt(lButton), CInt(lShift), LoWord(lParam), HiWord(lParam))
  391.      
  392.    Case WM_LBUTTONUP, WM_RBUTTONUP
  393.      If iMsg = WM_LBUTTONUP Then lButton = vbLeftButton
  394.      If iMsg = WM_RBUTTONUP Then lButton = vbRightButton
  395.      If wParam <> 0 Then
  396.        If wParam = (wParam And MK_ALT) Then lShift = vbAltMask
  397.        If wParam = (wParam And MK_SHIFT) Then lShift = vbShiftMask
  398.        If wParam = (wParam And MK_CONTROL) Then lShift = vbCtrlMask
  399.      End If
  400.      RaiseEvent MouseUp(CInt(lButton), CInt(lShift), LoWord(lParam), HiWord(lParam))
  401.      RaiseEvent Click
  402.        
  403.    Case WM_MOUSEMOVE
  404.      If wParam <> 0 Then
  405.        If wParam = (wParam And MK_LBUTTON) Then lButton = vbLeftButton
  406.        If wParam = (wParam And MK_MBUTTON) Then lButton = vbMiddleButton
  407.        If wParam = (wParam And MK_RBUTTON) Then lButton = vbRightButton
  408.        If wParam = (wParam And MK_ALT) Then lShift = vbAltMask
  409.        If wParam = (wParam And MK_SHIFT) Then lShift = vbShiftMask
  410.        If wParam = (wParam And MK_CONTROL) Then lShift = vbCtrlMask
  411.      End If
  412.      RaiseEvent MouseMove(CInt(lButton), CInt(lShift), LoWord(lParam), HiWord(lParam))
  413.      
  414.    Case WM_KEYDOWN, WM_KEYUP
  415.      iKeyCode = LoWord(wParam)
  416.      If iMsg = WM_KEYDOWN Then RaiseEvent KeyDown(iKeyCode, pvGetShiftState)
  417.      If iMsg = WM_KEYUP Then RaiseEvent KeyUp(iKeyCode, pvGetShiftState)
  418.      
  419.    Case WM_CHAR
  420.      iKeyCode = LoWord(wParam)
  421.      RaiseEvent KeyPress(iKeyCode)
  422.      
  423.    Case WM_COMMAND
  424.      lNotify = HiWord(wParam)
  425.      If lNotify = EN_CHANGE Then RaiseEvent Change
  426.      
  427.  End Select
  428. End Function
  429. '***************************************************************************************
  430. ' Public Properties
  431. '***************************************************************************************
  432. '---hWnds
  433. Public Property Get hWnd() As Long
  434.  'The handle of the USERCONTROL (to put a PassBox in a toolbar, etc)
  435.   hWnd = lhWnd
  436. End Property
  437. Public Property Get hWndEdit() As Long
  438.  'The handle of the EDIT WINDOW (to attach Up-Down controls, etc)
  439.   hWndEdit = lTxtWnd
  440. End Property
  441. '---CanCut
  442. Public Property Get CanCut() As Boolean
  443.  'This can be used to update a toolbar or menu
  444.   If SelLength > 0 Then CanCut = True
  445. End Property
  446. '---CanCopy
  447. Public Property Get CanCopy() As Boolean
  448.  'This can be used to update a toolbar or menu
  449.   If SelLength > 0 Then CanCopy = True
  450. End Property
  451. '---CanPaste
  452. Public Property Get CanPaste() As Boolean
  453.  'This can be used to update a toolbar or menu
  454.   CanPaste = CBool(SendMessageLong(lTxtWnd, EM_CANPASTE, 0, 0))
  455. End Property
  456. '---CanUndo
  457. Public Property Get CanUndo() As Boolean
  458.  'This can be used to update a toolbar or menu
  459.   CanUndo = CBool(SendMessageLong(lTxtWnd, EM_CANUNDO, 0, 0))
  460. End Property
  461. '---CueBanner
  462. Public Property Get CueBanner() As String
  463.   CueBanner = sCueBanner
  464. End Property
  465. Public Property Let CueBanner(ByVal vData As String)
  466.   sCueBanner = vData
  467.   PropertyChanged ("CueBanner")
  468.   Call pvUpdateText
  469. End Property
  470. '---Text
  471. Public Property Get Text() As String
  472. Dim lLen As Long, sBuffer As String
  473.  'Retrieve the length of the window's text
  474.   lLen = GetWindowTextLength(lTxtWnd) + 1
  475.  'Allocate a buffer big enough to hold the string
  476.   sBuffer = String(lLen, vbNullChar)
  477.  'Fill the buffer with the window's text
  478.   Call GetWindowText(lTxtWnd, sBuffer, lLen)
  479.   sText = Left(sBuffer, Len(sBuffer) - 1)
  480.   Text = sText
  481. End Property
  482. Public Property Let Text(ByVal vData As String)
  483.   sText = vData
  484.   PropertyChanged ("Text")
  485.   Call pvUpdateText
  486. End Property
  487. '---PasswordChar
  488. Public Property Get PasswordChar() As String
  489.   PasswordChar = sPassChar
  490. End Property
  491. Public Property Let PasswordChar(ByVal vData As String)
  492.   sPassChar = vData
  493.   PropertyChanged ("PasswordChar")
  494.   Call pvUpdateStyles
  495. End Property
  496. '---ScrollBars
  497. Public Property Get ScrollBars() As ScrollBarConstants
  498.   ScrollBars = lSBars
  499. End Property
  500. Public Property Let ScrollBars(ByVal vData As ScrollBarConstants)
  501.   lSBars = vData
  502.   PropertyChanged ("ScrollBars")
  503.   Call pvUpdateStyles
  504. End Property
  505. '---Enabled
  506. Public Property Get Enabled() As Boolean
  507.   Enabled = bEnabled
  508. End Property
  509. Public Property Let Enabled(ByVal vData As Boolean)
  510.   bEnabled = vData
  511.   PropertyChanged ("Enabled")
  512.   Call pvUpdateStyles
  513. End Property
  514. '---Locked
  515. Public Property Get Locked() As Boolean
  516.   Locked = bLocked
  517. End Property
  518. Public Property Let Locked(ByVal vData As Boolean)
  519.   bLocked = vData
  520.   PropertyChanged ("Locked")
  521.   Call pvUpdateStyles
  522. End Property
  523. '---Multiline
  524. Public Property Get MultiLine() As Boolean
  525.   MultiLine = bMultiLine
  526. End Property
  527. Public Property Let MultiLine(ByVal vData As Boolean)
  528.   bMultiLine = vData
  529.   PropertyChanged ("MultiLine")
  530.   Call pvUpdateStyles
  531. End Property
  532. '---BackColor
  533. Public Property Get BackColor() As OLE_COLOR
  534.   BackColor = lBackColor
  535. End Property
  536. Public Property Let BackColor(ByVal vData As OLE_COLOR)
  537.   lBackColor = vData
  538.   PropertyChanged ("BackColor")
  539.   Call pvUpdateStyles
  540. End Property
  541. '---ForeColor
  542. Public Property Get ForeColor() As OLE_COLOR
  543.   ForeColor = lForeColor
  544. End Property
  545. Public Property Let ForeColor(ByVal vData As OLE_COLOR)
  546.   lForeColor = vData
  547.   PropertyChanged ("ForeColor")
  548.   Call pvUpdateStyles
  549. End Property
  550. '---SelStart
  551. Public Property Get SelStart() As Long
  552. Dim lParam As Long
  553.  'Get the starting position
  554.   lParam = SendMessageLong(lTxtWnd, EM_GETSEL, 0, 0)
  555.   SelStart = LoWord(lParam)
  556. End Property
  557. Public Property Let SelStart(ByVal vData As Long)
  558.  'Set the starting position
  559.   Call SendMessageLong(lTxtWnd, EM_SETSEL, vData, vData)
  560. End Property
  561. '---SelLength
  562. Public Property Get SelLength() As Long
  563. Dim lParam As Long
  564.  'Get the starting and ending position
  565.   lParam = SendMessageLong(lTxtWnd, EM_GETSEL, 0, 0)
  566.  'SelLength = Ending position - Starting position
  567.   SelLength = HiWord(lParam) - LoWord(lParam)
  568. End Property
  569. Public Property Let SelLength(ByVal vData As Long)
  570. Dim lParam As Long, lStart As Long
  571.  'Get the starting position
  572.   lParam = SendMessageLong(lTxtWnd, EM_GETSEL, 0, 0)
  573.   lStart = LoWord(lParam)
  574.  'SelLength = Starting position + Length
  575.   Call SendMessageLong(lTxtWnd, EM_SETSEL, lStart, lStart + vData)
  576. End Property
  577. '***************************************************************************************
  578. ' Private Properties
  579. '***************************************************************************************
  580. '---WindowStyle
  581. Private Property Get WindowStyle() As Long
  582. Dim lNewStyle As Long
  583. 'Is it a password field?
  584.  If sPassChar <> "" Then bPassword = True
  585.  'Create a "Template" style
  586.   lNewStyle = WS_CHILD Or WS_VISIBLE Or WS_TABSTOP
  587.  'Now set the specific styles
  588.   If bMultiLine And Not bPassword Then
  589.    'MultiLine Edit Control
  590.     lNewStyle = lNewStyle Or ES_MULTILINE Or ES_WANTRETURN
  591.     Select Case lSBars
  592.       Case vbSBNone:
  593.         lNewStyle = lNewStyle Or ES_AUTOVSCROLL
  594.       Case vbHorizontal
  595.         lNewStyle = lNewStyle Or ES_AUTOHSCROLL
  596.       Case vbVertical
  597.         lNewStyle = lNewStyle Or ES_AUTOVSCROLL
  598.       Case vbBoth
  599.         lNewStyle = lNewStyle Or ES_AUTOVSCROLL Or ES_AUTOHSCROLL
  600.     End Select
  601.   ElseIf Not bMultiLine And Not bPassword Then
  602.    'SingleLine Edit Control
  603.     lNewStyle = lNewStyle Or ES_AUTOHSCROLL
  604.   ElseIf bPassword Then
  605.    'Password Control
  606.     lNewStyle = lNewStyle Or ES_AUTOHSCROLL Or ES_PASSWORD
  607.     Call SendMessage(lTxtWnd, EM_SETPASSWORDCHAR, Asc(Left(sPassChar, 1)), 0)
  608.   End If
  609.  'Is it locked?
  610.   If bLocked Then lNewStyle = lNewStyle Or ES_READONLY
  611.  'Return the proper style
  612.   WindowStyle = lNewStyle
  613. End Property
  614. '---HiWord
  615. Private Property Get HiWord(ByVal lValue As Long) As Long
  616.   HiWord = lValue \ &H10000
  617. End Property
  618. '---LoWord
  619. Private Property Get LoWord(ByVal Value As Long) As Long
  620.   LoWord = (Value And &HFFFF&)
  621. End Property
  622. '---IsXPOrAbove
  623. Private Property Get IsXPOrAbove() As Boolean
  624. Dim OSVer As OSVERSIONINFO
  625.   OSVer.dwVersionInfoSize = Len(OSVer)
  626.   GetVersionEx OSVer
  627.   If (OSVer.dwMajorVersion > 5) Then
  628.     IsXPOrAbove = True
  629.   ElseIf (OSVer.dwMajorVersion = 5) Then
  630.     If (OSVer.dwMinorVersion >= 1) Then
  631.       IsXPOrAbove = True
  632.     End If
  633.   End If
  634. End Property
  635. '***************************************************************************************
  636. ' UserControl Events
  637. '***************************************************************************************
  638. '---GotFocus
  639. Private Sub UserControl_GotFocus()
  640.   Call SetFocus(lTxtWnd)
  641. End Sub
  642. '---InitProperties
  643. Private Sub UserControl_InitProperties()
  644.   lSBars = 0
  645.   sText = Ambient.DisplayName
  646.   sPassChar = ""
  647.   bMultiLine = False
  648.   bEnabled = True
  649.   bLocked = False
  650.   lBackColor = vbWindowBackground
  651.   lForeColor = vbWindowText
  652.   Call pvUpdateText
  653. End Sub
  654. '---Initialize
  655. Private Sub UserControl_Initialize()
  656. Dim IPAO As IOleInPlaceActiveObject
  657.  'Set our custom IPAO
  658.   With tIPAOHookStruct
  659.     Set IPAO = Me
  660.     CopyMemory .IPAOReal, IPAO, 4
  661.     CopyMemory .TBEx, Me, 4
  662.     .lpVTable = IPAOVTable
  663.     .ThisPointer = VarPtr(tIPAOHookStruct)
  664.   End With
  665.   lBackColor = vbWindowBackground
  666.   lForeColor = vbWindowText
  667.   UserControl.BackColor = lBackColor
  668.   UserControl.ForeColor = lForeColor
  669.   Call pvCreateTextBox
  670. End Sub
  671. '---Terminate
  672. Private Sub UserControl_Terminate()
  673.   'Reset the default IPAO
  674.    With tIPAOHookStruct
  675.       CopyMemory .IPAOReal, 0&, 4
  676.       CopyMemory .TBEx, 0&, 4
  677.    End With
  678.   Call pvDestroyTextBox
  679.   bRunning = False
  680. End Sub
  681. '---ReadProperties
  682. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  683.   With PropBag
  684.     sText = .ReadProperty("Text", Ambient.DisplayName)
  685.     sPassChar = .ReadProperty("PasswordChar", "")
  686.     sCueBanner = .ReadProperty("CueBanner", "")
  687.     lSBars = .ReadProperty("ScrollBars", vbSBNone)
  688.     bMultiLine = .ReadProperty("MultiLine", False)
  689.     bEnabled = .ReadProperty("Enabled", True)
  690.     bLocked = .ReadProperty("Locked", False)
  691.     lBackColor = .ReadProperty("BackColor", vbWindowBackground)
  692.     lForeColor = .ReadProperty("ForeColor", vbWindowText)
  693.   End With
  694.   bRunning = Ambient.UserMode
  695.   Call pvUpdateStyles
  696.   Call pvUpdateText
  697. End Sub
  698. '---WriteProperties
  699. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  700.   With PropBag
  701.     Call .WriteProperty("Text", sText, Ambient.DisplayName)
  702.     Call .WriteProperty("PasswordChar", sPassChar, "")
  703.     Call .WriteProperty("CueBanner", sCueBanner, "")
  704.     Call .WriteProperty("ScrollBars", lSBars, vbSBNone)
  705.     Call .WriteProperty("MultiLine", bMultiLine, False)
  706.     Call .WriteProperty("Enabled", bEnabled, True)
  707.     Call .WriteProperty("Locked", bLocked, False)
  708.     Call .WriteProperty("BackColor", lBackColor, vbWindowBackground)
  709.     Call .WriteProperty("ForeColor", lForeColor, vbWindowText)
  710.   End With
  711. End Sub
  712. '---Resize
  713. Private Sub UserControl_Resize()
  714. Dim CurHeight As Long
  715.   
  716.   CurHeight = ScaleY(Extender.Height, vbContainerSize, vbPixels)
  717.   If CurHeight < 19 Then Extender.Height = ScaleY(19, vbPixels, vbContainerSize)
  718.   
  719.   lhWnd = UserControl.hWnd
  720.   lHeight = UserControl.ScaleHeight
  721.   lWidth = UserControl.ScaleWidth
  722.   Call pvResizeTextBox
  723. End Sub
  724. '***************************************************************************************
  725. ' Public Procedures
  726. '***************************************************************************************
  727. Public Sub ShowBalloonTip(ByVal Text As String, ByVal Title As String, Optional ByVal Icon As BalloonTipIconConstants = 0)
  728. Dim lResult As Long
  729. Dim tBalloonTip As EDITBALLOONTIP
  730.   If Not IsXPOrAbove Then Exit Sub
  731.   tBalloonTip.cbStruct = LenB(tBalloonTip)
  732.   tBalloonTip.pszText = StrPtr(Text)
  733.   tBalloonTip.pszTitle = StrPtr(Title)
  734.   tBalloonTip.ttiIcon = Icon
  735.   lResult = SendMessageW(lTxtWnd, EM_SHOWBALLOONTIP, 0, tBalloonTip)
  736. End Sub
  737. Public Sub HideBalloonTip()
  738. Dim lResult As Long
  739.   If Not IsXPOrAbove Then Exit Sub
  740.   lResult = SendMessageLongW(lTxtWnd, EM_HIDEBALLOONTIP, 0, 0)
  741. End Sub
  742. '***************************************************************************************
  743. ' Private Procedures
  744. '***************************************************************************************
  745. '---pvResizeTextBox
  746. Private Sub pvResizeTextBox()
  747.   Call SetWindowPos(lTxtWnd, 0, 0, 0, lWidth, lHeight, 0)
  748. End Sub
  749. '---pvUpdateText
  750. Private Sub pvUpdateText()
  751.   Call SetWindowText(lTxtWnd, sText)
  752.   If Not IsXPOrAbove Then Exit Sub
  753.   Call SendMessageLongW(lTxtWnd, EM_SETCUEBANNER, 0, StrPtr(" " & sCueBanner))
  754. End Sub
  755. '---pvUpdateStyles
  756. Private Sub pvUpdateStyles()
  757.   UserControl.BackColor = lBackColor
  758.   UserControl.ForeColor = lForeColor
  759.   Call LockWindowUpdate(hWnd)
  760.   Call pvDestroyTextBox
  761.   Call pvCreateTextBox
  762.   Call LockWindowUpdate(0)
  763. End Sub
  764. '---pvCreateTextBox
  765. Private Sub pvCreateTextBox()
  766.  'Initialize Variables
  767.   lhWnd = UserControl.hWnd
  768.   lHeight = UserControl.ScaleHeight
  769.   lWidth = UserControl.ScaleWidth
  770.  'Retrieve the appropiate style
  771.   lStyle = WindowStyle
  772.  'Create an "Edit" window
  773.   lTxtWnd = CreateWindowEx(WS_EX_CLIENTEDGE Or WS_EX_NOPARENTNOTIFY, "EDIT", "", lStyle, 0, 0, lWidth, lHeight, lhWnd, 0, App.hInstance, 0)
  774.  'Remove the scrollbars
  775.   Call ShowScrollBar(lTxtWnd, SB_BOTH, False)
  776.  'If it is multiline then add the scrollbars
  777.   If bMultiLine Then
  778.     Select Case lSBars
  779.       Case vbHorizontal
  780.         Call ShowScrollBar(lTxtWnd, SB_HORZ, True)
  781.       Case vbVertical
  782.         Call ShowScrollBar(lTxtWnd, SB_VERT, True)
  783.       Case vbBoth
  784.         Call ShowScrollBar(lTxtWnd, SB_BOTH, True)
  785.     End Select
  786.   End If
  787.  'Set Font
  788.   pvOLEFontToLogFont UserControl.Font, lFont
  789.   hFont = CreateFontIndirect(lFont)
  790.   SendMessage lTxtWnd, WM_SETFONT, hFont, 1
  791.  'Set Text
  792.   Call pvUpdateText
  793.  'Subclass edit window
  794.   If bRunning Then
  795.     AttachMessage Me, lTxtWnd, WM_SETFOCUS
  796.     AttachMessage Me, lTxtWnd, WM_MOUSEACTIVATE
  797.     AttachMessage Me, lTxtWnd, WM_MOUSEMOVE
  798.     AttachMessage Me, lTxtWnd, WM_LBUTTONUP
  799.     AttachMessage Me, lTxtWnd, WM_LBUTTONDOWN
  800.     AttachMessage Me, lTxtWnd, WM_LBUTTONDBLCLK
  801.     AttachMessage Me, lTxtWnd, WM_RBUTTONUP
  802.     AttachMessage Me, lTxtWnd, WM_RBUTTONDOWN
  803.     AttachMessage Me, lTxtWnd, WM_RBUTTONDBLCLK
  804.     AttachMessage Me, lTxtWnd, WM_KEYDOWN
  805.     AttachMessage Me, lTxtWnd, WM_KEYUP
  806.     AttachMessage Me, lTxtWnd, WM_CHAR
  807.     AttachMessage Me, lhWnd, WM_COMMAND
  808.   End If
  809.   'Uncomment for filename auto completion
  810.   'pvSetAutoComplete lTxtWnd, SHACF_DEFAULT
  811. End Sub
  812. '---pvDestroyTextBox
  813. Private Sub pvDestroyTextBox()
  814.  'Destroy created windows
  815.   If lTxtWnd <> 0 Then DestroyWindow lTxtWnd
  816.   DeleteObject hFont
  817.  'Unubclass edit window
  818.   DetachMessage Me, lTxtWnd, WM_SETFOCUS
  819.   DetachMessage Me, lTxtWnd, WM_MOUSEACTIVATE
  820.   DetachMessage Me, lTxtWnd, WM_MOUSEMOVE
  821.   DetachMessage Me, lTxtWnd, WM_LBUTTONUP
  822.   DetachMessage Me, lTxtWnd, WM_LBUTTONDOWN
  823.   DetachMessage Me, lTxtWnd, WM_LBUTTONDBLCLK
  824.   DetachMessage Me, lTxtWnd, WM_RBUTTONUP
  825.   DetachMessage Me, lTxtWnd, WM_RBUTTONDOWN
  826.   DetachMessage Me, lTxtWnd, WM_RBUTTONDBLCLK
  827.   DetachMessage Me, lTxtWnd, WM_KEYDOWN
  828.   DetachMessage Me, lTxtWnd, WM_KEYUP
  829.   DetachMessage Me, lTxtWnd, WM_CHAR
  830.   DetachMessage Me, lhWnd, WM_COMMAND
  831. End Sub
  832. '---pvSetAutoComplete
  833. Private Function pvSetAutoComplete(ByVal hWnd As Long, ByVal eFlags As Long)
  834. Dim lR As Long
  835.   lR = SHAutoComplete(hWnd, eFlags)
  836.   pvSetAutoComplete = (lR <> S_OK)
  837. End Function
  838. '---pvOLEFontToLogFont
  839. Private Sub pvOLEFontToLogFont(fntThis As StdFont, tLF As LOGFONT)
  840. Dim sFont As String
  841. Dim iChar As Integer
  842.   With tLF
  843.     sFont = fntThis.Name
  844.     For iChar = 1 To Len(sFont)
  845.       .lfFaceName(iChar - 1) = CByte(Asc(Mid(sFont, iChar, 1)))
  846.     Next iChar
  847.     .lfHeight = -MulDiv((fntThis.Size), (GetDeviceCaps(hDC, LOGPIXELSY)), 72)
  848.     .lfItalic = fntThis.Italic
  849.     If (fntThis.Bold) Then
  850.       .lfWeight = FW_BOLD
  851.     Else
  852.       .lfWeight = FW_NORMAL
  853.     End If
  854.     .lfUnderline = fntThis.Underline
  855.     .lfStrikeOut = fntThis.Strikethrough
  856.     .lfCharSet = fntThis.Charset
  857.    'DEFAULT_QUALITY means that will support cleartype
  858.    'with capable fonts (tahoma, verdana, etc)
  859.     .lfQuality = DEFAULT_QUALITY
  860.   End With
  861. End Sub
  862. '---pvGetShiftState
  863. Private Function pvGetShiftState() As ShiftConstants
  864. Dim iR As Integer
  865.   iR = iR Or (-1 * pvKeyIsPressed(vbKeyShift))
  866.   iR = iR Or (-2 * pvKeyIsPressed(vbKeyMenu))
  867.   iR = iR Or (-4 * pvKeyIsPressed(vbKeyControl))
  868.   pvGetShiftState = iR
  869. End Function
  870. '---pvKeyIsPressed
  871. Private Function pvKeyIsPressed(ByVal nVirtKeyCode As KeyCodeConstants) As Boolean
  872. Dim lR As Long
  873.   lR = GetAsyncKeyState(nVirtKeyCode)
  874.   If (lR And &H8000&) = &H8000& Then
  875.     pvKeyIsPressed = True
  876.   End If
  877. End Function
  878. '***************************************************************************************
  879. ' Other Procedures
  880. '***************************************************************************************
  881. '---TranslateAccelerator
  882. Friend Function TranslateAccelerator(lpMsg As VBOleGuids.Msg) As Long
  883.    TranslateAccelerator = S_FALSE
  884.    If lpMsg.message = WM_KEYDOWN Then
  885.       Select Case lpMsg.wParam And &HFFFF&
  886.       Case vbKeyUp, vbKeyDown, vbKeyLeft, vbKeyRight, vbKeyPageDown, vbKeyPageUp, vbKeyHome, vbKeyEnd
  887.          SendMessageLong lTxtWnd, lpMsg.message, lpMsg.wParam, lpMsg.lParam
  888.          TranslateAccelerator = S_OK
  889.       End Select
  890.    End If
  891. End Function
  892. '***************************************************************************************
  893.