汉字转化为拼音

Question

      在vb中，怎样将字段的汉字转化为拼音，规则：将每个汉字转化为拼音（大写），只是保留每个拼音的开头的字母，如果字段是小写的英文，者转化为全部大写。数字，标点者不变
不知道那位大虾知道，能不能帮帮我，能提供参考程序最好，我先在这里谢了！！！！
     例如：“成龙”转化后为："CL",
          "好人"转化后为："HR",
          "真的爱你"转化后为："ZDAN",
           "55have.b"转化后为："55HAVE.B",
           "好人"转化后为："HR",

Answer 1

Option ExplicitFunction 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
Private Sub Command1_Click()
    Text2.Text = getpy(Text1.Text)
End Sub

Answer 2

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

Answer 3

http://blog.csdn.net/northwolves/archive/2007/05/24/1624766.aspx

Answer 4

 新问题出现了，为什么在调试的时候，有的能转化，有的不可以呢？
如“学”，“婷”就转化不了，是怎么会事，高手帮忙啊？
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 Asc(char) >= 48 And Asc(char) <= 57 Then
               getpychar = char
        ElseIf char >= "A" And char <= "Z" Then
            getpychar = char
        Else
            
            If Asc(char) = 32 Then
               getpychar = " "
            Else
           
                getpychar = ""
            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 = char
        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 FunctionPrivate Sub Text2_Change()
Text3.Text = getpy(Text2.Text)
Text4.Text = Len(Text2.Text)
End Sub

Answer 5

以上算法都只包括一部分汉字。见：
http://topic.csdn.net/u/20070720/20/b7b91f00-8515-458f-b484-7013e7d9a09e.html