如何获得输入汉字的拼音缩写？

这里有：
http://www.egooglet.com/static_html/200511072108063740admin.html

中文acs码就是根据拼音来排序的~

先把26个字母分别对应的头个汉字找出来,有23个汉字,他们的ASC码值是依次排列的.
拿你要求的汉字的ASC码和这23个汉字的ASC码进行比较,便能知道它的拼音的第一个字母的位置.这23个汉字是:
啊,芭,擦,搭,蛾,发,噶,哈,击,喀,垃,妈,拿,哦,啪,期,然,撒,塌,挖,昔,压,匝
A ,B ,C ,D ,E ,F ,G ,H ,J ,K ,L ,M ,N ,O ,P ,Q ,R ,S ,T ,W ,X ,Y ,Z

根据QQstone说法写的代码，只对简体有用
Dim col As New CollectionPrivate 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 IfNext j
Debug.Print
End SubPrivate 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

什么简体、繁体……统统搞定！
http://smallfairy.51.net/KiteGirl/PYGet.htm

Option Explicit
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 char >= "A" And char <= "Z" Then
            getpychar = char
        Else
            '如果是空格，排除
            If Asc(char) = 32 Then
               getpychar = ""
            Else
            '
                getpychar = char
            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 53640: getpychar = "X"
            Case 53689 To 54480: getpychar = "Y"
            Case 54481 To 55289: getpychar = "Z"
            Case Else: getpychar = "%"
        End Select
    End If
End FunctionFunction getpy(str)
Dim i As Long
    For i = 1 To Len(str)
        getpy = getpy & getpychar(Mid(str, i, 1))
    Next i
End Function

再在第一个文本框的键盘按下事件中调用上述函数getpy

楼上的函数对如下汉字是无能为力的，而且，实际上有很多这样的汉字。
“蓓葆芙霏琛晖昊瑾颉菁霁姣轲琨珑璐岚蔺靓闵霈菁琪祺樵麒晟佘嵩韬婷覃霆炜玮雯璇庠鑫曦轶赟闫滢瑜毓嫣煜烨晏瑛谌陟璋”
我的全部简体汉字拼音首字母解决方案：
clsHPY.cls文件
Option Explicit
Private secTable As String
Public Function getPY(Optional ByVal s As String = "") As String
    Dim t1 As String
    Dim a As Integer
    If Len(s) = 0 Then Exit Function
    a = Asc(s)
    If a < 0 Then

            If a > &HB0A0 And a < &HB0C5 Then
                getPY = "a"
                Exit Function
            End If

            If a < &HB2C1 Then
                getPY = "b"
                Exit Function
            End If

            If a < &HB4EE Then
                getPY = "c"
                Exit Function
            End If

            If a < &HB6EA Then
                getPY = "d"
                Exit Function
            End If
            If a < &HB7A2 Then
                getPY = "e"
                Exit Function
            End If
            If a < &HB8C1 Then
                getPY = "f"
                Exit Function
            End If
            If a < &HB9FE Then
                getPY = "g"
                Exit Function
            End If
            If a < &HBBF7 Then
                getPY = "h"
                Exit Function
            End If
            If a < &HBFA6 Then
                getPY = "j"
                Exit Function
            End If
            If a < &HC0AC Then
                getPY = "k"
                Exit Function
            End If
            If a < &HC2E8 Then
                getPY = "l"
                Exit Function
            End If
            If a < &HC4C3 Then
                getPY = "m"
                Exit Function
            End If
            If a < &HC5B6 Then
                getPY = "n"
                Exit Function
            End If
            If a < &HC5BE Then
                getPY = "o"
                Exit Function
            End If
            If a < &HC6DA Then
                getPY = "p"
                Exit Function
            End If
            If a < &HC8BB Then
                getPY = "q"
                Exit Function
            End If
            If a < &HC8F6 Then
                getPY = "r"
                Exit Function
            End If
            If a < &HCBFA Then
                getPY = "s"
                Exit Function
            End If
            If a < &HCDDA Then
                getPY = "t"
                Exit Function
            End If
            If a < &HCEF4 Then
                getPY = "w"
                Exit Function
            End If
            If a < &HD1B9 Then
                getPY = "x"
                Exit Function
            End If
            If a < &HD4D1 Then
                getPY = "y"
                Exit Function
            End If
            If a < &HD7FA Then
                getPY = "z"
                Exit Function
            End If

            getPY = getSecPy(s)

    Else
        getPY = LCase(s)
    End If

