再发一篇关于通过API利用输入法获取汉字拼音的源代码(带声调)

无意间发现的, 先转载过来

Option Compare Database

Const GCL_CONVERSION = 1
Const GCL_REVERSECONVERSION = 2

Const VER_PLATFORM_WIN32_WINDOWS = 1
Const VER_PLATFORM_WIN32_NT = 2

Private Const IME_ESC_MAX_KEY = &H1005
Private Const IME_ESC_IME_NAME = &H1006
Type CANDIDATELIST
  dwSize As Long
  dwStyle As Long
  dwCount As Long
  dwSelection As Long
  dwPageStart As Long
  dwPageSize As Long
  dwOffset(0) As Long
End Type
Declare Function ImmGetContext Lib "imm32" ( _
    ByVal hwnd As Long _
) As Long

Declare Function ImmReleaseContext Lib "imm32" ( _
    ByVal hwnd As Long, _
    ByVal hIMC As Long _
) As Long

Declare Function ImmGetConversionList Lib "imm32" Alias "ImmGetConversionListW" ( _
    ByVal hKL As Long, _
    ByVal hIMC As Long, _
    ByRef lpSrc As Byte, _
    ByRef lpDst As Any, _
    ByVal dwBufLen As Long, _
    ByVal uFlag As Long _
) As Long

Declare Function GetKeyboardLayout Lib "user32" ( _
    ByVal idThread As Long _
) As Long
Private Declare Function GetKeyboardLayoutList Lib "user32" _
   (ByVal nBuff As Long, _
    ByRef 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, _
    ByRef lpv As Any) As Long
   
Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" ( _
    ByRef strString As Any _
) As Long

Type OSVERSIONINFO
  dwOSVersionInfoSize As Long
  dwMajorVersion As Long
  dwMinorVersion As Long
  dwBuildNumber As Long
  dwPlatformId As Long
  szCSDVersion(127) As Byte
End Type

Public Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" ( _
    ByRef VersionInfo As OSVERSIONINFO _
) As Long

Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    ByRef Destination As Any, _
    ByRef Source As Any, _
    ByVal Length As Long _
)

Public Function ReverseConversionNew(hwnd As Long, strSource As String) As String

    Dim bySource() As Byte
   
    Dim i As Integer
    Dim arrKeyLayout() As Long
    Dim strIME As String
   
    Dim hIMC As Long
    Dim hKL As Long
    Dim lngSize As Long
    Dim lngOffset As Long
    Dim iKeyLayoutCount As Integer

    Dim byCandiateArray() As Byte
    Dim CandiateList As CANDIDATELIST

    Dim byWork() As Byte
    Dim lngResult As Long
   
    Const BUFFERSIZE As Integer = 255
    Dim osvi As OSVERSIONINFO

    Dim isChineseIme As Boolean
   
    If strSource = "" Then Exit Function

    'OS判別
    osvi.dwOSVersionInfoSize = Len(osvi)
    lngResult = GetVersionEx(osvi)

    If osvi.dwPlatformId = VER_PLATFORM_WIN32_NT Then
        'WindowsNT系:Unicode字符集
        bySource = strSource

        ReDim Preserve bySource(UBound(bySource) + 2)
    Else
        'Windows95系
        bySource = StrConv(strSource, vbFromUnicode)

        ReDim Preserve bySource(UBound(bySource) + 1)
    End If
   
        hIMC = ImmGetContext(hwnd)

    ReDim arrKeyLayout(BUFFERSIZE) As Long
    strIME = Space(BUFFERSIZE)
    iKeyLayoutCount = GetKeyboardLayoutList(BUFFERSIZE, arrKeyLayout(0))

    isChineseIme = False
    For i = 0 To iKeyLayoutCount - 1
        If ImmEscape(arrKeyLayout(i), hIMC, IME_ESC_IME_NAME, ByVal strIME) Then
            If Trim(UCase("微软拼音输入法")) = UCase(Replace(Trim(strIME), Chr(0), "")) Then
                isChineseIme = True
                Exit For
            End If
        End If
    Next i
 
    If isChineseIme = False Then Exit Function
    hKL = arrKeyLayout(i)
'    hKL = GetKeyboardLayout(0)

    lngSize = ImmGetConversionList(hKL, hIMC, bySource(0), Null, 0, GCL_REVERSECONVERSION)

    If lngSize > 0 Then

        ReDim byCandiateArray(lngSize)

        lngSize = ImmGetConversionList(hKL, hIMC, bySource(0), byCandiateArray(0), lngSize, _
                                       GCL_REVERSECONVERSION)

        MoveMemory CandiateList, byCandiateArray(0), Len(CandiateList)

        If CandiateList.dwCount > 0 Then

            lngOffset = CandiateList.dwOffset(0)

            ReverseConversionNew = MidB(byCandiateArray, lngOffset + 1, _
                                     lstrlen(byCandiateArray(lngOffset)) * 2)

        End If

    End If

    lngResult = ImmReleaseContext(hwnd, hIMC)

End Function

Sub Command1_Click()
    Dim strSource As String
    Dim strRev As Variant
    strSource = "中华人民共和国"
    strRev = ReverseConversionNew(Application.hWndAccessApp, strSource)
    MsgBox CStr(strRev)
End Sub