کد زیر را در ماژول قرار دهید :
Public Text_Object As Object
Public max_index As Integer
Public OldScroll As Integer
Public MatnHa() As String
Public CurrentText As Integer
Public IsFarsi As Boolean
Sub Change_Lang(KeyCode, Shift)
If KeyCode = vbKeyF2 And Shift = 1 Then
IsFarsi = Not (IsFarsi)
End If
End Sub
Function convert_txt(getch As Integer)
Select Case LCase(Chr(getch))
Case "q": getch = 174
Case "w": getch = 172
Case "e": getch = 153
Case "r": getch = 236
Case "t": getch = 234
Case "y": getch = 232
Case "u": getch = 228
Case "i": getch = 251
Case "o": getch = 161
Case "p": getch = 159
Case "[", "{": getch = 155
Case "]", "}": getch = 157
Case "a": getch = 170
Case "s": getch = 168
Case "d": getch = 254
Case "f": getch = 147
Case "g": getch = 243
Case "h":
If Chr(getch) = "h" Then
getch = 144
Else
getch = 141
End If
Case "j": getch = 151
Case "k": getch = 247
Case "l": getch = 245
Case ";": getch = 238
Case "'": getch = 240
Case "z": getch = 224
Case "x": getch = 175
Case "c": getch = 165
Case "v": getch = 164
Case "b": getch = 163
Case "n": getch = 162
Case "m":
If Chr(getch) = "m" Then
getch = 142
Else
getch = 143
End If
Case ",": getch = 248
Case "`": getch = 149
Case "\": getch = 166
Case "?": getch = 140
Case "0", "1", "2", "3", "4", "5", "6", "7", "8", "9": getch = getch + 80
Case "!": getch = 33
Case "@": getch = 34
Case "#": getch = 35
Case "$": getch = 197
Case "%": getch = 37
Case "^": getch = 58
Case "&": getch = 138
Case "*": getch = 120
Case "(": getch = 40
Case ")": getch = 41
'Case ".": getch = 46
End Select
'zero to point!
'If getch = 128 Then getch = 46
If getch = 128 Then getch = 189
convert_txt = getch
End Function
Function Convert_Num(getch As Integer)
Convert_Num = IIf(getch > 57, 0, getch + IIf(getch > 47, 80, 0))
If getch = 46 Then Convert_Num = 47
'zero to point!
'If Convert_Num = 128 Then Convert_Num = 46
If Convert_Num = 128 Then Convert_Num = 189
End Function
Sub Txt_Change()
If Len(Text_Object.Text) > 1 And Text_Object.SelStart > 0 Then
'Detect Last Character!
Text_Object.SelStart = Text_Object.SelStart - 1
Text_Object.SelLength = 2
' If it was number!
If Asc(Left(Text_Object.SelText, 1)) = 189 Or (Asc(Left(Text_Object.SelText, 1)) > 127 And Asc(Left(Text_Object.SelText, 1)) < 138) Then
'If Asc(Left(Text_Object.SelText, 1)) = 189 Or Asc(Left(Text_Object.SelText, 1)) = 46 Or Asc(Left(Text_Object.SelText, 1)) = 47 Or (Asc(Left(Text_Object.SelText, 1)) > 127 And Asc(Left(Text_Object.SelText, 1)) < 138) Then
Text_Object.SelStart = Text_Object.SelStart + 1
Text_Object.SelLength = 0
Exit Sub
End If
If Asc(Left(Text_Object.SelText, 1)) = 32 Then
Select Case Asc(Right(Text_Object.SelText, 1))
Case 159:
Text_Object.SelText = " " + Chr(190)
Text_Object.SelStart = Text_Object.SelStart - 1
Case 142:
Text_Object.SelText = " " + Chr(143)
Text_Object.SelStart = Text_Object.SelStart - 1
Case 147, 149, 151, 153, 155, 157, 168, 170, 172, 174, 227, 231, 238, 234, 236, 238, 240, 245, 247, 250:
Text_Object.SelText = " " + Chr(Asc(Right(Text_Object.SelText, 1)) - 1)
Text_Object.SelStart = Text_Object.SelStart - 1
Case 161:
Text_Object.SelText = " " + Chr(176)
Text_Object.SelStart = Text_Object.SelStart - 1
Case 243, 251, 254:
Text_Object.SelText = " " + Chr(Asc(Right(Text_Object.SelText, 1)) - 2)
Text_Object.SelStart = Text_Object.SelStart - 1
Case 228, 232:
Text_Object.SelText = " " + Chr(Asc(Right(Text_Object.SelText, 1)) - 3)
Text_Object.SelStart = Text_Object.SelStart - 1
End Select
Else
If Asc(Left(Text_Object.SelText, 1)) = 228 Or Asc(Left(Text_Object.SelText, 1)) = 232 Or Asc(Left(Text_Object.SelText, 1)) = 251 Then
Select Case Asc(Right(Text_Object.SelText, 1))
Case 243, 245, 247, 249, 250, 251, 254, 142, 147, 149, 151, 153, 155, 157, 159, 161, 168, 170, 172, 174, 175, 224, 227, 228, 231, 232, 234, 236, 238, 240:
Select Case Asc(Left(Text_Object.SelText, 1))
Case 228: Text_Object.SelText = Chr(227) + Right(Text_Object.SelText, 1)
Case 232: Text_Object.SelText = Chr(231) + Right(Text_Object.SelText, 1)
Case 251: Text_Object.SelText = Chr(250) + Right(Text_Object.SelText, 1)
End Select
Text_Object.SelStart = Text_Object.SelStart - 1
End Select
Else
Select Case Asc(Right(Text_Object.SelText, 1))
Case 243:
If Asc(Left(Text_Object.SelText, 1)) = 144 Then
Text_Object.SelText = Chr(242)
End If
Case 142, 147, 149, 151, 153, 155, 157, 159, 161, 168, 170, 172, 174, 175, 224, 227, 228, 231, 232, 234, 236, 238, 240, 245, 247, 250, 251, 254:
Text_Object.SelLength = 1
If Asc(Text_Object.SelText) = 144 Then
Text_Object.SelText = Chr(145)
End If
End Select
End If
End If
Text_Object.SelStart = Text_Object.SelStart + 1
End If
If Text_Object.SelStart <> 0 Then
Text_Object.SelStart = Text_Object.SelStart - 1
End If
If Len(Text_Object) = 1 Then
If Asc(Left(Text_Object, 1)) < 138 And Asc(Left(Text_Object, 1)) > 127 Then
Text_Object.SelStart = 1
End If
End If
End Sub
در اینجا فرض میکنیم که در برنامه ما چند TextBox وجود دارد . به دلیل اینکه نوشتن کد فعال کردن زبان فارسی برای هر TextBox کمی غیر معقول هست و ... ٬ نام جعبه های متنی خود را به شکل آرایه می نویسیم . بدین شکل :
text(0)
text(1)
text(2)
...
حال نوبت به کد فرم اصلی می رسد :
Private Sub Form_Load()
IsFarsi = True
End Sub
Private Sub Text_Change(Index As Integer)
If IsFarsi = True Then
Set Text_Object = Text(Index)
Txt_Change
End If
End Sub
Private Sub Text_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
Call Change_Lang(KeyCode, Shift)
End Sub
Private Sub Text_KeyPress(Index As Integer, KeyAscii As Integer)
If IsFarsi = True Then
If KeyAscii = 13 Then
KeyAscii = 0
'Call SetF(Index, 2)
Else
KeyAscii = convert_txt(KeyAscii)
End If
End If
If KeyAscii = 65 Then KeyAscii = 191
If KeyAscii = 90 Then KeyAscii = 192
If KeyAscii = 67 Then KeyAscii = 193
If KeyAscii = 83 Then KeyAscii = 194
If KeyAscii < 91 And KeyAscii > 64 Then KeyAscii = KeyAscii + 32
End Sub
برای استفاده از برنامه فوق به فونت با کدپیج ایران سیستم نیاز دارید که در فایل ضمیمه چندتا از اونها رو برای دانلود گذاشتم .
پاسخ با نقل قول
</p>
</p>
</p>
