提取汉字拼音首字符

以下是测试模块

Sub 测试()
  Dim str$
  str = InputBox("请输入要识别的字符串")
  MsgBox str & "的拼音首字母为：" & vbCr & vbCr & getPY(str)
End Sub

以下是功能实现模块

Function PinYin(str As String) As String
  Select Case Asc(str)
    Case -20319 To -20284: PinYin = "A"
    Case -20283 To -19776: PinYin = "B"
    Case -19775 To -19219: PinYin = "C"
    Case -19218 To -18711: PinYin = "D"
    Case -18710 To -18527: PinYin = "E"
    Case -18526 To -18240: PinYin = "F"
    Case -18239 To -17923: PinYin = "G"
    Case -17922 To -17418: PinYin = "H"
    Case -17417 To -16475: PinYin = "J"
    Case -16474 To -16213: PinYin = "K"
    Case -16212 To -15641: PinYin = "L"
    Case -15640 To -15166: PinYin = "M"
    Case -15165 To -14923: PinYin = "N"
    Case -14922 To -14915: PinYin = "O"
    Case -14914 To -14631: PinYin = "P"
    Case -14630 To -14150: PinYin = "Q"
    Case -14149 To -14091: PinYin = "R"
    Case -14090 To -13319: PinYin = "S"
    Case -13318 To -12839: PinYin = "T"
    Case -12838 To -12557: PinYin = "W"
    Case -12556 To -11848: PinYin = "X"
    Case -11847 To -11056: PinYin = "Y"
    Case -11055 To -2050: PinYin = "Z"
    Case Else: PinYin = str
  End Select
End Function

Function getPY(str)
  Dim i%
  For i = 1 To Len(str)
    getPY = getPY & PinYin(Mid(str, i, 1))
  Next i
End Function