End Function
Private Function getSecPy(ByVal Hz As String) As String
    Dim c As String
    Dim Q As Integer, W As Integer, tabPos As Integer
    'If Asc(Hz) >= 0 Then Exit Function
    Hz = Hex(Asc(Hz))
    Q = CDec("&H" & Left(Hz, 2)) - 160
    W = CDec("&H" & Right(Hz, 2)) - 160
    '在secTable中的位置
    tabPos = (Q - 56) * 94 + W
    If tabPos > 3008 Then Exit Function
    getSecPy = LCase(Mid(secTable, tabPos, 1))
End FunctionPrivate Sub Class_Initialize()
    secTable = "CJWGNSPGCGNESYPBTYYZDXYKYGTDJNNJQMBSGZSCYJSYYQPGKBZGYCYWJKGKLJYWKPJQHYTWDDZLSYMRYPYWWCCKZNKYYGTTNGJ"
    secTable = secTable & "EYKKZYTCJNMCYLQLYPYSFQRPZSLWBTGKJFYXJWZLTBNCXJJJJTXDTTSQZYCDXXHGCKBPHFFSSWYBGMXLPBYLLLHLXSPZMYJHSOJN"
    secTable = secTable & "GHDZQYKLGJHSGQZHXQGKEZZWYSCSCJXYEYXADZPMDSSMZJZQJYZCDJZWQJBDZBXGZNZCPWHWXHQKMWFBPBYDTJZZKQXYLYGXFPTY"
    secTable = secTable & "JYYZPSZLFCHMQSHGMXXSXJJSDCSBBQBEFSJYHXWGZKPYLQBGLDLCDTNMAYDDKSSNGYCSGXLYZAYPNPTSDKDYLHGYMYLCXPYCJNDQ"
    secTable = secTable & "JWXQXFYYFJLEJPZRXCCQWQQSBZKYMGPLBMJRQCFLNYMYQMTQYRBCJTHZTQFRXQHXMQJCJLYXGJMSHZKBSWYEMYLTXFSYDSGLYCJQ"
    secTable = secTable & "XSJNQBSCTYHBFTDCYZDJWYGHQFSXWCKQKXEBPTLPXJZSRMEBWHJLBJSLYYSMDXLCLQKXLHXJRZJMFQHXHWYWSBHTRXXGLHQHFNMN"
    secTable = secTable & "YKLDYXZPYLGGTMTCFPNJJZYLJTYANJGBJPLQGDZYQYAXBKYSECJSZNSLYZHZXLZCGHPXZHZNYTDSBCJKDLZ?YFMYTLEBBGQYZKGG"
    secTable = secTable & "LDNDNYSKJSHDLYXBCGHXYPKDJMMZNGMMCLGEZSZXZJFZNMLZZTHCSYDBDLLSCZDNLKJYKJSYCJLKWHQASDKNHCSGAEHDAASHTCPL"
    secTable = secTable & "CPQYBSDMPJLPCJOQLCDHJXYSPRCHNWJNLHLYYQYHWZPTCZGWWMZFFJQQQQYXACLBHKDJXDGMMYDQXZLLSYGXGKJRYWZWYCLZMSSJ"
    secTable = secTable & "ZLDBYDCPCXYHLXCHYZJQSFQAGMNYXPFRKSSBJLYXYSYGLNSCMHCWWMNZJJLXXHCHSYDSTTXRYCYXBYHCSMXJSZNPWGPXXTAYBGAJ"
    secTable = secTable & "CXLYSDCCWZOCWKCCSBNHCPDYZNFCYYTYCKXKYBSQKKYTQQXFCWCHCYKELZQBSQYJQCCLMTHSYWHMKTLKJLYCXWHEQQHTQKZPQSQS"
    secTable = secTable & "CFYMMDMGBWHWLGSLLYSDLMLXPTHMJHWLJZYHZJXHTXJLHXRSWLWZJCBXMHZQXSDZPMGFCSGLSXYMQSHXPJXWMYQKSMYPLRTHBXFT"
    secTable = secTable & "PMHYXLCHLHLZYLXGSSSSTCLSLDCLRPBHZHXYYFHBBGDMYCNQQWLQHJJZYWJZYEJJDHPBLQXTQKWHLCHQXAGTLXLJXMSLXHTZKZJE"
    secTable = secTable & "CXJCJNMFBYCSFYWYBJZGNYSDZSQYRSLJPCLPWXSDWEJBJCBCNAYTWGMPAPCLYQPCLZXSBNMSGGFNZJJBZSFZYNTXHPLQKZCZWALS"
    secTable = secTable & "BCCJXJYZGWKYPSGXFZFCDKHJGXTLQFSGDSLQWZKXTMHSBGZMJZRGLYJBPMLMSXLZJQQHZYJCZYDJWBMJKLDDPMJEGXYHYLXHLQYQ"
    secTable = secTable & "HKYCWCJMYYXNATJHYCCXZPCQLBZWWYTWSQCMLPMYRJCCCXFPZNZZLJPLXXYZTZLGDLTCKLYRZZGQTKJHHGJLJAXFGFJZSLCFDQZL"
    secTable = secTable & "CLGJDJCSNZLLJPJQDCCLCJXMYZFTSXGCGSBRZXJQQCTZHGYQTJQQLZXJYLYLBCYAMCSTYLPDJBYREGKLZYZHLYSZQLZNWCZCLLWJ"
    secTable = secTable & "QJJJKDGJZOLBBZPPGLGHTGZXYGHZMYCNQSYCYHBHGXKAMTXYXNBSKYZZGJZLQJDFCJXDYGJQJJPMGWGJJJPKQSBGBMMCJSSCLPQP"
    secTable = secTable & "DXCDYYKYFCJDDYYGYWRHJRTGZNYQLDKLJSZZGZQZJGDYKSHPZMTLCPWNJYFYZDJCNMWESCYGLBTZCGMSSLLYXYSXXBSJSBBSGGHF"
    secTable = secTable & "JLYPMZJNLYYWDQSHZXTYYWHMCYHYWDBXBTLMSYYYFSXJCSTXXLHJHFSSXZQHFZMZCZTQCXZXRTTDJHNNYZQQMTQDMMGYYTXMJGDH"
    secTable = secTable & "CDYZBFFALLZTDLTFXMXQZDNGWQDBDCZJDXBZGSQQDDJCMBKZFFXMKDMDSYYSZCMLJDSYNSPRSKMKMPCKLGDBQTFZSWTFGGLYPLLJ"
    secTable = secTable & "ZHGJJGYPZLTCSMCNBTJBQFKTHPYZGKPBBYMTDSSXTBNPDKLEYCJNYCDYKZDDHQHSDZSCTARLLTKZLGECLLKJLQJAQNBDKKGHPJTZ"
    secTable = secTable & "QKSECSHALQFMMGJNLYJBBTMLYZXDCJPLDLPCQDHZYCBZSCZBZMSLJFLKRZJSNFRGJHXPDHYJYBZGDLQCSEZGXLBLHYXTWMABCHEC"
    secTable = secTable & "MWYJYZLLJJYHLGBDJLSLYGKDZPZXJYYZLWCXSZFGWYYDLYHCLJSCMBJHBLYZLYCBLYDPDQYSXQZBYTDKYXJYYCNRJMPDQGKLCLJB"
    secTable = secTable & "CTBJDDBBLBLCZQRPSXJCJLZCSHLTOLJNMDDDLNGKATHQHJHYKHEZNMSHRPHQQJCHGMFPRXHJGDYCHGKLYRZQLCYQJNZSQTKQJYMS"
    secTable = secTable & "ZSWLCFQQQXYFGGYPTQWLMCRNFKKFSYYLQBMQAMMMYXCTPSHCPTXXZZSMPHPSHMCLMLDQFYQXSZYJDJJZZHQPDSZGLSTJBCKBXYQZ"
    secTable = secTable & "JSGPSXQZQZRQTBDKYXZKHHGFLBCSMDLDGDZDBLZYYCXNNCSYBZBFGLZZXSWMSCCMQNJQSBDQSJTXXMBLTXCCLZSHZCXRQJGJYLXZ"
    secTable = secTable & "FJPHYMZQQYDFQJQLZZNZJCDGZYGZTXMZYSCTLKPHTXHTLBJXJLXSCDQXCBBTJFQZFSLTJBTKQBXXJJLJCHCZDBZJDCZJDCPRNPQC"
    secTable = secTable & "JPFCZLCLZXZDMXMPHJSGZGSZZQLYLWTJPFSYAXMCJBTZYYCWMYTZSJJLQCQLWZMALBXYFBPNLSFHTGJWEJJXXGLLJSTGSHJQLZFK"
    secTable = secTable & "CGNNDSZFDEQFHBSAQTGYLBXMMYGSZLDYDQMJJRGBJTKGDHGKBLQKBDMBYLXWCXYTTYBKMRTJZXQJBHLMHMJJZMQASLDCYXYQDLQCAFYWYXQHZ"End Sub

