当前位置:编程学习 > VB >>

VB6源码 汉转拼-决对ok


VB6源码 汉转拼-决对ok
这上面看看,本人感觉不错,里面有好多源码,有兴趣的朋友去看看吧,http://2e3.org/ --------------------编程问答-------------------- MARK --------------------编程问答-------------------- 支持一下lz,感谢分享


--------------------编程问答-------------------- 多音字能处理好吗? --------------------编程问答-------------------- 汉字拼音对照表 拼音汉字对照表 支持GBK同音字  
http://download.csdn.net/source/1675950 --------------------编程问答--------------------
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          '创建类
    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            '释放类

End Function

'***************************************************************************
'*
'* 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 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 inte易做图ce
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时的错误
'''
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
    '未进行优化
    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



--------------------编程问答--------------------
引用 6 楼 zhao4zhong1 的回复:
VB code
接上帖''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Subroutine: GetPinYin
'''
''' Purpose:    返回汉字的拼音
'''
''' Arguments:  HzStr - 待转换的拼音……


你有测试吗?在英文系统中报告“OLE error”。我的英文系统是Win7,装有MS Pinyin。 --------------------编程问答--------------------
引用 7 楼 vbadvisor 的回复:
引用 6 楼 zhao4zhong1 的回复:

VB code
接上帖''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Subroutine: GetPinYin
'''
''' Purpose: 返回汉字的拼音
'''
''
……
你有测试吗?在英文系统中报告“OLE error”。我的英文系统是Win7,装有MS Pinyin。

'AUTHOR & DATE:   tt.t & 03 Apirl 2007
作者不是我。我也没测试过。 --------------------编程问答-------------------- 缪显示的是miu,希望显示miao.请解决。 --------------------编程问答-------------------- 汉转音这块,我采用最笨的方法,
将微软拼音的字库转出来,存为表。

然后就是数据库检索,提示多音字组合,
可以设置一些其他属性,比如:是否是姓等。
补充:VB ,  网络编程
CopyRight © 2022 站长资源库 编程知识问答 zzzyk.com All Rights Reserved
部分文章来自网络,