白執事の徒然なる日々

'************************************************************************
' PaSoRiが抜き差しされたタイミングで詳細情報を取得します。
'------------------------------------------------------------------------
' (1) WndProc() でUSBデバイスの抜き差しを検知します。
'     --> Windowsメッセージが WM_DEVICECHANGE の場合に処理
' (2) 別スレッドでPaSoRiの情報を取得します。
'     --> WMI(Windows Management Instrumentation)を使用
'         WMIの情報取得に多少時間がかかるため、別スレッドで実行します。
' (3) 別スレッドから画面のコントロールを操作します。
'     --> Delegateを宣言、Invokeで呼び出す
'------------------------------------------------------------------------
' VB.NETのマルチスレッドに関しては下記URLに具体的なサンプルがございます。
' http://codezine.jp/article/detail/135?p=1
'
' WMIに関しては下記URLを参考にしました。
' http://www.wmifun.net/library/win32_pnpentity.html
'************************************************************************

Imports System.Threading
Imports System.Management

Public Class Form1

    '================
    ' Win32 API 定数
    '================
    Private Const WM_DEVICECHANGE As Integer = &H219  'USBに抜き差しを検知

    '================
    ' フォームロード
    '================
    Private Sub Form1_Load(sender As System.Object, e As System.EventArgs) Handles MyBase.Load
        '-------------------------------------
        ' PaSoRi が接続済みの場合は情報を取得
        '-------------------------------------
        thread_GetWMI()
    End Sub

    '================================================
    ' 別スレッドから関数を呼び出すためのDelegate宣言
    '================================================
    Delegate Sub txtWMI_Clear_Delegate()
    Delegate Sub txtWMI_Show_Delegate(ByVal msg As String)

    '===================================================
    '【関数名】txtWMI_Clear
    '【引  数】なし
    '【戻り値】なし
    '---------------------------------------------------
    ' txtWMI.Text に表示されているメッセージを消去する。
    '===================================================
    Private Sub txtWMI_Clear()
        txtWMI.Text = ""
    End Sub

    '===========================================
    '【関数名】txtWMI_Show
    '【引  数】[in] String  表示するメッセージ
    '【戻り値】なし
    '-------------------------------------------
    ' txtWMI.Text に指定のメッセージを表示する。
    '===========================================
    Private Sub txtWMI_Show(ByVal msg As String)
        txtWMI.Text = msg
    End Sub

    '========================================================================
    '【関数名】WndProc
    '【引  数】System.Windows.Forms.Message  OSから送られたWindowsメッセージ
    '【戻り値】なし
    '------------------------------------------------------------------------
    ' Windowsメッセージを処理します。
    '========================================================================
    Protected Overrides Sub WndProc(ByRef m As System.Windows.Forms.Message)
        '--------------------
        ' デバイス変更の検知
        '--------------------
        If m.Msg = WM_DEVICECHANGE Then
            '時間のかかる処理を別スレッドで実行
            Dim th As New Thread(New ThreadStart(AddressOf thread_GetWMI))
            th.Start()
            Return
        End If

        '----------------------------------------
        ' 上記以外の場合はメッセージを処理しない
        '----------------------------------------
        MyBase.WndProc(m)
    End Sub

    '===============================================================================
    '【関数名】thread_GetWMI
    '【引  数】なし
    '【戻り値】なし
    '-------------------------------------------------------------------------------
    ' WMIの情報を取得して、txtWMI.Textに表示する。
    ' デバイス名に PaSoRi が含まれていて、正常に動作しているものだけを抜き出します。
    '===============================================================================
    Private Sub thread_GetWMI()
        Try
            '--------------------------------
            ' Delegate宣言した関数の使用準備
            '--------------------------------
            Dim txtWMIClear As New txtWMI_Clear_Delegate(AddressOf txtWMI_Clear)
            Dim txtWMIShow As New txtWMI_Show_Delegate(AddressOf txtWMI_Show)

            '--------------------------------
            ' テキストボックスの情報をクリア
            '--------------------------------
            Invoke(txtWMIClear)

            '--------------------
            ' デバイス情報を取得
            '--------------------
            Dim oms As New ManagementObjectSearcher
            Dim omc As ManagementObjectCollection

            'デバイス名に PaSoRi が含まれていて、正常に動作しているものを検索する
            oms.Query.QueryString = "select * from Win32_PnPEntity " & _
                                    "where Name like '%PaSoRi%' and ConfigManagerErrorCode = 0"
            omc = oms.Get()

            Dim msg As String = ""

            For Each mo As ManagementObject In omc

                Dim list_CompatibleID As String()
                Dim list_HardwareID As String()
                Dim dt As New DateTime

                'Availability
                Select Case mo.Item("Availability")
                    Case 3
                        msg &= "Availability：[3] 電力 - 通常"
                    Case 4
                        msg &= "Availability：[4] 電力 - 警告"
                    Case 5
                        msg &= "Availability：[5] 電力 - テスト中"
                    Case 10
                        msg &= "Availability：[10] 電力 - 低下"
                    Case 13
                        msg &= "Availability：[13] 省電力 - 不明"
                    Case 14
                        msg &= "Availability：[14] 省電力 - 低電力モード"
                    Case 15
                        msg &= "Availability：[15] 省電力 - スタンバイ"
                    Case 17
                        msg &= "Availability：[17] 省電力 - 警告"
                    Case Else
                        msg &= "Availability："
                End Select
                msg &= vbNewLine

                'Caption
                msg &= "Caption：" & mo.Item("Caption") & vbNewLine

                'ClassGuid
                msg &= "ClassGuid：" & mo.Item("ClassGuid") & vbNewLine

                'CompatibleID
                msg &= "CompatibleID："
                If mo.Item("CompatibleID") IsNot Nothing Then
                    list_CompatibleID = mo.Item("CompatibleID")
                    For I As Integer = 0 To list_CompatibleID.Length() - 1
                        msg &= list_CompatibleID(I)

                        If I <> list_CompatibleID.Length() - 1 Then
                            msg &= ", "
                        End If
                    Next
                End If
                msg &= vbNewLine

                'ConfigManagerErrorCode
                Select Case mo.Item("ConfigManagerErrorCode")
                    Case 0
                        msg &= "ConfigManagerErrorCode：[0] " & _
                               "このデバイスは正常に動作しています。"
                    Case 1
                        msg &= "ConfigManagerErrorCode：[1] " & _
                               "このデバイスは正しく構成されていません。"
                    Case 2
                        msg &= "ConfigManagerErrorCode：[2] " & _
                               "このデバイスのドライバーを読み込めません。"
                    Case 3
                        msg &= "ConfigManagerErrorCode：[3] " & _
                               "このデバイスのドライバーは壊れているか、" & _
                               "あるいはメモリまたは他のリソースが不足している状態で" & _
                               "システムが実行されている可能性があります。"
                    Case 4
                        msg &= "ConfigManagerErrorCode：[4] " & _
                               "このデバイスは正常に動作していません。" & _
                               "ドライバーまたはレジストリが壊れている可能性があります。"
                    Case 5
                        msg &= "ConfigManagerErrorCode：[5] " & _
                               "このデバイスのドライバーには Windows が管理できないリソースが必要です。"
                    Case 6
                        msg &= "ConfigManagerErrorCode：[6] " & _
                               "このデバイスのブート構成が他のデバイスと競合しています。"
                    Case 7
                        msg &= "ConfigManagerErrorCode：[7] " & _
                               "フィルター処理できません。"
                    Case 8
                        msg &= "ConfigManagerErrorCode：[8] " & _
                               "デバイスのドライバー ローダーが見つかりません。"
                    Case 9
                        msg &= "ConfigManagerErrorCode：[9] " & _
                               "このデバイスを制御するファームウェアからリソースが正しく報告されないため、" & _
                               "このデバイスは正常に動作していません。"
                    Case 10
                        msg &= "ConfigManagerErrorCode：[10] " & _
                               "このデバイスを開始できません。"
                    Case 11
                        msg &= "ConfigManagerErrorCode：[11] " & _
                               "このデバイスはエラーで停止しました。"
                    Case 12
                        msg &= "ConfigManagerErrorCode：[12] " & _
                               "このデバイスで使用できる十分な空きリソースが見つかりません。"
                    Case 13
                        msg &= "ConfigManagerErrorCode：[13] " & _
                               "このデバイスのリソースを確認できません。"
                    Case 14
                        msg &= "ConfigManagerErrorCode：[14] " & _
                               "コンピューターを再起動するまでこのデバイスは正常に動作しません。"
                    Case 15
                        msg &= "ConfigManagerErrorCode：[15] " & _
                               "このデバイスは、再列挙に問題が発生している可能性があり、" & _
                               "正常に動作していません。"
                    Case 16
                        msg &= "ConfigManagerErrorCode：[16] " & _
                               "このデバイスで使用される一部のリソースを認識できません。"
                    Case 17
                        msg &= "ConfigManagerErrorCode：[17] " & _
                               "このデバイスは不明なリソースの種類を要求しています。"
                    Case 18
                        msg &= "ConfigManagerErrorCode：[18] " & _
                               "このデバイスのドライバーを再インストールしてください。"
                    Case 19
                        msg &= "ConfigManagerErrorCode：[19] " & _
                               "レジストリが壊れている可能性があります。"
                    Case 20
                        msg &= "ConfigManagerErrorCode：[20] " & _
                               "VxD ローダーの使用に失敗しました。"
                    Case 21
                        msg &= "ConfigManagerErrorCode：[21] " & _
                               "システム エラー: このデバイスのドライバーを変更してみてください。" & _
                               "うまくいかない場合はハードウェアのマニュアルを参照してください。" & _
                               "このデバイスは削除されます。"
                    Case 22
                        msg &= "ConfigManagerErrorCode：[22] " & _
                               "このデバイスは無効になっています。"
                    Case 23
                        msg &= "ConfigManagerErrorCode：[23] " & _
                               "システム障害: このデバイスのドライバーを変更してみてください。" & _
                               "うまくいかない場合はハードウェアのマニュアルを参照してください。"
                    Case 24
                        msg &= "ConfigManagerErrorCode：[24] " & _
                               "このデバイスは存在しないか、正常に動作していないか、" & _
                               "または一部のドライバーがインストールされていません。"
                    Case 25
                        msg &= "ConfigManagerErrorCode：[25] " & _
                               "このデバイスはまだセットアップ処理中です。"
                    Case 26
                        msg &= "ConfigManagerErrorCode：[26] " & _
                               "このデバイスはまだセットアップ処理中です。"
                    Case 27
                        msg &= "ConfigManagerErrorCode：[27] " & _
                               "このデバイスに有効なログ構成がありません。"
                    Case 28
                        msg &= "ConfigManagerErrorCode：[28] " & _
                               "このデバイスのドライバーはインストールされていません。"
                    Case 29
                        msg &= "ConfigManagerErrorCode：[29] " & _
                               "このデバイスは、必要なリソースがデバイスのファームウェアから" & _
                               "提供されなかったため無効になっています。"
                    Case 30
                        msg &= "ConfigManagerErrorCode：[30] " & _
                               "このデバイスは、他のデバイスが使用している" & _
                               "割り込み要求 (IRQ) リソースを使用しています。"
                    Case 31
                        msg &= "ConfigManagerErrorCode：[31] " & _
                               "このデバイスは、このデバイスに必要なドライバーを" & _
                               "読み込めないため正常に動作していません。"
                    Case Else
                        msg &= "ConfigManagerErrorCode："
                End Select
                msg &= vbNewLine

                'ConfigManagerUserConfig
                If mo.Item("ConfigManagerUserConfig") Then
                    msg &= "ConfigManagerUserConfig：[TRUE] " & _
                           "デバイスがユーザー定義の構成を使用しています。"
                Else
                    msg &= "ConfigManagerUserConfig：[FALSE] " & _
                           "デバイスがユーザー定義の構成を使用していません。"
                End If
                msg &= vbNewLine

                'CreationClassName
                msg &= "CreationClassName：" & mo.Item("CreationClassName") & vbNewLine

                'Description
                msg &= "Description：" & mo.Item("Description") & vbNewLine

                'DeviceID
                msg &= "DeviceID：" & mo.Item("DeviceID") & vbNewLine

                'ErrorCleared
                If mo.Item("ErrorCleared") Then
                    msg &= "ErrorCleared：[TRUE] " & _
                           "LastErrorCode プロパティで報告されたエラーが現在解決されています。"
                Else
                    msg &= "ErrorCleared：[FALSE] " & _
                           "LastErrorCode プロパティで報告されたエラーが現在解決されていません。"
                End If
                msg &= vbNewLine

                'ErrorDescription
                msg &= "ErrorDescription：" & mo.Item("ErrorDescription") & vbNewLine

                'HardwareID
                msg &= "HardwareID："
                If mo.Item("HardwareID") IsNot Nothing Then
                    list_HardwareID = mo.Item("HardwareID")
                    For I As Integer = 0 To list_HardwareID.Length() - 1
                        msg &= list_HardwareID(I)

                        If I <> list_HardwareID.Length() - 1 Then
                            msg &= ", "
                        End If
                    Next
                End If
                msg &= vbNewLine

                'InstallDate
                If mo.Item("InstallDate") Is Nothing Then
                    msg &= "InstallDate："
                Else
                    dt = mo.Item("InstallDate")
                    msg &= "InstallDate：" & _
                           String.Format("{0:0000}/{1:00}/{2:00} {3:00}:{4:00}:{5:00}", _
                                         dt.Year, dt.Month, dt.Day, dt.Hour, dt.Minute, dt.Second)
                End If
                msg &= vbNewLine

                'LastErrorCode
                msg &= "LastErrorCode：" & CStr(mo.Item("LastErrorCode")) & vbNewLine

                'Manufacturer
                msg &= "Manufacturer：" & mo.Item("Manufacturer") & vbNewLine

                'Name
                msg &= "Name：" & mo.Item("Name") & vbNewLine

                'PNPDeviceID
                msg &= "PNPDeviceID：" & mo.Item("PNPDeviceID") & vbNewLine

                'PowerManagementCapabilities
                Select Case mo.Item("PowerManagementCapabilities")
                    Case 0
                        msg &= "PowerManagementCapabilities：[0] 不明"
                    Case 1
                        msg &= "PowerManagementCapabilities：[1] サポートされていません"
                    Case 2
                        msg &= "PowerManagementCapabilities：[2] 無効"
                    Case 3
                        msg &= "PowerManagementCapabilities：[3] 有効"
                    Case 4
                        msg &= "PowerManagementCapabilities：[4] 自動省電力モード"
                    Case 5
                        msg &= "PowerManagementCapabilities：[5] 電源の状態設定可能"
                    Case 6
                        msg &= "PowerManagementCapabilities：[6] 電源サイクル サポート"
                    Case 7
                        msg &= "PowerManagementCapabilities：[7] 時刻指定電源オン サポート"
                    Case Else
                        msg &= "PowerManagementCapabilities："
                End Select
                msg &= vbNewLine

                'PowerManagementSupported
                If mo.Item("PowerManagementSupported") Then
                    msg &= "PowerManagementSupported：[TRUE] " & _
                           "デバイスの電源管理が可能。"
                Else
                    msg &= "PowerManagementSupported：[FALSE] " & _
                           "デバイスの電源管理がサポートされていません。"
                End If
                msg &= vbNewLine

                'Service
                msg &= "Service：" & mo.Item("Service") & vbNewLine

                'Status
                msg &= "Status：" & mo.Item("Status") & vbNewLine

                'StatusInfo
                Select Case mo.Item("StatusInfo")
                    Case 1
                        msg &= "StatusInfo：[1]その他の状態"
                    Case 2
                        msg &= "StatusInfo：[2]不明な状態"
                    Case 3
                        msg &= "StatusInfo：[3]論理デバイスが有効"
                    Case 4
                        msg &= "StatusInfo：[4]無効"
                    Case 5
                        msg &= "StatusInfo：[5]該当なし"
                    Case Else
                        msg &= "StatusInfo："
                End Select
                msg &= vbNewLine

                'SystemCreationClassName
                msg &= "SystemCreationClassName：" & mo.Item("SystemCreationClassName") & vbNewLine

                'SystemName
                msg &= "SystemName：" & mo.Item("SystemName") & vbNewLine
                msg &= vbNewLine
            Next

            '------------------
            ' 画面に情報を表示
            '------------------
            Invoke(txtWMIShow, New Object() {msg})
        Catch ex As Exception
            MessageBox.Show(ex.Message, Me.Text, MessageBoxButtons.OK, MessageBoxIcon.Exclamation)
        End Try
    End Sub
