Visual Basic, .NET, ASP, VBScript
| | | | VBA | VB | WinAPI | ActiveX | VB | | VBNet | ndex bar! | | | VBNet | | | | | VBNet | ! | | - |
 

   
 

: :

, , ?
 
     

-

: 1 |

 

  : Unicode Win1251 : 16.10.08 15:10  

:  Yanex | Web-: Progr.Do.am | ICQ: 387761649 
Visual Basic 6.0 Ошибка ? StrConv - , .

  : 4  

: 1
:
 



: 8
: 42
   | | #1 : 16.10.08 15:57
:
  1.  
  2. Option Explicit
  3. Enum Code
  4.     Win = 1
  5.     Dos = 2
  6.     Koi = 3
  7.     Iso = 5
  8. End Enum
  9. Function Recode(Char As String, Src As Code, Dest As Code) As String
  10. Const wDos As String = ""
  11. Const wIso As String = "ע"
  12. Const wKoi As String = ""
  13. Const wWin As String = ""
  14. Const NotRecodedChar As String = "?"
  15.  
  16. If Src = Dest Then
  17.     Recode = Char
  18.     Exit Function
  19. End If
  20.  
  21. Dim t As String, i As Long, tt As String, a As Long, ss As String, ch As String
  22. If Src = Win Then
  23.     t = Char
  24. Else
  25.     Select Case Src
  26.         Case Koi: ss = wKoi
  27.         Case Dos: ss = wDos
  28.         Case Iso: ss = wIso
  29.     End Select
  30.     For i = 1 To Len(Char)
  31.         ch = Mid(Char, i, 1)
  32.         If Asc(ch) < 128 Then
  33.             t = t & ch
  34.         Else
  35.             a = InStr(1, ss, ch, vbBinaryCompare)
  36.             If a = 0 Then
  37.                 t = t & NotRecodedChar
  38.             Else
  39.                 t = t & Mid$(wWin, a, 1)
  40.             End If
  41.         End If
  42.     Next i
  43. End If
  44.  
  45. If Dest = Win Then
  46.     Recode = t
  47. Else
  48.     Select Case Dest
  49.         Case Koi: ss = wKoi
  50.         Case Dos: ss = wDos
  51.         Case Iso: ss = wIso
  52.     End Select
  53.     For i = 1 To Len(Char)
  54.         ch = Mid(t, i, 1)
  55.         If Asc(ch) < 128 Then
  56.             tt = tt & ch
  57.         Else
  58.             a = InStr(1, wWin, ch, vbBinaryCompare)
  59.             If a = 0 Then
  60.                 tt = tt & NotRecodedChar
  61.             Else
  62.                 tt = tt & Mid$(ss, a, 1)
  63.             End If
  64.         End If
  65.     Next i
  66.     Recode = tt
  67. End If
  68. End Function
  69.  
: 2
:
 Winand



: 87
: 2795
  Web-: winandfx.narod.ru
  | | #2 		: 16.10.08 17:05
?
  1. Option Explicit
  2. Private Const CP_UTF8 = 65001
  3. Private Const CP_ACP = 0
  4. Private Declare Function GetACP Lib "Kernel32" () As Long
  5. Private Declare Function WideCharToMultiByte Lib "Kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, lpUsedDefaultChar As Long) As Long
  6. Private Declare Function MultiByteToWideChar Lib "Kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
  7.  
  8. Private Function WToA(ByVal st As String, Optional ByVal cpg As Long = -1, Optional lFlags As Long = 0) As String
  9.     Dim stBuffer As String
  10.     Dim cwch As Long
  11.     Dim pwz As Long
  12.     Dim pwzBuffer As Long
  13.     Dim lpUsedDefaultChar As Long
  14.     
  15.     If cpg = -1 Then cpg = GetACP()
  16.     pwz = StrPtr(st)
  17.     cwch = WideCharToMultiByte(cpg, lFlags, pwz, -1, 0&, 0&, ByVal 0&, ByVal 0&)
  18.     stBuffer = String$(cwch + 1, vbNullChar)
  19.     pwzBuffer = StrPtr(stBuffer)
  20.     cwch = WideCharToMultiByte(cpg, lFlags, pwz, -1, pwzBuffer, Len(stBuffer), ByVal 0&, ByVal 0&)
  21.     WToA = Left$(stBuffer, cwch - 1)
  22. End Function
  23.  
  24. Private Function AToW(ByVal st As String, Optional ByVal cpg As Long = -1, Optional lFlags As Long = 0) As String
  25.     Dim stBuffer As String
  26.     Dim cwch As Long
  27.     Dim pwz As Long
  28.     Dim pwzBuffer As Long
  29.         
  30.     If cpg = -1 Then cpg = GetACP()
  31.     pwz = StrPtr(st)
  32.     cwch = MultiByteToWideChar(cpg, lFlags, pwz, -1, 0&, 0&)
  33.     stBuffer = String$(cwch + 1, vbNullChar)
  34.     pwzBuffer = StrPtr(stBuffer)
  35.     cwch = MultiByteToWideChar(cpg, lFlags, pwz, -1, pwzBuffer, Len(stBuffer))
  36.     AToW = Left$(stBuffer, cwch - 1)
  37. End Function
  38.  
  39. Public Function EncodeUTF8(ByVal cnvUni As String) As String
  40.     If cnvUni = vbNullString Then Exit Function
  41.     EncodeUTF8 = StrConv(WToA(cnvUni, CP_UTF8), vbUnicode)
  42. End Function
  43.  
  44. Public Function DecodeUTF8(ByVal cnvUni As String) As String
  45.     If cnvUni = vbNullString Then Exit Function
  46.     DecodeUTF8 = AToW(WToA(cnvUni, CP_ACP), CP_UTF8)
  47. End Function
