|
谢谢楼主的分享。
我也放一个。
Public Function GetHzCode(oChar As String, Index As Byte) As String
Dim myArray() As Byte
Dim lngUniCode As Long
Dim strHex As String
Dim strGaoHex As String
Dim L As Integer
Dim R As Integer
On Error Resume Next
Select Case Index
Case 0 'GBK 十六进制值
myArray = StrConv(oChar, vbFromUnicode)
GetHzCode = Hex(CCur(myArray(0)) * 256 + myArray(1))
Case 1 'Surrogate(四字节)编码
GetHzCode = Encode(oChar)
Case 2 'UNICODE十六进制编码
strHex = Encode(oChar)
strGaoHex = Left$(strHex, 4)
lngUniCode = Val("&H" & strGaoHex)
If lngUniCode < -9984 And lngUniCode > -10240 Then '''四字节汉字(Len=2,LenB=4)
lngUniCode = (Val("&H" & strGaoHex) - Val("&H" & "D840")) * (-64512) + 666969088
GetHzCode = Hex(lngUniCode + Val("&H" & strHex))
Else '''双字节汉字(Len=1,LenB=2)
GetHzCode = Hex(AscW(oChar))
End If
Case 3 '''区位码
strHex = Hex(Asc(oChar))
L = Format(CInt("&H" + Mid$(strHex, 1, 2)) - 160, "00")
R = Format(CInt("&H" + Mid$(strHex, 3, 2)) - 160, "00")
If L < 0 Or R < 0 Then
GetHzCode = "可能是繁体字不能转换为区位码!"
Else
GetHzCode = L & R
End If
Case 4 '''Unicode码
GetHzCode = CStr(AscW(oChar))
End Select
End Function
Private Function Encode(strEncode As String) As String
'取得十六进制的UNICODE
Dim i As Long
Dim chrTmp As String
Dim ByteLower As String
Dim ByteUpper As String
Dim strReturn As String
For i = 1 To Len(strEncode)
chrTmp$ = Mid(strEncode, i, 1)
ByteLower$ = Hex$(AscB(MidB$(chrTmp$, 1, 1)))
If Len(ByteLower$) = 1 Then ByteLower$ = "0" & ByteLower$
ByteUpper$ = Hex$(AscB(MidB$(chrTmp$, 2, 1)))
If Len(ByteUpper$) = 1 Then ByteUpper$ = "0" & ByteUpper$
strReturn$ = strReturn$ & ByteUpper$ & ByteLower$
Next
Encode = strReturn$
End Function
[ 本帖最后由 守柔 于 2010-7-2 07:19 编辑 ] |
|