[解决多音字]汉字转拼音的完美解决方案[12.11.29更新]

china047

WIn8 64位运行不了

xiaoxinla

谢谢分享，好用！

cquzhang

感谢大神的贡献，谢谢，使用中非常方便，也有一个问题恳请大侠抽时间更正一下， o的声调标注不准确

Nonenever

希望能支持 64 Excel
自己改了一下，运行不了，不知道这个问题咋解决，类模块的内容没有看懂，网上搜索着改了一下，但一运行就死了

1. Option Explicit
   
2. Private Type GUID '自定义的类型
   
3.     Data1 As Long
   
4.     Data2 As Integer
   
5.     Data3 As Integer
   
6.     Data4(0 To 7) As Byte
   
7. End Type
   
8. 
   
9. Private Type VB_MORRSLT '自定义的类型
   
10.     dwSize As Long          '4
    
11.     pwchOutput As Long      '4
    
12.     cchOutput As Integer    '2+(2)
    
13.     Block1 As Long          '4
    
14.     pchInputPos As Long     '4
    
15.     pchOutputIdxWDD As Long '4
    
16.     pchReadIdxWDD As Long   '4
    
17.     paMonoRubyPos As Long   '4
    
18.     pWDD As Long            '4
    
19.     cWDD As Integer         '2
    
20.     pPrivate As Long        '4
    
21.     BLKBuff As Long         '4
    
22. End Type
    
23. 
    
24. #If VBA7 Then
    
25. Private Declare PtrSafe Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
    
26.         (Destination As Any, Source As Any, ByVal Length As Long)
    
27. 
    
28. Private Declare PtrSafe Function CLSIDFromString Lib "ole32.dll" _
    
29.         (ByVal lpszProgID As LongLong, pCLSID As GUID) As LongLong
    
30. 'CLSIDFromString: 将字符串方式表达的GUID转换为CLSID结构
    
31. 
    
32. Private Declare PtrSafe Function CoCreateInstance Lib "ole32" ( _
    
33.         rclsid As GUID, ByVal pUnkOuter As Long, _
    
34.         ByVal dwClsContext As Long, riid As GUID, _
    
35.         ByRef ppv As Long) As Long
    
36. 'CoCreateInstance，函数名。用指定的类标识符创建一个Com对象,用指定的类标识符创建一个未初始化的对象
    
37. Private Declare PtrSafe Function DispCallFunc Lib "oleaut32" _
    
38.         (ByVal pvInstance As Long, ByVal oVft As Long, _
    
39.         ByVal cc As Long, ByVal vtReturn As Integer, _
    
40.         ByVal cActuals As Long, prgvt As Integer, _
    
41.         prgpvarg As Long, pvargResult As Long) As Long
    
42. 
    
43. Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32" (pv As Long)
    
44. 'CoTaskMemFree是一种函数，此函数用于释放被分配的内存块。
    
45. #Else
    
46. Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
    
47.         (Destination As Any, Source As Any, ByVal Length As Long)
    
48. 
    
49. Private Declare Function CLSIDFromString Lib "ole32.dll" _
    
50.         (ByVal lpszProgID As Long, pCLSID As GUID) As Long
    
51. 
    
52. Private Declare Function CoCreateInstance Lib "ole32" ( _
    
53.         rclsid As GUID, ByVal pUnkOuter As Long, _
    
54.         ByVal dwClsContext As Long, riid As GUID, _
    
55.         ByRef ppv As Long) As Long
    
56. 
    
57. Private Declare Function DispCallFunc Lib "oleaut32" _
    
58.         (ByVal pvInstance As Long, ByVal oVft As Long, _
    
59.         ByVal cc As Long, ByVal vtReturn As Integer, _
    
60.         ByVal cActuals As Long, prgvt As Integer, _
    
61.         prgpvarg As Long, pvargResult As Long) As Long
    
62. 
    
63. Private Declare Sub CoTaskMemFree Lib "ole32" (pv As Long)
    
64. 
    
65. #End If
    
66. 
    
67. 
    
68. Dim MSIME_GUID As GUID          'MSIME's GUID
    
69. Dim IFELanguage_GUID As GUID    'IFELanguage's GUID
    
70. Dim IFELanguage As Long       'Pointer to IFELanguage interface  IFELanguage接口指针
    
71. Dim PinYinArray() As String
    
72. Dim HzLen As Integer
    
73. Dim pvSeperator As String
    
74. Dim pvUseSeperator As Boolean
    
75. Dim pvInitialOnly As Boolean
    
76. Dim pvOnlyOneChar As Boolean
    
77. Dim pvNonChnUseSep As Boolean
    
78. 
    
79. Public Function GetPinYin(HzStr As String) As String
    
80.     Dim i As Integer
    
81.     Dim Py As String
    
82.     Dim IsPy As Boolean
    
83.     GetPinYin = ""
    
84.     If IFELanguage = 0 Then
    
85.         GetPinYin = "未发现运行环境，请安装微软拼音2.0以上版本！"
    
86.         Exit Function
    
87.     End If
    
88.     If HzStr = "" Then Exit Function
    
89.     HzLen = Len(HzStr)
    