: 3
:
 Yanex



ICQ: 387761649 

: 32
: 169
  Web-: Progr.Do.am
  | | #3 		: 17.10.08 08:58
! ! , ))

. )

: 4
:
 Winand



: 87
: 2795
  Web-: winandfx.narod.ru
  | | #4 		: 18.10.08 18:38
:
  1. Option Explicit
  2. '(C)2002
  3. 'MAIL : http://www.geocities.co.jp/SilkRoad/4511/img/mailaddr.png
  4. 'HOME : http://www.geocities.co.jp/SilkRoad/4511/
  5. Public Const ISUTF8_DEFAULT_READSIZE = 1024
  6.  
  7. Public Function Utf8Encode(ByRef strUnicode As String, ByRef bytUtf8() As Byte) As Long
  8.     Dim lngUnicodeLength As Long
  9.     Dim lngUtf8Size As Long
  10.     Dim lngCharCode As Long
  11.     Dim i As Long
  12.  
  13.     lngUnicodeLength = Len(strUnicode)
  14.     If Not CBool(lngUnicodeLength) Then Exit Function
  15.     ReDim bytUtf8((lngUnicodeLength * 3) - 1)
  16.     
  17.     For i = 1 To lngUnicodeLength Step 1
  18.         lngCharCode = CLng(AscW(Mid$(strUnicode, i, 1))) And &HFFFF&
  19.         If lngCharCode <= &H7F& Then
  20.             bytUtf8(lngUtf8Size) = CByte(lngCharCode)
  21.             lngUtf8Size = lngUtf8Size + 1
  22.         ElseIf (lngCharCode >= &H80&) And (lngCharCode <= &H7FF&) Then
  23.             
  24.             bytUtf8(lngUtf8Size) = CByte((lngCharCode \ &H40&) Or &HC0&)
  25.             
  26.             bytUtf8(lngUtf8Size + 1) = CByte((lngCharCode And &H3F&) Or &H80&)
  27.             lngUtf8Size = lngUtf8Size + 2
  28.         ElseIf (lngCharCode >= &H800&) And (lngCharCode <= &HFFFF&) Then
  29.             
  30.             bytUtf8(lngUtf8Size) = CByte((lngCharCode \ &H1000&) Or &HE0&)
  31.             
  32.             bytUtf8(lngUtf8Size + 1) = CByte(((lngCharCode And &HFC0&) \ &H40&) Or &H80&)
  33.             
  34.             bytUtf8(lngUtf8Size + 2) = CByte((lngCharCode And &H3F&) Or &H80&)
  35.             lngUtf8Size = lngUtf8Size + 3
  36.         End If
  37.     Next i
  38.     
  39.     If lngUtf8Size Then
  40.         ReDim Preserve bytUtf8(lngUtf8Size - 1)
  41.         Utf8Encode = lngUtf8Size
  42.     End If
  43. End Function
  44.  
  45. Public Function Utf8Decode(ByRef bytUtf8() As Byte, Optional ByRef strDefaultChar As String) As String
  46.     Dim lngUtf8Size As Long
  47.     Dim lngDefaultCharLength As Long
  48.     Dim strBuffer As String
  49.     Dim lngWriteLength As Long
  50.     Dim bytUcs2Char(1) As Byte
  51.     Dim i As Long
  52.  
  53.     On Error GoTo ExitFunction
  54.     lngUtf8Size = UBound(bytUtf8)
  55.     On Error GoTo 0
  56.     lngDefaultCharLength = Len(strDefaultChar)
  57.     If lngDefaultCharLength Then
  58.         strBuffer = String$((lngUtf8Size + 1) * lngDefaultCharLength, vbNullChar)
  59.     Else
  60.         strBuffer = String$(lngUtf8Size + 1, vbNullChar)
  61.     End If
  62.     lngWriteLength = 1
  63.     
  64.     Do While i <= lngUtf8Size
  65.         If bytUtf8(i) <= &H7F Then
  66.             Mid(strBuffer, lngWriteLength, 1) = ChrW$(bytUtf8(i))
  67.             lngWriteLength = lngWriteLength + 1
  68.             i = i + 1
  69.         ElseIf (bytUtf8(i) >= &HC2 And bytUtf8(i) <= &HDF) Then
  70.             If (i + 1) <= lngUtf8Size Then
  71.                 If (bytUtf8(i + 1) >= &H80 And bytUtf8(i + 1) <= &HBF) Then
  72.                     bytUcs2Char(0) = ((bytUtf8(i) And &H3) * &H40) Or (bytUtf8(i + 1) And &H3F)
  73.                     bytUcs2Char(1) = (bytUtf8(i) And &H1C) \ &H4
  74.                     Mid(strBuffer, lngWriteLength, 1) = bytUcs2Char
  75.                     lngWriteLength = lngWriteLength + 1
  76.                     i = i + 2
  77.                 Else
  78.                     If lngDefaultCharLength Then GoSub SetDefaultChar
  79.                     i = i + 1
  80.                 End If
  81.             Else
  82.                 If lngDefaultCharLength Then GoSub SetDefaultChar
  83.                 i = i + 1
  84.             End If
  85.         ElseIf (bytUtf8(i) >= &HE0 And bytUtf8(i) <= &HEF) Then
  86.             If (i + 2) <= lngUtf8Size Then
  87.                 If (bytUtf8(i + 1) >= &H80 And bytUtf8(i + 1) <= &HBF) And _
  88.                    (bytUtf8(i + 2) >= &H80 And bytUtf8(i + 2) <= &HBF) Then
  89.                     bytUcs2Char(0) = ((bytUtf8(i + 1) And &H3) * &H40) Or (bytUtf8(i + 2) And &H3F)
  90.                     bytUcs2Char(1) = ((bytUtf8(i) And &HF) * &H10) Or ((bytUtf8(i + 1) And &H3C) \ &H4)
  91.                     Mid(strBuffer, lngWriteLength, 1) = bytUcs2Char
  92.                     lngWriteLength = lngWriteLength + 1
  93.                     i = i + 3
  94.                 Else
  95.                     If lngDefaultCharLength Then GoSub SetDefaultChar
  96.                     i = i + 1
  97.                 End If
  98.             Else
  99.                 If lngDefaultCharLength Then GoSub SetDefaultChar
  100.                 i = i + 1
  101.             End If
  102.         Else
  103.             If lngDefaultCharLength Then GoSub SetDefaultChar
  104.             i = i + 1
  105.         End If
  106.     Loop
  107.  
  108.     Utf8Decode = Left$(strBuffer, lngWriteLength - 1)
  109.  
  110.     Exit Function
  111. SetDefaultChar:
  112.     Mid(strBuffer, lngWriteLength, lngDefaultCharLength) = strDefaultChar
  113.     lngWriteLength = lngWriteLength + lngDefaultCharLength
  114.     Return
  115. ExitFunction:
  116. End Function
  117.  
  118. Public Function IsUtf8(ByRef bytArray() As Byte, Optional ByVal lngReadSize As Long = ISUTF8_DEFAULT_READSIZE) As Boolean
  119.     Dim lngArraySize As Long
  120.     Dim lngReadPosition As Long
  121.     Dim lngUtf8ByteSize As Long
  122.     Dim lngIsUtf8 As Long
  123.     Dim i As Long
  124.  
  125.     If Not CBool(lngReadSize) Then GoTo ExitFunction
  126.     On Error GoTo ExitFunction
  127.     lngArraySize = UBound(bytArray) + 1
  128.     On Error GoTo 0
  129.     If lngReadSize > lngArraySize Then lngReadSize = lngArraySize
  130.     
  131.     Do While lngReadPosition < lngReadSize
  132.         If bytArray(lngReadPosition) <= &H7F Then
  133.             lngReadPosition = lngReadPosition + 1
  134.         ElseIf bytArray(lngReadPosition) < &HC0 Then
  135.             Exit Function
  136.         ElseIf (bytArray(lngReadPosition) >= &HC0) And (bytArray(lngReadPosition) <= &HFD) Then
  137.             If (bytArray(lngReadPosition) And &HFC) = &HFC Then
  138.                 lngUtf8ByteSize = 5
  139.             ElseIf (bytArray(lngReadPosition) And &HF8) = &HF8 Then
  140.                 lngUtf8ByteSize = 4
  141.             ElseIf (bytArray(lngReadPosition) And &HF0) = &HF0 Then
  142.                 lngUtf8ByteSize = 3
  143.             ElseIf (bytArray(lngReadPosition) And &HE0) = &HE0 Then
  144.                 lngUtf8ByteSize = 2
  145.             ElseIf (bytArray(lngReadPosition) And &HC0) = &HC0 Then
  146.                 lngUtf8ByteSize = 1
  147.             End If
  148.             If (lngReadPosition + lngUtf8ByteSize) >= lngReadSize Then Exit Do
  149.             For i = (lngReadPosition + 1) To (lngReadPosition + lngUtf8ByteSize) Step 1
  150.                 If Not ((bytArray(i) >= &H80) And (bytArray(i) <= &HBF)) Then Exit Function
  151.             Next i
  152.             lngIsUtf8 = lngIsUtf8 + 1
  153.             lngReadPosition = lngReadPosition + lngUtf8ByteSize + 1
  154.         Else
  155.             lngReadPosition = lngReadPosition + 1
  156.         End If
  157.     Loop
  158.     
  159.     If lngIsUtf8 > 1 Then IsUtf8 = True
  160. ExitFunction:
  161. End Function