End Class

Public Class Form1
    '======================
    ' felicalib.dll クラス
    '======================
    Private felicalib As New CFelicaLib

    '================
    ' フォームロード
    '================
    Private Sub Form1_Load(sender As System.Object, e As System.EventArgs) Handles MyBase.Load
        '------------------
        ' DLL 存在チェック
        '------------------
        If Not isDLLExists() Then
            MessageBox.Show("felicalib.dll がありません。", Me.Text)
            Application.Exit()
        End If

        '------------------
        ' ボタンの名前変更
        '------------------
        btnFelica.Text = "FeliCa 読み取り"
    End Sub

    '======================
    ' ボタン・クリック処理
    '======================
    Private Sub btnFelica_Click(sender As System.Object, e As System.EventArgs) Handles btnFelica.Click
        Dim sIDm As String
        Dim sPMm As String
        Dim sMsg As String

        '-------------------
        ' PaSoRi に接続する
        '-------------------
        If Not felicalib.Pasori_Connect() Then
            MessageBox.Show("PaSoRi に接続できませんでした。", Me.Text)
            Return
        End If

        '----------------------------
        ' ポーリング(FeliCa読み取り)
        '----------------------------
        If felicalib.Polling() Then
            '-----------------
            ' IDm, PMm を取得
            '-----------------
            sIDm = felicalib.getIDm()
            sPMm = felicalib.getPMm()

            '------------------
            ' メッセージを表示
            '------------------
            sMsg = "IDm=[" & sIDm & "]" & vbNewLine & _
                   "PMm=[" & sPMm & "]"
            MessageBox.Show(sMsg, Me.Text)
        Else
            '--------------------------
            ' ポーリングに失敗した場合
            '--------------------------
            MessageBox.Show("FeliCa がセットされていません。", Me.Text)
        End If

        '-------------------
        ' PaSoRi を解放する
        '-------------------
        felicalib.Pasori_Free()
    End Sub
