前沿拓展：

clsid

CLSID:6BF52A52-394A-11d3-B153-00C04F79FAA6

---

發(fā)現(xiàn)一漢字注音的代碼，不取獨(dú)享，分與各位學(xué)習(xí)及個人使用，如用作商業(yè)用途，請與作者本人聯(lián)系。

使用動圖

使用說明動圖一

以此代碼，運(yùn)用到VBA中，結(jié)合其它功能，可應(yīng)用到很多地方，比如開發(fā)小型進(jìn)銷存，在錄入、查找等**作中，以拼音首字母為輸入方式，提高效率。還可應(yīng)用到下拉框的輸入中。又如給小孩識字注音等。

使用說明動圖二

代碼動圖

附代碼：

部分語句添加了解說，如有不對請自行理解。

標(biāo)準(zhǔn)模塊部分代碼

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 ‘創(chuàng)建類

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原件內(nèi)沒有，后添加的。

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() ‘帶注音,省略其它所有參數(shù)

MsgBox HzToPy(“重慶重要”)

End Sub

函數(shù)原型

在電子表格中直接調(diào)用函數(shù)

類模塊部分

‘***************************************************************************

‘*

‘* Module: HzToPy

‘* Update: 2011-09-23

‘* Author: tt.t

‘*

‘* Description: 將中文字符串轉(zhuǎn)換為拼音，就這些。原先這里寫了太多廢話，刪了。

‘*

‘* Theory： 原理依然是通過IFELanguage接口實(shí)現(xiàn)。

‘* 唯一需要解釋的是如何解決多音字正確注音的問題。

‘* IFELanguage接口是能夠正確返回很多多音字拼音的，但多音字的讀音只有特定詞匯中

‘* 才能確認(rèn)，因此在解析拼音時候不能把詞拆成單字，否則多音字返回的拼音就很可能不對。

‘* 之前版本中就是因?yàn)榘言~拆開獲取拼音導(dǎo)致多音字拼音錯誤。

‘* 這次的更新利用接口返回數(shù)據(jù)中標(biāo)識每個拼音長度的數(shù)組實(shí)現(xiàn)了對返回拼音

‘* 的按字拆分，無需再把詞拆成字獲取單個字的拼音，從而解決了多音字問題。

‘* 需要說明的是，VB_MORRSLT結(jié)構(gòu)就是MS文檔中的MORRSLT結(jié)構(gòu)，但是VBA自定義結(jié)構(gòu)

‘* 無法實(shí)現(xiàn)不按4字節(jié)對齊，使得不得不修改MORRSLT的定義方式，能這樣修改只能說運(yùn)氣不錯，

‘* 因?yàn)楸恍薷牡牟糠謩偤毛@取拼音用不到。

‘*

‘*

‘* Histroy:

‘* 2011-09-23

‘* ● 重寫主要代碼，支持多音字，提高了運(yùn)行效率。

‘* ● 取拼音首字時，ao, ai, ei, ou, er作為首字而不是原來的第一個字母。

‘* ● 為函數(shù)增加了注音方式選擇，hàn可以顯示為han或han4。

‘* ● 函數(shù)的使用與之前版本兼容，將模塊中函數(shù)代碼和HZ2PY類代碼覆蓋之前版本即可實(shí)現(xiàn)升級，無需修改文檔中的公式。

‘* 2011-04-07

‘* ● 更正CoTaskMemFree傳遞參數(shù)錯誤，消除了Win7等環(huán)境下崩潰。

‘* 2007-04-03

‘* ● 更正redim時vba數(shù)組默認(rèn)起始值錯誤。

‘* 2007-04-02

‘* ● 最初版本，實(shí)現(xiàn)了由漢字獲取拼音。

‘*

‘***************************************************************************

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內(nèi)存對齊鬧得，折騰了好一陣才確認(rèn)問題所在，唉

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 = “未發(fā)現(xiàn)運(yùn)行環(huán)境，請安裝微軟拼音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 ‘注音轉(zhuǎn)換，pn=-1表示帶注音不轉(zhuǎn)換，

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中運(yùn)行暫未發(fā)現(xiàn)問題，其它版本情況不清，請自行測試，無誤后使用，以免發(fā)生數(shù)據(jù)錯誤或丟失，本人概不負(fù)責(zé)。

拓展知識：

