发现一汉字注音拼音转汉字的代码拼音转汉字，不取独享拼音转汉字，分与各位学习及个人使用，如用作商业用途，请与作者本人联系。

使用动图

使用说明动图一

以此代码，运用到VBA中，结合其它功能，可应用到很多地方，比如开发小型进销存，在录入、查找等操作中，以拼音首字母为输入方式，提高效率。还可应用到下拉框的输入中。又如给小孩识字注音等。

使用说明动图二

代码动图

附代码拼音转汉字：

部分语句添加了解说，如有不对请自行理解。

标准模块部分代码

Public Function HzToPy(Hz As String, _

Optional Sep As String = "", _

Optional NotationType As Integer = -1, _

Optional ShowInitialOnly As Boolean = False, _

Optional ShowOnlyOneChar As Boolean = False) As String

Dim hp As HZ2PY

Set hp = New HZ2PY '创建类

hp.Seperator = Sep

hp.InitialOnly = ShowInitialOnly

hp.OnlyOneChar = ShowOnlyOneChar

HzToPy = hp.GetPinYin(Hz)

HzToPy = hp.AdjustPhoneticNotation(HzToPy, NotationType)

Set hp = Nothing '释放类

End Function

'以下test1-test6原件内没有，后添加的。

Sub test1() '不带注音

MsgBox HzToPy("重庆重要", " ", 0)

End Sub

Sub test2() '带注音

MsgBox HzToPy("重庆重要", " ")

End Sub

Sub test3() '只显示声母

MsgBox HzToPy("重庆重要", " ", , True)

End Sub

Sub test4() '只显示第一个声母

MsgBox HzToPy("重庆重要", " ", , , True)

End Sub

Sub test5() '带注音,间隔符为"+"

MsgBox HzToPy("重庆重要", "+")

End Sub

Sub test6() '带注音,省略其它所有参数

MsgBox HzToPy("重庆重要")

End Sub

函数原型

在电子表格中直接调用函数

类模块部分

'***************************************************************************

'*

'* Module: HzToPy

'* Update: 2011-09-23

'* Author: tt.t

'*

'* Description: 将中文字符串转换为拼音，就这些。原先这里写了太多废话，删了。

'*

'* Theory： 原理依然是通过IFELanguage接口实现。

'* 唯一需要解释的是如何解决多音字正确注音的问题。

'* IFELanguage接口是能够正确返回很多多音字拼音的，但多音字的读音只有特定词汇中

'* 才能确认，因此在解析拼音时候不能把词拆成单字，否则多音字返回的拼音就很可能不对。

'* 之前版本中就是因为把词拆开获取拼音导致多音字拼音错误。

'* 这次的更新利用接口返回数据中标识每个拼音长度的数组实现了对返回拼音

'* 的按字拆分，无需再把词拆成字获取单个字的拼音，从而解决了多音字问题。

'* 需要说明的是，VB_MORRSLT结构就是MS文档中的MORRSLT结构，但是VBA自定义结构

'* 无法实现不按4字节对齐，使得不得不修改MORRSLT的定义方式，能这样修改只能说运气不错，

'* 因为被修改的部分刚好获取拼音用不到。

'*

'*

'* Histroy:

'* 2011-09-23

'* ● 重写主要代码，支持多音字，提高了运行效率。

'* ● 取拼音首字时，ao, ai, ei, ou, er作为首字而不是原来的第一个字母。

'* ● 为函数增加了注音方式选择，hàn可以显示为han或han4。

'* ● 函数的使用与之前版本兼容，将模块中函数代码和HZ2PY类代码覆盖之前版本即可实现升级，无需修改文档中的公式。

'* 2011-04-07

'* ● 更正CoTaskMemFree传递参数错误，消除了Win7等环境下崩溃。

'* 2007-04-03

'* ● 更正redim时vba数组默认起始值错误。

'* 2007-04-02

'* ● 最初版本，实现了由汉字获取拼音。

'*

'***************************************************************************

Option Explicit

Private Type GUID

Data1 As Long

Data2 As Integer

Data3 As Integer

Data4(0 To 7) As Byte

End Type

Private Type VB_MORRSLT

dwSize As Long '4

pwchOutput As Long '4

cchOutput As Integer '2+(2)，VBA内存对齐闹得，折腾了好一阵才确认问题所在，唉

Block1 As Long '4

pchInputPos As Long '4

pchOutputIdxWDD As Long '4

pchReadIdxWDD As Long '4

paMonoRubyPos As Long '4

pWDD As Long '4

