我做到一个通讯录的模块，请问怎么根据26个字母查找出拼音的第一个字母与之相对映的汉字，比如点击“Z”，能查到“中国”。

看看这个帖子是否对你有帮助 转贴,转自 http://www.cndiy8.com/ask21/how133660.htm 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

转贴
出自同上


Public Function GetChineseSpellCode(ByVal SourceStr As String) As String

    '得到中文的拼音缩写

    Dim Serial_S As String
    Dim Serial_T As String
    Dim TempS As String
    Dim j As Integer
     
    Dim i As Integer
    Dim HelpChar As String
     
    Serial_S = "啊芭擦搭蛾发噶哈击喀垃妈拿哦啪期然撒塌挖昔压匝座"
    Serial_T = "abcdefghjklmnopqrstwxyz"
     
    For i = 1 To Len(SourceStr)
        HelpChar = Mid(SourceStr, i, 1)
         
        If Asc(HelpChar) &gt;= Asc(Left(Serial_S, 1)) And Asc(HelpChar) &lt;= Asc(Right(Serial_S, 1)) Then
            '-------------------------------
            If Asc(HelpChar) = Asc(Right(Serial_S, 1)) Then
                GetChineseSpellCode = GetHelpCode &amp; Right(Serial_T, 1)
            Else
                For j = 2 To Len(Serial_S)
                    TempS = Mid(Serial_S, j, 1)
                    If Asc(HelpChar) &lt; Asc(TempS) Then
                        GetChineseSpellCode = GetChineseSpellCode &amp; Mid(Serial_T, j - 1, 1)
                        Exit For
                    End If
                Next j
            End If

            '-------------------------------
        Else
            GetHelpCode = GetHelpCode &amp; "?"
        End If

    Next i

End Function

转贴
出自同上
Option Explicit  

Private Const IME_ESC_MAX_KEY = &amp;H1005  
Private Const IME_ESC_IME_NAME = &amp;H1006  
Private Const GCL_REVERSECONVERSION = &amp;H2  

Private Type CANDIDATELIST  
    dwSize As Long  
    dwStyle As Long  
    dwCount As Long  
    dwSelection As Long  
    dwPageStart As Long  
    dwPageSize As Long  
    dwOffset(1) As Long  
End Type  

Private Declare Function GetKeyboardLayoutList Lib "user32" (ByVal nBuff As Long, lpList As Long) As Long  
Private Declare Function ImmEscape Lib "imm32.dll" Alias "ImmEscapeA" (ByVal hkl As Long, ByVal himc As Long, ByVal un As Long, lpv As Any) As Long  
Private Declare Function ImmGetConversionList Lib "imm32.dll" Alias "ImmGetConversionListA" (ByVal hkl As Long, ByVal himc As Long, ByVal lpsz As String, lpCandidateList As Any, ByVal dwBufLen As Long, ByVal uFlag As Long) As Long  
'Private Declare Function ImmGetConversionList Lib "imm32.dll" Alias "ImmGetConversionListA" (ByVal hkl As Long, ByVal himc As Long, ByVal lpsz As String, lpCandidateList As CANDIDATELIST, ByVal dwBufLen As Long, ByVal uFlag As Long) As Long  
Private Declare Function IsDBCSLeadByte Lib "kernel32" (ByVal bTestChar As Byte) As Long  

Private Const NUM_OF_BUFFERS = 40  
Private Const MSPY = "微软拼音输入法"  
Dim imeHandle(1 To NUM_OF_BUFFERS) As Long  
Dim imeName(1 To NUM_OF_BUFFERS) As String  

Dim mlMSPYIndex As Long  
Dim imeCount As Long  

