漢字→ふりがな逆変換
少しでも精度を上げるために、ふりがなの出現順にソートしたりしてます。
( general ) の ( Declarations ) ----------
Private Declare Function GetKeyboardLayout Lib "user32" (ByVal dwLayout As Long) As Long
Private Declare Function ImmCreateContext Lib "imm32.dll" () 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
Declare Function ImmDestroyContext Lib "imm32.dll" (ByVal himc As Long) As Long
Private Const GCL_CONVERSION = &H1
Private Const GCL_REVERSECONVERSION = &H2
Private Const IME_ESC_MAX_KEY = &H1005
Private 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
( Function本体 ) ----------
Public Function GetPhonetic(IN漢字 As Variant) As String
’ふりがな取得。APIバージョン
Dim wkBufLen As Long
Dim DMYCand As CANDIDATELIST ’ダミー
Dim wkBuff() As Byte ’変換結果はここに入る
Dim result() As Byte
Dim KL As Long
Dim IMC As Long
Dim i As Long， j As Long
Dim iStart As Long
Dim iCount As Integer
Dim iEnd As Integer
Dim wk結果() As String
Dim wkSTR As String
Dim wkIDX As Integer
Dim wkFLG As Integer
Dim idxMAX As Integer
GetPhonetic = ""
KL = GetKeyboardLayout(0)
IMC = ImmCreateContext()
’wkBufLenを得る為のダミーコール
wkBufLen = ImmGetConversionList(KL， IMC， IN漢字， DMYCand， 0， GCL_REVERSECONVERSION)
If wkBufLen <= 0 Then Exit Function
’本番
ReDim wkBuff(wkBufLen)
wkBufLen = ImmGetConversionList(KL， IMC， IN漢字， wkBuff(0)， wkBufLen， GCL_REVERSECONVERSION)
ReDim wk結果(1 To wkBuff(8)， 1 To 2)
If wkBufLen > 0 Then
idxMAX = 0
For iCount = 1 To wkBuff(8)
wk結果(iCount， 1) = ""
wk結果(iCount， 2) = 0
iStart = wkBuff(24 + (iCount - 1) * 4)
iStart = iStart + 256 * (wkBuff(25 + (iCount - 1) * 4))
If iCount < wkBuff(8) Then
iEnd = wkBuff(24 + iCount * 4)
iEnd = iEnd + 256 * (wkBuff(25 + iCount * 4)) - 2
Else
iEnd = wkBufLen - 2
End If
j = 0
ReDim result(iEnd - iStart)
For i = iStart To iEnd
If wkBuff(i) = 0 Then
result(j) = &H20
Else
result(j) = wkBuff(i)
End If
j = j + 1
Next i
GoSub 結果セット
Next iCount
End If
i = ImmDestroyContext(IMC)
GoSub 結果ソート
’wk結果が郵便番号の可能性も有るので、それ以外の一番最初の変換結果を返す
For iCount = 1 To idxMAX
wkSTR = RepString(wk結果(iCount， 1)， "－"， "")
’最初の一文字で数値かどうかを判断する
If Not IsNumeric(Left(wkSTR， 1)) Then
wkSTR = StrConv(wkSTR， vbKatakana)
GetPhonetic = StrConv(wkSTR， vbNarrow)
Exit For
End If
Next iCount
Exit Function
結果セット:
wkFLG = 0
wkSTR = Trim(StrConv(result， vbUnicode))
For wkIDX = 1 To iCount
If wk結果(wkIDX， 1) = wkSTR And wk結果(wkIDX， 1) <> "" Then
wkFLG = 1
Exit For
End If
Next wkIDX
If wkFLG = 1 Then
wk結果(wkIDX， 1) = wkSTR
wk結果(wkIDX， 2) = wk結果(wkIDX， 2) + 1
Else
idxMAX = idxMAX + 1
wk結果(idxMAX， 1) = wkSTR
wk結果(idxMAX， 2) = 1
End If
Return
結果ソート:
For i = 1 To idxMAX - 1
For j = i + 1 To idxMAX
If CInt(wk結果(i， 2)) < CInt(wk結果(j， 2)) Then
wkSTR = wk結果(i， 1)
wkIDX = CInt(wk結果(i， 2))
wk結果(i， 1) = wk結果(j， 1)
wk結果(i， 2) = wk結果(j， 2)
wk結果(j， 1) = wkSTR
wk結果(j， 2) = wkIDX
End If
Next j
Next i
Return
End Function
© Rakuten Group, Inc.
