取汉字拼音首字母

再来一个,取汉字拼音首字母.

这是在网上搜索到的,有点小错误,已经修正了.

而在我找到它的那个网站里的代码没有版权,所以我也不知道作者是谁.

VB code

'*************************************************************************
'**模 块 名：ModGetPY
'**说    明：取汉字拼音首字母,改良自网上某版本
'**创 建 人：嗷嗷叫的老马
'**日    期：2008年3月17日
'**备    注: 紫水晶工作室 版权所有
'**版    本：V1.0
'*************************************************************************
Option Explicit

Public 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 Function

Public 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

这个在一些数据录入的情况下比较常用.