前沿拓展：

clsid

CLSID:6BF52A52-394A-11d3-B153-00C04F79FAA6

---

發(fā)現(xiàn)一漢字注音的代碼，不取獨(dú)享，分與各位學(xué)習(xí)及個人使用，如用作商業(yè)用途，請與作者本人聯(lián)系。

使用動圖

使用說明動圖一

以此代碼，運(yùn)用到VBA中，結(jié)合其它功能，可應(yīng)用到很多地方，比如開發(fā)小型進(jìn)銷存，在錄入、查找等**作中，以拼音首字母為輸入方式，提高效率。還可應(yīng)用到下拉框的輸入中。又如給小孩識字注音等。

使用說明動圖二

代碼動圖

附代碼：

部分語句添加了解說，如有不對請自行理解。

標(biāo)準(zhǔn)模塊部分代碼

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 ‘創(chuàng)建類

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原件內(nèi)沒有，后添加的。

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() ‘帶注音,省略其它所有參數(shù)

MsgBox HzToPy(“重慶重要”)

End Sub

函數(shù)原型

在電子表格中直接調(diào)用函數(shù)

類模塊部分

‘***************************************************************************

‘*

‘* Module: HzToPy

‘* Update: 2011-09-23

‘* Author: tt.t

‘*

‘* Description: 將中文字符串轉(zhuǎn)換為拼音，就這些。原先這里寫了太多廢話，刪了。

‘*

‘* Theory： 原理依然是通過IFELanguage接口實(shí)現(xiàn)。

‘* 唯一需要解釋的是如何解決多音字正確注音的問題。

‘* IFELanguage接口是能夠正確返回很多多音字拼音的，但多音字的讀音只有特定詞匯中

‘* 才能確認(rèn)，因此在解析拼音時候不能把詞拆成單字，否則多音字返回的拼音就很可能不對。

‘* 之前版本中就是因?yàn)榘言~拆開獲取拼音導(dǎo)致多音字拼音錯誤。

‘* 這次的更新利用接口返回數(shù)據(jù)中標(biāo)識每個拼音長度的數(shù)組實(shí)現(xiàn)了對返回拼音

‘* 的按字拆分，無需再把詞拆成字獲取單個字的拼音，從而解決了多音字問題。

‘* 需要說明的是，VB_MORRSLT結(jié)構(gòu)就是MS文檔中的MORRSLT結(jié)構(gòu)，但是VBA自定義結(jié)構(gòu)

‘* 無法實(shí)現(xiàn)不按4字節(jié)對齊，使得不得不修改MORRSLT的定義方式，能這樣修改只能說運(yùn)氣不錯，

‘* 因?yàn)楸恍薷牡牟糠謩偤毛@取拼音用不到。

‘*

‘*

‘* Histroy:

‘* 2011-09-23

‘* ● 重寫主要代碼，支持多音字，提高了運(yùn)行效率。

‘* ● 取拼音首字時，ao, ai, ei, ou, er作為首字而不是原來的第一個字母。

‘* ● 為函數(shù)增加了注音方式選擇，hàn可以顯示為han或han4。

‘* ● 函數(shù)的使用與之前版本兼容，將模塊中函數(shù)代碼和HZ2PY類代碼覆蓋之前版本即可實(shí)現(xiàn)升級，無需修改文檔中的公式。

‘* 2011-04-07

‘* ● 更正CoTaskMemFree傳遞參數(shù)錯誤，消除了Win7等環(huán)境下崩潰。

‘* 2007-04-03

‘* ● 更正redim時vba數(shù)組默認(rèn)起始值錯誤。

‘* 2007-04-02

‘* ● 最初版本，實(shí)現(xiàn)了由漢字獲取拼音。

‘*

‘***************************************************************************

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內(nèi)存對齊鬧得，折騰了好一陣才確認(rèn)問題所在，唉

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 = “未發(fā)現(xiàn)運(yùn)行環(huán)境，請安裝微軟拼音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 ‘注音轉(zhuǎn)換，pn=-1表示帶注音不轉(zhuǎn)換，

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中運(yùn)行暫未發(fā)現(xiàn)問題，其它版本情況不清，請自行測試，無誤后使用，以免發(fā)生數(shù)據(jù)錯誤或丟失，本人概不負(fù)責(zé)。

拓展知識：

