VBA：编码与汉字相互转换

 

通过VBA实现编码转汉字

三段代码分别是将GBK、区位码、Unicode转换为汉字

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

以下代码是将汉字转换为编码

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

转换后不带汉字的代码

 

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

将上面已转换的内容再转换为原文档

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