方法一
'//在vb中实现返回一个汉字的拼音首字母
Option Compare Text '比较重要的一句，说明了在模块内部字符进行比较的方式，如果没有这一句，VB默认按Binary方式进行字符串的比较，那样得不到正确结果。
Public Function getfirstletter(strInput As String, Optional nlength As Integer) As String
getfirstletter = ""
Dim nlen As Integer
nlen = 0
If IsNumeric(nlength) Then
If nlength > 0 Then
nlen = nlength
End If
End If
If nlen = 0 Then
nlen = Len(strInput)
End If
Dim strFirst As String
Dim i As Integer
i = 1
Do While i <= nlen
strFirst = Mid(strInput, i, 1)
i = i + 1
If strFirst < "阿" Then
'非汉字
getfirstletter = getfirstletter & strFirst
End If
Select Case strFirst
Case Is >= "匝"
getfirstletter = getfirstletter & "Z"
Case Is >= "压"
getfirstletter = getfirstletter & "Y"
Case Is >= "昔"
getfirstletter = getfirstletter & "X"
Case Is >= "挖"
getfirstletter = getfirstletter & "W"
Case Is >= "塌"
getfirstletter = getfirstletter & "T"
Case Is >= "撒"
getfirstletter = getfirstletter & "S"
Case Is >= "然"
getfirstletter = getfirstletter & "R"
Case Is >= "期"
getfirstletter = getfirstletter & "Q"
Case Is >= "啪"
getfirstletter = getfirstletter & "P"
Case Is >= "哦"
getfirstletter = getfirstletter & "O"
Case Is >= "拿"
getfirstletter = getfirstletter & "N"
Case Is >= "妈"
getfirstletter = getfirstletter & "M"
Case Is >= "垃"
getfirstletter = getfirstletter & "L"
Case Is >= "喀"
getfirstletter = getfirstletter & "K"
Case Is >= "击"
getfirstletter = getfirstletter & "J"
Case Is >= "哈"
getfirstletter = getfirstletter & "H"
Case Is >= "噶"
getfirstletter = getfirstletter & "G"
Case Is >= "发"
getfirstletter = getfirstletter & "F"
Case Is >= "蛾"
getfirstletter = getfirstletter & "E"
Case Is >= "搭"
getfirstletter = getfirstletter & "D"
Case Is >= "擦"
getfirstletter = getfirstletter & "C"
Case Is >= "芭"
getfirstletter = getfirstletter & "B"
Case Is >= "啊"
getfirstletter = getfirstletter & "A"
End Select
Loop
End Function
--------------------------------------------------------------------------
方法二(不认识的字会以%代替)
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 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
--------------------------------------------------------------------------
方法三（只能获得第一个汉字的首字拼音）
Public Function GetPY(a1 As String) As String
'获得输入名称的首字拼音
Dim t1 As String
If Asc(a1) < 0 Then
t1 = Left(a1, 1)
If Asc(t1) < Asc("啊") Then
GetPY = "0"
Exit Function
End If
If Asc(t1) >= Asc("啊") And Asc(t1) < Asc("芭") Then
GetPY = "A"
Exit Function
End If
If Asc(t1) >= Asc("芭") And Asc(t1) < Asc("擦") Then
GetPY = "B"
Exit Function
End If
If Asc(t1) >= Asc("擦") And Asc(t1) < Asc("搭") Then
GetPY = "C"
Exit Function
End If
If Asc(t1) >= Asc("搭") And Asc(t1) < Asc("蛾") Then
GetPY = "D"
Exit Function
End If
If Asc(t1) >= Asc("蛾") And Asc(t1) < Asc("发") Then
GetPY = "E"
Exit Function
End If
If Asc(t1) >= Asc("发") And Asc(t1) < Asc("噶") Then
GetPY = "F"
Exit Function
End If
If Asc(t1) >= Asc("噶") And Asc(t1) < Asc("哈") Then
GetPY = "G"
Exit Function
End If
If Asc(t1) >= Asc("哈") And Asc(t1) < Asc("击") Then
GetPY = "H"
Exit Function
End If
If Asc(t1) >= Asc("击") And Asc(t1) < Asc("喀") Then
GetPY = "J"
Exit Function
End If
If Asc(t1) >= Asc("喀") And Asc(t1) < Asc("垃") Then
GetPY = "K"
Exit Function
End If
If Asc(t1) >= Asc("垃") And Asc(t1) < Asc("妈") Then
GetPY = "L"
Exit Function
End If
If Asc(t1) >= Asc("妈") And Asc(t1) < Asc("拿") Then
GetPY = "M"
Exit Function
End If
If Asc(t1) >= Asc("拿") And Asc(t1) < Asc("哦") Then
GetPY = "N"
Exit Function
End If
If Asc(t1) >= Asc("哦") And Asc(t1) < Asc("啪") Then
GetPY = "O"
Exit Function
End If
If Asc(t1) >= Asc("啪") And Asc(t1) < Asc("期") Then
GetPY = "P"
Exit Function
End If
If Asc(t1) >= Asc("期") And Asc(t1) < Asc("然") Then
GetPY = "Q"
Exit Function
End If
If Asc(t1) >= Asc("然") And Asc(t1) < Asc("撒") Then
GetPY = "R"
Exit Function
End If
If Asc(t1) >= Asc("撒") And Asc(t1) < Asc("塌") Then
GetPY = "S"
Exit Function
End If
If Asc(t1) >= Asc("塌") And Asc(t1) < Asc("挖") Then
GetPY = "T"
Exit Function
End If
If Asc(t1) >= Asc("挖") And Asc(t1) < Asc("昔") Then
GetPY = "W"
Exit Function
End If
If Asc(t1) >= Asc("昔") And Asc(t1) < Asc("压") Then
GetPY = "X"
Exit Function
End If
If Asc(t1) >= Asc("压") And Asc(t1) < Asc("匝") Then
GetPY = "Y"
Exit Function
End If
If Asc(t1) >= Asc("匝") Then
GetPY = "Z"
Exit Function
End If
Else
If UCase(a1) <= "Z" And UCase(a1) >= "A" Then
GetPY = UCase(Left(a1, 1))
Else
GetPY = "0"
End If
End If
End Function
----------------------------------------------------------------------------