Textbox: только цифры

[noob4ever]

код потерялся,
как сделать???

[vvs_adm]

Код: Выделить всё

Private Sub Text1_KeyPress(KeyAscii As Integer)
    If (KeyAscii < Asc("0")) Or (KeyAscii > Asc("9")) Then KeyAscii = 0
End Sub

[Warn]

Ещё можно так:

Код: Выделить всё

If Not IsNumeric Then ...

[keks-n]

Гы-гы
А если туды какой-нить умник скопипастит?
А по поводу IsNumeric то cтрока типа &H..... может прокатить, а челу надо тока цифры!
Надо ловить Change и проверять каждый символ выкидывая ненужные

[vvs_adm]

А если туды какой-нить умник скопипастит?

А мы будем буфер обмена очищать при установке фокуса на текстбокс

[noob4ever]

Private Sub Text1_KeyPress(KeyAscii As Integer)
If (KeyAscii < Asc("0")) Or (KeyAscii > Asc("9")) Then KeyAscii = 0
End Sub
Нее такое не годится, оно блокирует ввод в Text1, а надо чтобы просто буквы не песатались и все!
эх был у меня код маленький такой, там еще паст не действовал)
и по типу в скобках еще перечислял какие симовлы можно вводить: (1,2,3,4,5,6,7,8,9,0) типа того.

[noob4ever]

Private Sub Текст1_KeyPress(KeyAscii As Integer)
Const Accept = "1234567890"
If Len(Replace(Accept, Chr(KeyAscii), "")) = Len(Accept) Then KeyAscii = 0
End Sub

пользуйтесь, нашел.
Кстати никто незнает как сделать чтобы нельзя было копировать в TextBox??

[vvs_adm]

Ну и что ты в итоге нашел? Оно же

блокирует ввод в Text1, а надо чтобы просто буквы не песатались и все!

[GM]

А как же установка стиля ES_NUMERIC текстбоксу

Код: Выделить всё

'This project needs a TextBox
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
Const GWL_STYLE = (-16)
Const ES_NUMBER = &H2000&
Public Sub SetNumber(NumberText As TextBox, Flag As Boolean)
    Dim curstyle As Long, newstyle As Long
    'retrieve the window style
    curstyle = GetWindowLong(NumberText.hwnd, GWL_STYLE)
    If Flag Then
       curstyle = curstyle Or ES_NUMBER
    Else
       curstyle = curstyle And (Not ES_NUMBER)
    End If
    'Set the new style
    newstyle = SetWindowLong(NumberText.hwnd, GWL_STYLE, curstyle)
    'refresh
    NumberText.Refresh
End Sub
Private Sub Form_Load()
    'KPD-Team 1999
    'URL: http://www.allapi.net/
    'E-Mail: KPDTeam@Allapi.net
    SetNumber Text1, True
    Me.Caption = "Now, try typing some letters into the textbox"
End Sub


[noob4ever]

но это не решает проблему с пастом

[noob4ever]

vvs_adm
и вправду

[keks-n]

Буфер обмена чистить НИЗЯ! Может юзеру надо n-значное число туды закопировать? И что, ему всё n знаков руками вводить? Или у него рисунок/файл/еще_что-нибудь в буфере лежит? И когда надо будет вставить у него этого в буфере ужо нету! А оригинальный документ пришилен (это если рисунок/что-нибудь)! Юзеру масса неудобств!!! Этого быть не должно.

[Kovu]

Код: Выделить всё


'В модуле пишешь
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
Public Const GWL_WNDPROC = (-4)


Public Const WM_NULL As Long = &H0


Global prevWnd As Long

Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case uMsg
Case 770
uMsg = WM_NULL
lParam = 0
wParam = 0
End Select
WindowProc = CallWindowProc(prevWnd, hwnd, uMsg, wParam, lParam)
End Function
'на форме текстбокс, в коде:
Private Sub Form_Load()

