VB 汉字拼音及声调

 

1. Private Sub Command1_Click()
2.     Text2 = "全拼+声调：" & GetChineseSpell(Text1, 0) & vbCrLf & "全拼：" & GetChineseSpell(Text1, 1) & vbCrLf & "拼音首字母：" & GetChineseSpell(Text1, 2)
3. End Sub
5. '===================================
7. Option Explicit
9. Private Const IME_ESC_MAX_KEY = 
10. Private Const IME_ESC_IME_NAME = 
11. Private Const GCL_REVERSECONVERSION = 
12. Private Declare Function GetKeyboardLayoutList Lib "user32" (ByVal nBuff As Long, lpList As Long) As Long
13. Private Declare Function ImmEscape Lib "imm32.dll" Alias "ImmEscapeA" (ByVal hkl As Long, ByVal himc As Long, ByVal un As Long, lpv As Any) As Long
14. Private Declare Function ImmGetConversionList Lib "imm32.dll" Alias "ImmGetConversionListA" (ByVal hkl As Long, ByVal himc As Long, ByVal lpsz As String, lpCandidateList As Any, ByVal dwBufLen As Long, ByVal uFlag As Long) As Long
15. Private Declare Function IsDBCSLeadByte Lib "kernel32" (ByVal bTestChar As Byte) As Long
17. Public Function GetChineseSpell(ByVal CHINESE As String, Optional PYTYPE As Integer = 0, Optional Delimiter As String = " ") As String
19. If Len(Trim(CHINESE)) > 0 Then
20.  Dim i As Long
21.  Dim s As String
22.  s = Space(255)
23.  Dim IMEInstalled As Boolean
24.  Dim j As Long
25.  Dim a() As Long
27.  ReDim a(255) As Long
28.  j = GetKeyboardLayoutList(255, a(LBound(a)))
30.  For i = LBound(a) To LBound(a) + j - 1
31.    If ImmEscape(a(i), 0, IME_ESC_IME_NAME, ByVal s) Then
32.      If Trim("微软拼音输入法") = Replace(Trim(s), Chr(0), "") Then
33.       IMEInstalled = True
34.       Exit For
35.      End If
36.    End If
37.  Next i
38.  If IMEInstalled Then
39.    CHINESE = Trim(CHINESE)
40.    Dim sChar As String
41.    Dim Buffer0() As Byte
42.    Dim bBuffer0() As Byte
43.    Dim bBuffer() As Byte
44.    Dim k As Long
45.    Dim l As Long
46.    Dim m As Long
47.    For j = 0 To Len(CHINESE) - 1
48.      sChar = Mid(CHINESE, j + 1, 1)
49.    '  If Not InStr("《》，。/？、][{}“”‘’；：！·〈〉「」『』｜〖〗【】（）［］｛｝…—.,""'';:?//!", sChar) > 0 Then
50.      Buffer0 = StrConv(sChar, vbFromUnicode)
51.      If IsDBCSLeadByte(Buffer0(0)) Then
52.       k = ImmEscape(a(i), 0, IME_ESC_MAX_KEY, Null)
53.       If k Then
54.         l = ImmGetConversionList(a(i), 0, sChar, 0, 0, GCL_REVERSECONVERSION)
55.         If l Then
56.          s = Space(255)
57.          If ImmGetConversionList(a(i), 0, sChar, ByVal s, l, GCL_REVERSECONVERSION) Then
58.            
59.            bBuffer0 = StrConv(s, vbFromUnicode)
60.            ReDim bBuffer(k * 2 - 1)
61.            For m = bBuffer0(24) To bBuffer0(24) + k * 2 - 1
62.              bBuffer(m - bBuffer0(24)) = bBuffer0(m)
63.            Next m
64.            sChar = Trim(StrConv(bBuffer, vbUnicode))
65.            If InStr(sChar, vbNullChar) Then
66.             sChar = Trim(Left(sChar, InStr(sChar, vbNullChar) - 1))
67.            End If
68.           End If
69.          End If
70.          
71.         End If
72.       End If
73.     ' End If
74.      GetChineseSpell = GetChineseSpell & Switch(PYTYPE = 0, sChar, PYTYPE = 1, Left(sChar, Len(sChar) - 1), PYTYPE = 2, UCase(Left(sChar, 1))) & IIf(PYTYPE = 2, "", Delimiter)  ''返回全拼
75.      Next j
76.  Else ''没安装“微软拼音输入法”,返回一个空格
77.     GetChineseSpell = " "
78.  End If
79. Else
80.  GetChineseSpell = "" ''输入为空字符串
81. End If
82. End Function