یه نیم نگاه هم به این قسمت بندازید.
از فونتی انتخاب کنید برای تکست باکس که عربی داشته باشه اگه باز هم نشد از ماژول یونیکد استفاده کنید
کد:
Public Const CP_ACP = 0 'ANSI
Public Const CP_MACCP = 2 'Mac
Public Const CP_OEMCP = 1 'OEM
Public Const CP_UTF7 = 65000 'UTF7
Public Const CP_UTF8 = 65001 'UTF8
'dwFlags
Public Const WC_NO_BEST_FIT_CHARS = &H400
Public Const WC_COMPOSITECHECK = &H200
Public Const WC_DISCARDNS = &H10
Public Const WC_SEPCHARS = &H20 'Default
Public Const WC_DEFAULTCHAR = &H40
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, lpMultiByteStr As Byte, ByVal cchMultiByte As Long, lpWideCharStr As Integer, ByVal cchWideChar As Long) As Long
Public Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, lpWideCharStr As Integer, ByVal cchWideChar As Long, lpMultiByteStr As Byte, ByVal cchMultiByte As Long, ByVal lpDefaultChar As String, ByVal lpUsedDefaultChar As Long) As Long
Public Declare Function lstrlenW Lib "kernel32" (lpString As Any) As Long
Function Decode_MIXED_UTF8_Byte_Sequence(x As String) As String
Dim pos As Integer, bt() As Byte, x1 As String
Dim exportString As String
Dim i As Integer
Dim bytesAdded As Boolean
pos% = 1
Do While pos% <= Len(x$)
If Mid$(x$, pos%, 1) = "=" Then
If Mid$(x$, pos% + 1, 1) <> "=" Then
x1$ = Mid$(x, pos + 1, 2)
ReDim Preserve bt(i)
bt(i) = ConvertHexToDec("&H" & x1$)
bytesAdded = True
pos% = pos% + 3
i% = i% + 1
Else
pos% = pos% + 1
End If
Else
If bytesAdded Then
UTF8_to_String ByteArrayToString(bt()), X2$
exportString = exportString & X2$
ReDim bt(0)
i% = 0
bytesAdded = False
End If
x1$ = Mid$(x, pos, 1)
exportString = exportString & x1$
pos% = pos% + 1
End If
Loop
If bytesAdded Then
UTF8_to_String ByteArrayToString(bt()), X2$
exportString = exportString & X2$
ReDim bt(0)
i% = 0
bytesAdded = False
End If
Decode_MIXED_UTF8_Byte_Sequence = exportString
End Function
Public Function GetStrFromBufferA(sz As String) As String
If InStr(sz, vbNullChar) Then
GetStrFromBufferA = Left$(sz, InStr(sz, vbNullChar) - 1)
Else
GetStrFromBufferA = sz
End If
End Function
Public Function ByteArrayToString(Bytes() As Byte) As String
Dim iUnicode As Long, i As Long, j As Long
On Error Resume Next
i = UBound(Bytes)
If (i < 1) Then
ByteArrayToString = StrConv(Bytes, vbUnicode)
Exit Function
End If
i = i + 1
CopyMemory iUnicode, Bytes(0), 2
If iUnicode = Bytes(0) Then
If (i Mod 2) Then i = i - 1
ByteArrayToString = String$(i / 2, 0)
CopyMemory ByVal StrPtr(ByteArrayToString), Bytes(0), i
Else
ByteArrayToString = StrConv(Bytes, vbUnicode)
End If
End Function
Function ConvertHexToDec(hString As String) As Byte
On Error GoTo Err
Dim h As String
h = Right$(hString, 2)
Dim Tmp$
Dim lo1 As Integer, lo2 As Integer
Dim hi1 As Long, hi2 As Long
Const Hx = "&H"
Const BigShift = 65536
Const LilShift = 256, Two = 2
Tmp = h
If UCase(Left$(h, 2)) = "&H" Then Tmp = Mid$(h, 3)
Tmp = Right$("0000000" & Tmp, 8)
If IsNumeric(Hx & Tmp) Then
lo1 = CInt(Hx & Right$(Tmp, Two))
hi1 = CLng(Hx & Mid$(Tmp, 5, Two))
lo2 = CInt(Hx & Mid$(Tmp, 3, Two))
hi2 = CLng(Hx & Left$(Tmp, Two))
ConvertHexToDec = CCur(hi2 * LilShift + lo2) * BigShift + (hi1 * LilShift) + lo1
End If
Exit Function
Err:
MsgBox "There was an error", vbCritical, "Error"
End Function
Public Function UTF8_to_String(strInput As String, strResult As String) As Boolean
Dim UTF16Buffer() As Integer, res As Long
Dim UTF8Buffer() As Byte
Dim Length As Long
Length = Len(strInput)
UTF8_to_String = False
UTF8Buffer = StrConv(strInput, vbFromUnicode)
res = MultiByteToWideChar(CP_UTF8, 0, UTF8Buffer(LBound(UTF8Buffer)), Length, 0, 0)
If res = 0 Then
UTF8_to_String = False
strResult = "*"
Exit Function
End If
ReDim UTF16Buffer(0 To res + 10)
res = MultiByteToWideChar(CP_UTF8, 0, UTF8Buffer(LBound(UTF8Buffer)), Length, UTF16Buffer(0), UBound(UTF16Buffer) + 1)
If res = 0 Then
UTF8_to_String = strInput
Exit Function
End If
strResult = Space(res)
CopyMemory ByVal StrPtr(strResult), UTF16Buffer(0), res * 2
UTF8_to_String = True
End Function
Public Function String_to_UTF8(strInput As String) As String
Dim res As Long
Dim UTF8Buffer() As Byte
Dim UTF16Buffer() As Integer
Dim Length As Long
Length = Len(strInput)
ReDim UTF16Buffer(0 To Length + 1) As Integer
CopyMemory UTF16Buffer(0), ByVal StrPtr(strInput), Length * 2
res = WideCharToMultiByte(CP_UTF8, 0, UTF16Buffer(LBound(UTF16Buffer)), Length, 0, 0, vbNullString, 0)
If res = 0 Then Exit Function
ReDim UTF8Buffer(0 To res - 1)
res = WideCharToMultiByte(CP_UTF8, 0, UTF16Buffer(LBound(UTF16Buffer)), Length, UTF8Buffer(0), res, vbNullString, 0)
If res = 0 Then Exit Function
String_to_UTF8 = StrConv(UTF8Buffer, vbUnicode)
End Function
صفحه اصلی
انجمن
جستجو
فهرست اعضا
افزونه های فایرفاکس
» 
تشکر شده توسط :
![[تصویر: 308amwy27tq1md4matcy.jpg]](http://up5.iranblog.com/images/308amwy27tq1md4matcy.jpg)
![[تصویر: j8xthvriwqjk0ut0thhq.jpg]](http://up6.iranblog.com/images/j8xthvriwqjk0ut0thhq.jpg)