prevWnd = SetWindowLong(Text1.hwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub


Пользуйся

[DirectXManiac]

ОГО! Даже с распечаткой?? Круто!!!

[mdx]

Код: Выделить всё

Private Sub Text1_Change()
    Dim i As Integer
    Dim a() As String
    Dim s As String
   
    'Если нужно, чтобы поле очищалось, раскомментируй следующую строчку
    'If Text1 = "" Then Exit Sub
    If Text1 = "" Then Text1 = "0"
   
    a = StrToArr(Text1)
    For i = 0 To UBound(a)
        If (a(i) < "0") Or (a(i) > "9") Then a(i) = ""
    Next
    s = ArrToStr(a)
    If s <> Text1 Then Text1 = s
End Sub

Private Function StrToArr(ByVal s As String) As String()
    Dim a() As String
   
    ReDim a(Len(s) - 1)
    For i = 0 To UBound(a)
        a(i) = Mid(s, i + 1, 1)
    Next
   
    StrToArr = a()
End Function

Private Function ArrToStr(ByRef a() As String) As String
    Dim s As String
   
    For i = 0 To UBound(a)
        s = s & a(i)
    Next

    ArrToStr = s
End Function


По-моему всё делает правильно

[keks-n]

Правильно, конечно. Вот только код раза в три сократить можно...
Примерно так:

Код: Выделить всё

dim s1 as string, s2 as string

dim n as long

for n=1 to len(s1)
if asc(mid(s1,n,1))>=vbkey0 and asc(mid(s1,n,1))<=vbkey9 then s2=s2+ mid(s1,n,1)
next



[Andrey Fedorov]

А если туды какой-нить умник скопипастит?

А пущай - можно ведь в Validate проверить и ругнуться. Пускай туда вводит как запятую так и точку (программа должна разобраться и заменить на правильный разделитель).

Пускай даже вводит выражение навроде 12+34/3 - программа должна вычислить и поместить результат выражения.

[Viper]

Пускай даже вводит выражение навроде 12+34/3 - программа должна вычислить и поместить результат выражения.

Заодно человек напишет парсер выражений...

[Andrey Fedorov]

Заодно человек напишет парсер выражений...

Нафиг маяться? ScriptControl на это есть.

[noob4ever]

а может кто знает код стрелочки, не той что "лево", а над Enter! чтобы символы удалять еще с конца можно было бы

[Andrey Fedorov]

а может кто знает код стрелочки, не той что "лево", а над Enter! чтобы символы удалять еще с конца можно было бы

Это чтоль: vbKeyBack ?

[noob4ever]

да

[[root]]

Private Sub Text1_KeyPress(KeyAscii As Integer)
Select Case KeyAscii
Case 48 To 57
Case Else
KeyAscii = 0
End Select
End Sub

[DirectXManiac]

Вот, правильно [root]! Вот так и надо учиться!

[Matew]

Вот так универсально, тока проц чуть грузит

Код: Выделить всё

Private Sub txtKolvo_Change()
Static oldText As String
Dim i As Integer
    For i = 1 To Len(txtKolvo.Text)
        If InStr("0123456789.", Mid$(txtKolvo.Text, i, 1)) = 0 Then
             MsgBox "Напишите арабскими цифрами."
             txtKolvo.Text = oldText
        End If
    Next i
        If Val(txtKolvo.Text) > 200 Then
             MsgBox "По-моему число слишком большое!"
             txtKolvo.Text = oldText
        Else
             oldText = txtKolvo.Text
        End If
End Sub


[Andrey Fedorov]

Private Sub Text1_KeyPress(KeyAscii As Integer)
Select Case KeyAscii
Case 48 To 57
Case Else
KeyAscii = 0
End Select
End Sub

Э-э-х-х:

Код: Выделить всё

' Отсечение недопустимых символов при вводе в поле
Public Sub CheckNumKeyPress(Value As Variant, KeyAscii As Integer, FieldType As ADODB.DataTypeEnum)
    Select Case FieldType
        ' Контроль ввода целочисленных полей
        Case adInteger, adSmallInt, adUnsignedTinyInt
            Select Case KeyAscii
                Case 48 To 57, Is < 32
                Case 45
                Case Else: KeyAscii = 0
            End Select
        ' Контроль ввода полей с плавающей запятой
        Case adCurrency, adDouble, adSingle, adNumeric
            Select Case KeyAscii
                Case 44, 46: KeyAscii = Asc(Format(0, "."))
                Case 48 To 57, Is < 32
                Case 45
                Case Else: KeyAscii = 0
            End Select
    End Select
End Sub


[VVitafresh]

2 Kovu Честно говоря твой код не работает (по крайней мере буквы спокойно вводятся)?

2 Andrey Fedorov Полезная процедурка, только не могу понять, зачем нужен первый параметр Value?
И еще. Поясни строку:

Код: Выделить всё


Case 44, 46: KeyAscii = Asc(Format(0, "."))


Почему нельзя простро:

Код: Выделить всё


Case 44, 46: KeyAscii = Asc(".")


Ведь в БД в качестве разделителя дробной части зачастую используется точка. А у тебя испольюзуются локальные настройки пользователя. Или я не прав?

Вопрос CopyPaste, кроме как полным перебором символов, выходит так и не решается

[Kovu]

VVitafresh
Дык ето это было дополнение для блокировки вставки

[VVitafresh]

Тады понятно. Блокировка работает.
Я думаю, совместно с контролем KeyPress, напр. ф-ией Андрея Федорова (или подобной) -- это идеальный вариант.

[Andrey Fedorov]

2 Andrey Fedorov Полезная процедурка, только не могу понять, зачем нужен первый параметр Value?

Убери. Я из какой-то старой процедурки этот код выдрал...

Почему нельзя простро:

Код: Выделить всё

Case 44, 46: KeyAscii = Asc(".")


Ведь в БД в качестве разделителя дробной части зачастую используется точка. А у тебя испольюзуются локальные настройки пользователя. Или я не прав?

Прав. Ибо я не знаю что у него за разделитель точка или запятая.
Потому и подставляю то что надо для локали пользователя.
В идеале тут бы еще надо чуть поправить чтобы исключить случай когда точка или запятая может являться разделителем разрядов (тогда подмену делать нельзя). Но таких юзеров у меня просто небыло. Хотя счас у себя поправлю - благо оно не сложно и в одном месте...

Вопрос CopyPaste, кроме как полным перебором символов, выходит так и не решается

Решается элементарной проверкой в событии Validate с соответствующей руганью. Кстати, там-же можно и на допустимый диапазон проверить...