90.     Call IFELanguage_GetMorphResult(HzStr)
    
91.     For i = 1 To HzLen
    
92.         Py = PinYinArray(i)
    
93.         IsPy = Py <> ""
    
94.         If Not IsPy Then Py = Mid(HzStr, i, 1)
    
95.         GetPinYin = GetPinYin & Py & IIf(IsPy, pvSeperator, "")
    
96.     Next i
    
97.     If IsPy And pvSeperator <> "" Then GetPinYin = Left(GetPinYin, Len(GetPinYin) - 1)
    
98. End Function
    
99. 
    
100. Private Function IFELanguage_GetMorphResult(HzStr As String) As String
     
101.     Dim ret As Long
     
102.     Dim pArgs(0 To 5) As Long
     
103.     Dim vt(0 To 5) As Integer
     
104.     Dim Args(0 To 5) As Long
     
105.     Dim ResultPtr As Long
     
106.     Dim TinyM As VB_MORRSLT
     
107.     Dim Py() As Byte
     
108.     Dim i As Integer
     
109.     Dim j As Integer
     
110.     Dim PinyinIndexArray() As Integer
     
111.     IFELanguage_GetMorphResult = ""
     
112.     If IFELanguage = 0 Then Exit Function
     
113.     Args(0) = &H30000
     
114.     Args(1) = &H40000100
     
115.     Args(2) = Len(HzStr)
     
116.     Args(3) = StrPtr(HzStr)
     
117.     Args(4) = 0
     
118.     Args(5) = VarPtr(ResultPtr)
     
119.     For i = 0 To 5
     
120.         vt(i) = vbLong
     
121.         pArgs(i) = VarPtr(Args(i)) - 8
     
122.     Next
     
123.     Call DispCallFunc(IFELanguage, 20, 4, vbLong, 6, vt(0), pArgs(0), ret)
     
124.     Call MoveMemory(TinyM, ByVal ResultPtr, Len(TinyM))
     
125.     ReDim PinyinIndexArray(0 To HzLen - 1)
     
126.     ReDim PinYinArray(1 To HzLen)
     
127.     If TinyM.cchOutput > 0 Then
     
128.         ReDim Py(0 To TinyM.cchOutput * 2 - 1)
     
129.         Call MoveMemory(Py(0), ByVal TinyM.pwchOutput, TinyM.cchOutput * 2)
     
130.         IFELanguage_GetMorphResult = Py
     
131.         Call MoveMemory(PinyinIndexArray(0), ByVal TinyM.paMonoRubyPos + 2, HzLen * 2)
     
132.         j = 0
     
133.         For i = 0 To HzLen - 1
     
134.             PinYinArray(i + 1) = VBA.Mid(IFELanguage_GetMorphResult, j + 1, PinyinIndexArray(i) - j)
     
135.             j = PinyinIndexArray(i)
     
136.         Next i
     
137.     End If
     
138.     Call CoTaskMemFree(ByVal ResultPtr)
     
139. End Function
     
140. Private Sub IFELanguage_Open()
     
141.     Dim ret As Long
     
142.      Debug.Print " IFELanguage_Open   0:" & IFELanguage 'Excel 已停止工作 的位置
     
143.     Call DispCallFunc(IFELanguage, 4, 4, vbLong, 0, 0, 0, ret)
     
144.      Debug.Print " IFELanguage_Open   1 :" & IFELanguage
     
145.     Call DispCallFunc(IFELanguage, 12, 4, vbLong, 0, 0, 0, ret)
     
146.      Debug.Print " IFELanguage_Open    2:" & IFELanguage
     
147. End Sub
     
148. Private Sub IFELanguage_Close()
     
149.     Dim ret As Long
     
150.     If IFELanguage = 0 Then Exit Sub
     
151.     Call DispCallFunc(IFELanguage, 8, 4, vbLong, 0, 0, 0, ret)
     
152.     Call DispCallFunc(IFELanguage, 16, 4, vbLong, 0, 0, 0, ret)
     
153. End Sub
     
154. Private Function GenerateGUID()
     
155.     Dim Rlt As LongLong
     
156. '       Debug.Print "Rlt :" & Rlt
     
157.     Rlt = CLSIDFromString(StrPtr("MSIME.China"), MSIME_GUID)
     
158. '    StrPtr：返回真正的UNICODE字符串缓冲区的地址
     
159.     'IFELanguage GUID = "{019F7152-E6DB-11d0-83C3-00C04FDDB82E}"
     
160.     With IFELanguage_GUID
     
161.         .Data1 = &H19F7152
     
162.         .Data2 = &HE6DB
     
163.         .Data3 = &H11D0
     
164.         .Data4(0) = &H83
     
165.         .Data4(1) = &HC3
     
166.         .Data4(2) = &H0
     
167.         .Data4(3) = &HC0
     
168.         .Data4(4) = &H4F
     
169.         .Data4(5) = &HDD
     
170.         .Data4(6) = &HB8
     
171.         .Data4(7) = &H2E
     
172.     End With
     
173.     GenerateGUID = Rlt = 0
     
174. End Function
     
175. Private Sub Class_Initialize() '类初始化
     
