通过VBA实现编码转汉字

ngcg

Sub m_GBK2HZ()
  Dim f As String
  Dim chkOptn As Boolean
  Dim bArr(0 To 1) As Byte
  Dim sMe As String
  Dim Tile As String
  Dim Message As String
  Dim Default As String
  Default = "B0A1"
  Title = "Enter GBK code"
  Message = "Range 8140 to FEA0"
  Do While Not chkOptn
    f = InputBox(Message, Title, Default)
    f = Trim(f)
    If f = "" Then Exit Sub
    If Len(f) <> 4 Then
      MsgBox "Length of Value Entered must be 4."
    Else
       chkOptn = True
    End If
  Loop
  bArr(0) = CInt("&H" + Mid(f, 1, 2))
  bArr(1) = CInt("&H" + Mid(f, 3, 2))
  sMe = StrConv(bArr, vbUnicode, &H804)
  Selection.TypeText Text:=sMe
End Sub

Sub m_QuWei2HZ()
  Dim f As String
  Dim chkOptn As Boolean
  Dim bArr(0 To 1) As Byte
  Dim sMe As String
  Dim Tile As String
  Dim Message As String
  Dim Default As String
  Default = "1601"
  Title = "Enter QuWei code"
  Message = "Range 1601 to 8794"
  Do While Not chkOptn
    f = InputBox(Message, Title, Default)
    f = Trim(f)
    If f = "" Then Exit Sub
    If Val(f) > 1600 And Val(f) < 8795 Then
      chkOptn = True
    Else
      MsgBox "Enter Incorrect Data."
    End If
  Loop
  bArr(0) = Val(Mid(f, 1, 2)) + 160
  bArr(1) = Val(Mid(f, 3, 2)) + 160
  sMe = StrConv(bArr, vbUnicode, &H804)
  Selection.TypeText Text:=sMe
End Sub

Sub m_Unicode2HZ()
  Dim f As String
  Dim chkOptn As Boolean
  Dim Tile As String
  Dim Message As String
  Dim Default As String
  Default = "3400"
  Title = "Enter Hex"
  Message = "Range 3400 to 9FBB"
  Do While Not chkOptn
    f = InputBox(Message, Title, Default)
    f = Trim(f)
    If f = "" Then Exit Sub
    If Len(f) <> 4 Then
      MsgBox "Length of Value Entered must be 4."
    Else
       chkOptn = True
    End If
  Loop
  Selection.TypeText Text:=ChrW$(CLng("&H" & f))
End Sub

tangqingfu

请教ngcg兄：
这三段代码分别是将GBK、区位码、Unicode转换为汉字吗？能否提供相关的文档，以便测试及学习？
能否将其进行反转？即将汉字分别转换为对应的GBK、区位码、Unicode？及GBK、区位码、Unicode之间的转换？

[ 本帖最后由 tangqingfu 于 2010-2-17 14:46 编辑 ]

ngcg

以下代码是将汉字转换为编码
Sub k_GetQuWei()
  On Error GoTo ErrHandle
  Dim buffer() As Byte
  Dim f
  Dim sPos As Single
  Dim s As String
  Dim i As Long
  Dim L1 As Integer
  Dim R1 As Integer
  If Selection.Type = wdSelectionNormal Then
    Set MyRange = Selection.Range
    Selection.Collapse wdCollapseStart
  Else
    Set MyRange = ActiveDocument.Range(Selection.Start, ActiveDocument.Content.End)
  End If
  sPos = Selection.Start
  Selection.Collapse wdCollapseStart
  For Each iChar In MyRange.Characters
    f = ""
    iChar = Selection.Text
    Selection.MoveRight unit:=wdCharacter, Count:=1
    a = Hex(AscW(iChar))
    If "&H" & a <> &HD Then
      buffer = VBA.StrConv(iChar, vbFromUnicode, &H804) 'Simplified Chinese:&H804,Chinese Taiwan:&H404,English - United States:&H409
      For i = LBound(buffer) To UBound(buffer)
        f = f & VBA.Right("00" & VBA.Hex(buffer(i)), 2)
      Next i
      L1 = CInt("&H" + Mid(f, 1, 2))
      R1 = CInt("&H" + Mid(f, 3, 2))
      Selection.TypeText Text:=(L1 - 160)
      If R1 - 160 < 10 Then
        Selection.TypeText Text:="0" & (R1 - 160)
      Else
        Selection.TypeText Text:=R1 - 160
      End If
    End If
  Next
  Selection.Start = sPos
  Selection.Collapse wdCollapseStart
  MsgBox "Job Done!"
  Exit Sub