Public Function py(mystr As String) As String
  If Asc(mystr) < 0 Then
    If Asc(Left(mystr, 1)) < Asc("啊") Then
       py = "0"
       Exit Function
    End If
    If Asc(Left(mystr, 1)) >= Asc("啊") And Asc(Left(mystr, 1)) < Asc("芭") Then
       py = "A"
       Exit Function
    End If
    If Asc(Left(mystr, 1)) >= Asc("芭") And Asc(Left(mystr, 1)) < Asc("擦") Then
       py = "B"
       Exit Function
    End If
    If Asc(Left(mystr, 1)) >= Asc("擦") And Asc(Left(mystr, 1)) < Asc("搭") Then
       py = "C"
       Exit Function
    End If
    If Asc(Left(mystr, 1)) >= Asc("搭") And Asc(Left(mystr, 1)) < Asc("蛾") Then
       py = "D"
       Exit Function
    End If
    If Asc(Left(mystr, 1)) >= Asc("蛾") And Asc(Left(mystr, 1)) < Asc("发") Then
       py = "E"
       Exit Function
    End If
    If Asc(Left(mystr, 1)) >= Asc("发") And Asc(Left(mystr, 1)) < Asc("噶") Then
       py = "F"
       Exit Function
    End If
    If Asc(Left(mystr, 1)) >= Asc("噶") And Asc(Left(mystr, 1)) < Asc("哈") Then
       py = "G"
       Exit Function
    End If
    If Asc(Left(mystr, 1)) >= Asc("哈") And Asc(Left(mystr, 1)) < Asc("击") Then
       py = "H"
       Exit Function
    End If
    If Asc(Left(mystr, 1)) >= Asc("击") And Asc(Left(mystr, 1)) < Asc("喀") Then
       py = "J"
       Exit Function
    End If
    If Asc(Left(mystr, 1)) >= Asc("喀") And Asc(Left(mystr, 1)) < Asc("垃") Then
       py = "K"
       Exit Function
    End If
    If Asc(Left(mystr, 1)) >= Asc("垃") And Asc(Left(mystr, 1)) < Asc("妈") Then
       py = "L"
       Exit Function
    End If
    If Asc(Left(mystr, 1)) >= Asc("妈") And Asc(Left(mystr, 1)) < Asc("拿") Then
       py = "M"
       Exit Function
    End If
    If Asc(Left(mystr, 1)) >= Asc("拿") And Asc(Left(mystr, 1)) < Asc("哦") Then
       py = "N"
       Exit Function
    End If
    If Asc(Left(mystr, 1)) >= Asc("哦") And Asc(Left(mystr, 1)) < Asc("啪") Then
       py = "O"
       Exit Function
    End If
    If Asc(Left(mystr, 1)) >= Asc("啪") And Asc(Left(mystr, 1)) < Asc("期") Then
       py = "P"
       Exit Function
    End If
    If Asc(Left(mystr, 1)) >= Asc("期") And Asc(Left(mystr, 1)) < Asc("然") Then
       py = "Q"
       Exit Function
    End If
    If Asc(Left(mystr, 1)) >= Asc("然") And Asc(Left(mystr, 1)) < Asc("撒") Then
       py = "R"
       Exit Function
    End If
    If Asc(Left(mystr, 1)) >= Asc("撒") And Asc(Left(mystr, 1)) < Asc("塌") Then
       py = "S"
       Exit Function
    End If
    If Asc(Left(mystr, 1)) >= Asc("塌") And Asc(Left(mystr, 1)) < Asc("挖") Then
       py = "T"
       Exit Function
    End If
    If Asc(Left(mystr, 1)) >= Asc("挖") And Asc(Left(mystr, 1)) < Asc("昔") Then
       py = "W"
       Exit Function
    End If
    If Asc(Left(mystr, 1)) >= Asc("昔") And Asc(Left(mystr, 1)) < Asc("压") Then
       py = "X"
       Exit Function
    End If
    If Asc(Left(mystr, 1)) >= Asc("压") And Asc(Left(mystr, 1)) < Asc("匝") Then
       py = "Y"
       Exit Function
    End If
    If Asc(Left(mystr, 1)) >= Asc("匝") Then
       py = "Z"
       Exit Function
    End If
  Else
    If UCase(mystr) <= "Z" And UCase(mystr) >= "A" Then
       py = UCase(Left(mystr, 1))
      Else
       py = mystr
    End If
  End If
