home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 7_2009-2012.ISO / data / zips / Multi_hash2224896142012.psc / clsKeyEdit.cls < prev    next >
Text File  |  2012-06-14  |  31KB  |  770 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "cKeyEdit"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = False
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
  15. Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
  16. ' ***************************************************************************
  17. ' Module:        cKeyEdit
  18. '
  19. ' Description:   These are the common edit routines you will find in most
  20. '                word processors.  (Copy, Cut, Paste)
  21. '
  22. ' ===========================================================================
  23. '    DATE      NAME / DESCRIPTION
  24. ' -----------  --------------------------------------------------------------
  25. ' 02-JUL-1998  Kenneth Ives  kenaso@tx.rr.com
  26. '              Wrote module
  27. ' 11-Jan-2009  Kenneth Ives  kenaso@tx.rr.com
  28. '              Updated ProcessNumericOnly() routine flower box with an
  29. '              additional code suggestion.
  30. ' 20-Dec-2010  Kenneth Ives  kenaso@tx.rr.com
  31. '              - Major update to CenterCaption() routine.
  32. '              - Changed ErrorMsg call to InfoMsg call in CenterCaption()
  33. '                and CenterReportText() routines.
  34. ' 25-Dec-2010  Kenneth Ives  kenaso@tx.rr.com
  35. '              Rewrote CenterReportText() routine.
  36. ' 18-Feb-2011  Kenneth Ives  kenaso@tx.rr.com
  37. '              Added NoCopyText() routine.
  38. ' 16-Mar-2011  Kenneth Ives  kenaso@tx.rr.com
  39. '              Updated CenterReportText() routine
  40. ' 10-Jul-2011  Kenneth Ives  kenaso@tx.rr.com
  41. '              Fixed a bug in CenterCaption() routine.
  42. ' 02-Oct-2011  Kenneth Ives  kenaso@tx.rr.com
  43. '              Fixed minor bugs.  See ProcessNumericOnly() and
  44. '              ProcessAlphaNumeric() routines.
  45. ' ***************************************************************************
  46. Option Explicit
  47.   
  48. ' ***************************************************************************
  49. ' Constants
  50. ' ***************************************************************************
  51.   Private Const MODULE_NAME             As String = "clsKeyEdit"
  52.   Private Const SPI_GETNONCLIENTMETRICS As Long = 41
  53.   Private Const LOGPIXELSY              As Long = 90
  54.  
  55. ' ***************************************************************************
  56. ' Type structures
  57. ' ***************************************************************************
  58.   Private Type LogFont
  59.       FontHeight          As Long
  60.       FontWidth           As Long
  61.       FontEscapement      As Long
  62.       FontOrientation     As Long
  63.       FontWeight          As Long
  64.       FontItalic          As Byte
  65.       FontUnderline       As Byte
  66.       FontStrikeOut       As Byte
  67.       FontCharSet         As Byte
  68.       FontOutPrecision    As Byte
  69.       FontClipPrecision   As Byte
  70.       FontQuality         As Byte
  71.       FontPitchAndFamily  As Byte
  72.       FontFaceName        As String * 32
  73.   End Type
  74.  
  75.   Private Type NONCLIENTMETRICS
  76.       cbSize              As Long
  77.       iBorderWidth        As Long
  78.       iScrollWidth        As Long
  79.       iScrollHeight       As Long
  80.       iCaptionWidth       As Long
  81.       iCaptionHeight      As Long
  82.       LFCaptionFont       As LogFont
  83.       iSMCaptionWidth     As Long
  84.       iSMCaptionHeight    As Long
  85.       LFSMCaptionFont     As LogFont
  86.       iMenuWidth          As Long
  87.       iMenuHeight         As Long
  88.       LFMenuFont          As LogFont
  89.       LFStatusFont        As LogFont
  90.       LFMessageFont       As LogFont
  91.   End Type
  92.  
  93. ' ***************************************************************************
  94. ' API Declares
  95. ' ***************************************************************************
  96.   ' The GetSystemMetrics function retrieves various system metrics and
  97.   ' system configuration settings.  System metrics are the dimensions
  98.   ' (widths and heights) of Windows display elements. All dimensions
  99.   ' retrieved by GetSystemMetrics are in pixels.
  100.   Private Declare Function GetSystemMetrics Lib "user32" _
  101.           (ByVal nIndex As Long) As Long
  102.  
  103.   ' The GetDeviceCaps function retrieves device-specific information
  104.   ' about a specified device.
  105.   Private Declare Function GetDeviceCaps Lib "gdi32" _
  106.           (ByVal hDC As Long, ByVal nIndex As Long) As Long
  107.  
  108.   ' The SystemParametersInfo function queries or sets systemwide
  109.   ' parameters. This function can also update the user profile while
  110.   ' setting a parameter.  This function is intended for use with
  111.   ' applications, such as Control Panel, that allow the user to
  112.   ' customize the Windows environment.
  113.   Private Declare Function SystemParametersInfo Lib "user32" _
  114.           Alias "SystemParametersInfoA" (ByVal uAction As Long, _
  115.           ByVal uParam As Long, lpvParam As Any, _
  116.           ByVal fuWinIni As Long) As Long
  117.  
  118.   ' ZeroMemory is used for clearing contents of a type structure.
  119.   Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" _
  120.           (Destination As Any, ByVal Length As Long)
  121.  
  122.  
  123. ' ***************************************************************************
  124. ' ****                      Methods                                      ****
  125. ' ***************************************************************************
  126.  
  127. ' ***************************************************************************
  128. ' Routine:       CenterCaption
  129. '
  130. ' Description:   Centers a caption on a form.
  131. '
  132. ' Parameters:    frmForm - Name of form whose caption is to be centered
  133. '
  134. ' ===========================================================================
  135. '    DATE      NAME / DESCRIPTION
  136. ' -----------  --------------------------------------------------------------
  137. ' 17-OCT-2000  Tom Pydeski
  138. '              http://www.Planet-Source-Code.com/vb/scripts/ShowCode.asp?txtCodeId=12103&lngWId=1
  139. ' 20-Dec-2010  Kenneth Ives  kenaso@tx.rr.com
  140. '              Modified and documented
  141. ' 10-Jul-2011  Kenneth Ives  kenaso@tx.rr.com
  142. '              Exit routine if form caption is empty.
  143. ' ***************************************************************************
  144. Public Sub CenterCaption(ByRef frmForm As Form)
  145.                     
  146.     Dim strCaption      As String
  147.     Dim lngTwips        As Long
  148.     Dim lngCtrlBox      As Long
  149.     Dim lngTbarWidth    As Long
  150.     Dim lngTbarHeight   As Long
  151.     Dim lngCaptionWidth As Long
  152.     
  153.     On Error GoTo CenterCaption_Error
  154.        
  155.     Set frmForm.Font = GetTitleFont(frmForm)  ' Get font information
  156.     strCaption = TrimStr(frmForm.Caption)     ' Capture form caption
  157.     
  158.     ' If no caption then leave
  159.     If Len(strCaption) = 0 Then
  160.         Exit Sub
  161.     End If
  162.     
  163.     lngTbarHeight = GetSystemMetrics(4) * Screen.TwipsPerPixelX   ' height of window title bar area
  164.     lngTbarWidth = GetSystemMetrics(30) * Screen.TwipsPerPixelX   ' width of button in window title bar area
  165.     lngTwips = (frmForm.TextWidth(strCaption)) / Len(strCaption)  ' get average size of character in twips
  166.     lngCtrlBox = (lngTbarWidth * 3) + lngTbarHeight               ' Calculate box space used on caption bar
  167.     lngCaptionWidth = (frmForm.Width - lngCtrlBox) / lngTwips     ' Calculate total caption space
  168.     strCaption = Space$(Fix(lngCaptionWidth / 1.5)) & strCaption  ' Format caption string
  169.     
  170.     frmForm.Caption = strCaption   ' Return modified caption
  171.     
  172. CenterCaption_CleanUp:
  173.     On Error GoTo 0
  174.     Exit Sub
  175.  
  176. CenterCaption_Error:
  177.     Err.Clear
  178.     Resume CenterCaption_CleanUp
  179.  
  180. End Sub
  181.  
  182. ' ***************************************************************************
  183. ' Routine:       CenterReportText
  184. '
  185. ' Description:   Center text on a line
  186. '
  187. ' Parameters:    lngLineLength - Length of report line
  188. '                strMiddle - Optional - String of data to be centered.
  189. '                    (ex:  "My name and email")
  190. '                    Default = vbNullString
  191. '                strLeftSide - Optional - String of data to remain at left
  192. '                    most end of output string.  (ex:  "25-Dec-2010")
  193. '                    Default = vbNullString
  194. '                strRightSide - Optional - String of data to remain at right
  195. '                    most end of output string.  (ex:  "Page 1")
  196. '                    Default = vbNullString
  197. '
  198. ' Returns:       Formatted text
  199. '
  200. ' ===========================================================================
  201. '    DATE      NAME / DESCRIPTION
  202. ' -----------  --------------------------------------------------------------
  203. ' 25-Dec-2010  Kenneth Ives  kenaso@tx.rr.com
  204. '              Wrote routine
  205. ' 16-Mar-2011  Kenneth Ives  kenaso@tx.rr.com
  206. '              Added better parameter evaluation with error messages
  207. ' 11-Sep-2011  Kenneth Ives  kenaso@tx.rr.com
  208. '              Made line length parameter mandatory
  209. ' ***************************************************************************
  210. Public Function CenterReportText(ByVal lngLineLength As Long, _
  211.                         Optional ByVal strMiddle As String = vbNullString, _
  212.                         Optional ByVal strLeftSide As String = vbNullString, _
  213.                         Optional ByVal strRightSide As String = vbNullString) As String
  214.     
  215.     Dim lngDataLength As Long
  216.     
  217.     Const ROUTINE_NAME As String = "CenterReportText"
  218.     
  219.     CenterReportText = vbNullString   ' Verify return string is empty
  220.     
  221.     ' If no line length, data cannot be centered
  222.     If lngLineLength < 1 Then
  223.         InfoMsg "Line length must be a positive number." & _
  224.                 vbNewLine & vbNewLine & MODULE_NAME & "." & ROUTINE_NAME
  225.         Exit Function
  226.     End If
  227.  
  228.     ' Remove leading and trailing blank spaces
  229.     strLeftSide = TrimStr(strLeftSide)
  230.     strMiddle = TrimStr(strMiddle)
  231.     strRightSide = TrimStr(strRightSide)
  232.  
  233.     ' Capture data length
  234.     lngDataLength = Len(strLeftSide & strMiddle & strRightSide)
  235.     
  236.     Select Case lngDataLength
  237.  
  238.            Case Is < 1   ' If no data to process then leave
  239.                 InfoMsg "No data to process." & _
  240.                         vbNewLine & vbNewLine & MODULE_NAME & "." & ROUTINE_NAME
  241.                 Exit Function
  242.  
  243.            Case is > lngLineLength   ' If too much data then leave
  244.                 InfoMsg "Line length must be equal to or greater than data length." & _
  245.                         vbNewLine & "Line length:  " & CStr(lngLineLength) & _
  246.                         vbNewLine & "Data length:  " & CStr(lngDataLength) & _
  247.                         vbNewLine & vbNewLine & MODULE_NAME & "." & ROUTINE_NAME
  248.                 Exit Function
  249.     End Select
  250.  
  251.     ' Add a blank space to beginning and end of
  252.     ' middle string of data until line length
  253.     ' requirement has been met or exceeded
  254.     Do While Len(strMiddle) < lngLineLength
  255.         strMiddle = Chr$(32) & strMiddle & Chr$(32)
  256.     Loop
  257.     
  258.     ' Verify string length equals line length
  259.     strMiddle = Left$(strMiddle, lngLineLength)
  260.     
  261.     ' If data is available then overlay left side
  262.     If Len(strLeftSide) > 0 Then
  263.         Mid$(strMiddle, 1, Len(strLeftSide)) = strLeftSide
  264.     End If
  265.     
  266.     ' If data is available then overlay right side
  267.     If Len(strRightSide) > 0 Then
  268.         Mid$(strMiddle, (lngLineLength - Len(strRightSide)) + 1, Len(strRightSide)) = strRightSide
  269.     End If
  270.         
  271.     ' Remove any excess trailing blanks because
  272.     ' only leading blanks are needed to push data
  273.     ' to middle of line.
  274.     CenterReportText = RTrim$(strMiddle)
  275.     
  276. End Function
  277.  
  278. ' ***************************************************************************
  279. ' Routine:       TextBoxKeyDown
  280. '
  281. ' Description:   Processes a KeyDown() event for a textbox.  A combination
  282. '                of keys that have been depressed in a TextBox
  283. '
  284. ' Syntax:        Private Sub txtLength_KeyDown(KeyCode As Integer, Shift As Integer)
  285. '                    ' Process any key combinations
  286. '                    mobjKeyEdit.TextBoxKeyDown txtLength, KeyCode, Shift
  287. '                End Sub
  288. '
  289. ' Parameters:    ctlTextBox - TextBox control
  290. '                intKeyCode - Possible special key being pressed (Ctl, Alt, etc)
  291. '                intShift   - Possible shift key being pressed
  292. '
  293. ' ===========================================================================
  294. '    DATE      NAME / DESCRIPTION
  295. ' -----------  --------------------------------------------------------------
  296. ' 06-APR-2002  Kenneth Ives  kenaso@tx.rr.com
  297. '              Wrote routine
  298. ' ***************************************************************************
  299. Public Sub TextBoxKeyDown(ByRef ctlTextBox As TextBox, _
  300.                           ByRef intKeyCode As Integer, _
  301.                           ByRef intShift As Integer)
  302.  
  303.     Dim CtrlDown    As Integer
  304.     Dim PressedKey  As Integer
  305.     
  306.     ' Initialize  variables
  307.     CtrlDown = (intShift And vbCtrlMask) > 0      ' Define control key
  308.     PressedKey = Asc(UCase$(Chr$(intKeyCode)))    ' Convert to uppercase
  309.       
  310.     ' Check to see if it is okay to make changes
  311.     If CtrlDown And PressedKey = vbKeyX Then      ' Ctrl + X was pressed
  312.         Edit_Cut ctlTextBox
  313.         
  314.     ElseIf CtrlDown And PressedKey = vbKeyA Then  ' Ctrl + A was pressed
  315.         TextBoxFocus ctlTextBox
  316.         
  317.     ElseIf CtrlDown And PressedKey = vbKeyC Then  ' Ctrl + C was pressed
  318.         Edit_Copy ctlTextBox
  319.         
  320.     ElseIf CtrlDown And PressedKey = vbKeyV Then  ' Ctrl + V was pressed
  321.         Edit_Paste ctlTextBox
  322.         
  323.     ElseIf PressedKey = vbKeyDelete Then          ' Delete key was pressed
  324.         Edit_Delete ctlTextBox
  325.     End If
  326.  
  327. End Sub
  328.  
  329. ' ***************************************************************************
  330. ' Routine:       TextBoxFocus
  331. '
  332. ' Description:   Processes a GotFocus() event for a textbox.  Whenever the
  333. '                textbox has been first entered then all the text within
  334. '                will be highlighted.
  335. '
  336. ' Syntax:        Private Sub txtLength_GotFocus()
  337. '                    ' Highlight all the text in the box
  338. '                    mobjKeyEdit.TextBoxFocus txtLength
  339. '                End Sub
  340. '
  341. ' Parameters:    ctlTextBox - TextBox control
  342. '
  343. ' ===========================================================================
  344. '    DATE      NAME / DESCRIPTION
  345. ' -----------  --------------------------------------------------------------
  346. ' 06-APR-2002  Kenneth Ives  kenaso@tx.rr.com
  347. '              Wrote routine
  348. ' ***************************************************************************
  349. Public Sub TextBoxFocus(ByRef ctlTextBox As TextBox)
  350.  
  351.     ' Called by TextBoxKeyDown()
  352.     
  353.     ' Highlight all the text in the box
  354.     With ctlTextBox
  355.          .SelStart = 0             ' Start with first character in TextBox
  356.          .SelLength = Len(.Text)   ' To last character in TextBox
  357.     End With
  358.   
  359. End Sub
  360.  
  361. ' ***************************************************************************
  362. ' Routine:       NoCopyText
  363. '
  364. ' Description:   Prevents text from being copied from a textbox.
  365. '
  366. ' Syntax:        Private Sub txtLength_KeyDown(KeyCode As Integer, Shift As Integer)
  367. '                    ' Protect data from being copied
  368. '                    mobjKeyEdit.NoCopyText txtLength, KeyCode, Shift
  369. '                End Sub
  370. '
  371. ' Parameters:    ctlTextBox - TextBox control
  372. '                intKeyCode - Possible special key being pressed (Ctl, Alt, etc)
  373. '                intShift   - Possible shift key being pressed
  374. '
  375. ' ===========================================================================
  376. '    DATE      NAME / DESCRIPTION
  377. ' -----------  --------------------------------------------------------------
  378. ' 18-Feb-2011  Kenneth Ives  kenaso@tx.rr.com
  379. '              Wrote routine
  380. ' ***************************************************************************
  381. Public Sub NoCopyText(ByRef ctlTextBox As TextBox, _
  382.                       ByRef intKeyCode As Integer, _
  383.                       ByRef intShift As Integer)
  384.  
  385.     Dim CtrlDown   As Integer
  386.     Dim PressedKey As Integer
  387.     
  388.     ' Define control key
  389.     CtrlDown = (intShift And vbCtrlMask) > 0
  390.     
  391.     ' Convert keycode to uppercase then to decimal
  392.     PressedKey = Asc(UCase$(Chr$(intKeyCode)))
  393.       
  394.     With ctlTextBox
  395.         If (CtrlDown And PressedKey = vbKeyX) Or _
  396.            (CtrlDown And PressedKey = vbKeyA) Or _
  397.            (CtrlDown And PressedKey = vbKeyC) Or _
  398.            (CtrlDown And PressedKey = vbKeyV) Then
  399.             
  400.             .SelStart = 0   ' Keep mouse pointer at beginning of data
  401.             .SelLength = 0
  402.             Clipboard.SetText vbNullString  ' capture an empty string
  403.             Clipboard.Clear                 ' Empty clipboard
  404.          End If
  405.     End With
  406.     
  407. End Sub
  408.  
  409. ' ***************************************************************************
  410. ' Routine:       ProcessNumericOnly
  411. '
  412. ' Description:   Processes a KeyPress() event for a textbox.  Numeric only
  413. '                data.  ASCII 9 (TAB), 13 (ENTER), 8 (BACKSPACE), 48-57 (0-9)
  414. '
  415. '
  416. ' Syntax:        Private Sub txtLength_KeyPress(KeyAscii As Integer)
  417. '                    ' Save only numeric and the backspace character
  418. '                    mobjKeyEdit.ProcessNumericOnly KeyAscii
  419. '                End Sub
  420. '
  421. ' Parameters:    intKeyASCII - key being pressed
  422. '
  423. ' NOTE:          To prevent someone from pasting a non-numeric value
  424. '                into this textbox, insert the code below into the
  425. '                textbox_Change() event. Change "txtbox" to the name
  426. '                of the textbox control.
  427. '
  428. '                ' Prevent user from pasting a non-numeric value
  429. '                ' into this textbox
  430. '                If Not IsNumeric(txtbox.Text) Then
  431. '                    txtbox.Text = vbNullString
  432. '                End If
  433. '
  434. ' ===========================================================================
  435. '    DATE      NAME / DESCRIPTION
  436. ' -----------  --------------------------------------------------------------
  437. ' 06-APR-2002  Kenneth Ives  kenaso@tx.rr.com
  438. '              Wrote routine
  439. ' 11-Jan-2009  Kenneth Ives  kenaso@tx.rr.com
  440. '              Added above note to prevent a user from pasting non-numeric
  441. '              data into a textbox.  Got code from Masino Sinaga (04-Aug-2003)
  442. '              http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=47381&lngWId=1
  443. ' 02-Oct-2011  Kenneth Ives  kenaso@tx.rr.com
  444. '              Fixed bug.  ENTER key improperly recognized.  Now sends a
  445. '              TAB key response.
  446. ' ***************************************************************************
  447. Public Sub ProcessNumericOnly(ByRef intKeyASCII As Integer)
  448.       
  449.         Select Case intKeyASCII
  450.                Case 9, 13
  451.                     ' Tab key, ENTER key
  452.                     intKeyASCII = 0
  453.                     SendKeys "{TAB}"
  454.                 
  455.                Case 8, 48 To 57
  456.                     ' Backspace and numeric keys only
  457.                 
  458.                Case Else  ' Everything else (invalid)
  459.                     intKeyASCII = 0
  460.         End Select
  461.                               
  462. End Sub
  463.  
  464. ' ***************************************************************************
  465. ' Routine:       ProcessAlphaNumeric
  466. '
  467. ' Description:   Processes a KeyPress() event for a textbox.  All keyboard
  468. '                characters.  ASCII 32-126
  469. '
  470. ' Syntax:        Private Sub txtLength_KeyPress(KeyAscii As Integer)
  471. '                    ' Save only alphanumeric characters
  472. '                    mobjKeyEdit.ProcessAlphaNumeric KeyAscii
  473. '                End Sub
  474. '
  475. ' Parameters:    intKeyASCII - key being pressed
  476. '                blnAcceptSpaces - [Optional]
  477. '                     TRUE=Accept blanks spaces as input (DEFAULT)
  478. '                     FALSE=Do not aceept any blank spaces as input
  479. '
  480. ' ===========================================================================
  481. '    DATE      NAME / DESCRIPTION
  482. ' -----------  --------------------------------------------------------------
  483. ' 06-APR-2002  Kenneth Ives  kenaso@tx.rr.com
  484. '              Wrote routine
  485. ' 02-Oct-2011  Kenneth Ives  kenaso@tx.rr.com
  486. '              Fixed bug.  ENTER key improperly recognized.  Now enters a
  487. '              Carriage Return and Linefeed.
  488. ' ***************************************************************************
  489. Public Sub ProcessAlphaNumeric(ByRef intKeyASCII As Integer, _
  490.                       Optional ByVal blnAcceptSpaces As Boolean = True)
  491.  
  492.     If blnAcceptSpaces Then
  493.         Select Case intKeyASCII
  494.                Case 9, 13
  495.                     ' Tab key, ENTER key
  496.                     intKeyASCII = 0
  497.                     SendKeys "{TAB}"
  498.                 
  499.                Case 8, 32 To 126
  500.                     ' Backspace and other
  501.                     ' valid data keys
  502.                 
  503.                Case Else  ' Everything else (invalid)
  504.                     intKeyASCII = 0
  505.         End Select
  506.     Else
  507.         ' Do not accept blank spaces
  508.         Select Case intKeyASCII
  509.                Case 9, 13
  510.                     ' Tab key, ENTER key
  511.                     intKeyASCII = 0
  512.                     SendKeys "{TAB}"
  513.                 
  514.                Case 8, 33 To 126
  515.                     ' Backspace and other
  516.                     ' valid data keys
  517.                 
  518.                Case Else  ' Everything else (invalid)
  519.                     intKeyASCII = 0
  520.         End Select
  521.     End If
  522.  
  523. End Sub
  524.  
  525. ' ***************************************************************************
  526. ' Routine:       ProcessAlphabetic
  527. '
  528. ' Description:   Processes a KeyPress() event for a textbox.  Alphabetic
  529. '                only data.  (A-Z, a-z)
  530. '
  531. ' Syntax:        Private Sub txtLength_KeyPress(KeyAscii As Integer)
  532. '                    ' Save only alphabetic only characters
  533. '                    mobjKeyEdit.ProcessAlphabetic KeyAscii
  534. '                End Sub
  535. '
  536. ' Parameters:    intKeyASCII - key being pressed
  537. '                blnUppercaseOnly - [Optional] - Allow only uppercase
  538. '                    values to be entered.
  539. '                    TRUE=Convert all letters to uppercase
  540. '                    FALSE=Upper and lower case allowed (DEFAULT)
  541. '
  542. ' ===========================================================================
  543. '    DATE      NAME / DESCRIPTION
  544. ' -----------  --------------------------------------------------------------
  545. ' 06-APR-2002  Kenneth Ives  kenaso@tx.rr.com
  546. '              Wrote routine
  547. ' ***************************************************************************
  548. Public Sub ProcessAlphabetic(ByRef intKeyASCII As Integer, _
  549.                     Optional ByVal blnUppercaseOnly As Boolean = False)
  550.       
  551.     If blnUppercaseOnly Then
  552.         Select Case intKeyASCII
  553.                Case 9, 13
  554.                     ' Tab key, ENTER key
  555.                     intKeyASCII = 0
  556.                     SendKeys "{TAB}"
  557.                 
  558.                Case 8, 65 To 90
  559.                     ' Backspace and uppercase
  560.                     ' alphabetic keys only
  561.                
  562.                Case 97 To 122
  563.                     ' Convert lowercase to uppercase
  564.                     intKeyASCII = intKeyASCII - 32
  565.                     
  566.                Case Else  ' Everything else (invalid)
  567.                     intKeyASCII = 0
  568.         End Select
  569.     Else
  570.         ' Case does not matter
  571.         Select Case intKeyASCII
  572.                Case 9, 13
  573.                     ' Tab key, ENTER key
  574.                     intKeyASCII = 0
  575.                     SendKeys "{TAB}"
  576.                 
  577.                Case 8, 65 To 90, 97 To 122
  578.                     ' Backspace and alphabetic keys only
  579.  
  580.                Case Else  ' Everything else (invalid)
  581.                     intKeyASCII = 0
  582.         End Select
  583.     End If
  584.     
  585. End Sub
  586.  
  587.  
  588. ' ***************************************************************************
  589. ' ****              Internal Functions and Procedures                    ****
  590. ' ***************************************************************************
  591.  
  592. ' ***************************************************************************
  593. ' Routine:       GetTitleFont
  594. '
  595. ' Description:   Captues the font information
  596. '
  597. ' Parameters:    frmForm - Name of the form whose caption is to be centered
  598. '
  599. ' Returns:       Complete type structure describing the font used on this form
  600. '
  601. ' ===========================================================================
  602. '    DATE      NAME / DESCRIPTION
  603. ' -----------  --------------------------------------------------------------
  604. ' 17-OCT-2000  Tom Pydeski
  605. '              http://www.Planet-Source-Code.com/vb/scripts/ShowCode.asp?txtCodeId=12103&lngWId=1
  606. ' 16-APR-2001  Kenneth Ives  kenaso@tx.rr.com
  607. '              Modified and documented
  608. ' ***************************************************************************
  609. Private Function GetTitleFont(ByRef frmForm As Form) As StdFont
  610.     
  611.     ' Called by CenterCaption()
  612.     
  613.     Dim typNCM        As NONCLIENTMETRICS
  614.     Dim typLogFont    As LogFont
  615.     Dim typTargetFont As Font
  616.     
  617.     On Error GoTo GetTitleFont_Error
  618.  
  619.     ZeroMemory typNCM, Len(typNCM)
  620.     ZeroMemory typLogFont, Len(typLogFont)
  621.     
  622.     typNCM.cbSize = Len(typNCM)    ' initialize variables
  623.     
  624.     ' Make the API to get the windows position
  625.     SystemParametersInfo SPI_GETNONCLIENTMETRICS, 0&, typNCM, 0&
  626.     
  627.     ' See if there are any fonts
  628.     If typNCM.iCaptionHeight = 0 Then
  629.         ' If no fonts involved then set to zero
  630.         typLogFont.FontHeight = 0
  631.     Else
  632.         ' save the height of the caption font
  633.         typLogFont = typNCM.LFCaptionFont
  634.     End If
  635.     
  636.     Set typTargetFont = New StdFont
  637.     
  638.     With typTargetFont
  639.         .Charset = typLogFont.FontCharSet
  640.         .Weight = typLogFont.FontWeight
  641.         .Name = typLogFont.FontFaceName
  642.         .Strikethrough = typLogFont.FontStrikeOut
  643.         .Underline = typLogFont.FontUnderline
  644.         .Italic = typLogFont.FontItalic
  645.         .Bold = (typLogFont.FontWeight = 700)
  646.         .Size = -(typLogFont.FontHeight * (72 / GetDeviceCaps(frmForm.hDC, LOGPIXELSY)))
  647.     End With
  648.     
  649.     Set GetTitleFont = typTargetFont
  650.  
  651. GetTitleFont_CleanUp:
  652.     On Error GoTo 0
  653.     Exit Function
  654.  
  655. GetTitleFont_Error:
  656.     ErrorMsg MODULE_NAME, "GetTitleFont", Err.Description
  657.     Resume GetTitleFont_CleanUp
  658.  
  659. End Function
  660.  
  661. ' ***************************************************************************
  662. ' Routine:       Edit_Copy
  663. '
  664. ' Description:   Copy highlighted text to the clipboard. See Keydown event
  665. '                for the text boxes to see an example of the code calling
  666. '                this routine.
  667. '
  668. ' Special Logic: When the user highlights text with the cursor and presses
  669. '                CTRL+C to perform a copy function.  The highlighted text
  670. '                is then loaded into the clipboard.
  671. '
  672. ' Parameters:    ctlTextBox - TextBox control
  673. '
  674. ' ===========================================================================
  675. '    DATE      NAME / DESCRIPTION
  676. ' -----------  --------------------------------------------------------------
  677. ' 06-APR-2002  Kenneth Ives  kenaso@tx.rr.com
  678. '              Wrote routine
  679. ' ***************************************************************************
  680. Private Sub Edit_Copy(ByRef ctlTextBox As TextBox)
  681.  
  682.     ' Called by TextBoxKeyDown()
  683.     
  684.     Clipboard.Clear                       ' Clear clipboard contents
  685.     Clipboard.SetText ctlTextBox.SelText  ' Load clipboard with highlighted text
  686.   
  687. End Sub
  688.  
  689. ' ***************************************************************************
  690. ' Routine:       Edit_Cut
  691. '
  692. ' Description:   Copy highlighted text to the clipboard and then remove it
  693. '                from the text box. See Keydown event for the text boxes to
  694. '                see an example of the code calling this routine.
  695. '
  696. ' Special Logic: When the user highlights text with the cursor and presses
  697. '                CTRL+X to perform a cutting function.  The highlighted text
  698. '                is then moved to the clipboard.
  699. '
  700. ' Parameters:    ctlTextBox - TextBox control
  701. '
  702. ' ===========================================================================
  703. '    DATE      NAME / DESCRIPTION
  704. ' -----------  --------------------------------------------------------------
  705. ' 06-APR-2002  Kenneth Ives  kenaso@tx.rr.com
  706. '              Wrote routine
  707. ' ***************************************************************************
  708. Private Sub Edit_Cut(ByRef ctlTextBox As TextBox)
  709.  
  710.     ' Called by TextBoxKeyDown()
  711.     
  712.     Clipboard.Clear                        ' Clear clipboard contents
  713.     Clipboard.SetText ctlTextBox.SelText   ' Load clipboard with highlighted text
  714.     ctlTextBox.SelText = vbNullString                ' Empty TextBox contents
  715.   
  716. End Sub
  717.  
  718. ' ***************************************************************************
  719. ' Routine:       Edit_Delete
  720. '
  721. ' Description:   Copy highlighted text to the clipboard and then remove it
  722. '                from the text box. See Keydown event for the text boxes to
  723. '                see an example of the code calling this routine.
  724. '
  725. ' Special Logic: When the user highlights text with the cursor and presses
  726. '                CTRL+X to perform a cutting function.  The highlighted text
  727. '                is then moved to the clipboard and the clipboard is emptied
  728. '
  729. ' Parameters:    ctlTextBox - TextBox control
  730. '
  731. ' ===========================================================================
  732. '    DATE      NAME / DESCRIPTION
  733. ' -----------  --------------------------------------------------------------
  734. ' 06-APR-2002  Kenneth Ives  kenaso@tx.rr.com
  735. '              Wrote routine
  736. ' ***************************************************************************
  737. Private Sub Edit_Delete(ByRef ctlTextBox As TextBox)
  738.  
  739.     ' Called by TextBoxKeyDown()
  740.     
  741.     ctlTextBox.SelText = vbNullString  ' remove highlighted text from TextBox
  742.   
  743. End Sub
  744.  
  745. ' ***************************************************************************
  746. ' Routine:       Edit_Paste
  747. '
  748. ' Description:   Copy whatever text is being held in the clipboard and then
  749. '                paste it in the text box. See Keydown event for the text
  750. '                boxes to see an example of the code calling this routine.
  751. '
  752. ' Parameters:    ctlTextBox - TextBox control
  753. '
  754. ' ===========================================================================
  755. '    DATE      NAME / DESCRIPTION
  756. ' -----------  --------------------------------------------------------------
  757. ' 06-APR-2002  Kenneth Ives  kenaso@tx.rr.com
  758. '              Wrote routine
  759. ' ***************************************************************************
  760. Private Sub Edit_Paste(ByRef ctlTextBox As TextBox)
  761.  
  762.     ' Called by TextBoxKeyDown()
  763.     
  764.     ctlTextBox.SelText = Clipboard.GetText()  ' unload clipboard into TextBox
  765.   
  766. End Sub
  767.  
  768.  
  769.  
  770.