前沿拓展：

clsid

CLSID:6BF52A52-394A-11d3-B153-00C04F79FAA6

---

發(fā)現(xiàn)一漢字注音的代碼，不取獨(dú)享，分與各位學(xué)習(xí)及個人使用，如用作商業(yè)用途，請與作者本人聯(lián)系。

使用動圖

使用說明動圖一

以此代碼，運(yùn)用到VBA中，結(jié)合其它功能，可應(yīng)用到很多地方，比如開發(fā)小型進(jìn)銷存，在錄入、查找等**作中，以拼音首字母為輸入方式，提高效率。還可應(yīng)用到下拉框的輸入中。又如給小孩識字注音等。

使用說明動圖二

代碼動圖

附代碼：

部分語句添加了解說，如有不對請自行理解。

標(biāo)準(zhǔn)模塊部分代碼

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 ‘創(chuàng)建類

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原件內(nèi)沒有，后添加的。

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() ‘帶注音,省略其它所有參數(shù)

MsgBox HzToPy(“重慶重要”)

End Sub

函數(shù)原型

在電子表格中直接調(diào)用函數(shù)

類模塊部分

‘***************************************************************************

‘*

‘* Module: HzToPy

‘* Update: 2011-09-23

‘* Author: tt.t

‘*

‘* Description: 將中文字符串轉(zhuǎn)換為拼音，就這些。原先這里寫了太多廢話，刪了。

‘*

‘* Theory： 原理依然是通過IFELanguage接口實(shí)現(xiàn)。

‘* 唯一需要解釋的是如何解決多音字正確注音的問題。

‘* IFELanguage接口是能夠正確返回很多多音字拼音的，但多音字的讀音只有特定詞匯中

‘* 才能確認(rèn)，因此在解析拼音時候不能把詞拆成單字，否則多音字返回的拼音就很可能不對。

‘* 之前版本中就是因?yàn)榘言~拆開獲取拼音導(dǎo)致多音字拼音錯誤。

‘* 這次的更新利用接口返回數(shù)據(jù)中標(biāo)識每個拼音長度的數(shù)組實(shí)現(xiàn)了對返回拼音

‘* 的按字拆分，無需再把詞拆成字獲取單個字的拼音，從而解決了多音字問題。

‘* 需要說明的是，VB_MORRSLT結(jié)構(gòu)就是MS文檔中的MORRSLT結(jié)構(gòu)，但是VBA自定義結(jié)構(gòu)

‘* 無法實(shí)現(xiàn)不按4字節(jié)對齊，使得不得不修改MORRSLT的定義方式，能這樣修改只能說運(yùn)氣不錯，

‘* 因?yàn)楸恍薷牡牟糠謩偤毛@取拼音用不到。

‘*

‘*

‘* Histroy:

‘* 2011-09-23

‘* ● 重寫主要代碼，支持多音字，提高了運(yùn)行效率。

‘* ● 取拼音首字時，ao, ai, ei, ou, er作為首字而不是原來的第一個字母。

‘* ● 為函數(shù)增加了注音方式選擇，hàn可以顯示為han或han4。

‘* ● 函數(shù)的使用與之前版本兼容，將模塊中函數(shù)代碼和HZ2PY類代碼覆蓋之前版本即可實(shí)現(xiàn)升級，無需修改文檔中的公式。

‘* 2011-04-07

‘* ● 更正CoTaskMemFree傳遞參數(shù)錯誤，消除了Win7等環(huán)境下崩潰。

‘* 2007-04-03

‘* ● 更正redim時vba數(shù)組默認(rèn)起始值錯誤。

‘* 2007-04-02

‘* ● 最初版本，實(shí)現(xiàn)了由漢字獲取拼音。

‘*

‘***************************************************************************

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內(nèi)存對齊鬧得，折騰了好一陣才確認(rèn)問題所在，唉

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 = “未發(fā)現(xiàn)運(yùn)行環(huán)境，請安裝微軟拼音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 ‘注音轉(zhuǎn)換，pn=-1表示帶注音不轉(zhuǎn)換，

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中運(yùn)行暫未發(fā)現(xiàn)問題，其它版本情況不清，請自行測試，無誤后使用，以免發(fā)生數(shù)據(jù)錯誤或丟失，本人概不負(fù)責(zé)。

拓展知識：

