汉字转化为拼音

      在vb中，怎样将字段的汉字转化为拼音，规则：将每个汉字转化为拼音（大写），只是保留每个拼音的开头的字母，如果字段是小写的英文，者转化为全部大写。数字，标点者不变
不知道那位大虾知道，能不能帮帮我，能提供参考程序最好，我先在这里谢了！！！！
     例如：“成龙”转化后为："CL",
          "好人"转化后为："HR",
          "真的爱你"转化后为："ZDAN",
           "55have.b"转化后为："55HAVE.B",
           "好人"转化后为："HR",

11 个解决方案

#1

http://topic.csdn.net/u/20070728/13/140bc249-b659-47ae-ba1c-fce8c5769b19.html
http://topic.csdn.net/u/20071027/18/57567f5f-ca77-4ce6-bc60-77af278a05d6.html
上述网址有相关讨论和代码
使用yachong(蚜虫)提供的方法：
用windows自带的全拼输入法的字库比较好
运行C:\Program       Files\Windows       NT\Accessories\imegen.exe，
把C:\WINDOWS\system32\WINPY.mb逆转换为txt文件
然后再整理一下就是一个很不错的拼音库
你先运行imegen.exe，
把C:\WINDOWS\system32\WINPY.mb逆转换为txt文件
然后将WINPY.TXT文件的头部的内容：
Description]
Name=全拼
MaxCodes=12
MaxElement=1
UsedCodes=abcdefghijklmnopqrstuvwxyz
WildChar=?
NumRules=3
[Rule]
ca4=p10+p20+p30+p40
ce2=p10+p20
ce3=p10+p20+p30
[Text]
删除
把此WINPY.TXT文件导入ACCESS数据库保存与WINPY表，不设关键字，字段命名为汉字，做成字库，用VB的程序读出，代码如下：

VBScript codeOption Explicit
    Dim i As Integer
    Dim sj() As String
    Dim l As Integer
    Dim j As Integer
    Dim k As Integer
    Dim hz(7) As String * 1
    Dim py1(7) As String * 1
    Dim hz1(7) As String
    Dim PY As String
    Dim PYH(7) As String
    Dim PYHSTR As String
    Dim PYHSTR1 As String
    Dim strData() As String
    Dim data As String
Private Sub Command2_Click()
    Text2 = ""
    PYHSTR1 = ""
    PYHSTR = ""
    ReDim strData(Len(Text1))
    For k = 0 To Len(Text1) - 1
        strData(k) = Mid(Text1, k + 1, 1)
        If Asc(strData(k)) < 0 Then
            data = strData(k)
            hzzh
            PYHSTR1 = PYHSTR1 + PYHSTR
        Else
            PYHSTR1 = PYHSTR1 + strData(k)
        End If
    Next
    Text2 = PYHSTR1
End Sub

Private Sub Form_Load()
    Text2 = ""
    Text1 = ""
End Sub

Public Function hzz()
    Dim k As Integer
    Dim l As Integer
    l = Len(PYH(j))
    For k = 1 To l
        hz1(k) = Mid(PYH(j), k, 1)
        If hz1(k) = "A" Or hz1(k) = "I" Or hz1(k) = "E" Or hz1(k) = "V" Or hz1(k) = "U" Or hz1(k) = "O" Then
            If k = 1 Then
                hz1(k) = Mid(PYH(j), 1, k)
            Else
                hz1(k) = Mid(PYH(j), 1, k - 1)
            End If
            Exit For
        End If
    Next
    py1(j) = hz1(k)
End Function

Public Sub hzzh() '汉字取声母
    PYHSTR = ""
    For j = 1 To Len(data)
    hz(j) = Mid(data, j, 1)
    Adodc1.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\db8.mdb;Persist Security Info=False"
    Adodc1.RecordSource = "select * from winpy where 汉字 like '" & hz(j) & "%'"
    Adodc1.Refresh
    If Adodc1.Recordset.RecordCount > 0 Then
        l = Len(Adodc1.Recordset(0))
        ReDim sj(l)
        For i = 1 To l
            sj(i) = Mid(Adodc1.Recordset(0), i, 1)
            If Asc(sj(i)) > 0 Then
                PY = UCase(Mid(Adodc1.Recordset(0), i, l - i + 1))
                Exit For
            End If
        Next
    End If
    PYH(j) = PY
    Next j
    For j = 1 To Len(data)
        hzz
        PYHSTR = PYHSTR + py1(j)
    Next
End Sub

#2