Private Sub Init()  
    Dim i As Long  
    Dim sName As String  

    mlMSPYIndex = 0  
    imeCount = GetKeyboardLayoutList(NUM_OF_BUFFERS, imeHandle(1))  
    If imeCount Then  
        For i = 1 To imeCount  
            sName = String(255, " ")  
            If ImmEscape(imeHandle(i), 0, IME_ESC_IME_NAME, ByVal sName) Then  
                If sName &lt;&gt; "" Then sName = Left(sName, InStr(sName, vbNullChar) - 1)  
                    imeName(i) = sName  
                    If sName = MSPY Then  mlMSPYIndex = i  
                End If  
            End If  
        Next i  
    End If  

End Sub  

Public Property Get MSPYInstalled() As Boolean  
    MSPYInstalled = IIf(mlMSPYIndex, True, False)  
End Property  

Public Property Get MSPYIndex() As Long  
    MSPYIndex = mlMSPYIndex  
End Property  

Public Property Get Count() As Long  
    Count = imeCount  
End Property  

Public Function GetHandle(ByVal lIndex As Long) As Long  
    If lIndex &gt;= 1 And lIndex &lt;= imeCount Then
        GetHandle = imeHandle(lIndex)
    End If
End Function

Public Function GetName(ByVal lIndex As Long) As String
    If lIndex &gt;= 1 And lIndex &lt;= imeCount Then
        GetName = imeName(lIndex)
    End If
End Function

Public Function MSPYReverse(ByVal sString As String) As String
    Dim lStrLen As Long
    Dim i As Long
    Dim sChar As String
    Dim bChar() As Byte

    If MSPYInstalled Then
        lStrLen = Len(sString)
        MSPYReverse = ""
        If lStrLen Then
            For i = 1 To lStrLen
                sChar = Mid(sString, i, 1)
                bChar = StrConv(sChar, vbFromUnicode)
                If IsDBCSLeadByte(bChar(0)) Then
                    Dim lMaxKey As Long
                    Dim lGCL As Long
                    lMaxKey = ImmEscape(imeHandle(mlMSPYIndex), 0, IME_ESC_MAX_KEY, Null)
                    If lMaxKey Then
                        Dim tCandi As CANDIDATELIST
                        lGCL = ImmGetConversionList(imeHandle(mlMSPYIndex), 0, sChar, 0, 0, GCL_REVERSECONVERSION)
                        If lGCL &gt; 0 Then  
                            Dim bBuffer() As Byte  
                            Dim MaxKey As Long  
                            Dim sBuffer As String  
                            sBuffer = String(255, vbNullChar)  
                            MaxKey = lMaxKey  
                            lGCL = ImmGetConversionList(imeHandle(mlMSPYIndex), 0, sChar, ByVal sBuffer, lGCL, GCL_REVERSECONVERSION)  
                            If lGCL &gt; 0 Then  
                                Dim bPY() As Byte  
                                Dim j As Long  

                                bBuffer = StrConv(sBuffer, vbFromUnicode)  

                                ReDim bPY(MaxKey * 2 - 1)  
                                For j = bBuffer(24) To bBuffer(24) + MaxKey * 2 - 1  
                                    bPY(j - bBuffer(24)) = bBuffer(j)  
                                Next j  
                                sChar = StrConv(bPY, vbUnicode)  
                                If InStr(sChar, vbNullChar) Then  
                                    sChar = Trim(Left(sChar, InStr(sChar, vbNullChar) - 1))  
                                End If  
                            End If  
                        End If  
                    End If  
                End If  
                MSPYReverse = MSPYReverse &amp; sChar  
            Next i  
        End If  
    Else  
        '替代方法  
        MSPYReverse = GetPYStr(sString)  
    End If  
End Function  

Private Sub Class_Initialize()  
    Init  
End Sub  

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

End Function  

Private Function GetPYStr(ByVal S As String) As String  
    Dim l As Long  
    Dim sOut As String  

    If S &lt;&gt; "" Then  
        For l = 1 To Len(S)  
            sOut = sOut &amp; GetPYChar(Mid(S, l, 1))  
        Next l  
        GetPYStr = sOut  
    End If  
End Function

怎么是VB啊