前沿拓展：

clsid

CLSID:6BF52A52-394A-11d3-B153-00C04F79FAA6

---

發(fā)現(xiàn)一漢字注音的代碼，不取獨(dú)享，分與各位學(xué)習(xí)及個人使用，如用作商業(yè)用途，請與作者本人聯(lián)系。

使用動圖

使用說明動圖一

以此代碼，運(yùn)用到VBA中，結(jié)合其它功能，可應(yīng)用到很多地方，比如開發(fā)小型進(jìn)銷存，在錄入、查找等**作中，以拼音首字母為輸入方式，提高效率。還可應(yīng)用到下拉框的輸入中。又如給小孩識字注音等。

使用說明動圖二

代碼動圖

附代碼：

部分語句添加了解說，如有不對請自行理解。

標(biāo)準(zhǔn)模塊部分代碼

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 ‘創(chuàng)建類

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原件內(nèi)沒有，后添加的。

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() ‘帶注音,省略其它所有參數(shù)

MsgBox HzToPy(“重慶重要”)

End Sub

函數(shù)原型

在電子表格中直接調(diào)用函數(shù)

類模塊部分

‘***************************************************************************

‘*

‘* Module: HzToPy

‘* Update: 2011-09-23

‘* Author: tt.t

‘*

‘* Description: 將中文字符串轉(zhuǎn)換為拼音，就這些。原先這里寫了太多廢話，刪了。

‘*

‘* Theory： 原理依然是通過IFELanguage接口實(shí)現(xiàn)。

‘* 唯一需要解釋的是如何解決多音字正確注音的問題。

‘* IFELanguage接口是能夠正確返回很多多音字拼音的，但多音字的讀音只有特定詞匯中

‘* 才能確認(rèn)，因此在解析拼音時候不能把詞拆成單字，否則多音字返回的拼音就很可能不對。

‘* 之前版本中就是因?yàn)榘言~拆開獲取拼音導(dǎo)致多音字拼音錯誤。

‘* 這次的更新利用接口返回數(shù)據(jù)中標(biāo)識每個拼音長度的數(shù)組實(shí)現(xiàn)了對返回拼音

‘* 的按字拆分，無需再把詞拆成字獲取單個字的拼音，從而解決了多音字問題。

‘* 需要說明的是，VB_MORRSLT結(jié)構(gòu)就是MS文檔中的MORRSLT結(jié)構(gòu)，但是VBA自定義結(jié)構(gòu)

‘* 無法實(shí)現(xiàn)不按4字節(jié)對齊，使得不得不修改MORRSLT的定義方式，能這樣修改只能說運(yùn)氣不錯，

‘* 因?yàn)楸恍薷牡牟糠謩偤毛@取拼音用不到。

‘*

‘*

‘* Histroy:

‘* 2011-09-23

‘* ● 重寫主要代碼，支持多音字，提高了運(yùn)行效率。

‘* ● 取拼音首字時，ao, ai, ei, ou, er作為首字而不是原來的第一個字母。

‘* ● 為函數(shù)增加了注音方式選擇，hàn可以顯示為han或han4。

‘* ● 函數(shù)的使用與之前版本兼容，將模塊中函數(shù)代碼和HZ2PY類代碼覆蓋之前版本即可實(shí)現(xiàn)升級，無需修改文檔中的公式。

‘* 2011-04-07

‘* ● 更正CoTaskMemFree傳遞參數(shù)錯誤，消除了Win7等環(huán)境下崩潰。

‘* 2007-04-03

‘* ● 更正redim時vba數(shù)組默認(rèn)起始值錯誤。

‘* 2007-04-02

‘* ● 最初版本，實(shí)現(xiàn)了由漢字獲取拼音。

‘*

‘***************************************************************************

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內(nèi)存對齊鬧得，折騰了好一陣才確認(rèn)問題所在，唉

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 = “未發(fā)現(xiàn)運(yùn)行環(huán)境，請安裝微軟拼音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 ‘注音轉(zhuǎn)換，pn=-1表示帶注音不轉(zhuǎn)換，

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中運(yùn)行暫未發(fā)現(xiàn)問題，其它版本情況不清，請自行測試，無誤后使用，以免發(fā)生數(shù)據(jù)錯誤或丟失，本人概不負(fù)責(zé)。

拓展知識：