cWDD As Integer '2

pPrivate As Long '4

BLKBuff As Long '4

End Type

Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _

(Destination As Any, Source As Any, ByVal Length As Long)

Private Declare Function CLSIDFromString Lib "ole32.dll" _

(ByVal lpszProgID As Long, pCLSID As GUID) As Long

Private Declare Function CoCreateInstance Lib "ole32" ( _

rclsid As GUID, ByVal pUnkOuter As Long, _

ByVal dwClsContext As Long, riid As GUID, _

ByRef ppv As Long) As Long

Private Declare Function DispCallFunc Lib "oleaut32" _

(ByVal pvInstance As Long, ByVal oVft As Long, _

ByVal cc As Long, ByVal vtReturn As Integer, _

ByVal cActuals As Long, prgvt As Integer, _

prgpvarg As Long, pvargResult As Variant) As Long

Private Declare Sub CoTaskMemFree Lib "ole32" (pv As Long)

Dim MSIME_GUID As GUID 'MSIME's GUID

Dim IFELanguage_GUID As GUID 'IFELanguage's GUID

Dim IFELanguage As Long 'Pointer to IFELanguage interface

Dim PinYinArray() As String

Dim HzLen As Integer

Dim pvSeperator As String

Dim pvUseSeperator As Boolean

Dim pvInitialOnly As Boolean

Dim pvOnlyOneChar As Boolean

Dim pvNonChnUseSep As Boolean

Public Function GetPinYin(HzStr As String) As String

Dim i As Integer

Dim Py As String

Dim IsPy As Boolean

GetPinYin = ""

If IFELanguage = 0 Then

GetPinYin = "未发现运行环境，请安装微软拼音2.0以上版本拼音转汉字！"

Exit Function

End If

If HzStr = "" Then Exit Function

HzLen = Len(HzStr)

Call IFELanguage_GetMorphResult(HzStr) '获取汉字拼音，带注音

For i = 1 To HzLen

Py = PinYinArray(i)

IsPy = Py <> ""

If Not IsPy Then Py = Mid(HzStr, i, 1)

If pvInitialOnly Then Py = GetInitial(Py) '获取声母

If pvOnlyOneChar Then Py = VBA.Left(Py, 1) '获取第一个拼音字母

GetPinYin = GetPinYin & Py & IIf(IsPy, pvSeperator, "") '加入间隔符号

Next i

If IsPy And pvSeperator <> "" Then GetPinYin = Left(GetPinYin, Len(GetPinYin) - 1) '去除最后面的间隔符号

End Function

Property Get Seperator() As String

Seperator = pvSeperator

End Property

Property Let Seperator(Value As String)

pvSeperator = Value

End Property

Property Get InitialOnly() As Boolean

UseSeperator = pvInitialOnly

End Property

Property Let InitialOnly(Value As Boolean)

pvInitialOnly = Value

End Property

Property Get OnlyOneChar() As Boolean

UseSeperator = pvOnlyOneChar

End Property

Property Let OnlyOneChar(Value As Boolean)

pvOnlyOneChar = Value

End Property

Public Function AdjustPhoneticNotation(Py As String, ByVal pn As Integer) As String '注音转换，pn=-1表示带注音不转换，

Dim i As Integer

Dim c As String

If pn = -1 Then

AdjustPhoneticNotation = Py

Exit Function

Else

For i = 1 To Len(Py)

c = VBA.Mid(Py, i, 1)

Select Case Asc(c)

Case VBA.Asc("ā") To VBA.Asc("à")

c = "a" & IIf(pn = 0, "", (VBA.Asc(c) - VBA.Asc("ā") + 1))

Case VBA.Asc("ē") To VBA.Asc("è")

c = "e" & IIf(pn = 0, "", (VBA.Asc(c) - VBA.Asc("ē") + 1))

Case VBA.Asc("ī") To VBA.Asc("ì")

c = "i" & IIf(pn = 0, "", (VBA.Asc(c) - VBA.Asc("ī") + 1))

Case VBA.Asc("ō") To VBA.Asc("ò")

c = "o" & IIf(pn = 0, "", (VBA.Asc(c) - VBA.Asc("ō") + 1))

Case VBA.Asc("ū") To VBA.Asc("ù")

c = "u" & IIf(pn = 0, "", (VBA.Asc(c) - VBA.Asc("ū") + 1))

Case VBA.Asc("ǖ") To VBA.Asc("ǜ")

c = "u" & IIf(pn = 0, "", (VBA.Asc(c) - VBA.Asc("ǖ") + 1))

