Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Const GWL_WNDPROC = (-4)
Private Const WM_CONTEXTMENU = &H7B
Private Const WM_PASTE = &H302
' *********************************************
' Pass along all messages except the one that
' makes the context menu appear and paste.
' *********************************************
Public Function NewWindowProc(ByVal hWnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If (msg <> WM_PASTE) And (msg <> WM_CONTEXTMENU) Then
NewWindowProc = CallWindowProc( _
OldWindowProc, hWnd, msg, wParam, _
lParam)
End If
End Function
窗体代码:
Option Explicit
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Const GWL_STYLE = (-16)
Private Const ES_NUMBER = &H2000
Private Sub Form_Load()
Dim style As Long
' Get the current style.
style = GetWindowLong(Text1.hWnd, GWL_STYLE)
' Add ES_NUMBER to the style.
SetWindowLong Text1.hWnd, GWL_STYLE, style Or ES_NUMBER
' Subclass to ignore the context menu.
OldWindowProc = SetWindowLong( _
Text1.hWnd, GWL_WNDPROC, _
AddressOf NewWindowProc)
End Sub
Private Sub Form_Unload(Cancel As Integer)
SetWindowLong Text1.hWnd, GWL_WNDPROC, OldWindowProc
End Sub
Private Sub Text1_KeyPress(KeyAscii As Integer)
Const strIn As String = "1234567890"
Debug.Print Chr(KeyAscii)
If InStr(strIn, Chr(KeyAscii)) = 0 Then
KeyAscii = 0
End If
End Sub
Private Sub txtTimeout_KeyPress(KeyAscii As Integer)
If Not ((KeyAscii >= 48 And KeyAscii <= 57) Or KeyAscii = 8) Then
KeyAscii = 0
End If
End Sub
'仅允许输入数字,并且BACKSPACE键可以用.