文章
文章用户商铺文档快讯圈子网址导航供求信息

Excel 汉字转拼音带音调函数 HztoPy_20121129

1.打开 Excel 新建工作簿，打开文件-更多-选项【以实际 Office 版本为准】。

2.在自定义功能区勾选开发者工具。

3.在菜单栏中找到开发者工具，点击Visual Basic。

4.右键工作簿插入-模块。

5.插入以下代码。

  1. Public Function HzToPy(Hz As String, _  
  2.         Optional Sep As String = "", _  
  3.         Optional NotationType As Integer = -1, _  
  4.         Optional ShowInitialOnly As Boolean = False, _  
  5.         Optional ShowOnlyOneChar As Boolean = False) As String  
  6.           
  7.     Dim hp As HZ2PY  
  8.       
  9.     Set hp = New HZ2PY          '创建类  
  10.     hp.Seperator = Sep  
  11.     hp.InitialOnly = ShowInitialOnly  
  12.     hp.OnlyOneChar = ShowOnlyOneChar  
  13.     HzToPy = hp.GetPinYin(Hz)  
  14.     HzToPy = hp.AdjustPhoneticNotation(HzToPy, NotationType)  
  15.     Set hp = Nothing            '释放类  
  16. End Function  

6.右键工作簿插入-类模块。

