非常强大的汉字转拼音的类（带音调）

今天学习了一下这个类，学到了不少东西。贴出来收藏

追加解释：类的代码一定要写在类模块中，类模块的名称为HZ2PY。调用代码写在一般模块中，切记切记，不能写在一个模块里。

另：32位win7+office2010环境下会有些问题，跟自带输入法有关，原因待查，但XP下肯定可以使用。

'*************************************************************************** '* '* MODULE NAME: HzToPy '* AUTHOR & DATE: tt.t '* 03 Apirl 2007 '* '* DESCRIPTION: 将中文字符串转换为拼音，就这些～ '* 有汉字得到拼音其实并不是我很关心的一个问题，只是发现已经公开 '* 的方法有很大的缺陷，但WORD却做得很好，因此才尝试解决这个问题。 '* 过程比我预期的要曲折的多，主要是VBA实在是一种很受限制的语言。 '* 不过好在有Google和Olldbg，难题也仅仅是如何找到绕过限制的途径， '* 终于在5个小时内搞定了一切～ '* 时间比我预计的长了很多，因为我实在是不了解VBA，也不很熟悉OLE:"( '* 不过好在一切都解决了～～终于从VBA小白成长了一些。 '* 其实VBA也是很强大的～ '* '* Theory：废话了好多还是说说原理吧，虽然不是每个人都很关心～ '* WORD的拼音向导能够将汉字转成拼音全是倚仗微软拼音的帮助， '* 微软拼音2.0以上版本都提供了汉字到拼音的转换功能。 '* 微软拼音MSIME.China类中的IFELanguage接口具体实现了转换功能 '* 不过MSIME.China中没有提供IDispatch接口，VBA的CreateObject不支持 '* 调用这样的类，因此我们只好手工调用。CoCreateInstance可以创建类 '* 并获取IFELanguage接口，但我们无法直接调用，因为VBA不知道如何调用 '* IFELanguage接口的Method。这里困扰了我好久，原本希望能向其他语言那样 '* 声明接口结构，但VBA并不支持。万般无奈下只好在OLE相关DLL中寻找，期待能 '* 找到代理函数简介调用接口的Method。呵呵～功夫不负苦心人终于在OLEAUT32中 '* 找到了DispCallfunc。Google了一下，果然是我需要的。接口知道了，如何调用也 '* 清楚了，剩下的问题就是如何取得转换后的结果。IFELanguage.GetMorphResult会将 '* 转换的结果存在一个叫做tagMORRSLT的结构中，并返回指向tagMORRSLT的指针。 '* 新问题又来了，VBA不支持指针...sigh，为什么其他语言很容易实现的功能VBA用起来 '* 就这么烦呢～幸好VBA读取内存的限制也好突破，只需调用ntdll的RtlMoveMemory。 '* 好了～一切限制都已解除，HzToPy终于正常工作了～～ '* 说起来一切顺理成章，可是寻找解决方法的过程真的很痛苦，不过VBA经验值大涨也算有所收获。 '* 下面就让代码来说话吧。 '* '* Memo: 改成类了，加入了拼音间加入分隔符和去掉注音的功能，请参照“模块1”中的例子，用起来很简单：） '* 更正了一个错误，redim时vba数组默认起始搞错了 '* '***************************************************************************Option ExplicitPublic Enum PhoneticNotationpnDefault = 0pnNoNotation = 1 End EnumPrivate Type GUIDData1 As LongData2 As IntegerData3 As IntegerData4(0 To 7) As Byte End TypePrivate Type TinyMORRSLTdwSize As LongpwchOutput As LongcchOutput As Integer End TypePrivate 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 LongPrivate 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 LongPrivate 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 dNotationDim pvSeperator As String Dim pvUseSeperator As Boolean Dim pvInitialOnly As Boolean Dim pvOnlyOneChar As BooleanPrivate 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 SubPrivate 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) = &HC0End 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) = &H2EEnd WithEnd SubPrivate Sub IFELanguage_Open()Dim ret As VariantDispCallFunc IFELanguage, 4, 4, vbLong, 0, 0, 0, retDispCallFunc IFELanguage, 12, 4, vbLong, 0, 0, 0, ret End SubPrivate Sub IFELanguage_Close()Dim ret As VariantIf IFELanguage = 0 Then Exit SubDispCallFunc IFELanguage, 8, 4, vbLong, 0, 0, 0, retDispCallFunc 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时的错误 ''' Private Function IFELanguage_GetMorphResult(HzStr As String) As StringDim ret As VariantDim pArgs(0 To 5) As LongDim vt(0 To 5) As IntegerDim Args(0 To 5) As LongDim ResultPtr As LongDim TinyM As TinyMORRSLTDim py() As ByteDim i As IntegerIFELanguage_GetMorphResult = ""If IFELanguage = 0 Then Exit FunctionArgs(0) = &H30000Args(1) = &H40000100Args(2) = Len(HzStr)Args(3) = StrPtr(HzStr)Args(4) = 0Args(5) = VarPtr(ResultPtr)For i = 0 To 5vt(i) = vbLongpArgs(i) = VarPtr(Args(i)) - 8NextDispCallFunc IFELanguage, 20, 4, vbLong, 6, vt(0), pArgs(0), retMoveMemory TinyM, ByVal ResultPtr, 4 * 3If TinyM.cchOutput > 0 ThenReDim py(0 To TinyM.cchOutput * 2 - 1)MoveMemory py(0), ByVal TinyM.pwchOutput, TinyM.cchOutput * 2IFELanguage_GetMorphResult = pyEnd IfCoTaskMemFree (ResultPtr) End FunctionPrivate Function GetInitial(py As String) As StringDim Char1 As StringDim Char2 As StringChar1 = Left(py, 1)Char2 = Mid(py, 2, 1)GetInitial = Char1If Not pvOnlyOneChar ThenSelect Case Char1Case "z", "c", "s"If Char2 = "h" Then GetInitial = GetInitial + Char2End SelectEnd IfEnd Function'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''' Subroutine: GetPinYin ''' ''' Purpose: 返回汉字的拼音 ''' ''' Arguments: HzStr - 待转换的拼音 ''' ''' ''' Date Developer Action ''' -------------------------------------------------------------------------- ''' 02 April 2007 tt.t Create ''' Public Function GetPinYin(HzStr As String) As StringDim i As IntegerDim tmpStr As StringGetPinYin = ""If HzStr <> "" ThenIf pvUseSeperator Or pvInitialOnly ThenFor i = 1 To Len(HzStr)tmpStr = IFELanguage_GetMorphResult(Mid(HzStr, i, 1))If tmpStr <> "" ThenIf pvInitialOnly ThenGetPinYin = GetPinYin & GetInitial(tmpStr) & pvSeperatorElseGetPinYin = GetPinYin & tmpStr & pvSeperatorEnd IfEnd IfNextIf Len(GetPinYin) > 0 Then GetPinYin = Left(GetPinYin, Len(GetPinYin) - 1)ElseGetPinYin = IFELanguage_GetMorphResult(HzStr)End IfEnd If End FunctionPublic Function AdjustPhoneticNotation(hz As String, pn As PhoneticNotation) As StringDim i As IntegerAdjustPhoneticNotation = hz'未进行优化Select Case pnCase pnNoNotationFor i = LBound(dNotation) To UBound(dNotation)AdjustPhoneticNotation = Replace(AdjustPhoneticNotation, sNotation1(i), dNotation(i))NextFor i = LBound(dNotation) To UBound(dNotation)AdjustPhoneticNotation = Replace(AdjustPhoneticNotation, sNotation2(i), dNotation(i))NextEnd Select End FunctionPrivate Sub Class_Initialize()IFELanguage = 0InitalArrayInitialOnly = FalseGenGUIDIf CoCreateInstance(MSIME_GUID, 0, 1, _IFELanguage_GUID, IFELanguage) = 0 ThenIFELanguage_OpenpvUseSeperator = FalsepvSeperator = " "ElseErr.Raise "OLE error!!"End If End SubPrivate Sub Class_Terminate()If IFELanguage <> 0 Then IFELanguage_Close End SubProperty Get Seperator() As StringSeperator = pvSeperator End PropertyProperty Let Seperator(Value As String)pvSeperator = Value End PropertyProperty Get UseSeperator() As BooleanUseSeperator = pvUseSeperator End PropertyProperty Let UseSeperator(Value As Boolean)pvUseSeperator = Value End PropertyProperty Get InitialOnly() As BooleanUseSeperator = pvInitialOnly End PropertyProperty Let InitialOnly(Value As Boolean)pvInitialOnly = Value End PropertyProperty Get OnlyOneChar() As BooleanUseSeperator = pvOnlyOneChar End PropertyProperty 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 StringDim hp As HZ2PYSet hp = New HZ2PY '创建类If Sep <> "" Thenhp.Seperator = Sephp.UseSeperator = TrueEnd Ifhp.InitialOnly = ShowInitialOnlyhp.OnlyOneChar = ShowOnlyOneCharHzToPy = hp.GetPinYin(hz)If Not ShowNotation Then HzToPy = hp.AdjustPhoneticNotation(HzToPy, pnNoNotation)Set hp = Nothing '释放类End Function

