'[basSubClass.bas]
            '   テキストボックスを数値のみの入力にする。
            '                                               Ver1.0
            '                                  Programinged By Uz.
            Option Explicit

            '-- ＡＰＩ定数群
            Public Const GWL_WNDPROC = (-4)
            Public Const WM_CHAR = &H102

            '-- ＡＰＩ関数群
            Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
                ByVal hWnd As Long, _
                ByVal nIndex As Long, _
                ByVal dwNewLong As Long _
            ) As Long
            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

            '-- プライベート変数群
            Private lpDefaultProc As Long       'デフォルトのウィンドウプロシージャのアドレス

            '-- パブリック関数群

            'サブクラス化開始関数
            Public Function SubClass(hWnd As Long) As Boolean
                On Error GoTo ErrorHandle
                
                'デフォルトのウィンドウプロシージャのアドレスの保存と新しいウィンドウプロシージャの登録
                lpDefaultProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WindowProc)
                If lpDefaultProc = 0 Then GoTo ErrorHandle
                SubClass = True
                Exit Function
            ErrorHandle:
                SubClass = False
            End Function

            'サブクラス化終了関数
            Public Function UnSubClass(hWnd As Long) As Boolean
                Dim lpX As Long     '戻り値を格納
                
                On Error GoTo ErrorHandle
                'サブクラス化していないときは処理を行わない
                If lpDefaultProc <> 0 Then
                    'ウィンドウプロシージャをデフォルトに戻す
                    lpX = SetWindowLong(hWnd, GWL_WNDPROC, lpDefaultProc)
                    If lpX = 0 Then GoTo ErrorHandle
                    lpDefaultProc = 0
                End If
                UnSubClass = True
                Exit Function
            ErrorHandle:
                UnSubClass = False
            End Function

            '自前のウィンドウプロシージャ
            Public Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, _
                                       ByVal wParam As Long, ByVal lParam As Long) As Long
                'Debug.Print Hex(hWnd), Hex(uMsg), Hex(wParam), Hex(lParam)     'すべてのメッセージを表示(結構楽しい(^_^))
                Select Case uMsg
                    Case WM_CHAR            '文字が送られたら
                        Select Case wParam      '送られた文字
                            Case Asc("0") To Asc("9"), vbKeyReturn, vbKeyBack, vbKeyHome, vbKeyEnd
                                '許可する文字なら何もしない
                            Case Else
                                '送られた文字を無効化する
                                wParam = 0
                        End Select
                End Select
                
                'デフォルトのウィンドウプロシージャを呼び出す
                WindowProc = CallWindowProc(lpDefaultProc, hWnd, uMsg, wParam, lParam)
            End Function

            '[frmMain]
            '	フォーム側はこれだけ(^^)
            '
            Option Explicit

            '終了ボタン
            Private Sub cmdExit_Click()
                Call Unload(Me)
            End Sub

            'フォームロード
            Private Sub Form_Load()
                'サブクラス化開始
                Call SubClass(txtTextBox.hWnd)
            End Sub

            'フォームアンロード
            Private Sub Form_Unload(Cancel As Integer)
                'サブクラス化終了
                Call UnSubClass(txtTextBox.hWnd)
            End Sub

サンプル subclass.lzh