End Class

Imports System.Runtime.InteropServices
Imports UInt8 = System.Byte

Module modFelicaLib
    Private Const MAX_SYSTEM_CODE = 8
    Private Const MAX_AREA_CODE = 16
    Private Const MAX_SERVICE_CODE = 256

    '-------------------------------
    ' FeliCa の情報を格納する構造体
    '-------------------------------
    <StructLayout(LayoutKind.Sequential)> _
    Private Structure felica
        Public p As IntPtr           'PaSoRi ハンドル
        Public systemcode As UInt16  'システムコード
        <MarshalAs(UnmanagedType.ByValArray, SizeConst:=8)> _
        Public IDm() As UInt8        'IDm
        <MarshalAs(UnmanagedType.ByValArray, SizeConst:=8)> _
        Public PMm() As UInt8        'PMm

        'systemcode
        Public num_system_code As UInt8      '列挙システムコード数
        <MarshalAs(UnmanagedType.ByValArray, SizeConst:=MAX_SYSTEM_CODE)> _
        Public system_code() As UInt16       '列挙システムコード

        'area/service codes
        Public num_area_code As UInt8        'エリアコード数
        <MarshalAs(UnmanagedType.ByValArray, SizeConst:=MAX_AREA_CODE)> _
        Public area_code() As UInt16         'エリアコード
        <MarshalAs(UnmanagedType.ByValArray, SizeConst:=MAX_AREA_CODE)> _
        Public end_service_code() As UInt16  'エンドサービスコード

        Public num_service_code As UInt8     'サービスコード数
        <MarshalAs(UnmanagedType.ByValArray, SizeConst:=MAX_SERVICE_CODE)> _
        Public service_code() As UInt16      'サービスコード
    End Structure

    '-----------
    ' constants
    '-----------
    'システムコード (ネットワークバイトオーダ/ビックエンディアンで表記)
    Private Const POLLING_ANY = &HFFFF
    Private Const POLLING_EDY = &HFE00  'システムコード: 共通領域 (Edyなどが使用)
    Private Const POLLING_SUICA = &H3   'システムコード: サイバネ領域

    '------
    ' APIs
    '------
    '【関 数 名】pasori_open
    '【第１引数】[in] dummy
    '【戻 り 値】pasori  ハンドル
    <DllImport("felicalib.dll")> _
    Private Function pasori_open(ByVal dummy As IntPtr) As IntPtr
    End Function

    '【関 数 名】pasori_close
    '【第１引数】[in] p  pasoriハンドル (pasori_open で得たポインタを指定する)
    <DllImport("felicalib.dll")> _
    Private Sub pasori_close(ByVal p As IntPtr)
    End Sub

    '【関 数 名】InteropServices
    '【第１引数】[in] p  pasoriハンドル (pasori_open で得たポインタを指定する)
    '【戻 り 値】エラーコード
    <DllImport("felicalib.dll")> _
    Private Function pasori_init(ByVal p As IntPtr) As Integer
    End Function

    '【関 数 名】felica_polling
    '【第１引数】[in] p           pasoriハンドル (pasori_open で得たポインタを指定する)
    '【第２引数】[in] systemcode  システムコード
    '【第３引数】[in] RFU         RFU (使用しない)
    '【第４引数】[in] timeslot    タイムスロット
    '【戻 り 値】felicaハンドル (MarshalクラスのPtrToStructureメソッドを使用)
    <DllImport("felicalib.dll")> _
    Private Function felica_polling( _
        ByVal p As IntPtr, _
        ByVal systemcode As UInt16, _
        ByVal RFU As UInt8, _
        ByVal timeslot As UInt8 _
    ) As IntPtr
    End Function

    '【関 数 名】felica_free
    '【第１引数】[in] f  felicaハンドル (felica構造体のポインタを指定する)
    <DllImport("felicalib.dll")> _
    Private Sub felica_free(ByVal f As IntPtr)
    End Sub

    '【関 数 名】felica_getidm
    '【第１引数】[in]  f   felicaハンドル (felica構造体のポインタを指定する)
    '【第２引数】[out] buf IDm を格納するバッファ(8バイト)
    <DllImport("felicalib.dll")> _
    Private Sub felica_getidm(ByVal f As IntPtr, ByVal buf As IntPtr)
    End Sub

    '【関 数 名】felica_getpmm
    '【第１引数】[in]   f    felicaハンドル (felica構造体のポインタを指定する)
    '【第２引数】[out]  buf  PMm を格納するバッファ(8バイト)
    <DllImport("felicalib.dll")> _
    Private Sub felica_getpmm(ByVal f As IntPtr, ByVal buf As IntPtr)
    End Sub

    '【関 数 名】felica_read_without_encryption02
    '【第１引数】[in]   f            felicaハンドル (felica構造体のポインタを指定する)
    '【第２引数】[in]   servicecode  サービスコード
    '【第３引数】[in]   mode         モード(使用しない)
    '【第４引数】[in]   addr         ブロック番号
    '【第５引数】[out]  data         データ(16バイト)
    '【戻 り 値】エラーコード
    <DllImport("felicalib.dll")> _
    Private Function felica_read_without_encryption02( _
        ByVal f As IntPtr, _
        ByVal servicecode As Integer, _
        ByVal mode As Integer, _
        ByVal addr As UInt8, _
        ByVal buf As IntPtr _
    ) As Integer
    End Function

    '【関 数 名】felica_write_without_encryption
    '【第１引数】[in]   f            felicaハンドル (felica構造体のポインタを指定する)
    '【第２引数】[in]   servicecode  サービスコード
    '【第３引数】[in]   mode         モード(使用しない)
    '【第４引数】[in]   addr         ブロック番号
    '【第５引数】[out]  data         データ(16バイト)
    '【戻 り 値】エラーコード
    <DllImport("felicalib.dll")> _
    Private Function felica_write_without_encryption( _
        ByVal f As IntPtr, _
        ByVal servicecode As Integer, _
        ByVal addr As UInt8, _
        ByVal buf As IntPtr _
    ) As Integer
    End Function

    '【関 数 名】felica_enum_systemcode
    '【第１引数】[in]  p  pasoriハンドル (pasori_open で得たポインタを指定する)
    '【戻 り 値】felicaハンドル (felica構造体のポインタを指定する)
    <DllImport("felicalib.dll")> _
    Private Function felica_enum_systemcode(ByVal p As IntPtr) As IntPtr
    End Function

    '【関 数 名】felica_enum_service
    '【第１引数】[in]  p           pasoriハンドル (pasori_open で得たポインタを指定する)
    '【第２引数】[in]  systemcode  システムコード
    '【戻 り 値】felicaハンドル (felica構造体のポインタを指定する)
    <DllImport("felicalib.dll")> _
    Private Function felica_enum_service(ByVal p As IntPtr, ByVal systemcode As UInt16) As IntPtr
    End Function


    '===================================
    ' Win32 API (DLL存在チェックに必要)
    '===================================
    <DllImport("kernel32")> _
    Private Function SetDllDirectory(ByVal lpPathName As String) As Boolean
    End Function

    <DllImport("kernel32")> _
    Private Function LoadLibrary(ByVal lpLibFileName As String) As Integer
    End Function

    <DllImport("kernel32")> _
    Private Function GetProcAddress(ByVal hModule As Integer, ByVal lpProcName As String) As Integer
    End Function

    <DllImport("kernel32")> _
    Private Function FreeLibrary(ByVal hLibModule As Integer) As Boolean
    End Function

    '====================================================
    '【関数名】isDLLExists
    '【引  数】なし
    '【戻り値】[out] Boolean  TRUE   DLLの読み込みに成功
    '                         FALSE  DLLの読み込みに失敗
    '----------------------------------------------------
    ' felicalib.dll が存在するかチェックする。
    '====================================================
    Public Function isDLLExists() As Boolean
        'DLLのハンドル
        Dim hModule As IntPtr = IntPtr.Zero

        'DLL内の関数を受け取るポインタ
        Dim pPasoriOpen                    As IntPtr = IntPtr.Zero
        Dim pPasoriClose                   As IntPtr = IntPtr.Zero
        Dim pPasoriInit                    As IntPtr = IntPtr.Zero
        Dim pFelicaPolling                 As IntPtr = IntPtr.Zero
        Dim pFelicaFree                    As IntPtr = IntPtr.Zero
        Dim pFelicaGetidm                  As IntPtr = IntPtr.Zero
        Dim pFelicaGetpmm                  As IntPtr = IntPtr.Zero
        Dim pFelicaReadWithoutEncryption02 As IntPtr = IntPtr.Zero
        Dim pFelicaWriteWithoutEncryption  As IntPtr = IntPtr.Zero
        Dim pFelicaEnumSystemcode          As IntPtr = IntPtr.Zero
        Dim pFelicaEnumService             As IntPtr = IntPtr.Zero

        Try
            'DLLプリロード対策 ※DLLの読み込み先から現在の作業ディレクトリ(CWD)を除外する
            SetDllDirectory("")

            'DLLを読み込む
            hModule = LoadLibrary("felicalib.dll")
            If hModule = IntPtr.Zero Then
                Return False
            End If

            'DLLの関数を読み込む
            pPasoriOpen                    = GetProcAddress(hModule, "pasori_open")
            pPasoriClose                   = GetProcAddress(hModule, "pasori_close")
            pPasoriInit                    = GetProcAddress(hModule, "pasori_init")
            pFelicaPolling                 = GetProcAddress(hModule, "felica_polling")
            pFelicaFree                    = GetProcAddress(hModule, "felica_free")
            pFelicaGetidm                  = GetProcAddress(hModule, "felica_getidm")
            pFelicaGetpmm                  = GetProcAddress(hModule, "felica_getpmm")
            pFelicaReadWithoutEncryption02 = GetProcAddress(hModule, "felica_read_without_encryption02")
            pFelicaWriteWithoutEncryption  = GetProcAddress(hModule, "felica_write_without_encryption")
            pFelicaEnumSystemcode          = GetProcAddress(hModule, "felica_enum_systemcode")
            pFelicaEnumService             = GetProcAddress(hModule, "felica_enum_service")

            If pPasoriOpen                    = IntPtr.Zero OrElse _
               pPasoriClose                   = IntPtr.Zero OrElse _
               pPasoriInit                    = IntPtr.Zero OrElse _
               pFelicaPolling                 = IntPtr.Zero OrElse _
               pFelicaFree                    = IntPtr.Zero OrElse _
               pFelicaGetidm                  = IntPtr.Zero OrElse _
               pFelicaGetpmm                  = IntPtr.Zero OrElse _
               pFelicaReadWithoutEncryption02 = IntPtr.Zero OrElse _
               pFelicaWriteWithoutEncryption  = IntPtr.Zero OrElse _
               pFelicaEnumSystemcode          = IntPtr.Zero OrElse _
               pFelicaEnumService             = IntPtr.Zero _
            Then
                FreeLibrary(hModule)
                Return False
            End If

            '読み込み成功
            FreeLibrary(hModule)
            Return True
        Catch ex As Exception
            MessageBox.Show(ex.Message, "isDLLExists()")
            If hModule <> IntPtr.Zero Then FreeLibrary(hModule)
            Return False
        End Try
    End Function

    '=============================================
    '【関 数 名】hexdump
    '【第１引数】[in]  UInt8()  データ配列
    '【第２引数】[in]  Integer  配列のサイズ
    '【戻 り 値】[out] String   16進数文字列
    '---------------------------------------------
    ' 受け取ったデータを16進数の文字列に変換する。
    '=============================================
    Private Function hexdump(ByVal arg() As UInt8, ByVal size As Integer) As String
        Dim sResult As String = ""

        For I As Integer = 0 To size - 1
            sResult &= arg(I).ToString("X2")
        Next

        Return sResult
    End Function

    '================================
    ' felicalib.dll アクセス用クラス
    '================================
    Class CFelicaLib
        Implements IDisposable 'デストラクタ

        '==========
        ' 変数定義
        '==========
        Private p_ptr As IntPtr  'Pasoriポインタ
        Private f_ptr As IntPtr  'felica構造体ポインタ

        '===========================================
        '【関数名】New
        '【引  数】なし
        '【戻り値】なし
        '-------------------------------------------
        ' コンストラクタ。ポインタの初期化を行なう。
        '===========================================
        Public Sub New()
            '初期化
            p_ptr = IntPtr.Zero
            f_ptr = IntPtr.Zero
        End Sub

        '=================================
        '【関数名】Dispose
        '【引  数】なし
        '【戻り値】なし
        '---------------------------------
        ' デストラクタ。PaSoRiを解放する。
        '=================================
        Public Sub Dispose() Implements IDisposable.Dispose
            'PaSoRi の接続を解放
            Pasori_Free()
        End Sub

        '===============================================
        '【関数名】Pasori_Connect
        '【引  数】なし
        '【戻り値】[out] Boolean  TRUE   PaSoRi接続成功
        '                         FALSE  PaSoRi接続失敗
        '-----------------------------------------------
        ' PaSoRiに接続して使用可能な状態にする。
        '===============================================
        Public Function Pasori_Connect() As Boolean
            Try
                '----------------------
                ' PaSoRi ハンドル取得
                '----------------------
                p_ptr = pasori_open(Nothing)
                If p_ptr = IntPtr.Zero Then
                    Return False
                End If

                '---------------------
                ' PaSoRi 初期化(接続)
                '---------------------
                If pasori_init(p_ptr) <> 0 Then
                    Return False
                End If

                Return True
            Catch ex As Exception
                MessageBox.Show(ex.Message, "Pasori_Connect()")
                Return False
            End Try
        End Function

        '======================
        '【関数名】Pasori_Free
        '【引  数】なし
        '【戻り値】なし
        '----------------------
        ' PaSoRiの接続を解放
        '======================
        Public Sub Pasori_Free()
            Try
                If f_ptr <> IntPtr.Zero Then felica_free(f_ptr)
                If p_ptr <> IntPtr.Zero Then pasori_close(p_ptr)
            Catch ex As Exception
                MessageBox.Show(ex.Message, "Pasori_Free()")
            End Try
        End Sub

        '===========================================================
        '【関数名】Polling
        '【引  数】なし
        '【戻り値】[out] Boolean  TRUE   felicaハンドルの取得に成功
        '                         FALSE  felicaハンドルの取得に失敗
        '-----------------------------------------------------------
        ' ポーリング。FeliCaの読み取り準備。
        '===========================================================
        Public Function Polling() As Boolean
            Try
                '--------------------------------
                ' felicaハンドルを一度クリアする
                '--------------------------------
                If f_ptr <> IntPtr.Zero Then
                    felica_free(f_ptr)
                End If

                '------------
                ' ポーリング
                '------------
                f_ptr = felica_polling(p_ptr, POLLING_ANY, 0, 0)

                '------------
                ' 結果を返す
                '------------
                If f_ptr = IntPtr.Zero Then
                    Return False
                Else
                    Return True
                End If
            Catch ex As Exception
                MessageBox.Show(ex.Message, "Polling()")
                Return False
            End Try
        End Function

        '====================================
        '【関数名】getIDm
        '【引  数】なし
        '【戻り値】[out] String  FeliCaのIDm
        '------------------------------------
        ' FeliCaのIDmを取得する。
        '====================================
        Public Function getIDm() As String
            Try
                '------------
                ' エラー処理
                '------------
                If f_ptr = IntPtr.Zero Then
                    Return ""
                End If

                '-------------
                ' IDm読み取り
                '-------------
                Dim IDm As String
                Dim buf(8) As UInt8

                '---------------------
                ' bufのアドレスを取得
                '---------------------
                Dim gch As GCHandle = GCHandle.Alloc(buf, GCHandleType.Pinned)
                Dim b As IntPtr = gch.AddrOfPinnedObject().ToInt32

                felica_getidm(f_ptr, b)
                IDm = hexdump(buf, 8)
                gch.Free()

                Return IDm
            Catch ex As Exception
                MessageBox.Show(ex.Message, "getIDm()")
                Return ""
            End Try
        End Function

        '====================================
        '【関数名】getPMm
        '【引  数】なし
        '【戻り値】[out] String  FeliCaのPMm
        '------------------------------------
        ' FeliCaのPMmを取得する。
        '====================================
        Public Function getPMm() As String
            Try
                '------------
                ' エラー処理
                '------------
                If f_ptr = IntPtr.Zero Then
                    Return ""
                End If

                '-------------
                ' PMm読み取り
                '-------------
                Dim PMm As String
                Dim buf(8) As UInt8

                '---------------------
                ' bufのアドレスを取得
                '---------------------
                Dim gch As GCHandle = GCHandle.Alloc(buf, GCHandleType.Pinned)
                Dim b As IntPtr = gch.AddrOfPinnedObject().ToInt32

                felica_getpmm(f_ptr, b)
                PMm = hexdump(buf, 8)
                gch.Free()

                Return PMm
            Catch ex As Exception
                MessageBox.Show(ex.Message, "getIDm()")
                Return ""
            End Try
        End Function

        '======================================
        '【関 数 名】getIDmPMm
        '【第１引数】[out] String  FeliCaのIDm
        '【第２引数】[out] String  FeliCaのPMm
        '【戻 り 値】なし
        '--------------------------------------
        ' FeliCaのIDmとPMmを同時に取得する。
        '======================================
        Public Sub getIDmPMm(ByRef IDm As String, ByRef PMm As String)
            Try
                '------------
                ' エラー処理
                '------------
                If f_ptr = IntPtr.Zero Then
                    IDm = ""
                    PMm = ""
                    Return
                End If

                '--------------------------
                ' felica構造体の実体を取得
                '--------------------------
                Dim f As felica = Marshal.PtrToStructure(f_ptr, GetType(felica))

                '------------------
                ' IDm・PMm読み取り
                '------------------
                IDm = hexdump(f.IDm, 8)
                PMm = hexdump(f.PMm, 8)
            Catch ex As Exception
                MessageBox.Show(ex.Message, "getIDmPMm()")
                IDm = ""
                PMm = ""
            End Try
        End Sub
    End Class
End Module

Structure Sample
    Dim buf() As UInt16

    Public Sub Initialize()
        ReDim buf(8)
    End Sub
End Structure

Structure Sample
    <MarshalAs(UnmanagedType.ByValArray, SizeConst:=8)> _
    Public buf() As UInt16

    Public Sub Initialize()
        ReDim buf(8)
    End Sub
End Structure

<StructLayout(LayoutKind.Sequential)> _
Structure Sample
    <MarshalAs(UnmanagedType.ByValArray, SizeConst:=8)> _
    Public buf() As UInt16

    Public Sub Initialize()
        ReDim buf(8)
    End Sub
End Structure