在家里收藏有 xmxoxo 的一个获取中文第一个拼音的程序应用这个应该可以解决楼主的问题

下面我先说下思路!

星期天晚上若还没能解决这个我再贴出那个程序的例题 (星期天晚上在家..)

思路是循环所有字符串

循环内的代码主要解决

把所有的中文都转换为拼音
把所有的字符都加上Ucase() 转换函数转换为大写

问题就这样解决了...

#3

自己用的一段

Public   Function   HzToSpell(Hz   As   String)   As   String   '生成简拚 

        Dim   slen,   xx   As   Integer 

        Dim   high,   low,   i   As   Long 

        Dim   Ss1,   Ss2   As   String 

        Ss2   =   Hz 

        slen   =   Len(Ss2) 

        If   slen   =   0   Then 

                HzToSpell   =   "" 

                Exit   Function 

        End   If 

        For   xx   =   1   To   slen 

                        i   =   65535   +   Asc(Mid(Hz,   xx))   +   1 

                        If   i   > =   45217   And   i   <   45253   Then 

                                Ss1   =   Ss1   +   "A" 

                        End   If 

                        If   i   > =   45253   And   i   <   45761   Then 

                                Ss1   =   Ss1   +   "B" 

                        End   If 

                        If   i   > =   45761   And   i   <   46318   Then 

                                Ss1   =   Ss1   +   "C" 

                        End   If 

                        If   i   > =   46318   And   i   <   46826   Then 

                                Ss1   =   Ss1   +   "D" 

                        End   If 

                        If   i   > =   46826   And   i   <   47010   Then 

                                Ss1   =   Ss1   +   "E" 

                        End   If 

                        If   i   > =   47010   And   i   <   47297   Then 

                                Ss1   =   Ss1   +   "F" 

                        End   If 

                        If   i   > =   47297   And   i   <   47614   Then 

                                Ss1   =   Ss1   +   "G" 

                        End   If 

                        If   i   > =   47614   And   i   <   48119   Then 

                                Ss1   =   Ss1   +   "H" 

                        End   If 

                        If   i   > =   48119   And   i   <   49062   Then 

                                Ss1   =   Ss1   +   "J" 

                        End   If 

                        If   i   > =   49062   And   i   <   49324   Then 

                                Ss1   =   Ss1   +   "K" 

                        End   If 

                        If   i   > =   49324   And   i   <   49896   Then 

                                Ss1   =   Ss1   +   "L" 

                        End   If 

                        If   i   > =   49896   And   i   <   50371   Then 

                                Ss1   =   Ss1   +   "M" 

                        End   If 

                        If   i   > =   50371   And   i   <   50614   Then 

                                Ss1   =   Ss1   +   "N" 

                        End   If 

                        If   i   > =   50614   And   i   <   50622   Then 

                                Ss1   =   Ss1   +   "O" 

                        End   If 

                        If   i   > =   50622   And   i   <   50906   Then 

                                Ss1   =   Ss1   +   "P" 

                        End   If 

                        If   i   > =   50906   And   i   <   51387   Then 

                                Ss1   =   Ss1   +   "Q" 

                        End   If 

                        If   i   > =   51387   And   i   <   51446   Then 

                                Ss1   =   Ss1   +   "R" 

                        End   If 

                        If   i   > =   51446   And   i   <   52218   Then 

                                Ss1   =   Ss1   +   "S" 

                        End   If 

                        If   i   > =   52218   And   i   <   52698   Then 

                                Ss1   =   Ss1   +   "T" 

                        End   If 

                        If   i   > =   52698   And   i   <   52980   Then 

                                Ss1   =   Ss1   +   "W" 

                        End   If 

                        If   i   > =   52980   And   i   <   53689   Then 

                                Ss1   =   Ss1   +   "X" 

                        End   If 

                        If   i   > =   53689   And   i   <   54481   Then 

                                Ss1   =   Ss1   +   "Y" 

                        End   If 

                        If   i   > =   54481   And   i   <   55290   Then 

                                Ss1   =   Ss1   +   "Z" 

                        End   If 

                        If   (Asc(Mid(Hz,   xx))   > =   97   And   Asc(Mid(Hz,   xx))   <=   122)   Or   (Asc(Mid(Hz,   xx))   > =   65   And   Asc(Mid(Hz,   xx))   <=   90)   Then 

                                Ss1   =   Ss1   +   Mid(Hz,   xx,   1) 

                        End   If 

        Next 

        HzToSpell   =   Ss1 

End   Function

#4

我也想知道多音字是如何处理的

