mf_engineer
جمعه 09 شهریور 1386, 10:04 صبح
با سلام
من می خوام توی فرمم وقتی که اجرا می کنم تکس بکس هام فارسی باشه وتوش بدون تغییر زبان صفحه کلید فارسی بنویسم
من کد اقای غیبی رو هم نوشتم ولی ارر میگیره
کدش رو اینجا می ذارم
منتظر یاری سبز شما هستم
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
من می خوام توی فرمم وقتی که اجرا می کنم تکس بکس هام فارسی باشه وتوش بدون تغییر زبان صفحه کلید فارسی بنویسم
من کد اقای غیبی رو هم نوشتم ولی ارر میگیره
کدش رو اینجا می ذارم
منتظر یاری سبز شما هستم
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