176.     IFELanguage = 0
     
177.     pvSeperator = " "
     
178.     GenerateGUID
     
179.     If CoCreateInstance(MSIME_GUID, 0, 1, IFELanguage_GUID, IFELanguage) = 0 Then Call IFELanguage_Open
     
180. End Sub
     
181. Private Sub Class_Terminate() '类终止
     
182.     If IFELanguage <> 0 Then Call IFELanguage_Close
     
183. End Sub
     
184. 
     
185. 
     
186. 
     

复制代码

weiyingde

smhf_6 发表于 2019-3-2 08:26
对多音字有一定的识别功能，但仍有一定的差错率，当然这不是楼主造成的，比如工商银行，大家都知道读hang,  ...

说的不错，可不可以将常见多音字整理出来，另外编写代码，整合到本程序之中？
到能实现，将是一个不错的实用程序。

weiyingde

在ppt上用，弹出如下问题窗口，请问大侠，这是为什么？

shenjianrong163

Nonenever 发表于 2019-8-9 22:20
希望能支持 64 Excel
自己改了一下，运行不了，不知道这个问题咋解决，类模块的内容没有看懂，网上搜索着 ...

将代码中“LongLong”改成“Long”试试

shenjianrong163

您好，我下载了您的“汉字转拼音的完美解决方案[12.11.29更新]”字符串中出现非中文就不显示了，这是为什么?
HztoPy_20121129.rar

shenjianrong163

ttui 发表于 2007-3-30 10:50
最初版本，请不要使用了。&nbsp;服了服了，上传附件如此难

您好，我下载了您的“汉字转拼音的完美解决方案[12.11.29更新]”字符串中出现非中文就不显示了，这是为什么? HztoPy_20121129.rar

nonknower

shenjianrong163 发表于 2020-1-26 11:49
您好，我下载了您的“汉字转拼音的完美解决方案[12.11.29更新]”字符串中出现非中文就不显示了，这是为什么 ...

我在Win8.1上使用，也出现了这种状况，只要输入的字符串还有非中文就不行。
经观察发现这种字符串的转换结果，要么第一个字符必然是Chr(0)，要么长度为0。
根据这个规律，我们可以逐字检查字符串，把能转换的部分截取出来，不能转换的保留，最后拼接即可。

提供一个做法作为参考，我是直接针对TinyM结构体判断的：
首先仿造GetMorphResult做一个判断函数。

1. Private Function IFEL_Test(ch As String) As Boolean
   
2.     Dim varg As Variant
   
3.     Dim probe As Byte
   
4.    
   
5.     Args.cwchInput = 1
   
6.     Args.pwchInput = strptr(ch)
   
7.    
   
8.     Call DispCallFunc(lpIFEL, 20, 4, vbLong, 6, vt(0), pArgs(0), varg)
   
9.     Call CopyMemory(TinyM, ByVal pResult, Len(TinyM))
   
10. 
    
11.     '正常情况下，对于非拼音，返回长度应该为0
    
12.     If TinyM.cchOutput = 0 Then
    
13.         IFEL_Test = True
    
14.     Else
    
15.         Call CopyMemory(probe, ByVal TinyM.pwchOutput, 1)
    
16.         '如果第一个字符是\0，肯定不正常
    
17.         IFEL_Test = probe
    
18.     End If
    
19.    
    
20.     Call CoTaskMemFree(ByVal pResult)
    
21. End Function

复制代码

然后我给GetMorphResult添加了一个偏移量参数，因为只是对源字符串的中间一部分转化。

1. Private Function IFEL_GetMorphResult(HzStr As String, Offset As Long) As String
   
2. ......
   
3.     If TinyM.cchOutput > 0 Then
   
4.     ......
   
5.         For i = 0 To HzLen - 1
   
6.             PinYinArray(i + Offset) = VBA.Mid(IFEL_GetMorphResult, j + 1, PinyinIndexArray(i) - j)
   
7.             j = PinyinIndexArray(i)
   
8.         Next i
   
9.     End If
   
10.     ......
    
11. End Function

复制代码

最后组合起来用

1. Private Sub SegmentalMorph(HzStr As String)
   
2.     Dim i As Long, j As Long
   
3.     Dim ch As String * 1
   
4. 
   
5.     For i = 1 To Len(HzStr)
   
6.         ch = Strings.Mid$(HzStr, i, 1)
   
7.         
   
8.         '遇到非中文时，总是会使j=0
   
9.         '所以如果j>0，那么之前一定有中文字符
   
10.         If IFEL_Test(ch) Then
    
11.             If j = 0 Then j = i     '遇到中文字符，如果j=0，表示这是一连串中文的开始
    
12.         ElseIf j Then
    
13.             Call IFEL_GetMorphResult(Strings.Mid$(HzStr, j, i - j), j)
    
14.             j = 0
    
15.         End If
    
16.     Next i
    
17. 
    
18.     '如果最后一个字符为中文，便不会触发转化，需要手动补充
    
19.     If j Then Call IFEL_GetMorphResult(Right$(HzStr, i - j), j)
    
20.    
    
21. End Sub

复制代码