vb常用编码函数

 

 1 Private Const CP_UTF8 = 65001   ' default to UTF-8 code page
 2 
 3 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, ByVal lpUsedDefaultChar As Long) As Long
 4 
 5 Public Function EncodeToBytes(ByVal sData As String) As Byte()
 6 
 7     Dim aRetn() As Byte
 8     Dim nSize As Long
 9     
     nSize = WideCharToMultiByte(CP_UTF8, 0, StrPtr(sData), -1, 0, 0, 0, 0)
     ReDim aRetn(0 To nSize - 1) As Byte
     WideCharToMultiByte CP_UTF8, 0, StrPtr(sData), -1, VarPtr(aRetn(0)), nSize, 0, 0
     
     EncodeToBytes = aRetn
 End Function
 
 'Purpose:Convert   Unicode   string   to   UTF-8.
   Public Function UTF8_Encode(ByVal strUnicode As String, Optional ByVal bHTML As Boolean = True) As String
         Dim i                                   As Long
         Dim TLen                             As Long
         Dim lPtr                             As Long
         Dim UTF16                           As Long
         Dim UTF8_EncodeLong       As String
     
         TLen = Len(strUnicode)
         If TLen = 0 Then Exit Function
     
         If m_bIsNt Then
               Dim lngBufferSize           As Long
               Dim lngResult                   As Long
               Dim bytUtf8()                   As Byte
               'Set   buffer   for   longest   possible   string.
               lngBufferSize = TLen * 3 + 1
               ReDim bytUtf8(lngBufferSize - 1)
               'Translate   using   code   page   65001(UTF-8).
               lngResult = WideCharToMultiByte(CP_UTF8, 0, StrPtr(strUnicode), _
                     TLen, bytUtf8(0), lngBufferSize, vbNullString, 0)
               'Trim   result   to   actual   length.
               If lngResult Then
                     lngResult = lngResult - 1
                     ReDim Preserve bytUtf8(lngResult)
                     'CopyMemory   StrPtr(UTF8_Encode),   bytUtf8(0&),   lngResult
                     UTF8_Encode = StrConv(bytUtf8, vbUnicode)
                     '   For   i   =   0   To   lngResult
                     '         UTF8_Encode   =   UTF8_Encode   &   Chr$(bytUtf8(i))
                     '   Next
               End If
         Else
               For i = 1 To TLen
                     '   Get   UTF-16   value   of   Unicode   character
                     lPtr = StrPtr(strUnicode) + ((i - 1) * 2)
                     CopyMemory UTF16, ByVal lPtr, 2
                     'Convert   to   UTF-8
                     If UTF16 < &H80 Then                                                                                     '   1   UTF-8   byte
                           UTF8_EncodeLong = Chr$(UTF16)
                     ElseIf UTF16 < &H800 Then                                                                           '   2   UTF-8   bytes
                           UTF8_EncodeLong = Chr$(&H80 + (UTF16 And &H3F))                                         '   Least   Significant   6   bits
                           UTF16 = UTF16 \ &H40                                                                               '   Shift   right   6   bits
                           UTF8_EncodeLong = Chr$(&HC0 + (UTF16 And &H1F)) & UTF8_EncodeLong                     '   Use   5   remaining   bits
                     Else                                                                                                             '   3   UTF-8   bytes
                           UTF8_EncodeLong = Chr$(&H80 + (UTF16 And &H3F))                                         '   Least   Significant   6   bits
                           UTF16 = UTF16 \ &H40                                                                               '   Shift   right   6   bits
                           UTF8_EncodeLong = Chr$(&H80 + (UTF16 And &H3F)) & UTF8_EncodeLong                     '   Use   next   6   bits
                           UTF16 = UTF16 \ &H40                                                                               '   Shift   right   6   bits
                           UTF8_EncodeLong = Chr$(&HE0 + (UTF16 And &HF)) & UTF8_EncodeLong                       '   Use   4   remaining   bits
                     End If
                     UTF8_Encode = UTF8_Encode & UTF8_EncodeLong
               Next
         End If
     
         'Substitute   vbCrLf   with   HTML   line   breaks   if   requested.
         If bHTML Then
               UTF8_Encode = Replace$(UTF8_Encode, vbCrLf, "<br/>")
         End If
     
   End Function
 

 

 

 

 1 Public Function URLEncode(strInput As String) As String
 2     Dim strOutput As String
 3     Dim intAscii As Integer
 4     Dim i As Integer
 5     For i = 1 To Len(strInput)
 6     intAscii = Asc(Mid(strInput, i, 1))
 7     If ((intAscii < 58) And (intAscii > 47)) Or _
 8     ((intAscii < 91) And (intAscii > 64)) Or _
 9     ((intAscii < 123) And (intAscii > 96)) Then
     strOutput = strOutput & Chr$(intAscii)
     Else
     strOutput = strOutput & _
     IIf(intAscii < 16, "%0", "%") & _
     Trim$(Hex$(intAscii))
     End If
     Next
     URLEncode = strOutput
 End Function

 

 

 

 1 Private Function URLEncode(url As String) As String
 2        Dim oneChar As String, result As String
 3        Dim oneAsc As Long, uch As String
 4         If url = "" Then
 5             URLEncode = url
 6             Exit Function
 7         End If
 8         For i = 1 To Len(url)
 9             oneChar = Mid(url, i, 1)
             oneAsc = AscW(oneChar)
             If oneAsc < 0 Then oneAsc = oneAsc + 65536
             If (oneAsc And &HFF80) = 0 Then
                  If (oneAsc >= 65 And oneAsc <= 90) _
                  Or (oneAsc >= 97 And oneAsc <= 122) _
                  Or (oneAsc >= 48 And oneAsc <= 57) _
                  Or oneAsc = 45 Or oneAsc = 46 _
                  Or oneAsc = 95 Then
                         result = result & oneChar
                  Else
                         result = result & IIf(oneAsc < 16, "%0", "%") & Hex(oneAsc)
                  End If
             Else
                     If (oneAsc And &HF000) = 0 Then
                         uch = "%" & Hex(((oneAsc \ 2 ^ 6)) Or &HC0) & Hex(oneAsc And &H3F Or &H80)
                         result = result & uch
                     Else
                         uch = "%" & Hex((oneAsc \ 2 ^ 12) Or &HE0) & "%" & _
                         Hex((oneAsc \ 2 ^ 6) And &H3F Or &H80) & "%" & _
                         Hex(oneAsc And &H3F Or &H80)
                         result = result & uch
                     End If
             End If
         Next
 
         URLEncode = result
 End Function