حل مشکل آدرس یاب [بایگانی]

ershad_tb

شنبه 04 آبان 1392, 13:30 عصر

سلام آدرس یاب من مشکلی که داره پیغام مدیرش فارسی نمیشه فقط خارجی رو نشان میده میشه کاری کرد فارسی هم ساپورت کنه ؟

پیغام لینکی هست که به صورت txt هست توی هاست گذاشته میشود .

encoding فایل txt هم تمام حالات گذاشتم ولی نشد

ضمیمه : فایل txt فارسی تایپ شده است ولی به این شکل نشان میدهد .

لطفا گام به گام توضیح بدید و به زبان ساده

ممنون

R2du-soft

شنبه 04 آبان 1392, 13:53 عصر

سلام دوست عزیز
اون تکستی که توش متن فارسی رو میخوای نمایش داده بشه خاصیت multi line رو بزار روی true که بعد چیغام با محتویات چند خط دادی به مشکل نخوری
و برای نمایس فارسی:
روی همون تکست باکسی که محتویات فارسی رو نشون نمیده کلیک کن و از داخل properties گزینه font رو پیدا کن و نوع فونت رو بزار روی Tahoma و از قسمت script (لیست کشویی) گزینه arabic رو انتخاب کنین تا فارسی نمایش داده بشه.

ershad_tb

شنبه 04 آبان 1392, 16:57 عصر

انجام شد ولی نتیجه بخش نبود

یکی از دوستان قبلن کدی دادند ولی آخرش رو متوجه نشدم باید چکار کنم ( بعد از دریافت متن تابع UTF8_Decode رو به صورت زیر صدا بزنید :
string1 = UTF8_Decode(string1) )

سلام
توابع زیر را در پروژتون کپی کنید :

Public Function UTF8_Encode(ByVal sStr As String)
Dim L As Long, lChar As Long, sUTF8 As String
For L& = 1 To Len(sStr)
lChar& = AscW(Mid(sStr, L&, 1))
If lChar& < 128 Then
sUTF8$ = sUTF8$ + Mid(sStr, L&, 1)
ElseIf ((lChar& > 127) And (lChar& < 2048)) Then
sUTF8$ = sUTF8$ + Chr(((lChar& \ 64) Or 192))
sUTF8$ = sUTF8$ + Chr(((lChar& And 63) Or 128))
Else
sUTF8$ = sUTF8$ + Chr(((lChar& \ 144) Or 234))
sUTF8$ = sUTF8$ + Chr((((lChar& \ 64) And 63) Or 128))
sUTF8$ = sUTF8$ + Chr(((lChar& And 63) Or 128))
End If
Next L&
UTF8_Encode = sUTF8$
End Function
Public Function UTF8_Decode(ByVal sStr As String)
On Error Resume Next
Dim L As Long, sUTF8 As String, iChar As Integer, iChar2 As Integer

sStr = Replace(sStr, "U^Œ", UTF8_Encode("i'"))

sStr = Replace(sStr, "U`‰", UTF8_Encode("i'"))

For L = 1 To Len(sStr)

iChar = Asc(Mid(sStr, L, 1))

If iChar > 127 Then

If Not iChar And 32 Then

iChar2 = Asc(Mid(sStr, L + 1, 1))

sUTF8 = sUTF8 & IIf(iChar2 = 156, ChrW(1610), ChrW$(((31 And iChar) * 64 + (63 And iChar2))))

L = L + 1

Else

Dim iChar3 As Integer

iChar2 = Asc(Mid(sStr, L + 1, 1))

iChar3 = Asc(Mid(sStr, L + 2, 1))

'sUTF8 = sUTF8 & ChrW$(((iChar And 15) * 16 * 256) + ((iChar2 And 63) * 64) + (iChar3 And 63))

L = L + 2

End If

Else

sUTF8 = sUTF8 & Chr$(iChar)

End If

Next L

UTF8_Decode = sUTF8

End Function

Public Function EncodeString(StrText As String) As String
On Error Resume Next
Dim i As Integer, bEnc As String
For i = 1 To Len(StrText)
bEnc = bEnc & "%" & Hex(Asc(Mid(StrText, i, 1)))
Next
EncodeString = bEnc
End Function

و بعد از دریافت متن تابع UTF8_Decode رو به صورت زیر صدا بزنید :
string1 = UTF8_Decode(string1)

R2du-soft

شنبه 04 آبان 1392, 20:43 عصر

شما آدرس یک فایل تکست بهم بده تا برات یه قسمت از برنامه درست کنم که فارسی رو ساپورت کنه و شما از روی اون برنامه خودت رو تکمیل کنی.

majid12376

سه شنبه 08 بهمن 1392, 20:14 عصر