End Function

使用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的程序读出，代码如下：
Option 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 SubPrivate Sub Form_Load()
    Text2 = ""
    Text1 = ""
End SubPublic 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 FunctionPublic 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

经仔细推敲，VBTOY的方法解决了一、二级汉字的声母问题，但示范程序中的类初始化代码即Class_Initialize中的每个字符串后面的空格必须删除，否则乱套的，去掉空格后经初步检测正确。

我所采用的方法中是可以解决“浏”的声母的。我曾经为汉字的拼音首字母查过一些资料，一部分汉字可以用楼上各位提供的算法（当然也包括我的）得到，另外一些字，除了用二级汉字表外，好象别无它法。我所贴的汉字表，正如kakon说的，末尾有一个空格，这应该是CSDN程序自动加上的。各位用该表时，得费点功夫去掉这个空格。

以下代码是老马的.老马来了给他加分吧.我借用一下.'*************************************************************************
'**模块名：ModGetPY
'**说    明：取汉字拼音首字母,改良自网上某版本
'**创建人：嗷嗷叫的老马
'**日    期：2008年3月17日
'**备    注: 紫水晶工作室版权所有
'**版    本：V1.0
'*************************************************************************
Option ExplicitPublic Function GetPYChar(ByVal sChar As String) As String
    '返回第一个汉字拼音首字母
    'sChar - 转入的汉字
    '返回值:
    '       成功返回第一个字的拼音首字母
    '       失败返回原字符串
    Dim lChar As Long

    lChar = 65536 + Asc(sChar)
    Select Case lChar
        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 53640
            GetPYChar = "X"
        Case 53689 To 54480
            GetPYChar = "Y"
        Case 54481 To 55289
            GetPYChar = "Z"
        Case Else
            GetPYChar = sChar
    End Select
End FunctionPublic Function GetPY(ByVal InString As String, Optional ByVal MaxLen As Variant) As String
    '转换一个字符串内所有汉字为拼音首字母
    'InString - 输入的汉字字符串
    'MaxLen - 返回的字符最大长度
    '返回值:
    '       所有汉字的拼音首字母.
    '备注:
    '       仅处理汉字,非汉字原样返回.
    '       如果转换后的字符串长度大于MaxLen,那么从左起取MaxLen-1个字符加上最后一个字符作为返回值.
    Dim I As Long

    For I = 0 To Len(InString) - 1
        GetPY = GetPY & GetPYChar(Mid(InString, I + 1, 1))
    Next
    If IsMissing(MaxLen) = False Then
        If Len(GetPY) > MaxLen Then
            GetPY = Mid(GetPY, 1, MaxLen - 1) & Right(GetPY, 1)
        End If
    End If
End Function

调试易

如何获得输入汉字的拼音缩写？

解决方案 »