Tác giả: Sưu tầm + Mrcoding
Mô tả: Giúp chặn lỗi khi người dùng nhập số thập phân sai mới decimal symbol của hệ thống
Đầu tiên tạo 1 module có nội dung sau
- Mã: Chọn tất cả
Const LOCALE_USER_DEFAULT = &H400
Private Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long
Public Const LOCALE_SSHORTDATE = &H1F
Public Const WM_SETTINGCHANGE = &H1A
Const Hwnd_BROADCAST = &HFFFF&
Private Declare Function SetLocaleInfo Lib "kernel32" Alias "SetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String) As Boolean
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetSystemDefaultLCID Lib "kernel32" () As Long
'==================================================================
Private Const LOCALE_SDECIMAL = &HE ' decimal separator
'ham kiem tra ky tu decimol symbol cua he thong
Public Function GetDecimalChar() As String
GetDecimalChar = GetInfo(LOCALE_SDECIMAL)
End Function
Public Function GetInfo(ByVal lInfo As Long) As String
Dim Buffer As String, Ret As String
Buffer = String$(256, 0)
Ret = GetLocaleInfo(LOCALE_USER_DEFAULT, lInfo, Buffer, Len(Buffer))
If Ret > 0 Then
GetInfo = Left$(Buffer, Ret - 1)
Else
GetInfo = ""
End If
End Function
'thu tuc chi cho phep nhap so va ky tu decimol symbol==============================
Private Sub CheckNumber()
Dim sTemplate As String
sTemplate = "0123456789" & GetDecimalChar 'Cac ky tu cho phep go vao textbox
If InStr(1, sTemplate, Chr(KeyAscii)) > 0 Then
Else
If KeyAscii = 13 Or KeyAscii = vbKeyBack Then
Else
KeyAscii = 0
End If
End If
End Sub
'ham dem so lan xuat hien cua ky tu trong chuoi==========
Public Function CharCount(ByVal OrigString As String, _
ByVal Chars As String, Optional ByVal CaseSensitive As Boolean = False) _
As Long
'**********************************************
'PURPOSE: Returns Number of occurrences of a character or
'or a character sequencence within a string
'PARAMETERS:
'OrigString: String to Search in
'Chars: Character(s) to search for
'CaseSensitive (Optional): Do a case sensitive search
'Defaults to false
'RETURNS:
'Number of Occurrences of Chars in OrigString
'EXAMPLES:
'Debug.Print CharCount("FreeVBCode.com", "E") -- returns 3
'Debug.Print CharCount("FreeVBCode.com", "E", True) -- returns 0
'Debug.Print CharCount("FreeVBCode.com", "co") -- returns 2
''**********************************************
Dim lLen As Long
Dim lCharLen As Long
Dim lAns As Long
Dim sInput As String
Dim sChar As String
Dim lCtr As Long
Dim lEndOfLoop As Long
Dim bytCompareType As Byte
sInput = OrigString
If sInput = "" Then Exit Function
lLen = Len(sInput)
lCharLen = Len(Chars)
lEndOfLoop = (lLen - lCharLen) + 1
bytCompareType = IIf(CaseSensitive, vbBinaryCompare, _
vbTextCompare)
For lCtr = 1 To lEndOfLoop
sChar = Mid(sInput, lCtr, lCharLen)
If StrComp(sChar, Chars, bytCompareType) = 0 Then _
lAns = lAns + 1
Next
CharCount = lAns
End Function
Sau đó tạo 1 from gồm 1 textbox và chèn lệnh này vào
- Mã: Chọn tất cả
Dim yKey as Integer
Private Sub Text1_Change()
Text1_KeyPress ykEY
End Sub
Private Sub Text1_KeyPress(KeyAscii As Integer)
Dim sTemplate As String
Dim count As Long
ykEY = KeyAscii
sTemplate = "0123456789" & GetDecimalChar 'Cac ky tu cho phep go vao textbox
If CharCount(Text1.text, GetDecimalChar) > 0 And Chr(KeyAscii) = GetDecimalChar Then
KeyAscii = 0
Exit Sub
End If
If InStr(1, sTemplate, Chr(KeyAscii)) > 0 Then
Else
If KeyAscii = 13 Or KeyAscii = vbKeyBack Then
Else
IMsgbox UnicodeTelex("Bajn chir dduwowjc phesp nhaajp soos vaf kys tuwj ngawn casch giuwxa casc soos thaajp phaan laf daasu '") & GetDecimalChar & ("'"), vbInformation
KeyAscii = 0
End If
End If
End Sub
Hy vọng là có ích cho các bạn
