مراجع حل مشکلات فارس و کدهای مربوط

سلام قرار است که در این قسمت در باره فارسی و کدهای مرتبط با آن صحبت کنیم؟
اين قسمت مخصوص وي بي است
البطه هر کس که مایلد؟
این تایپک اصلا ربطی به قسمت هاي ديگر ندارد.
این قسمت مراجع حل مشکلات فارسی در ویژوال بیسیک؟
حالا هر کسی که مایلد در این قسمت تایپک بگزارد.

دوستان اولین تایپک در باره فارسی در ویژوال بیسیک
خوب فارسی سازی ویندوز xp را در قسمت مطالب در مورد vb درس دادم
حالا می خواهم آموزش چگونگی فارسی سازی صفحه کلید در ویژوال بیسیک را درس بدهم
کدی که مشاهده می نمایید برای تبدیل صفحه کلید به فارسی؟

نقل قول:

---

Public Declare Function LoadKeyboardLayout Lib "user32" Alias "LoadKeyboardLayoutA" (ByVal pwszKLID As String, ByVal flags As Long) As Long

---

خوب ویندوز xp و 2000 که فارسی نصب شده باشد
[PHP]Dim xx As Long[/PHP]
[PHP]xx = LoadKeyboardLayout("00000429", 1)[/PHP]
ویندوز پارسا 99 و ماننده این ها....
[PHP]Dim xx As Long[/PHP]
[PHP]xx = LoadKeyboardLayout("00000401", 1)[/PHP]
کد 401 برای اربستان ولی در پارسا فارسی است

اگر در پارسا نشد از کد 429 هم استفاده نمایید

سلام
می خواهم آموزش تبدیل عدد به حرو را آموزش بدم؟!!!!!
این تابع ما فقط تا حروف وعدد
(نهصد و نود و نه ميليارد و نهصد و نود و نه ميليون و نهصد و نود نه هزار و نهصد و نود و نه) مي باشد.
پشتیبانی می کند؟
[PHP]Option Explicit
Private Const hezar = " هزار"
Private Const melun = " ميليون"
Private Const melyard = " ميليارد"
Private Const va = " و "

Public Function heji_adad(ByVal adad As Double) As String
Dim hooroof As String
Dim SS As Integer 'sadgan
Dim hh As Integer 'hezargan
Dim mm As Integer 'melungan
Dim yy As Integer 'melyardgan
Dim STRadad As String
Dim LENadad As Integer

STRadad = Str(Val(Str(adad)))
LENadad = Len(STRadad)

Select Case adad
Case Is = 0
hooroof = "صفر"
Case 1 To 999
hooroof = Adad_Heji(adad)
Case 1000 To 999999
If (adad Mod 1000 = 0) Then hooroof = Adad_Heji(Int(adad / 1000)) + hezar
If (adad Mod 1000 <> 0) Then hooroof = Adad_Heji(Int(adad / 1000)) + hezar + va + (Adad_Heji(adad Mod 1000))
Case 1000000 To 999999999
SS = Val(Right$(STRadad, 3))
hh = Val(Mid$(STRadad, LENadad - 5, 3))
mm = Val(Left$(STRadad, LENadad - 6))
If (SS = 0 And hh = 0) Then hooroof = Adad_Heji(mm) + melun
If (SS = 0 And hh <> 0) Then hooroof = Adad_Heji(mm) + melun + va + Adad_Heji(hh) + hezar
If (SS <> 0 And hh = 0) Then hooroof = Adad_Heji(mm) + melun + va + Adad_Heji(SS)
If (SS <> 0 And hh <> 0) Then hooroof = Adad_Heji(mm) + melun + va + Adad_Heji(hh) + hezar + va + Adad_Heji(SS)
Case 1000000000 To 999999999999#
SS = Val(Right$(STRadad, 3))
hh = Val(Mid$(STRadad, LENadad - 5, 3))
mm = Val(Mid$(STRadad, LENadad - 8, 3))
yy = Val(Left$(STRadad, LENadad - 9))
If (SS = 0 And hh = 0 And mm = 0) Then hooroof = Adad_Heji(yy) + melyard
If (SS = 0 And hh = 0 And mm <> 0) Then hooroof = Adad_Heji(yy) + melyard + va + Adad_Heji(mm) + melun
If (SS = 0 And hh <> 0 And mm <> 0) Then hooroof = Adad_Heji(yy) + melyard + va + Adad_Heji(mm) + melun + va + Adad_Heji(hh) + hezar
If (SS <> 0 And hh <> 0 And mm <> 0) Then hooroof = Adad_Heji(yy) + melyard + va + Adad_Heji(mm) + melun + va + Adad_Heji(hh) + hezar + va + Adad_Heji(SS)
Case Is > 999999999999#
hooroof = "عدد وارد شده بزرگتر از 999999999999 است"
End Select
heji_adad = hooroof
End Function