7.插入以下代码。

  1. ***************************************************************************  
  2. '*  
  3. '* Module:          HzToPy  
  4. '* Update:          2011-09-23  
  5. '* Author:          tt.t  
  6. '*  
  7. '* Description:     将中文字符串转换为拼音，就这些。原先这里写了太多废话，删了。  
  8. '*  
  9. '* Theory：         原理依然是通过IFELanguage接口实现。  
  10. '*                  唯一需要解释的是如何解决多音字正确注音的问题。  
  11. '*                  IFELanguage接口是能够正确返回很多多音字拼音的，但多音字的读音只有特定词汇中  
  12. '*                  才能确认，因此在解析拼音时候不能把词拆成单字，否则多音字返回的拼音就很可能不对。  
  13. '*                  之前版本中就是因为把词拆开获取拼音导致多音字拼音错误。  
  14. '*                  这次的更新利用接口返回数据中标识每个拼音长度的数组实现了对返回拼音  
  15. '*                  的按字拆分，无需再把词拆成字获取单个字的拼音，从而解决了多音字问题。  
  16. '*                  需要说明的是，VB_MORRSLT结构就是MS文档中的MORRSLT结构，但是VBA自定义结构  
  17. '*                  无法实现不按4字节对齐，使得不得不修改MORRSLT的定义方式，能这样修改只能说运气不错，  
  18. '*                  因为被修改的部分刚好获取拼音用不到。  
  19. '*  
  20. '*  
  21. '* Histroy:  
  22. '*                  2011-09-23  
  23. '*                  ● 重写主要代码，支持多音字，提高了运行效率。  
  24. '*                  ● 取拼音首字时，ao, ai, ei, ou, er作为首字而不是原来的第一个字母。  
  25. '*                  ● 为函数增加了注音方式选择，hàn可以显示为han或han4。  
  26. '*                  ● 函数的使用与之前版本兼容，将模块中函数代码和HZ2PY类代码覆盖之前版本即可实现升级，无需修改文档中的公式。  
  27. '*                  2011-04-07  
  28. '*                  ● 更正CoTaskMemFree传递参数错误，消除了Win7等环境下崩溃。  
  29. '*                  2007-04-03  
  30. '*                  ● 更正redim时vba数组默认起始值错误。  
  31. '*                  2007-04-02  
  32. '*                  ● 最初版本，实现了由汉字获取拼音。  
  33. '*  
  34. '***************************************************************************  
  35.   
  36. Option Explicit  
  37.   
  38. Private Type GUID  
  39.     Data1 As Long  
  40.     Data2 As Integer  
  41.     Data3 As Integer  
  42.     Data4(0 To 7) As Byte  
  43. End Type  
  44.   
  45. Private Type VB_MORRSLT  
  46.     dwSize As Long          '4  
  47.     pwchOutput As Long      '4  
  48.     cchOutput As Integer    '2+(2)，VBA内存对齐闹得，折腾了好一阵才确认问题所在，唉  
  49.     Block1 As Long          '4  
  50.     pchInputPos As Long     '4  
  51.     pchOutputIdxWDD As Long '4  
  52.     pchReadIdxWDD As Long   '4  
  53.     paMonoRubyPos As Long   '4  
  54.     pWDD As Long            '4  
  55.     cWDD As Integer         '2  
  56.     pPrivate As Long        '4  
  57.     BLKBuff As Long         '4  
  58. End Type  
  59.   
  60. Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _  
  61.         (Destination As Any, Source As Any, ByVal Length As Long)  
  62.           
  63. Private Declare Function CLSIDFromString Lib "ole32.dll" _  
  64.         (ByVal lpszProgID As Long, pCLSID As GUID) As Long  
  65.           
  66. Private Declare Function CoCreateInstance Lib "ole32" ( _  
  67.         rclsid As GUID, ByVal pUnkOuter As Long, _  
  68.         ByVal dwClsContext As Long, riid As GUID, _  
  69.         ByRef ppv As Long) As Long  
  70.   
  71. Private Declare Function DispCallFunc Lib "oleaut32" _  
  72.         (ByVal pvInstance As Long, ByVal oVft As Long, _  
  73.         ByVal cc As Long, ByVal vtReturn As Integer, _  
  74.         ByVal cActuals As Long, prgvt As Integer, _  
  75.         prgpvarg As Long, pvargResult As Variant) As Long  
  76.   
  77. Private Declare Sub CoTaskMemFree Lib "ole32" (pv As Long)  
  78.   
  79. Dim MSIME_GUID As GUID          'MSIME's GUID  
  80. Dim IFELanguage_GUID As GUID    'IFELanguage's GUID  
  81. Dim IFELanguage As Long         'Pointer to IFELanguage interface  
  82. Dim PinYinArray() As String  
  83. Dim HzLen As Integer  
  84.   
  85. Dim pvSeperator As String  
  86. Dim pvUseSeperator As Boolean  
  87. Dim pvInitialOnly As Boolean  
  88. Dim pvOnlyOneChar As Boolean  
  89. Dim pvNonChnUseSep As Boolean  
  90.   
  91. Public Function GetPinYin(HzStr As String) As String  
  92.     Dim i As Integer  
  93.     Dim Py As String  
  94.     Dim IsPy As Boolean  
  95.       
  96.     GetPinYin = ""  
  97.     If IFELanguage = 0 Then  
  98.         GetPinYin = "未发现运行环境，请安装微软拼音2.0以上版本！"  
  99.         Exit Function  
  100.     End If  
  101.     If HzStr = "" Then Exit Function  
  102.     HzLen = Len(HzStr)  
  103.     Call IFELanguage_GetMorphResult(HzStr)  
  104.     For i = 1 To HzLen  
  105.         Py = PinYinArray(i)  
  106.         IsPy = Py <> ""  
  107.         If Not IsPy Then Py = Mid(HzStr, i, 1)  
  108.         If pvInitialOnly Then Py = GetInitial(Py)  
  109.         If pvOnlyOneChar Then Py = VBA.Left(Py, 1)  
  110.         GetPinYin = GetPinYin & Py & IIf(IsPy, pvSeperator, "")  
  111.     Next i  
  112.     If IsPy And pvSeperator <> "" Then GetPinYin = Left(GetPinYin, Len(GetPinYin) - 1)  
  113. End Function  
  114.   
  115. Property Get Seperator() As String  
  116.     Seperator = pvSeperator  
  117. End Property  
  118.   
  119. Property Let Seperator(Value As String)  
  120.     pvSeperator = Value  
  121. End Property  
  122.   
  123. Property Get InitialOnly() As Boolean  
  124.     UseSeperator = pvInitialOnly  
  125. End Property  
  126.   
  127. Property Let InitialOnly(Value As Boolean)  
  128.     pvInitialOnly = Value  
  129. End Property  
  130.   
  131. Property Get OnlyOneChar() As Boolean  
  132.     UseSeperator = pvOnlyOneChar  
  133. End Property  
  134.   
  135. Property Let OnlyOneChar(Value As Boolean)  
  136.     pvOnlyOneChar = Value  
  137. End Property  
  138.   
  139. Public Function AdjustPhoneticNotation(Py As String, ByVal pn As Integer) As String  
  140.     Dim i As Integer  
  141.     Dim c As String  
  142.       
  143.     If pn = -1 Then  
  144.         AdjustPhoneticNotation = Py  
  145.         Exit Function  
  146.     Else  
  147.         For i = 1 To Len(Py)  
  148.             c = VBA.Mid(Py, i, 1)  
  149.             Select Case Asc(c)  
  150.             Case VBA.Asc("ā") To VBA.Asc("à")  
  151.                 c = "a" & IIf(pn = 0, "", (VBA.Asc(c) - VBA.Asc("ā") + 1))  
  152.             Case VBA.Asc("ē") To VBA.Asc("è")  
  153.                 c = "e" & IIf(pn = 0, "", (VBA.Asc(c) - VBA.Asc("ē") + 1))  
  154.             Case VBA.Asc("ī") To VBA.Asc("ì")  
  155.                 c = "i" & IIf(pn = 0, "", (VBA.Asc(c) - VBA.Asc("ī") + 1))  
  156.             Case VBA.Asc("ō") To VBA.Asc("ò")  
  157.                 c = "o" & IIf(pn = 0, "", (VBA.Asc(c) - VBA.Asc("ō") + 1))  
  158.             Case VBA.Asc("ū") To VBA.Asc("ù")  
  159.                 c = "u" & IIf(pn = 0, "", (VBA.Asc(c) - VBA.Asc("ū") + 1))  
  160.             Case VBA.Asc("ǖ") To VBA.Asc("ǜ")  
  161.                 c = "u" & IIf(pn = 0, "", (VBA.Asc(c) - VBA.Asc("ǖ") + 1))  
  162.             Case VBA.Asc("ü")  
  163.                 c = "u"  
  164.             Case VBA.Asc("ɡ")  
  165.                 c = "g"  
  166.             End Select  
  167.             AdjustPhoneticNotation = AdjustPhoneticNotation & c  
  168.         Next i  
  169.     End If  
  170. End Function  
  171.   
  172. Private Function GetInitial(Py As String) As String  
  173.     GetInitial = VBA.Mid(Py, 1, 2)  
  174.     Select Case AdjustPhoneticNotation(GetInitial, 0)  
  175.     Case "ch", "sh", "zh", "ao", "ai", "ei", "ou", "er"  
  176.     Case Else  
  177.         GetInitial = VBA.Left(GetInitial, 1)  
  178.     End Select  
  179. End Function  
  180.   
  181. Private Function IFELanguage_GetMorphResult(HzStr As String) As String  
  182.     Dim ret As Variant  
  183.     Dim pArgs(0 To 5) As Long  
  184.     Dim vt(0 To 5) As Integer  
  185.     Dim Args(0 To 5) As Long  
  186.     Dim ResultPtr As Long  
  187.     Dim TinyM As VB_MORRSLT  
  188.     Dim Py() As Byte  
  189.     Dim i As Integer  
  190.     Dim j As Integer  
  191.     Dim PinyinIndexArray() As Integer  
  192.           
  193.     IFELanguage_GetMorphResult = ""  
  194.     If IFELanguage = 0 Then Exit Function  
  195.       
  196.     Args(0) = &H30000  
  197.     Args(1) = &H40000100  
  198.     Args(2) = Len(HzStr)  
  199.     Args(3) = StrPtr(HzStr)  
  200.     Args(4) = 0  
  201.     Args(5) = VarPtr(ResultPtr)  
  202.           
  203.     For i = 0 To 5  
  204.         vt(i) = vbLong  
  205.         pArgs(i) = VarPtr(Args(i)) - 8  
  206.     Next  
  207.       
  208.     Call DispCallFunc(IFELanguage, 20, 4, vbLong, 6, vt(0), pArgs(0), ret)  
  209.     Call MoveMemory(TinyM, ByVal ResultPtr, Len(TinyM))  
  210.   
  211.     ReDim PinyinIndexArray(0 To HzLen - 1)  
  212.     ReDim PinYinArray(1 To HzLen)  
  213.     If TinyM.cchOutput > 0 Then  
  214.         ReDim Py(0 To TinyM.cchOutput * 2 - 1)  
  215.         Call MoveMemory(Py(0), ByVal TinyM.pwchOutput, TinyM.cchOutput * 2)  
  216.         IFELanguage_GetMorphResult = Py  
  217.         Call MoveMemory(PinyinIndexArray(0), ByVal TinyM.paMonoRubyPos + 2, HzLen * 2)  
  218.         j = 0  
  219.         For i = 0 To HzLen - 1  
  220.             PinYinArray(i + 1) = VBA.Mid(IFELanguage_GetMorphResult, j + 1, PinyinIndexArray(i) - j)  
  221.             j = PinyinIndexArray(i)  
  222.         Next i  
  223.     End If  
  224.       
  225.     Call CoTaskMemFree(ByVal ResultPtr)  
  226. End Function  
  227.   
  228. Private Sub IFELanguage_Open()  
  229.     Dim ret As Variant  
  230.       
  231.     Call DispCallFunc(IFELanguage, 4, 4, vbLong, 0, 0, 0, ret)  
  232.     Call DispCallFunc(IFELanguage, 12, 4, vbLong, 0, 0, 0, ret)  
  233. End Sub  
  234.   
  235. Private Sub IFELanguage_Close()  
  236.     Dim ret As Variant  
  237.       
  238.     If IFELanguage = 0 Then Exit Sub  
  239.     Call DispCallFunc(IFELanguage, 8, 4, vbLong, 0, 0, 0, ret)  
  240.     Call DispCallFunc(IFELanguage, 16, 4, vbLong, 0, 0, 0, ret)  
  241. End Sub  
  242.   
  243. Private Function GenerateGUID()  
  244.     Dim Rlt As Long  
  245.       
  246.     'MSIME.China GUID = "{E4288337-873B-11D1-BAA0-00AA00BBB8C0}"  
  247.     Rlt = CLSIDFromString(StrPtr("MSIME.China"), MSIME_GUID)  
  248.     'IFELanguage GUID = "{019F7152-E6DB-11d0-83C3-00C04FDDB82E}"  
  249.     With IFELanguage_GUID  
  250.         .Data1 = &H19F7152  
  251.         .Data2 = &HE6DB  
  252.         .Data3 = &H11D0  
  253.         .Data4(0) = &H83  
  254.         .Data4(1) = &HC3  
  255.         .Data4(2) = &H0  
  256.         .Data4(3) = &HC0  
  257.         .Data4(4) = &H4F  
  258.         .Data4(5) = &HDD  
  259.         .Data4(6) = &HB8  
  260.         .Data4(7) = &H2E  
  261.     End With  
  262.     GenerateGUID = Rlt = 0  
  263. End Function  
  264.   
  265. Private Sub Class_Initialize()  
  266.     IFELanguage = 0  
  267.     pvSeperator = ""  
  268.     GenerateGUID  
  269.     If CoCreateInstance(MSIME_GUID, 0, 1, IFELanguage_GUID, IFELanguage) = 0 Then Call IFELanguage_Open  
  270. End Sub  
  271.   
  272. Private Sub Class_Terminate()  
  273.     If IFELanguage <> 0 Then Call IFELanguage_Close  
  274. End Sub  

8.重命名类模块为HZ2PY。

9.关闭 vb 窗口回到 Excel，输入汉字，然后在需要转成拼音的表格中输入=HzToPy(A4," ")，其中A4汉字所在位置。

注：更多使用方式下载本文附件。

作者发布页

https://club.excelhome.net/thread-229924-1-1.html

本文附件

本文密码：【iIl1o0O】 网盘链接获取地址:https://www.qishe.org/downloads.html

给TA打赏
共{{data.count}}人
人已打赏
ExcelHztoPy
经验分享

Cyber​​Panel 面板安装教程

2022-5-15 14:24:03

经验分享

杜绝电话骚扰，开启屏蔽模式，享受生活

2022-6-19 10:36:53

猜你喜欢

安装SQL数据库挂起

5184

红米3S线刷教程

0379

Steam查看账号申诉进度

04.5k
0 条回复 A文章作者 M管理员
    暂无讨论，说说你的看法吧
❯
个人中心
购物车
优惠劵
搜索

  • 扫码打开当前页

返回顶部