VB6 - やするん＠Wiki

• なんかBASファイルがでてきた

漢字をカナにコンバートするプログラムらしい。
DBに漢字でしか名前が入っていないのに、「かな検索できるようにしてくれ！」
とか無茶ぶりされて、WEBのどこかから仕入れたコードででっちあげた代物だと思う。

あ、コメントに書いてあった。
http://plaza.rakuten.co.jp/pgmemo/diary/200512060000/
どうもその節はお世話になりました(*_ _)

良い子のみなさんは人名リストをDBで管理するときは
ふりがなのカラムもきちんと用意しませう。

Attribute VB_Name = "KanjiKanaConvert"
' このプログラムは以下のサイトから取得したものを利用しています。
' http://plaza.rakuten.co.jp/pgmemo/diary/200512060000/
Option Explicit

Const GCL_CONVERSION = 1
Const GCL_REVERSECONVERSION = 2

Const VER_PLATFORM_WIN32_WINDOWS = 1
Const VER_PLATFORM_WIN32_NT = 2

'==IME 関連==
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

'文字列長取得(Unicode）
Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" ( _
    ByRef strString As Any _
) As Long

'==OS バージョン取得==
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 ReverseConversion(strSource As String) As String

    Dim bySource() As Byte '前変換用

    Dim hIMC As Long '入力コンテキストハンドル
    Dim hKL As Long 'キーボードレイアウトハンドル
    Dim lngSize As Long '変換後バッファサイズ
    Dim lngOffset As Long '変換文字列候補オフセットアドレス

    Dim byCandiateArray() As Byte '変換結果バッファ
    Dim CandiateList As CANDIDATELIST

    Dim byWork() As Byte
    Dim lngResult As Long

    Dim osvi As OSVERSIONINFO

    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系:シフトJISに変換
        bySource = StrConv(strSource, vbFromUnicode)

        '終端を付加
        ReDim Preserve bySource(UBound(bySource) + 1)
    End If

    hIMC = ImmGetContext(Forms(0).hWnd)
    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)

            '"ふりがな"取得
            ReverseConversion = MidB(byCandiateArray, lngOffset + 1, _
                                     lstrlen(byCandiateArray(lngOffset)) * 2)

        End If

    End If

    lngResult = ImmReleaseContext(Forms(0).hWnd, hIMC)

End Function