Private Function Adad_Heji(ByVal adad As Integer) As String
Dim yekan As Byte
Dim dahgan As Byte
Dim sadgan As Byte
Dim behooroof As String
Dim heji(19) As String
Dim heji_dahgan(9) As String
Dim heji_sadgan(9) As String
'-------------------------------
heji(1) = "يک": heji(2) = "دو": heji(3) = "سه": heji(4) = "چهار": heji(5) = "پنج"
heji(6) = "شش": heji(7) = "هفت": heji(8) = "هشت": heji(9) = "نه": heji(10) = "ده"
heji(11) = "يازده": heji(12) = "دوازده": heji(13) = "سيزده": heji(14) = "چهارده": heji(15) = "پانزده"
heji(16) = "شانزده": heji(17) = "هفده": heji(18) = "هيجده": heji(19) = "نوزده"
'-------------------------------
heji_dahgan(1) = "ده"
heji_dahgan(2) = "بيست"
heji_dahgan(3) = "سي": heji_dahgan(4) = "چهل": heji_dahgan(5) = "پنجاه"
heji_dahgan(6) = "شصت": heji_dahgan(7) = "هفتاد": heji_dahgan(8) = "هشتاد"
heji_dahgan(9) = "نود"
'-------------------------------
heji_sadgan(1) = "يكصد": heji_sadgan(2) = "دويست": heji_sadgan(3) = "سيصد"
heji_sadgan(4) = "چهارصد": heji_sadgan(5) = "پانصد": heji_sadgan(6) = "ششصد"
heji_sadgan(7) = "هفتصد": heji_sadgan(8) = "هشتصد": heji_sadgan(9) = "نهصد"
'-------------------------------
yekan = adad Mod 10
dahgan = adad Mod 100
sadgan = Int(adad / 100)
'-------------------------------
If dahgan < 20 Then
If (sadgan = 0) Then behooroof = heji(dahgan)
If (sadgan <> 0) Then behooroof = heji_sadgan(sadgan) + va + heji(dahgan)
If (yekan = 0 And dahgan = 0) Then behooroof = heji_sadgan(sadgan)
Else
dahgan = (adad Mod 100) - yekan
If (sadgan = 0 And yekan = 0) Then behooroof = heji_dahgan(dahgan / 10)
If (sadgan = 0 And yekan <> 0) Then behooroof = heji_dahgan(dahgan / 10) + va + heji(yekan)
If (sadgan <> 0 And yekan = 0) Then behooroof = heji_sadgan(sadgan) + va + heji_dahgan(dahgan / 10)
If (sadgan <> 0 And yekan <> 0) Then behooroof = heji_sadgan(sadgan) + va + heji_dahgan(dahgan / 10) + va + heji(yekan)
End If

Adad_Heji = behooroof
End Function[/PHP]
طرز استفاده:
[PHP]Text1.text = heji_adad(156489)[/PHP]

نقل قول:

---

با اجراي کد بالا عبارت "يكصد و پنجاه و شش هزار و چهارصد و هشتاد و نه" در Text1 نمايش داده خواهد شد.

---

برای این کد از برادرم پوریا تشکر می کنم؟

خوب امیدوارم که مورد قبول واقع شود
تمامی پست هایی که مشاهده می کنید اصلا ربطی به هم دیگر ندارد بلکه هر کدام سوا هستند و باید تایپک ها را جدا گانه فرستاد.

خوب حالا دوستان می خواهم به شما آموزش
تغویم هجری شمسی بدهم ولی اما دست نگه می دارم چون می خواهم بدانم که دوستان آیا مایلند که من ادامه بدهم؟
اگر نه که تایپک را دیگر ادامه نمی دهم
ولی اگر آره به تامای سوالات شما جواب می دهم و قرار اگر شما با ادامه این بحث موافق بودید آموزش ساخت
تقویم هجری شمس و تبدیل فایل تبدیل موزیک ساخت کتابخانه و اکسل.......................................... .
را بدهم بس سبر می کنم تا جواب بدهید؟!!!!
:rolleye:

نظر نظر بدين ديگه دوستان عزيزم

سلام
خیلی تا÷یک جالبلیه
من در موردvc++ مشکل دارم
مثلا وقتی می نویسم
xxx= "سلام"
توی برنامه ای که کام÷ایل می شه یه سری کاراکترای عجیب غریب نشون میده
ولی اگه مثلا یه عبارتو از یه editbox بخونی و بعد نشونش بدی درست نشونش میده
ایا تو vb به یه چنین مشکلی برخوردین؟؟؟

سلام با تشکر از شما ولی‌ عنوان تاپیک رو مناسب تر و بهتر اگه کنید بیشتر مشخص می‌شه که فارسی‌ نویسی‌ در زبان ویبی‌ هست .
متشکر.

سلام دوست عزیز این هم عنوان را درست کردم
خوبه ممنون ؟

دوست عزیز چنین مشکلی که فرمودین در ویبی اتفاق نیافتاده اما شاید برای من همچنین اتفاقی نیفتاده
یه جستجو می کنم و برایتان مشکلتان را پیدا کنم
ممنون خدا نگهدار

[PHP]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[/PHP]
كد بالارا در ماژول قرار دهيد
[PHP]
text(0)
text(1)
text(2)
...[/PHP]
کد بال برای چن تکست باکس داشته باشید بصورت بالا نوشته"
و کد پایین برای فورم اصلی:
[PHP]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[/PHP]

دوستان عزیز امیدوارم مورد قبول باشد
و نظر یادتون نره

دوست گرامی:

برای عوض کردن سیستم تاریخ میلادی به شمسی server 2003 و کامپیوتر های دیگر در شبکه کاری می توان کرد؟

میخوام سیستم Microsoft CRM را اجرا کنم و باید کل outlook ها,... تاریخ شمسی شود .

با تشکر فراوان