如何将Unicode编码转换成GBK编码

ngcg

请教如何通过vba将Unicode转换成GBK
例如：“一”的Unicode编码是“4E00”，怎样将它转换为GBK编码“D2BB”

dul

这段东西你参考一下：

Sub Transcoding()

    Dim iReadNumber As Integer    '读文件号
    Dim iWriteNumber As Integer    '写文件号
    Dim mem() As Byte    'byte数组
    Dim strFileName As String    '文件名
    Dim lLength As Long    '文件长度'将文件内容读入mem byte数组
    iReadNumber = FreeFile < strFileName = TextFileName.Text
    lLength = FileLen(strFileName)
    ReDim mem(lLength) As Byte
    Open strFileName For Binary As #iReadNumber
    Get #iReadNumber, , mem
    Close #iReadNumber
    '将mem数组转换为Big5码所对应的Unicode码mem = StrConv(mem，vbUnicode，&H404)
    '再将Unicode码转换为GBK编码mem = StrConv(mem，vbFromUnicode，&H804)
    '写到源文件里去iWriteNumber = FreeFile
    Kill strFileName
    Open strFileName For Binary As #iWriteNumber
    Put #iWriteNumber, , mem
    Close #iWriteNumber

End Sub

ngcg

以上代码无法运作。或许我把问题简化为：
我想通过MSWord的vba查找某个汉字例如“阿”的GBK编码就是“B0A2”。
我用以下的代码通过，VisualBasicFor2008可以查出“阿”的GBK编码。
  Dim strText As String = "阿"
    Dim arrbytOut() As Byte
    Dim myMod As Integer = 0
    Dim myGBK As String = ""
    arrbytOut = System.Text.Encoding.GetEncoding(936).GetBytes(strText) 'VBA没有相应的函数
    For i As Integer = 0 To arrbytOut.Length - 1
      myMod = i Mod 2
      myGBK += Hex(arrbytOut(i).ToString)
      If myMod <> 0 Then
        MsgBox(myGBK)
        myGBK = ""
      End If
    Next

ngcg

问题已解决，我用以下编码能找到汉字的GBK代码
'啊的GBK代码为b0a1
Sub GetGBKCode()
  dim i as integer
  dim x() as Byte
  dim myGBK as string
  x=strconv("啊",vbfromunicode,&h804)
for i=0 to ubound(x)
  myGBK=myGBK+hex(x(i))
  next
  msgbox myGBK
End Sub

ngcg

'优化后的代码如下：
Sub Example()
  Dim buffer() As Byte
  Dim s As String
  s = "啊阿一"
  buffer = VBA.StrConv(s, vbFromUnicode, &H804) 'Simplified Chinese:&H804,Chinese Taiwan:&H404,English - United States:&H409
  Dim i As Long
  Dim n As Integer
  For i = LBound(buffer) To UBound(buffer)
    n = n + 1
    GBK2Unicode = GBK2Unicode & VBA.Right("00" & VBA.Hex(buffer(i)), 2)
    If n = 2 Then
      n = 0
      GBK2Unicode = GBK2Unicode + "/"
    End If
  Next i
  MsgBox GBK2Unicode
End Sub

ngcg

操作系统是中文或者是英文但选择ChinesePRC，则以上代码可简化为：
Sub GetGBKCode()
  Dim f
  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
    f = ""
    iChar = Selection.text
    Selection.MoveRight unit:=wdCharacter, Count:=1
    a = Hex(AscW(iChar))
    If "&H" & a <> &HD Then
      f = Hex(Asc(iChar))
      Selection.TypeText text:=f
    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

Allen2018

dul 发表于 2010-2-11 09:14
这段东西你参考一下：

Sub Transcoding()

问题求助。非常感谢！！！！
http://club.excelhome.net/forum. ... 762&pid=9039596

huyongapple

ASC()不就是求GBK编码的函数吗？若要显示出来：
Right(WorksheetFunction.Dec2Hex(Asc("一")), 4)