#5

Option Explicit

Dim col As New Collection


Private Sub Command1_Click()

Dim str1 As String, ascii As Integer, i As Integer

Dim j As Integer

str1 = Text1.Text

For j = 1 To Len(str1)

    ascii = Asc(Mid(str1, j, 1))

    If ascii < Asc(Left(col.Item(1), 1)) Then

        'Debug.Print "不是简体汉字"

    ElseIf ascii >= Asc("匝") And ascii <= Asc("座") Then

       Debug.Print "Z";

    ElseIf ascii > Asc("座") Then

       ' Debug.Print "不是简体汉字"

    Else

        For i = 1 To col.Count - 1

            If ascii >= Asc(Left(col.Item(i), 1)) And ascii < Asc(Left(col.Item(i + 1), 1)) Then

                Debug.Print Right(col.Item(i), 1);

            End If

        Next i

    End If


Next j

Debug.Print

End Sub


Private Sub Form_Load()

col.Add "啊:A"

col.Add "芭:B"

col.Add "擦:C"

col.Add "搭:D"

col.Add "蛾:E"

col.Add "发:F"

col.Add "噶:G"

col.Add "哈:H"

col.Add "击:J"

col.Add "喀:K"

col.Add "垃:L"

col.Add "妈:M"

col.Add "拿:N"

col.Add "哦:O"

col.Add "啪:P"

col.Add "期:Q"

col.Add "然:R"

col.Add "撒:S"

col.Add "塌:T"

col.Add "挖:W"

col.Add "昔:X"

col.Add "压:Y"

col.Add "匝:Z"

End Sub

以前写过一个

#6

我先研究下,

#7

收藏了

#8

新问题出现了，为什么在调试的时候，有的能转化，有的不可以呢？
如，“怡”“媛”，“婷”。。。就转化不了，是怎么会事，高手帮忙啊？
Function getpychar(char) As String  '拼音转化
    On Error Resume Next
    Dim tmp As String, vs1 As String

    If Asc(char) >= 0 And Asc(char) <= 127 Then
        If char >= "a" And char <= "z" Then
            getpychar = Chr(Asc(char) - 32)
        ElseIf Asc(char) >= 48 And Asc(char) <= 57 Then
               getpychar = char
        ElseIf char >= "A" And char <= "Z" Then
            getpychar = char
        Else
            If Asc(char) = 32 Then
               getpychar = " "
            Else
              getpychar = ""
            End If
        End If
    Else
        tmp = 65536 + Asc(char)
        Select Case tmp
            Case 45217 To 45252: getpychar = "A"
            Case 45253 To 45760: getpychar = "B"
            Case 45761 To 46317: getpychar = "C"
            Case 46318 To 46825: getpychar = "D"
            Case 46826 To 47009: getpychar = "E"
            Case 47010 To 47296: getpychar = "F"
            Case 47297 To 47613: getpychar = "G"
            Case 47614 To 48118: getpychar = "H"
            Case 48119 To 49061: getpychar = "J"
            Case 49062 To 49323: getpychar = "K"
            Case 49324 To 49895: getpychar = "L"
            Case 49896 To 50370: getpychar = "M"
            Case 50371 To 50613: getpychar = "N"
            Case 50614 To 50621: getpychar = "O"
            Case 50622 To 50905: getpychar = "P"
            Case 50906 To 51386: getpychar = "Q"
            Case 51387 To 51445: getpychar = "R"
            Case 51446 To 52217: getpychar = "S"
            Case 52218 To 52697: getpychar = "T"
            Case 52698 To 52979: getpychar = "W"
            Case 52980 To 53688: getpychar = "X"
            Case 53689 To 54480: getpychar = "Y"
            Case 54481 To 55289: getpychar = "Z"
            Case Else: getpychar = char


        End Select
    End If
End Function

Function getpy(str)
    Dim i As Long
    For i = 1 To Len(str)
        getpy = getpy & getpychar(Mid(str, i, 1))
    Next i
End Function

Private Sub Text2_Change()
Text3.Text = getpy(Text2.Text)
Text4.Text = Len(Text2.Text)
End Sub

#9

“怡”“媛”，“婷”这些字简体和繁体形式一样，内码不在一般简体范围内，所以要用一个既能转简体又能转繁体的

#10

谁能帮我写既能转简体又能转繁体的程序？先谢了

#11

这个转换程序，和其他好多转换程序都不正确，很多字不在条件范围内而不能得到声母，比如“浏览”中的“浏”字就得不到啊。

#1

#2

#3