非常强大的汉字转拼音的类（带音调）相关推荐

汉字转拼音（不带音调）
[JS 版本] 实现原理:直接弄一字库,汉字后面紧接着对应的拼音,把要转换的字符串逐字跟字库匹配,如果不是汉字直接返回,如果是汉字,查找字库返回相应的拼音. <script> var py ...
php 汉字转拼音类,PHP汉字转换拼音的类_php
网络上类似的代码大多只能在gb2312编码下使用,下面这个类同时能在utf-8编码下将汉字转换为拼音,具体的代码和用法如下: function Pinyin($_String, $_Code='gb2 ...
Java汉字转换拼音工具类
1. 使用pinyin4j 1.1 引入相关maven依赖 <dependency><groupId>com.belerweb</groupId><artif ...
汉字转拼音(工具类)
2019独角兽企业重金招聘Python工程师标准>>> package com.qst.tesc.course.web.rest.util; import java.io.Unsup ...
Java汉字转为拼音工具类
依赖文件 <dependency><gr ...
汉字转拼音工具类，依赖Pinyin4J
汉字转拼音工具类,依赖Pinyin4J Maven 坐标 <dependency><groupId>com.belerweb</groupId><artifa ...
java汉字转拼音工具类源代码
原文:java汉字转拼音工具类源代码源代码下载地址:http://www.zuidaima.com/share/1550463387880448.htm 汉字转拼音 Pinyin pinyin = ...
汉字转拼音 java_Java汉字转拼音工具类完整代码实例
添加依赖 com.belerweb pinyin4j 2.5.1 工具类代码: public class PinYinUtils { public static HanyuPinyinOutputFo ...
中文汉字转换拼音PHP类
1 <?php 2 /** 3 * 中文汉字转换拼音类 4 * 功能支持 5 * 1.支持中文转换全拼 6 * 2.支持中文转换简拼(首字母) 7 * 3.支持转换的字符串返回格式设置(字符中间 ...

非常强大的汉字转拼音的类（带音调）

非常强大的汉字转拼音的类（带音调）相关推荐

最新文章

热门文章