Attribute VB_Name = "modIME"
Option Explicit
'名詞解釋
' status window 出現 [注音 半形] 的那一個window
' composition window: key in 時出現字根/注音符號 的window
' candidate window : 同一字根有多個字可選擇時，所出現的window
' composition string : 即字根
' conversion status :指有沒有小鍵盤、相關字詞功能等之狀態
' soft keyboard : 螢幕小鍵盤
' SymbolKeyboard: 標點符號
' PHRASEPREDICT :字詞相關功能
'待testing 的東西
' register string register word:不知是什麼
' ImmEscape 的第三個參數可傳哪些，及其意義
' 對candidate list的控制
Public Declare Function GetKeyboardLayout Lib "user32" (ByVal dwLayout As Long) As Long
Public Declare Function GetKeyboardLayoutList Lib "user32" (ByVal nBuff As Long, lpList As Long) As Long
Public Declare Function GetKeyboardLayoutName Lib "user32" Alias "GetKeyboardLayoutNameA" (ByVal pwszKLID As String) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Public Declare Function ImmConfigureIMEA Lib "imm32.dll" (ByVal hkl As Long, ByVal hwnd As Long, ByVal dw As Long, lpData As Any) As Long
Public Declare Function ImmGetCompositionString Lib "imm32.dll" Alias "ImmGetCompositionStringA" (ByVal himc As Long, ByVal dw As Long, lpv As Any, ByVal dw2 As Long) As Long
Public Declare Function ImmGetContext Lib "imm32.dll" (ByVal hwnd As Long) As Long
Public Declare Function ImmGetConversionStatus Lib "imm32.dll" (ByVal himc As Long, lpdw As Long, lpdw2 As Long) As Long
Public Declare Function ImmSetConversionStatus Lib "imm32.dll" (ByVal himc As Long, ByVal dw1 As Long, ByVal dw2 As Long) As Long
Public Declare Function ImmReleaseContext Lib "imm32.dll" (ByVal hwnd As Long, ByVal himc As Long) As Long
Public Declare Function ImmIsIME Lib "imm32.dll" (ByVal hkl As Long) As Long
Public Declare Function ImmSimulateHotKey Lib "imm32.dll" (ByVal hwnd As Long, ByVal dw As Long) As Long
Public Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As Msg, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
Public Declare Function TranslateMessage Lib "user32" (lpMsg As Msg) As Long
Public Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As Msg) As Long
Public Declare Function ActivateKeyboardLayout Lib "user32" (ByVal hkl As Long, ByVal flags As Long) As Long
Public 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
Public 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
Public Declare Function ImmSetCompositionString Lib "imm32.dll" Alias "ImmSetCompositionStringA" (ByVal himc As Long, ByVal dwIndex As Long, ByVal lpComp As String, ByVal dw As Long, ByVal lpRead As String, ByVal dw2 As Long) As Long
Public Declare Function ImmGetCandidateList Lib "imm32.dll" Alias "ImmGetCandidateListA" (ByVal himc As Long, ByVal deIndex As Long, lpCandidateList As Any, ByVal dwBufLen As Long) As Long
Public Declare Function ImmGetCandidateListCount Lib "imm32.dll" Alias "ImmGetCandidateListCountA" (ByVal himc As Long, lpdwListCount As Long) As Long
Public Declare Function ImmNotifyIME Lib "imm32.dll" (ByVal himc As Long, ByVal dwAction As Long, ByVal dwIndex As Long, ByVal dwValue As Long) As Long
Public Declare Function ImmGetDescription Lib "imm32.dll" Alias "ImmGetDescriptionA" (ByVal hkl As Long, ByVal lpsz As String, ByVal uBufLen As Long) As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Public Declare Function LoadKeyboardLayout Lib "user32" Alias "LoadKeyboardLayoutA" (ByVal pwszKLID As String, ByVal flags As Long) As Long
'Private Const HEB_CODE_PAGE As String = "0000040d"
Private Const ENG_CODE_PAGE As String = "00000409"
Private Const KLF_ACTIVATE = &H1
Public Const SW_SHOW = 5
Public Const SW_HIDE = 0
Public Const NI_COMPOSITIONSTR = &H15
Public Const NI_OPENCANDIDATE = &H10
Public Const NI_SELECTCANDIDATESTR = &H12
Public Const NI_SETCANDIDATE_PAGESIZE = &H17
Public Const NI_SETCANDIDATE_PAGESTART = &H16
Public Const NI_CLOSECANDIDATE = &H11
Public Const NI_FINALIZECONVERSIONRESULT = &H14
Public Const NI_CHANGECANDIDATELIST = &H13
Public Const CPS_CANCEL = &H4
Public Const CPS_COMPLETE = &H1
Public Const CPS_CONVERT = &H2
Public Const CPS_REVERT = &H3
Const PM_REMOVE = &H1
Const IME_THOTKEY_IME_NONIME_TOGGLE = &H70
Const IME_CMODE_SOFTKBD = &H80
Const IME_SMODE_PHRASEPREDICT = &H8
Const IME_ESC_MAX_KEY = &H1005
Const IME_CMODE_SYMBOL = &H400
Const GCS_COMPSTR = &H8
Const GCS_COMPREADSTR = &H1
Const SCS_SETSTR = (GCS_COMPREADSTR Or GCS_COMPSTR)
Const GCS_RESULTSTR = &H800
Const GCS_RESULTREADSTR = &H200
Const GCL_REVERSECONVERSION = &H2
Const IME_THOTKEY_SHAPE_TOGGLE = &H71
Const IME_THOTKEY_SYMBOL_TOGGLE = &H72
Const HKL_NEXT = 1
Const HKL_PREV = 0
Public Type POINTAPI
X As Long
Y As Long
End Type
Public Type Msg
hwnd As Long
message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type
Public Type CANDIDATELIST
dwSize As Long
dwStyle As Long
dwCount As Long
dwSelection As Long
dwPageStart As Long
dwPageSize As Long
dwOffset(1) As Long
End Type
Public Type REGISTERWORD
lpReading As String
lpWord As String
End Type
'設定標點符號
Public Function ShowSymbolKeyboard(ByVal hwnd As Long, ByVal vbShow As Boolean) As Long
Dim hct As Long
Dim aa As Long
Dim ll As Long
Dim hkb As Long
Dim conv As Long, senc As Long
Dim msgPeekResult As Msg
ShowSymbolKeyboard = 0
'Do While PeekMessage(msgPeekResult, hwnd, 0, 0, PM_REMOVE) = 1
' TranslateMessage msgPeekResult
' DispatchMessage msgPeekResult
'Loop
DoEvents
hkb = GetKeyboardLayout(0)
If ImmIsIME(hkb) = 0 Then
ImmSimulateHotKey hwnd, IME_THOTKEY_IME_NONIME_TOGGLE
End If
hct = ImmGetContext(hwnd)
If hct = 0 Then
Exit Function
End If
If ImmGetConversionStatus(hct, conv, senc) <> 1 Then
ImmReleaseContext hwnd, hct
Exit Function
End If
If vbShow Then
conv = conv Or IME_CMODE_SYMBOL
Else
conv = conv And (Not IME_CMODE_SYMBOL)
End If
If ImmSetConversionStatus(hct, conv, senc) = 1 Then
ShowSymbolKeyboard = 1
End If
ImmReleaseContext hwnd, hct
End Function
'設定螢幕小鍵盤
Public Function ShowSoftKeyboard(ByVal vbShow As Boolean) As Long
Dim hct As Long, hwnd As Long
Dim aa As Long
Dim ll As Long
Dim hkb As Long
Dim conv As Long, senc As Long
Dim msgPeekResult As Msg
hwnd = Screen.ActiveForm.hwnd
ShowSoftKeyboard = 0
DoEvents
'Do While PeekMessage(msgPeekResult, hwnd, 0, 0, PM_REMOVE) = 1
' TranslateMessage msgPeekResult
' DispatchMessage msgPeekResult
'Loop
hkb = GetKeyboardLayout(0)
If ImmIsIME(hkb) = 0 Then
ImmSimulateHotKey hwnd, IME_THOTKEY_IME_NONIME_TOGGLE
End If
hct = ImmGetContext(hwnd)
If hct = 0 Then
Exit Function
End If
If ImmGetConversionStatus(hct, conv, senc) <> 1 Then
ImmReleaseContext hwnd, hct
Exit Function
End If
If vbShow Then
conv = conv Or IME_CMODE_SOFTKBD
Else
conv = conv And (Not IME_CMODE_SOFTKBD)
End If
If ImmSetConversionStatus(hct, conv, senc) = 1 Then
ShowSoftKeyboard = 1
End If
ImmReleaseContext hwnd, hct
End Function
'設定字詞相關功能
Public Function PhaseRelation(ByVal vbShow As Boolean) As Long
Dim hct As Long
Dim aa As Long
Dim ll As Long
Dim hkb As Long
Dim conv As Long, senc As Long
Dim msgPeekResult As Msg
Dim hwnd As Long
hwnd = Screen.ActiveForm.hwnd
PhaseRelation = 0
'Do While PeekMessage(msgPeekResult, hwnd, 0, 0, PM_REMOVE) = 1
' TranslateMessage msgPeekResult
' DispatchMessage msgPeekResult
'Loop
DoEvents
hkb = GetKeyboardLayout(0)
If ImmIsIME(hkb) = 0 Then
ImmSimulateHotKey hwnd, IME_THOTKEY_IME_NONIME_TOGGLE
End If
DoEvents
hct = ImmGetContext(hwnd)
If hct = 0 Then
Exit Function
End If
If ImmGetConversionStatus(hct, conv, senc) <> 1 Then
ImmReleaseContext hwnd, hct
Exit Function
End If
If vbShow Then
senc = senc Or IME_SMODE_PHRASEPREDICT
Else
senc = senc And (Not IME_SMODE_PHRASEPREDICT)
End If
If ImmSetConversionStatus(hct, conv, senc) = 1 Then
PhaseRelation = 1
End If
ImmReleaseContext hwnd, hct
End Function
' 使用示例: ImeFullShape(True); // 全形
' ImeFullShape(False); // 半形
Public Sub ImeFullShape(ByVal vbFull As Boolean)
Dim msgPeekResult As Msg
Dim hwnd As Long
hwnd = Screen.ActiveForm.hwnd
If ImmIsIME(GetKeyboardLayout(0)) = 0 Then
ImmSimulateHotKey hwnd, IME_THOTKEY_IME_NONIME_TOGGLE
End If
'Do While PeekMessage(msgPeekResult, hwnd, 0, 0, PM_REMOVE) = 1
' TranslateMessage msgPeekResult
' DispatchMessage msgPeekResult
'Loop
DoEvents
ImmSimulateHotKey hwnd, IME_THOTKEY_SHAPE_TOGGLE
End Sub
'下一輸入法
Public Sub ImeNextIme()
ActivateKeyboardLayout HKL_NEXT, 0
End Sub
'hKB :keyboard handle, cChinaWord:中文字, nth :第n個拆字法（字根組合),由1起算
Public Function ImeQueryComp(ByVal hkb As Long, ByVal bChinaWord As String, Optional nth As Variant) As String
Dim iMaxkey As Long, dwGCL As Long
Dim tCandidate As CANDIDATELIST
Dim iStart As Long, i As Long, j As Long, icount As Integer
Dim dwBuff() As Byte
Dim Result() As Byte
If IsMissing(nth) Then
nth = 1
End If
ImeQueryComp = ""
iMaxkey = ImmEscape(hkb, 0, IME_ESC_MAX_KEY, vbNullString)
If iMaxkey <= 0 Then Exit Function
' 看看這個輸入法是否支援 Reverse Conversion 功能
' 同時, 偵測需要多大的空間容納取得的資訊
dwGCL = ImmGetConversionList(hkb, 0, bChinaWord, _
tCandidate, 0, GCL_REVERSECONVERSION)
If dwGCL <= 0 Then Exit Function '該輸入法不支援 Reverse Conversion 功能
'取得組字字根資訊, dwGCL 的值必須以上次呼叫 ImmGetConversionList
'傳回值代入
ReDim dwBuff(dwGCL)
dwGCL = ImmGetConversionList(hkb, 0, bChinaWord, dwBuff(0), _
dwGCL, GCL_REVERSECONVERSION)
icount = dwBuff(8) '取得一共多少種字根組合，如"的"就有三種
If dwGCL > 0 Then
If nth > icount Then '沒有nth個的candidate
Exit Function
End If
iStart = dwBuff(24 + (nth - 1) * 4)
j = 0
ReDim Result(iMaxkey * 2)
For i = iStart To iStart + iMaxkey * 2
Result(j) = dwBuff(i)
j = j + 1
Next i
ImeQueryComp = StrConv(Result, vbUnicode)
End If
End Function
'取得Composition Window內的字串(字根未完成)
Public Function GetCompCurrString() As String
Dim hct As Long
Dim ll As Long
Dim len5 As Long
Dim str5() As Byte
Dim hwnd As Long
hwnd = Screen.ActiveForm.hwnd
GetCompCurrString = ""
hct = ImmGetContext(hwnd)
If hct = 0 Then
Exit Function
End If
ll = ImmGetCompositionString(hct, GCS_COMPSTR, vbNullString, 0)
If ll > 0 Then
ReDim str5(0 To ll)
len5 = ImmGetCompositionString(hct, GCS_COMPSTR, str5(0), ll)
GetCompCurrString = StrConv(str5, vbUnicode)
End If
ImmReleaseContext hwnd, hct
End Function
'取得字根的結果
Public Function GetCompositionResult() As String
Dim hct As Long
Dim ll As Long
Dim len5 As Long
Dim str5() As Byte
Dim hwnd As Long
hwnd = Screen.ActiveForm.hwnd
GetCompositionResult = ""
hct = ImmGetContext(hwnd)
If hct = 0 Then
Exit Function
End If
ll = ImmGetCompositionString(hct, GCS_RESULTSTR, vbNullString, 0)
If ll > 0 Then
ReDim str5(0 To ll)
len5 = ImmGetCompositionString(hct, GCS_RESULTSTR, str5(0), ll)
GetCompositionResult = StrConv(str5, vbUnicode)
End If
ImmReleaseContext hwnd, hct
End Function
'取得Composition Window內的字串(字根已完成)
Public Function GetCompLastStr() As String
Dim hct As Long
Dim ll As Long
Dim len5 As Long
Dim str5() As Byte
Dim hwnd As Long
hwnd = Screen.ActiveForm.hwnd
GetCompLastStr = ""
hct = ImmGetContext(hwnd)
If hct = 0 Then
Exit Function
End If
ll = ImmGetCompositionString(hct, GCS_RESULTREADSTR, vbNullString, 0)
If ll > 0 Then
ReDim str5(0 To ll)
len5 = ImmGetCompositionString(hct, GCS_RESULTREADSTR, str5(0), ll)
GetCompLastStr = StrConv(str5, vbUnicode)
End If
ImmReleaseContext hwnd, hct
End Function
'設定字根到composition window
Public Function SetCompString(ByVal str5 As String) As Long
Dim hct As Long
Dim ll As Long, len5 As Long
Dim hwnd As Long
hwnd = Screen.ActiveForm.hwnd
len5 = LenB(StrConv(str5, vbFromUnicode))
SetCompString = 0
hct = ImmGetContext(hwnd)
If hct = 0 Then Exit Function
ll = ImmSetCompositionString(hct, SCS_SETSTR, str5, len5, vbNullString, 0)
If ll = 1 Then SetCompString = 1
ImmReleaseContext hwnd, hct
End Function
'取得按目前ctrl-space時的中文輸入法keyboard handle， 並切換到中文
Public Function toChinese() As Long
Dim hkb As Long
Dim msgPeekResult As Msg
Dim hwnd5 As Long
hwnd5 = Screen.ActiveForm.hwnd
DoEvents
hkb = GetKeyboardLayout(0)
If ImmIsIME(hkb) = 0 Then
ImmSimulateHotKey hwnd5, IME_THOTKEY_IME_NONIME_TOGGLE
DoEvents
toChinese = GetKeyboardLayout(0)
Else
toChinese = hkb
End If
End Function
Public Sub ShowImeConfig(ByVal hkb5 As Long)
Dim hwnd5 As Long
hwnd5 = Screen.ActiveForm.hwnd
ImmConfigureIMEA hkb5, hwnd5, 1, vbNullString
End Sub
'若同一個字根拆法，有多個字符合時用之，如:"一" 一共有34個與之同音，
'傳回第nth個字，這個function在字根全部出來後，且尚未選取時才有作用
Public Function GetCandidateString(ByVal nth As Long) As String
Dim hct As Long
Dim cd As CANDIDATELIST
Dim nBuff As Long, start As Long
Dim Buff() As Byte
Dim hwnd As Long, offset As Long
Dim str5 As String
Dim i As Long
GetCandidateString = ""
hwnd = Screen.ActiveForm.hwnd
hct = ImmGetContext(hwnd)
nBuff = ImmGetCandidateList(hct, 0, cd, 0)
'nBuff = ImmGetCandidateList(hct, 0, cd, nBuff)
If nBuff = 0 Then
ImmReleaseContext hwnd, hct
Exit Function
End If
ReDim Buff(nBuff)
nBuff = ImmGetCandidateList(hct, 0, Buff(0), nBuff)
If nth > Buff(8) Then '沒有第n個字, cd.dwCount為一共多少個
ImmReleaseContext hwnd, hct
Exit Function '字有相同字根，如與一同音者一共34個
End If
start = 24 + (nth - 1) * 4 '取得存offset的起始位置
offset = Buff(start) + Buff(start + 1) * 2 ^ 8 '取得第nth個字所在的offset
GetCandidateString = StrConv(MidB(Buff, offset + 1, 2), vbUnicode)
ImmReleaseContext hwnd, hct
End Function
'傳回所有的CandidateList字串
Public Function GetAllCandidateString(vstrAry() As String) As Integer
On Error GoTo ErrHandler
Dim hct As Long
Dim cd As CANDIDATELIST
Dim nBuff As Long, start As Long
Dim Buff() As Byte, intCount As Integer
Dim hwnd As Long, offset As Long
Dim str5 As String
Dim i As Long
GetAllCandidateString = 0
hwnd = Screen.ActiveForm.hwnd
hct = ImmGetContext(hwnd)
nBuff = ImmGetCandidateList(hct, 0, cd, 0)
If nBuff = 0 Then
Exit Function
End If
ReDim Buff(nBuff - 1)
nBuff = ImmGetCandidateList(hct, 0, Buff(0), nBuff)
intCount = Buff(8)
If intCount > 0 Then ReDim vstrAry(intCount - 1)
For i = 0 To intCount - 1
start = 24 + i * 4 '取得存offset的起始位置
offset = Buff(start) + Buff(start + 1) * 2 ^ 8 '取得第nth個字所在的offset
vstrAry(i) = StrConv(MidB(Buff, offset + 1, 2), vbUnicode)
Next
GetAllCandidateString = intCount
ImmReleaseContext hwnd, hct
Exit Function
ErrHandler:
End Function
'取消這次的字根組合
Public Function CancelComposition() As Long
Dim hwnd As Long
Dim hct As Long
hwnd = Screen.ActiveForm.hwnd
hct = ImmGetContext(hwnd)
CancelComposition = ImmNotifyIME(hct, NI_COMPOSITIONSTR, CPS_CANCEL, 0)
ImmReleaseContext hwnd, hct
End Function
'選擇這次的字根組合結果中，第nth個字
Public Function CompleteComposition(ByVal nth As Long) As Long
Dim hwnd As Long
Dim hct As Long
hwnd = Screen.ActiveForm.hwnd
hct = ImmGetContext(hwnd)
CompleteComposition = ImmNotifyIME(hct, NI_OPENCANDIDATE, 0, 0)
ImmReleaseContext hwnd, hct
End Function
'改變成中文輸入
Public Sub Chg2Chinese(ByVal hwnd As Long) '傳入Control項或Form 的hwnd
Dim hkb As Long
hkb = GetKeyboardLayout(0) '取得目前Thread的Keyboard Layout
If ImmIsIME(hkb) = 0 Then '代表不是中文輸入
ImmSimulateHotKey hwnd, IME_THOTKEY_IME_NONIME_TOGGLE '模擬按Strl-Space
End If
End Sub
'改變成英文輸入
Public Sub ChangeToEnglish() '轉換至 English Keyboard Layout
LoadKeyboardLayout ENG_CODE_PAGE, KLF_ACTIVATE
End Sub
Public Sub Chg2English(ByVal hwnd As Long) '傳入Control項或Form 的hwnd Window 2000 及XP 沒有效用
Dim hkb As Long
Dim hthr As Long, pid As Long
hthr = GetWindowThreadProcessId(hwnd, pid)
hkb = GetKeyboardLayout(hthr) '取得目前Thread的Keyboard Layout
If ImmIsIME(hkb) = 1 Then '代表是中文輸入 不能正確檢查中文狀態
ImmSimulateHotKey hwnd, IME_THOTKEY_IME_NONIME_TOGGLE '模擬按Strl-Space
End If
End Sub
'設定某個中文輸入法 如:Call ActiveIMEKeyBoard("大易")
Public Function ActiveIMEKeyBoard(ByVal ImeName As String) As Boolean
Dim hkbd As Long, i As Long
ActiveIMEKeyBoard = True
hkbd = GetIMEKeyBoardHandle(ImeName)
If hkbd <> 0 Then
i = ActivateKeyboardLayout(hkbd, 0)
If i <> 0 Then
ActiveIMEKeyBoard = True
End If
End If
End Function
'取得某個中文輸入法的Keyboard Handle ImeNmae傳入"大易" "注音" 等
'傳回0表示沒有找到
Public Function GetIMEKeyBoardHandle(ByVal ImeName As String) As Long
Dim hkb5(24) As Long, i As Long
Dim kln As String
Dim BuffLen As Long
Dim Buff As String
Dim RetStr As String, res As Long
Dim RetCount As Long, LayOutNo As Long
Buff = String(255, 0)
BuffLen = 255
kln = String(8, 0)
LayOutNo = GetKeyboardLayoutList(25, hkb5(0))
GetIMEKeyBoardHandle = 0
For i = 0 To LayOutNo - 1
ActivateKeyboardLayout hkb5(i), 0
res = GetKeyboardLayoutName(kln)
RetCount = ImmGetDescription(hkb5(i), Buff, BuffLen)
RetStr = Left(Buff, RetCount)
If InStr(1, RetStr, ImeName) <> 0 Then
GetIMEKeyBoardHandle = hkb5(i)
Exit Function
End If
Next i
End Function
'隱藏IME status Window，但只能隱藏一次，下次再叫會再出現
Public Function HideStatusWindow(ByVal IMEType As String) As Boolean
Dim hwnd5 As Long, ClassName As String
If IMEType = "注音" Then ClassName = "offPHON"
If IMEType = "大易" Then ClassName = "offDAYI"
If IMEType = "倉頡" Then ClassName = "OffCHAJEI"
hwnd5 = FindWindow(ClassName, vbNullString)
If hwnd5 = 0 Then Exit Function
Call ShowWindow(hwnd5, SW_HIDE)
HideStatusWindow = True
End Function
