再发一篇关于通过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
(责任编辑：admin)