ErrHandle:
  MsgBox "Error number: " + Str$(Err) + Chr(13) + Error$(Err), 48, m_Title
End Sub

Sub k_GetASCCode()
  On Error GoTo ErrHandle
  Dim myText As String
  If Selection.Type = wdSelectionNormal Then
    Set MyRange = Selection.Range
    Selection.Collapse wdCollapseStart
  Else
    Set MyRange = ActiveDocument.Range(Selection.Start, ActiveDocument.Content.End)
  End If
  sPos = Selection.Start
  myText = MyRange
  Selection.Collapse wdCollapseStart
  For Each iChar In MyRange.Characters
    If InStr(myText, iChar) > 0 Then
      iChar = Selection.Text
      a = "&H" & Hex(AscW(iChar))
      Selection.MoveRight unit:=wdCharacter, Count:=1
      If a <> &HD Then
        Selection.TypeText Text:=CLng(a)
      End If
    End If
  Next
  Selection.Start = sPos
  Selection.Collapse wdCollapseStart
  Exit Sub
ErrHandle:
  MsgBox "Error number: " + Str$(Err) + Chr(13) + Error$(Err), 48, m_Title
End Sub

Sub k_GetGBKCode()
  On Error GoTo ErrHandle
  Dim buffer() As Byte
  Dim GBKCode As String
  Dim s As String
  Dim i As Long
  Dim sPos As Single
  If Selection.Type = wdSelectionNormal Then
    Set MyRange = Selection.Range
    Selection.Collapse wdCollapseStart
  Else
    Set MyRange = ActiveDocument.Range(Selection.Start, ActiveDocument.Content.End)
  End If
  sPos = Selection.Start
  Selection.Collapse wdCollapseStart
  For Each iChar In MyRange.Characters
    GBKCode = ""
    iChar = Selection.Text
    Selection.MoveRight unit:=wdCharacter, Count:=1
    a = Hex(AscW(iChar))
    If "&H" & a <> &HD Then
      buffer = VBA.StrConv(iChar, vbFromUnicode, &H804) 'Simplified Chinese:&H804,Chinese Taiwan:&H404,English - United States:&H409
      For i = LBound(buffer) To UBound(buffer)
        GBKCode = GBKCode & VBA.Right("00" & VBA.Hex(buffer(i)), 2)
      Next i
      Selection.TypeText Text:=GBKCode
    End If
  Next
  Selection.Start = sPos
  Selection.Collapse wdCollapseStart
  MsgBox "Job Done!"
  Exit Sub
ErrHandle:
  MsgBox "Error number: " + Str$(Err) + Chr(13) + Error$(Err), 48, m_Title
End Sub

Sub k_GetUnicode()
  On Error GoTo ErrHandle
  Dim myText As String
  Dim sPos As Single
  If Selection.Type = wdSelectionNormal Then
    Set MyRange = Selection.Range
    Selection.Collapse wdCollapseStart
  Else
    Set MyRange = ActiveDocument.Range(Selection.Start, ActiveDocument.Content.End)
  End If
  sPos = Selection.Start
  myText = MyRange
  Selection.Collapse wdCollapseStart
  For Each iChar In MyRange.Characters
    If InStr(myText, iChar) > 0 Then
      iChar = Selection.Text
      Selection.MoveRight unit:=wdCharacter, Count:=1
      a = Hex(AscW(iChar))
      If "&H" & a <> &HD Then
        Selection.TypeText Text:=a
      End If
    End If
  Next
  Selection.Start = sPos
  Selection.Collapse wdCollapseStart
  MsgBox "Job Done!"
  Exit Sub
