1234

ExcelHome技术论坛

用户名  找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

帖子
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 16371|回复: 20

[分享] 汉字字符编码的转换

[复制链接]

TA的精华主题

TA的得分主题

发表于 2010-7-1 08:49 | 显示全部楼层 |阅读模式
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
Sub UnicodeToGBK()
  Dim mStr As String
  Dim i As Long
  Dim n As Integer
  Dim f
  Dim at(0 To 1) As Byte
  Dim bt() As Byte
  Dim myGBK As String
  Dim t1 As Date
  Dim t2 As Date
  t1 = Now
  Selection.Font.Name = "SimSun"
  Selection.Font.Size = 10
  For i = CLng("&H3400") To CLng("&H9FA5") '9FA59FA5?E815
    f = Hex(i)
    at(1) = CInt("&H" + Mid(f, 1, 2))
    at(0) = CInt("&H" + Mid(f, 3, 2))
    bt = StrConv(at, vbFromUnicode, &H804) '&H404 taiwan &H409 USA
    myGBK = ""
    For k = 0 To UBound(bt)
      myGBK = myGBK + Hex(bt(k))
    Next
    If Len(myGBK) < 4 Then myGBK = "0000"
    If f = "4DB5" Then i = CLng("&H" & "4DFF")
    n = n + 1
    mStr = ChrW$(CLng("&H" & f))
    Selection.TypeText Text:=n & mStr & f & "[" & myGBK & "]" & vbCrLf
  Next
  t2 = Now
  MsgBox "Time taken: " & DateDiff("s", t1, t2) & " second"
End Sub

[ 本帖最后由 守柔 于 2010-7-2 07:04 编辑 ]

TA的精华主题

TA的得分主题

 楼主| 发表于 2010-7-1 16:45 | 显示全部楼层

区位码转为Unicode和GBK

Sub QuWeitoUnicode()
  Dim bArr(0 To 1) As Byte
  Dim aArr() As Byte
  Dim m As Byte
  Dim n As Byte
  Dim k As Integer
  k = 0
  Dim sMe As String
  Dim t1 As Date
  Dim t2 As Date
  t1 = Now
  Selection.Font.Name = "SimSun"
  Selection.Font.Size = 10
  For m = 176 To 247
    For n = 161 To 254
      bArr(0) = m
      bArr(1) = n
      aArr = StrConv(bArr, vbUnicode, &H804) '&H404 taiwan &H409 USA
      If m = 215 And n > 249 Then
      Else
        k = k + 1
        Selection.TypeText Text:=k & CStr(aArr)
        If n - 160 < 10 Then
          Selection.TypeText Text:=m - 160 & "0" & n - 160
        Else
          Selection.TypeText Text:=m - 160 & n - 160
        End If
        Selection.TypeText Text:="[" & Hex(m) & Hex(n) & "]"
        Selection.TypeText Text:="[" & Hex(aArr(1)) & Hex(aArr(0)) & "]"
        Selection.TypeText Text:=vbCrLf
      End If
    Next
  Next
  t2 = Now
  MsgBox "Time Taken: " & DateDiff("s", t1, t2) & " second"
  Selection.HomeKey unit:=wdStory
End Sub

TA的精华主题

TA的得分主题

 楼主| 发表于 2010-7-1 16:48 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册

GBK转为Unicode

Sub GBKtoUnicode()
  Dim f As String
  Dim bArr(0 To 1) As Byte
  Dim aArr() As Byte
  Dim sMe As String
  Dim b As String
  Dim n As Integer
  Dim myUnicode As String
  Dim t1 As Date
  Dim t2 As Date
  n = 0
  t1 = Now
  Selection.Font.Name = "SimSun"
  Selection.Font.Size = 10
  For i = CLng("&H8140") To CLng("&HFEA0")
    f = Hex(i)
    bArr(0) = CInt("&H" + Mid(f, 1, 2))
    bArr(1) = CInt("&H" + Mid(f, 3, 2))
    b = Mid(f, 3, 2)
    If i > CLng("&HF89F") Then
      If b = "A0" Then i = CLng("&H" & f) + 159
    ElseIf i > CLng("&HB040") Then
      If b = "FE" Then i = CLng("&H" & f) + 65
      If f = "D7F9" Then i = CLng("&HD83F")
    ElseIf i > CLng("&HAA40") Then
      If b = "A0" Then i = CLng("&H" & f) + 159
    ElseIf i = CLng("&HA0FE") Then
      i = CLng("&HAA3F")
    ElseIf i > CLng("&H813F") Then
      If b = "FE" Then i = CLng("&H" & f) + 65
    End If
    aArr = StrConv(bArr, vbUnicode, &H804) 'SC &H804 / BIG5 &H404
    sMe = CStr(aArr)
    myUnicode = ""
    For k = 0 To UBound(aArr)
      myUnicode = Hex(aArr(k)) + myUnicode
    Next k
    If Len(myUnicode) = 3 Then myUnicode = Mid(myUnicode, 1, 2) + "0" + Mid(myUnicode, 3, 1)
    If sMe <> "?" Then
      n = n + 1
      Selection.TypeText Text:=n & sMe & f & "[" & myUnicode & "]" & vbCrLf
    End If
  Next
  t2 = Now
  MsgBox "Time Taken: " & DateDiff("s", t1, t2) & " second"
  Selection.HomeKey unit:=wdStory
End Sub

TA的精华主题

TA的得分主题

发表于 2010-7-1 22:53 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
不好意思,俺没遇到这样的情况,楼主能再解释下吗?什么情况下用的

TA的精华主题

TA的得分主题

发表于 2010-7-2 06:05 | 显示全部楼层
谢谢楼主的分享。
我也放一个。
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 编辑 ]

TA的精华主题

TA的得分主题

发表于 2010-7-2 08:27 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2010-7-2 09:10 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2010-7-2 10:41 | 显示全部楼层
通过以上的代码,你可以在极短时间内创建区位码(就是GB2312,共有6763个汉字)、GBK(21003个汉字)和GB18030(27484个汉字)字符集和其编码,

TA的精华主题

TA的得分主题

 楼主| 发表于 2010-7-2 10:52 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助

Gig5toUnicode

Sub Gig5toUnicode()
  Dim bA(0 To 1) As Byte
  Dim aA() As Byte
  Dim f As String
  Dim t1 As Date
  Dim t2 As Date
  t1 = Now
  Selection.Font.Name = "SimSun"
  Selection.Font.Size = 10
  For i = &HA440 To &HF9DC
    f = CStr(Hex(i))
    If Mid(f, 3, 2) = "FE" Then i = i + 65
    If i = &HC67E Then i = &HC93F
    bA(0) = "&H" & Mid(f, 1, 2)
    bA(1) = "&H" & Mid(f, 3, 2)
    aA = StrConv(bA, vbUnicode, &H404)
    If CStr(aA) <> "?" Then Selection.TypeText Text:=CStr(aA) + f + "[" + Hex(aA(1)) & VBA.Right("0" & Hex(aA(0)), 2) + "]" + vbCrLf
  Next
  t2 = Now
  MsgBox "Time taken: " & DateDiff("s", t1, t2)
end sub

TA的精华主题

TA的得分主题

发表于 2010-7-2 14:09 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
谢谢ngcg兄和守版的分享
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

1234

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2025-2-16 05:08 , Processed in 0.023976 second(s), 8 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表