VB 汉字拼音及声调

最新推荐文章于 2013-01-31 11:46:44 发布

原创最新推荐文章于 2013-01-31 11:46:44 发布 · 2.8k 阅读

2 ·

CC 4.0 BY-SA版权

文章标签：

#vb #输入法 #buffer #微软 #null #user

VB 专栏收录该内容

19 篇文章

订阅专栏

这段VB代码实现了一个功能，能够将输入的汉字转换为全拼、无声调全拼以及拼音首字母。通过调用`GetChineseSpell`函数，结合`ImmEscape`和`ImmGetConversionList`等API，完成对微软拼音输入法的交互，从而获取汉字的拼音信息。

Private Sub Command1_Click()
    Text2 = "全拼+声调：" & GetChineseSpell(Text1, 0) & vbCrLf & "全拼：" & GetChineseSpell(Text1, 1) & vbCrLf & "拼音首字母：" & GetChineseSpell(Text1, 2)
End Sub
'=================================== 
Option Explicit
Private Const IME_ESC_MAX_KEY = 
Private Const IME_ESC_IME_NAME = 
Private Const GCL_REVERSECONVERSION = 
Private Declare Function GetKeyboardLayoutList Lib "user32" (ByVal nBuff As Long, lpList As Long) As Long
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
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
Private Declare Function IsDBCSLeadByte Lib "kernel32" (ByVal bTestChar As Byte) As Long
Public Function GetChineseSpell(ByVal CHINESE As String, Optional PYTYPE As Integer = 0, Optional Delimiter As String = " ") As String
If Len(Trim(CHINESE)) > 0 Then
 Dim i As Long
 Dim s As String
 s = Space(255)
 Dim IMEInstalled As Boolean
 Dim j As Long
 Dim a() As Long
 ReDim a(255) As Long
 j = GetKeyboardLayoutList(255, a(LBound(a)))
 For i = LBound(a) To LBound(a) + j - 1
   If ImmEscape(a(i), 0, IME_ESC_IME_NAME, ByVal s) Then
     If Trim("微软拼音输入法") = Replace(Trim(s), Chr(0), "") Then
      IMEInstalled = True
      Exit For
     End If
   End If
 Next i
 If IMEInstalled Then
   CHINESE = Trim(CHINESE)
   Dim sChar As String
   Dim Buffer0() As Byte
   Dim bBuffer0() As Byte
   Dim bBuffer() As Byte
   Dim k As Long
   Dim l As Long
   Dim m As Long
   For j = 0 To Len(CHINESE) - 1
     sChar = Mid(CHINESE, j + 1, 1)
   '  If Not InStr("《》，。/？、][{}“”‘’；：！·〈〉「」『』｜〖〗【】（）［］｛｝…—.,""'';:?//!", sChar) > 0 Then 
     Buffer0 = StrConv(sChar, vbFromUnicode)
     If IsDBCSLeadByte(Buffer0(0)) Then
      k = ImmEscape(a(i), 0, IME_ESC_MAX_KEY, Null)
      If k Then
        l = ImmGetConversionList(a(i), 0, sChar, 0, 0, GCL_REVERSECONVERSION)
        If l Then
         s = Space(255)
         If ImmGetConversionList(a(i), 0, sChar, ByVal s, l, GCL_REVERSECONVERSION) Then
           
           bBuffer0 = StrConv(s, vbFromUnicode)
           ReDim bBuffer(k * 2 - 1)
           For m = bBuffer0(24) To bBuffer0(24) + k * 2 - 1
             bBuffer(m - bBuffer0(24)) = bBuffer0(m)
           Next m
           sChar = Trim(StrConv(bBuffer, vbUnicode))
           If InStr(sChar, vbNullChar) Then
            sChar = Trim(Left(sChar, InStr(sChar, vbNullChar) - 1))
           End If
          End If
         End If
         
        End If
      End If
    ' End If 
     GetChineseSpell = GetChineseSpell & Switch(PYTYPE = 0, sChar, PYTYPE = 1, Left(sChar, Len(sChar) - 1), PYTYPE = 2, UCase(Left(sChar, 1))) & IIf(PYTYPE = 2, "", Delimiter)  ''返回全拼 
     Next j
 Else ''没安装“微软拼音输入法”,返回一个空格 
    GetChineseSpell = " "
 End If
Else
 GetChineseSpell = "" ''输入为空字符串 
End If
End Function