汉字转化为拼音

[tomnes]

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

[大王派我去巡山]

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


Private Sub Command1_Click()
    Text2.Text = getpy(Text1.Text)
End Sub

[cike_1111]

呵呵~~ 好象就是这段了...

[bbhere]

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

[northwolves]

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

[tomnes]

我先实验下，再请教

[tomnes]

新问题出现了，为什么在调试的时候，有的能转化，有的不可以呢？
如“学”，“婷”就转化不了，是怎么会事，高手帮忙啊？
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 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

Private Sub Text2_Change()
Text3.Text = getpy(Text2.Text)
Text4.Text = Len(Text2.Text)
End Sub

[VBToy]

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