سلام
کل این کد در فرم اصلی بذار
''FARSI CODES''
Public Function UTF8_Encode(ByVal sStr As String)
Dim l As Long, lChar As Long, sUTF8 As String
For l& = 1 To Len(sStr)
lChar& = AscW(Mid(sStr, l&, 1))
If lChar& < 128 Then
sUTF8$ = sUTF8$ + Mid(sStr, l&, 1)
ElseIf ((lChar& > 127) And (lChar& < 2048)) Then
sUTF8$ = sUTF8$ + Chr(((lChar& \ 64) Or 192))
sUTF8$ = sUTF8$ + Chr(((lChar& And 63) Or 128))
Else
sUTF8$ = sUTF8$ + Chr(((lChar& \ 144) Or 234))
sUTF8$ = sUTF8$ + Chr((((lChar& \ 64) And 63) Or 128))
sUTF8$ = sUTF8$ + Chr(((lChar& And 63) Or 128))
End If
Next l&
UTF8_Encode = sUTF8$
End Function
'===============================Farsi nevisi
Public Function UTF8_Decode(ByVal sStr As String)
Dim l As Long, sUTF8 As String, iChar As Integer, iChar2 As Integer
sStr = Replace(sStr, "U^Œ", UTF8_Encode("i'"))
sStr = Replace(sStr, "U`‰", UTF8_Encode("i'"))
For l = 1 To Len(sStr)
iChar = Asc(Mid(sStr, l, 1))
If iChar > 127 Then
If Not iChar And 32 Then
iChar2 = Asc(Mid(sStr, l + 1, 1))
sUTF8 = sUTF8 & ChrW$(((31 And iChar) * 64 + (63 And iChar2)))
l = l + 1
Else
Dim iChar3 As Integer
iChar2 = Asc(Mid(sStr, l + 1, 1))
iChar3 = Asc(Mid(sStr, l + 2, 1))
'sUTF8 = sUTF8 & ChrW$(((iChar And 15) * 16 * 256) + ((iChar2 And 63) * 64) + (iChar3 And 63))
l = l + 2
End If
Else
sUTF8 = sUTF8 & Chr$(iChar)
End If
Next l
UTF8_Decode = sUTF8
End Function

Public Function EncodeString(StrText As String) As String
On Error Resume Next
Dim I As Integer, bEnc As String
For I = 1 To Len(StrText)
bEnc = bEnc & "%" & Hex(Asc(Mid(StrText, I, 1)))
Next
EncodeString = bEnc
End Function
و در انتها
نمونه مثال
AdminPM.Text = ""
AdminPM.Text = UTF8_Decode(AdminPM.Text) & GetUrlSource("http://www.yahoo.com/test.txt")
AdminPM.Text = UTF8_Decode(AdminPM.Text) & vbCrLf
در ضمن فایل متنی تونو که در هاست هست باید به صورت یونی کد ذخیره کنید

mmssoft

پنج شنبه 10 بهمن 1392, 02:36 صبح

انجام شد ولی نتیجه بخش نبود

یکی از دوستان قبلن کدی دادند ولی آخرش رو متوجه نشدم باید چکار کنم ( بعد از دریافت متن تابع UTF8_Decode رو به صورت زیر صدا بزنید :
string1 = UTF8_Decode(string1) )

سلام
توابع زیر را در پروژتون کپی کنید :

Public Function UTF8_Encode(ByVal sStr As String)
Dim L As Long, lChar As Long, sUTF8 As String
For L& = 1 To Len(sStr)
lChar& = AscW(Mid(sStr, L&, 1))
If lChar& < 128 Then
sUTF8$ = sUTF8$ + Mid(sStr, L&, 1)
ElseIf ((lChar& > 127) And (lChar& < 2048)) Then
sUTF8$ = sUTF8$ + Chr(((lChar& \ 64) Or 192))
sUTF8$ = sUTF8$ + Chr(((lChar& And 63) Or 128))
Else
sUTF8$ = sUTF8$ + Chr(((lChar& \ 144) Or 234))
sUTF8$ = sUTF8$ + Chr((((lChar& \ 64) And 63) Or 128))
sUTF8$ = sUTF8$ + Chr(((lChar& And 63) Or 128))
End If
Next L&
UTF8_Encode = sUTF8$
End Function
Public Function UTF8_Decode(ByVal sStr As String)
On Error Resume Next
Dim L As Long, sUTF8 As String, iChar As Integer, iChar2 As Integer

sStr = Replace(sStr, "U^Œ", UTF8_Encode("i'"))

sStr = Replace(sStr, "U`‰", UTF8_Encode("i'"))

For L = 1 To Len(sStr)

iChar = Asc(Mid(sStr, L, 1))

If iChar > 127 Then

If Not iChar And 32 Then

iChar2 = Asc(Mid(sStr, L + 1, 1))

sUTF8 = sUTF8 & IIf(iChar2 = 156, ChrW(1610), ChrW$(((31 And iChar) * 64 + (63 And iChar2))))

L = L + 1

Else

Dim iChar3 As Integer

iChar2 = Asc(Mid(sStr, L + 1, 1))

iChar3 = Asc(Mid(sStr, L + 2, 1))

'sUTF8 = sUTF8 & ChrW$(((iChar And 15) * 16 * 256) + ((iChar2 And 63) * 64) + (iChar3 And 63))

L = L + 2

End If

Else

sUTF8 = sUTF8 & Chr$(iChar)

End If

Next L

UTF8_Decode = sUTF8

End Function

Public Function EncodeString(StrText As String) As String
On Error Resume Next
Dim i As Integer, bEnc As String
For i = 1 To Len(StrText)
bEnc = bEnc & "%" & Hex(Asc(Mid(StrText, i, 1)))
Next
EncodeString = bEnc
End Function

و بعد از دریافت متن تابع UTF8_Decode رو به صورت زیر صدا بزنید :
string1 = UTF8_Decode(string1)

وقتی عملیات گرفتن متن از فایل txt انجام شد و متن توی TextBox قرار گرفت از این کد برای درست کردنش استفاده کنید :

Text1.Text = UTF8_Decode (Text1.Text)