ErrHandle:
  MsgBox "Error number: " + Str$(Err) + Chr(13) + Error$(Err), 48, m_Title
End Sub

tangqingfu

谢谢ngcg兄！
能否能简单地介绍一下GBK、区位码、Unicode知识？
如果有相关的GBK、区位码、Unicode编码实例就更好了，这样可以更好地进行测试。

chuhaiou

汉字转换为编码太长了

tangqingfu

原帖由 ngcg 于 2010-2-17 15:21 发表
以下代码是将汉字转换为编码
Sub k_GetQuWei()
  On Error GoTo ErrHandle
  Dim buffer() As Byte
  Dim f
  Dim sPos As Single
  Dim s As String
  Dim i As Long
  Dim L1 As Integer
  Dim R1 As Int ...

请教cgng兄，如何修改代码，使之转换的文档，只保留编码，而不保留原有的内容（汉字，数字及字母等）？

ngcg

Sub k_GetGBKCode()
  On Error GoTo ErrHandle
  Dim buffer() As Byte
  Dim GBKCode As String
  Dim sArr() As String
  Dim i As Long
  Dim n As Integer
  Dim myMod As Integer
  Dim sPos As Single
  Dim m As Integer
  sPos = Selection.Start
  If Selection.Type = wdSelectionNormal Then
    Set MyRange = Selection.Range
  Else
    Set MyRange = ActiveDocument.Range(Selection.Start, ActiveDocument.Content.End)
    ActiveDocument.Range(sPos, sPos + Len(MyRange)).Select
  End If
  ReDim sArr(Len(MyRange) \ 4000)
  For Each iChar In MyRange.Characters
    GBKCode = ""
    a = Hex(AscW(iChar))
    If "&H" & a <> &HD Then
      n = n + 1
      buffer = VBA.StrConv(iChar, vbFromUnicode, &H804) 'Simplified Chinese:&H804,Chinese Taiwan:&H404,English - United States:&H409
      For i = LBound(buffer) To UBound(buffer) 'vbUpperCase,vblowerCase,vbunicode
        GBKCode = GBKCode & VBA.Right("00" & VBA.Hex(buffer(i)), 2)
      Next i
      If myMod = n Mod 4000 Then m = m + 1
      sArr(m) = sArr(m) + "/" + GBKCode
    End If
  Next
  Selection.Delete Unit:=wdCharacter, Count:=1
  For i = 0 To m
    Selection.TypeText Text:=sArr(i)
  Next i
  ActiveDocument.Range(sPos, sPos).Select
  Exit Sub
ErrHandle:
  MsgBox "Error number: " + Str$(Err) + Chr(13) + Error$(Err), 48, m_Title
End Sub


Sub k_GetUnicode()
  On Error GoTo ErrHandle
  Dim sArr() As String
  Dim i As Long
  Dim n As Integer
  Dim myMod As Integer
  Dim sPos As Single
  Dim m As Integer
  sPos = Selection.Start
  If Selection.Type = wdSelectionNormal Then
    Set MyRange = Selection.Range
  Else
    Set MyRange = ActiveDocument.Range(Selection.Start, ActiveDocument.Content.End)
    ActiveDocument.Range(sPos, sPos + Len(MyRange)).Select
  End If
  ReDim sArr(Len(MyRange) \ 4000 + 1)
  For Each iChar In MyRange.Characters
    If InStr(MyRange, iChar) > 0 Then
      a = Hex(AscW(iChar))
      If "&H" & a <> &HD Then
        n = n + 1
        If myMod = n Mod 4000 Then m = m + 1
        sArr(m) = sArr(m) + "/" + a
        'sArr(m) = sArr(m) + ChrW$(CLng("&H" & a)) & a
      End If
    End If
  Next
  Selection.Delete Unit:=wdCharacter, Count:=1
  For i = 0 To m
    Selection.TypeText Text:=sArr(i)
  Next i
  ActiveDocument.Range(sPos, sPos).Select
