非常強大的漢字轉拼音的類(lèi)（帶音調） 收藏
今天學(xué)習了一下這個(gè)類(lèi)，學(xué)到了不少東西。貼出來(lái)收藏
view plaincopy to clipboardprint?
'***************************************************************************
'*
'* MODULE NAME: HzToPy
'* AUTHOR & DATE: tt.t
'* 03 Apirl 2007
'*
'* DESCRIPTION: 將中文字符串轉換為拼音，就這些～
'* 有漢字得到拼音其實(shí)并不是我很關(guān)心的一個(gè)問(wèn)題，只是發(fā)現已經(jīng)公開(kāi)
'* 的方法有很大的缺陷，但WORD卻做得很好，因此才嘗試解決這個(gè)問(wèn)題。
'* 過(guò)程比我預期的要曲折的多，主要是VBA實(shí)在是一種很受限制的語(yǔ)言。
'* 不過(guò)好在有Google和Olldbg，難題也僅僅是如何找到繞過(guò)限制的途徑，
'* 終于在5個(gè)小時(shí)內搞定了一切～
'* 時(shí)間比我預計的長(cháng)了很多，因為我實(shí)在是不了解VBA，也不很熟悉OLE:"(
'* 不過(guò)好在一切都解決了～～終于從VBA小白成長(cháng)了一些。
'* 其實(shí)VBA也是很強大的～
'*
'* Theory： 廢話(huà)了好多還是說(shuō)說(shuō)原理吧，雖然不是每個(gè)人都很關(guān)心～
'* WORD的拼音向導能夠將漢字轉成拼音全是倚仗微軟拼音的幫助，
'* 微軟拼音2.0以上版本都提供了漢字到拼音的轉換功能。
'* 微軟拼音MSIME.China類(lèi)中的IFELanguage接口具體實(shí)現了轉換功能
'* 不過(guò)MSIME.China中沒(méi)有提供IDispatch接口，VBA的CreateObject不支持
'* 調用這樣的類(lèi)，因此我們只好手工調用。CoCreateInstance可以創(chuàng )建類(lèi)
'* 并獲取IFELanguage接口，但我們無(wú)法直接調用，因為VBA不知道如何調用
'* IFELanguage接口的Method。這里困擾了我好久，原本希望能向其他語(yǔ)言那樣
'* 聲明接口結構，但VBA并不支持。萬(wàn)般無(wú)奈下只好在OLE相關(guān)DLL中尋找，期待能
'* 找到代理函數簡(jiǎn)介調用接口的Method。呵呵～功夫不負苦心人終于在OLEAUT32中
'* 找到了DispCallfunc。Google了一下，果然是我需要的。接口知道了，如何調用也
'* 清楚了，剩下的問(wèn)題就是如何取得轉換后的結果。IFELanguage.GetMorphResult會(huì )將
'* 轉換的結果存在一個(gè)叫做tagMORRSLT的結構中，并返回指向tagMORRSLT的指針。
'* 新問(wèn)題又來(lái)了，VBA不支持指針...sigh，為什么其他語(yǔ)言很容易實(shí)現的功能VBA用起來(lái)
'* 就這么煩呢～幸好VBA讀取內存的限制也好突破，只需調用ntdll的RtlMoveMemory。
'* 好了～一切限制都已解除，HzToPy終于正常工作了～～
'* 說(shuō)起來(lái)一切順理成章，可是尋找解決方法的過(guò)程真的很痛苦，不過(guò)VBA經(jīng)驗值大漲也算有所收獲。
'* 下面就讓代碼來(lái)說(shuō)話(huà)吧。
'*
'* Memo: 改成類(lèi)了，加入了拼音間加入分隔符和去掉注音的功能，請參照“模塊1”中的例子，用起來(lái)很簡(jiǎn)單：）
'* 更正了一個(gè)錯誤，redim時(shí)vba數組默認起始搞錯了
'*
'***************************************************************************
Option Explicit
Public Enum PhoneticNotation
pnDefault = 0
pnNoNotation = 1
End Enum
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type TinyMORRSLT
dwSize As Long
pwchOutput As Long
cchOutput As Integer
End Type
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, Source As Any, ByVal Length 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 sNotation1
Dim sNotation2
Dim dNotation
Dim pvSeperator As String
Dim pvUseSeperator As Boolean
Dim pvInitialOnly As Boolean
Dim pvOnlyOneChar As Boolean
Private Sub InitalArray()
sNotation1 = Array("ā", "á", "ǎ", "à", "ē", "é", "ě", "è", "ī", "í", "ǐ", "ì", "ō", "ó", "ǒ", _
"ò", "ū", "ú", "ǔ", "ù", "ǖ", "ǘ", "ǚ", "ǜ", "ü", "", "ń", "ň", "", "ɡ")
sNotation2 = Array("a1", "a2", "a3", "a4", "e1", "e2", "e3", "e4", "i1", "i2", "i3", "i4", "o1", "o2", "o3", _
"o4", "u1", "u2", "u3", "u4", "v1", "v2", "v3", "v4", "v", "m2", "n2", "n4", "n2", "g")
dNotation = Array("a", "a", "a", "a", "e", "e", "e", "e", "i", "i", "i", "i", "o", "o", "o", _
"o", "u", "u", "u", "u", "v", "v", "v", "v", "v", "m", "n", "n", "n", "g")
End Sub
Private Sub GenGUID()
InitalArray
'MSIME.China GUID = "{E4288337-873B-11D1-BAA0-00AA00BBB8C0}"
With MSIME_GUID
.Data1 = &HE4288337
.Data2 = &H873B
.Data3 = &H11D1
.Data4(0) = &HBA
.Data4(1) = &HA0
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &HBB
.Data4(6) = &HB8
.Data4(7) = &HC0
End With
'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
End Sub
Private Sub IFELanguage_Open()
Dim ret As Variant
DispCallFunc IFELanguage, 4, 4, vbLong, 0, 0, 0, ret
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
DispCallFunc IFELanguage, 8, 4, vbLong, 0, 0, 0, ret
DispCallFunc IFELanguage, 16, 4, vbLong, 0, 0, 0, ret
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Subroutine: GetPinYin
'''
''' Purpose: 返回漢字的拼音
'''
''' Arguments: HzStr - 待轉換的拼音
'''
'''
''' Date Developer Action
''' --------------------------------------------------------------------------
''' 02 April 2007 tt.t 更正ReDim Py時(shí)的錯誤
'''
Private Function IFELanguage_GetMorphResult(HzStr As String) As String
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 TinyMORRSLT
Dim py() As Byte
Dim i 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
DispCallFunc IFELanguage, 20, 4, vbLong, 6, vt(0), pArgs(0), ret
MoveMemory TinyM, ByVal ResultPtr, 4 * 3
If TinyM.cchOutput > 0 Then
ReDim py(0 To TinyM.cchOutput * 2 - 1)
MoveMemory py(0), ByVal TinyM.pwchOutput, TinyM.cchOutput * 2
IFELanguage_GetMorphResult = py
End If
CoTaskMemFree (ResultPtr)
End Function
Private Function GetInitial(py As String) As String
Dim Char1 As String
Dim Char2 As String
Char1 = Left(py, 1)
Char2 = Mid(py, 2, 1)
GetInitial = Char1
If Not pvOnlyOneChar Then
Select Case Char1
Case "z", "c", "s"
If Char2 = "h" Then GetInitial = GetInitial + Char2
End Select
End If
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Subroutine: GetPinYin
'''
''' Purpose: 返回漢字的拼音
'''
''' Arguments: HzStr - 待轉換的拼音
'''
'''
''' Date Developer Action
''' --------------------------------------------------------------------------
''' 02 April 2007 tt.t Create
'''
Public Function GetPinYin(HzStr As String) As String
Dim i As Integer
Dim tmpStr As String
GetPinYin = ""
If HzStr <> "" Then
If pvUseSeperator Or pvInitialOnly Then
For i = 1 To Len(HzStr)
tmpStr = IFELanguage_GetMorphResult(Mid(HzStr, i, 1))
If tmpStr <> "" Then
If pvInitialOnly Then
GetPinYin = GetPinYin & GetInitial(tmpStr) & pvSeperator
Else
GetPinYin = GetPinYin & tmpStr & pvSeperator
End If
End If
Next
If Len(GetPinYin) > 0 Then GetPinYin = Left(GetPinYin, Len(GetPinYin) - 1)
Else
GetPinYin = IFELanguage_GetMorphResult(HzStr)
End If
End If
End Function
Public Function AdjustPhoneticNotation(hz As String, pn As PhoneticNotation) As String
Dim i As Integer
AdjustPhoneticNotation = hz
'未進(jìn)行優(yōu)化
Select Case pn
Case pnNoNotation
For i = LBound(dNotation) To UBound(dNotation)
AdjustPhoneticNotation = Replace(AdjustPhoneticNotation, sNotation1(i), dNotation(i))
Next
For i = LBound(dNotation) To UBound(dNotation)
AdjustPhoneticNotation = Replace(AdjustPhoneticNotation, sNotation2(i), dNotation(i))
Next
End Select
End Function
Private Sub Class_Initialize()
IFELanguage = 0
InitalArray
InitialOnly = False
GenGUID
If CoCreateInstance(MSIME_GUID, 0, 1, _
IFELanguage_GUID, IFELanguage) = 0 Then
IFELanguage_Open
pvUseSeperator = False
pvSeperator = " "
Else
Err.Raise "OLE error!!"
End If
End Sub
Private Sub Class_Terminate()
If IFELanguage <> 0 Then IFELanguage_Close
End Sub
Property Get Seperator() As String
Seperator = pvSeperator
End Property
Property Let Seperator(Value As String)
pvSeperator = Value
End Property
Property Get UseSeperator() As Boolean
UseSeperator = pvUseSeperator
End Property
Property Let UseSeperator(Value As Boolean)
pvUseSeperator = 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 HzToPy(hz As String, Optional Sep As String = "", Optional ShowNotation As Boolean = True, Optional ShowInitialOnly As Boolean, Optional ShowOnlyOneChar As Boolean = True) As String
Dim hp As HZ2PY
Set hp = New HZ2PY '創(chuàng )建類(lèi)
If Sep <> "" Then
hp.Seperator = Sep
hp.UseSeperator = True
End If
hp.InitialOnly = ShowInitialOnly
hp.OnlyOneChar = ShowOnlyOneChar
HzToPy = hp.GetPinYin(hz)
If Not ShowNotation Then HzToPy = hp.AdjustPhoneticNotation(HzToPy, pnNoNotation)
Set hp = Nothing '釋放類(lèi)
End Function
