通过API利用输入法获取汉字拼音的源代码(带声调)

无意间发现的, 先转载过来Option Compare DatabaseConst GCL_CONVERSION = 1Const GCL_REVERSECONVERSION = 2Const VER_PLATFORM_WIN32_WINDOWS = 1Const VER_PLATFORM_WIN32_NT = 2Private Const IME_ESC_MAX_KEY = &H1005Private Const IME_ESC_IME_NAME = &H1006Type CANDIDATELISTdwSize As LongdwStyle As LongdwCount As LongdwSelection As LongdwPageStart As LongdwPageSize As LongdwOffset(0) As LongEnd TypeDeclare Function ImmGetContext Lib "imm32" ( _ByVal hwnd As Long _) As LongDeclare Function ImmReleaseContext Lib "imm32" ( _ByVal hwnd As Long, _ByVal hIMC As Long _) As LongDeclare 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 LongDeclare Function GetKeyboardLayout Lib "user32" ( _ByVal idThread As Long _) As LongPrivate Declare Function GetKeyboardLayoutList Lib "user32" _(ByVal nBuff As Long, _ByRef lpList As Long) As LongPrivate 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 LongDeclare Function lstrlen Lib "kernel32" Alias "lstrlenW" ( _ByRef strString As Any _) As LongType OSVERSIONINFOdwOSVersionInfoSize As LongdwMajorVersion As LongdwMinorVersion As LongdwBuildNumber As LongdwPlatformId As LongszCSDVersion(127) As ByteEnd TypePublic Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" ( _ByRef VersionInfo As OSVERSIONINFO _) As LongDeclare 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 StringDim bySource() As ByteDim i As IntegerDim arrKeyLayout() As LongDim strIME As StringDim hIMC As LongDim hKL As LongDim lngSize As LongDim lngOffset As LongDim iKeyLayoutCount As IntegerDim byCandiateArray() As ByteDim CandiateList As CANDIDATELISTDim byWork() As ByteDim lngResult As LongConst BUFFERSIZE As Integer = 255Dim osvi As OSVERSIONINFODim isChineseIme As BooleanIf strSource = "" Then Exit Function'OS判別osvi.dwOSVersionInfoSize = Len(osvi)lngResult = GetVersionEx(osvi)If osvi.dwPlatformId = VER_PLATFORM_WIN32_NT Then'WindowsNT系:Unicode字符集bySource = strSourceReDim Preserve bySource(UBound(bySource) + 2)Else'Windows95系bySource = StrConv(strSource, vbFromUnicode)ReDim Preserve bySource(UBound(bySource) + 1)End IfhIMC = ImmGetContext(hwnd)ReDim arrKeyLayout(BUFFERSIZE) As LongstrIME = Space(BUFFERSIZE)iKeyLayoutCount = GetKeyboardLayoutList(BUFFERSIZE, arrKeyLayout(0))isChineseIme = FalseFor i = 0 To iKeyLayoutCount - 1If ImmEscape(arrKeyLayout(i), hIMC, IME_ESC_IME_NAME, ByVal strIME) ThenIf Trim(UCase("微软拼音输入法")) = UCase(Replace(Trim(strIME), Chr(0), "")) ThenisChineseIme = TrueExit ForEnd IfEnd IfNext iIf isChineseIme = False Then Exit FunctionhKL = arrKeyLayout(i)' hKL = GetKeyboardLayout(0)lngSize = ImmGetConversionList(hKL, hIMC, bySource(0), Null, 0, GCL_REVERSECONVERSION)If lngSize > 0 ThenReDim byCandiateArray(lngSize)lngSize = ImmGetConversionList(hKL, hIMC, bySource(0), byCandiateArray(0), lngSize, _GCL_REVERSECONVERSION)MoveMemory CandiateList, byCandiateArray(0), Len(CandiateList)If CandiateList.dwCount > 0 ThenlngOffset = CandiateList.dwOffset(0)ReverseConversionNew = MidB(byCandiateArray, lngOffset + 1,_lstrlen(byCandiateArray(lngOffset)) * 2)End IfEnd IflngResult = ImmReleaseContext(hwnd, hIMC)End FunctionSub Command1_Click()Dim strSource As StringDim strRev As VariantstrSource = "中华人民共和国"strRev = ReverseConversionNew(Application.hWndAccessApp, strSource)MsgBox CStr(strRev)End Sub