Exit Sub
ErrHandle:
  MsgBox "Error number: " + Str$(Err) + Chr(13) + Error$(Err), 48, m_Title
End Sub

tangqingfu

请教ngcg兄：
用7楼的代码附件中文档的内容转换为GBK代码后，想将其再转换为原文档的内容（估且称之为汉字，但是里面也含有部分数字、单词或字母）？即想用1楼的代码将其再转换回来，可是没有效果。
Sub m_GBK2HZ()
.......
End Sub
请cgng兄示下！

[ 本帖最后由 tangqingfu 于 2010-2-21 11:56 编辑 ]

kqbt

谢谢分享，学习之

ngcg

Sub k_HZ2GBK()
  On Error GoTo ErrHandle
  Dim buffer() As Byte
  Dim GBKCode As String
  Dim sArr() As String
  Dim i As Long
  Dim n As Integer
  Dim myMod As Integer
  Dim sPos As Single
  Dim m As Integer
  Dim iChar As Range
  sPos = Selection.Start
  If Selection.Type = wdSelectionNormal Then
    Set MyRange = Selection.Range
  Else
    Set MyRange = ActiveDocument.Range(Selection.Start, ActiveDocument.Content.End)
    ActiveDocument.Range(sPos, sPos + Len(MyRange)).Select
  End If
  ReDim sArr(Len(MyRange) \ 4000)
  For Each iChar In MyRange.Characters
    GBKCode = ""
    a = Hex(AscW(iChar))
    If "&H" & a > &HFF Then
      n = n + 1
      buffer = VBA.StrConv(iChar, vbFromUnicode, &H804) 'Simplified Chinese:&H804,Chinese Taiwan:&H404,English - United States:&H409
      For i = LBound(buffer) To UBound(buffer) 'vbUpperCase,vblowerCase,vbunicode
        GBKCode = GBKCode & VBA.Right("00" & VBA.Hex(buffer(i)), 2)
      Next i
      If myMod = n Mod 4000 Then m = m + 1
      sArr(m) = sArr(m) + "/" + GBKCode
    Else
      sArr(m) = sArr(m) + "/" + iChar
    End If
  Next
  Selection.Delete Unit:=wdCharacter, Count:=1
  For i = 0 To m
    Selection.TypeText Text:=sArr(i)
  Next i
  ActiveDocument.Range(sPos, sPos).Select
  Exit Sub
ErrHandle:
  MsgBox "Error number: " + Str$(Err) + Chr(13) + Error$(Err), 48, m_Title
End Sub


Sub m_GBK2HZ()
  Dim f As String
  Dim chkOptn As Boolean
  Dim bArr(0 To 1) As Byte
  Dim sText As Variant
  Dim sArr() As String
  Dim sMe As String
  sPos = Selection.Start
  If Selection.Type = wdSelectionNormal Then
    Set myrange = Selection.Range
  Else
    Set myrange = ActiveDocument.Range(Selection.Start, ActiveDocument.Content.End)
    ActiveDocument.Range(sPos, sPos + Len(myrange)).Select
  End If
  sArr = Split(myrange, "/")
  For Each sText In sArr
    f = sText
    f = Trim(f)
    If Len(f) = 4 Then
      bArr(0) = CInt("&H" + Mid(f, 1, 2))
      bArr(1) = CInt("&H" + Mid(f, 3, 2))
      sMe = sMe + StrConv(bArr, vbUnicode, &H804)
    Else
      sMe = sMe + f
    End If
  Next
  Selection.Delete Unit:=wdCharacter, Count:=1
  Selection.TypeText Text:=sMe
End Sub