Case VBA.Asc("ü")

c = "u"

Case VBA.Asc("ɡ")

c = "g"

End Select

AdjustPhoneticNotation = AdjustPhoneticNotation & c

Next i

End If

End Function

Private Function GetInitial(Py As String) As String '获取声母

GetInitial = VBA.Mid(Py, 1, 2)

Select Case AdjustPhoneticNotation(GetInitial, 0)

Case "ch", "sh", "zh", "ao", "ai", "ei", "ou", "er"

Case Else

GetInitial = VBA.Left(GetInitial, 1)

End Select

End Function

Private Function IFELanguage_GetMorphResult(HzStr As String) As String 'API获取汉字拼音

Dim ret As Variant

Dim pArgs(0 To 5) As Long

Dim vt(0 To 5) As Integer

Dim Args(0 To 5) As Long

Dim ResultPtr As Long

Dim TinyM As VB_MORRSLT

Dim Py() As Byte

Dim i As Integer

Dim j As Integer

Dim PinyinIndexArray() As Integer

IFELanguage_GetMorphResult = ""

If IFELanguage = 0 Then Exit Function

Args(0) = &H30000

Args(1) = &H40000100

Args(2) = Len(HzStr)

Args(3) = StrPtr(HzStr)

Args(4) = 0

Args(5) = VarPtr(ResultPtr)

For i = 0 To 5

vt(i) = vbLong

pArgs(i) = VarPtr(Args(i)) - 8

Next

Call DispCallFunc(IFELanguage, 20, 4, vbLong, 6, vt(0), pArgs(0), ret)

Call MoveMemory(TinyM, ByVal ResultPtr, Len(TinyM))

ReDim PinyinIndexArray(0 To HzLen - 1)

ReDim PinYinArray(1 To HzLen)

If TinyM.cchOutput > 0 Then

ReDim Py(0 To TinyM.cchOutput * 2 - 1)

Call MoveMemory(Py(0), ByVal TinyM.pwchOutput, TinyM.cchOutput * 2)

IFELanguage_GetMorphResult = Py

Call MoveMemory(PinyinIndexArray(0), ByVal TinyM.paMonoRubyPos + 2, HzLen * 2)

j = 0

For i = 0 To HzLen - 1

PinYinArray(i + 1) = VBA.Mid(IFELanguage_GetMorphResult, j + 1, PinyinIndexArray(i) - j)

j = PinyinIndexArray(i)

Next i

End If

Call CoTaskMemFree(ByVal ResultPtr)

End Function

Private Sub IFELanguage_Open()

Dim ret As Variant

Call DispCallFunc(IFELanguage, 4, 4, vbLong, 0, 0, 0, ret)

Call DispCallFunc(IFELanguage, 12, 4, vbLong, 0, 0, 0, ret)

End Sub

Private Sub IFELanguage_Close()

Dim ret As Variant

If IFELanguage = 0 Then Exit Sub

Call DispCallFunc(IFELanguage, 8, 4, vbLong, 0, 0, 0, ret)

Call DispCallFunc(IFELanguage, 16, 4, vbLong, 0, 0, 0, ret)

End Sub

Private Function GenerateGUID()

Dim Rlt As Long

'MSIME.China GUID = "{E4288337-873B-11D1-BAA0-00AA00BBB8C0}"

Rlt = CLSIDFromString(StrPtr("MSIME.China"), MSIME_GUID)

'IFELanguage GUID = "{019F7152-E6DB-11d0-83C3-00C04FDDB82E}"

With IFELanguage_GUID

.Data1 = &H19F7152

.Data2 = &HE6DB

.Data3 = &H11D0

.Data4(0) = &H83

.Data4(1) = &HC3

.Data4(2) = &H0

.Data4(3) = &HC0

.Data4(4) = &H4F

.Data4(5) = &HDD

.Data4(6) = &HB8

.Data4(7) = &H2E

End With

GenerateGUID = Rlt = 0

End Function

Private Sub Class_Initialize()

IFELanguage = 0

pvSeperator = ""

GenerateGUID

If CoCreateInstance(MSIME_GUID, 0, 1, IFELanguage_GUID, IFELanguage) = 0 Then Call IFELanguage_Open

End Sub

Private Sub Class_Terminate()

If IFELanguage <> 0 Then Call IFELanguage_Close

End Sub

以上代码在W7（64）+EXCEL2007中运行暂未发现问题，其它版本情况不清，请自行测试，无误后使用，以免发生数据错误或丢失，本人概不负责。