sne:
  1. '--------------------------------------------------------------------------------
  2. ' : OfflineClient
  3. ' : WinToUTF8
  4. ' : UTF8
  5. ' : SNE
  6. ' - : 09.11.2004-11:52:01
  7. '
  8. ' : inString - , win
  9. ' lMaxSize -
  10. '--------------------------------------------------------------------------------
  11. Private Function WinToUTF8(ByRef inString As String, _
  12.                            ByVal lMaxSize As Long) As String
  13.  
  14.         If inString = vbNullString Then Exit Function
  15.  
  16.         Dim hMemLock1 As Long, hMemLock2 As Long
  17.         Dim iStrSize As Long
  18.  
  19.         hMemLock1 = GlobalAlloc(GPTR, lMaxSize)
  20.         hMemLock2 = GlobalAlloc(GPTR, lMaxSize)
  21.  
  22.         iStrSize = MultiByteToWideChar(0&, 0&, inString, -1, hMemLock1, lMaxSize)
  23.         iStrSize = WideCharToMultiByte(65001, 0&, hMemLock1, iStrSize, hMemLock2, lMaxSize, 0&, 0&) ' CP_UTF8
  24.  
  25.         If Len(iStrSize) Then
  26.             WinToUTF8 = String$(iStrSize - vbNull, 0&)
  27.             Call CopyMemory(ByVal WinToUTF8, ByVal hMemLock2, iStrSize - vbNull)
  28.         End If
  29.  
  30.         Call GlobalFree(hMemLock1)
  31.         Call GlobalFree(hMemLock2)
  32. End Function
  33.  
  34. '--------------------------------------------------------------------------------
  35. ' : OfflineClient
  36. ' : UTF8ToWin
  37. ' : UTF8 WIN
  38. ' : SNE
  39. ' - : 09.11.2004-11:56:58
  40. '
  41. ' : inString - utf8
  42. ' lMaxSize -
  43. '--------------------------------------------------------------------------------
  44. Private Function UTF8ToWin(ByRef inString As String, _
  45.                            ByVal lMaxSize As Long) As String
  46.  
  47.         If inString = vbNullString Then Exit Function
  48.  
  49.         Dim hMemLock1 As Long, hMemLock2 As Long
  50.         Dim iStrSize As Long
  51.  
  52.         hMemLock1 = GlobalAlloc(GPTR, lMaxSize)
  53.         hMemLock2 = GlobalAlloc(GPTR, lMaxSize)
  54.  
  55.         iStrSize = MultiByteToWideChar(CP_UTF8, 0&, inString, -1, hMemLock1, lMaxSize)
  56.         iStrSize = WideCharToMultiByte(0&, 0&, hMemLock1, -1, hMemLock2, iStrSize, 0&, 0&)
  57.  
  58.         If Len(iStrSize) Then
  59.             UTF8ToWin = String$(iStrSize - vbNull, 0&)
  60.             Call CopyMemory(ByVal UTF8ToWin, ByVal hMemLock2, iStrSize - vbNull)
  61.         End If
  62.  
  63.         Call GlobalFree(hMemLock1)
  64.         Call GlobalFree(hMemLock2)
  65. End Function

: 1 |



Copyright 2002-2011 VBNet.RU |