發現一漢字注音的代碼，不取獨享，分與各位學習及個人使用，如用作商業用途，請與作者本人聯系。

使用動圖

使用說明動圖一

以此代碼，運用到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中運行暫未發現問題，其它版本情況不清，請自行測試，無誤後使用，以免發生數據錯誤或丢失，本人概不負責。

更多精彩资讯请关注tft每日頭條，我们将持续为您更新最新资讯!