VB.NET-TIPS などプログラミングについて

2018/12/26

コレクションクラス(SortedList , Hashtable)でのクラスデータの使い方

プログラム上でKEYを持つリスト構造を使う場合に利用するのがコレクションクラスです。良く使うコレクションクラスには以下の様に3種類のものがあります。

クラス名	KEY操作	Index操作	備考
ArrayList	×	○	Indexでの操作しかできないコレクション基本クラス取り扱うデータ型は Object 型
Hashtable	○	×	連想配列的なKEYを持つコレクションクラス KEY及び、取り扱うデータ型は Object 型
SortedList	○	○	ArrayList と Hashtable の性質を併せ持ったコレクションクラス Indexは指定されたKEY順にソートされた結果が割り振られます

単なる Object 型の配列として使う場合は ArrayList でもいいのですが、データ処理をする場合には何がしかのキーがあって、それに紐づくデータがあるものです。そのためキーが扱える Hashtable SortedList を利用します。

これらのコレクションクラスはデータとして扱えるのは、 Object 型なので結果データ型としてOKなものは何でもになります。いろんなサイトで、データとして文字列が扱われているものはあるのですが、今回は少しだけ複雑にするため、ユーザクラスをデータにもつものを示したいと思います。

以下のソースを見て下さい。ユーザクラスとしてTest を宣言しています。
このクラスを SortedList のデータとして追加等を行います。
このプログラムはモジュールファイルに Sub Main を作成しその中に処理を記述しています。これをコンパイルする場合はプロジェクト・プロパティでスタートアップオブジェクトとして MdlMainSortList を指定して下さい。

クラスデータをリストする SortedList を宣言した後、テストクラスのデータを4件生成しながら SortedList に追加を行います。キーとしては4件とも同一の書式で文字列として処理しています。
その後確認の為に SortedList.Values から順次データを取得して、内容を表示しています。（この時取得されるのはクラス型なので、いわゆる参照型です。）

さて、内部のデータの変更を行う為にキーを指定しデータを取得します。ここでクラスのパブリック変数に直接値を入れることで内部データの変更が行われます。（クラスの参照を SortedList はデータとして持っているだけで、その参照により実体データにアクセスします）

再度 SortedList の中身を全て確認するのですが、今回はIndexを使ってデータを取得しています。

SortedListでのクラスデータの使い方

Module MdlMainSortList

    'テストクラス
    Private Class Test
        Public Key As String    'KEYとなる文字列
        Public Name As String   '名称の文字列
        Public Data As Integer  'あるデータとしてのInteger型データ
        Public Flag As Boolean  'フラグ

        'コンストラクタ
        Sub New(ByVal aKey As String, ByVal aName As String, ByVal aData As String)
            Me.Key = aKey
            Me.Name = aName
            Me.Data = aData
            Me.Flag = False
        End Sub
    End Class

    <STAThread()> _
    Sub Main()
        'クラスデータをリストするSortedList
        Dim SortTest As New SortedList
        Dim clsTest As Test

        '敢えてKEYの順番通りでは無い様に SortedList に追加
        clsTest = New Test("KEY004", "NAME004", 444)
        SortTest.Add("KEY004", clsTest)

        clsTest = New Test("KEY001", "NAME001", 100)
        SortTest.Add("KEY001", clsTest)

        clsTest = New Test("KEY003", "NAME003", 333)
        SortTest.Add("KEY003", clsTest)

        clsTest = New Test("KEY002", "NAME002", 222)
        SortTest.Add("KEY002", clsTest)

        Debug.Print("**************************")
        'SortedList のKEY順番に取り出す
        For Each clsTest In SortTest.Values
            '内容を確認
            Debug.Print(clsTest.Key & " : " & clsTest.Name & " : " & clsTest.Data.ToString)
        Next

        '1個のデータをKEYで内容を取り出し、そのクラスの中身を変更する
        clsTest = SortTest.Item("KEY002")
        '取り出した clsTest はクラスデータの参照なので、以下の処理でクラスの中身を変更
        clsTest.Name = "NAMEaaa"
        clsTest.Data = 555
        clsTest.Flag = True

        Debug.Print("**************************")
        'KEY順番に指標で取り出す
        For i As Integer = 0 To SortTest.Count - 1
            'クラスの参照を取り出す
            clsTest = CType(SortTest.GetByIndex(i), Test)
            '内容を確認
            Debug.Print(clsTest.Key & " : " & clsTest.Name & " : " & clsTest.Data.ToString & " : " & clsTest.Flag.ToString)
        Next
    End Sub

End Module

結果の出力を開発環境の「出力」ウインドウに表示していますが、以下の様になります。
（"KEY002"のデータが変更されていることが分かります。）

次に、 SortedList を Hashtable に変えてみた例を示します。特に SortedList の場合と変わりはありませんが、 Indexを使ってのデータへのアクセスは出来ないので、キーを使うことになります。

ここでキーについての注意ですが、私はキーとしては文字列で設定する様にしています。例えば扱うデータのキーとして「得意先コード（数値で5桁）」「商品コード（数値で8桁）」の2個があった場合は、それぞれのコードを先頭ゼロ付きで桁数固定で文字列変換し連結したものをキーとしています。
もし「商品コード」等が文字列（漢字を含まないとする）の場合でしたら、先頭に空白を補って桁数を揃えて連結します。そうしないと比較がうまくいかないからです。

Hashtableでのクラスデータの使い方

Module MdlMainHashList

    'テストクラス
    Private Class Test
        Public Key As String    'KEYとなる文字列
        Public Name As String   '名称の文字列
        Public Data As Integer  'あるデータとしてのInteger型データ
        Public Flag As Boolean  'フラグ

        'コンストラクタ
        Sub New(ByVal aKey As String, ByVal aName As String, ByVal aData As String)
            Me.Key = aKey
            Me.Name = aName
            Me.Data = aData
            Me.Flag = False
        End Sub
    End Class

    <STAThread()> _
    Sub Main()
        'クラスデータをリストするHashtable
        Dim HashTest As New Hashtable
        Dim clsTest As Test

        '敢えてKEYの順番通りでは無い様に SortedList に追加
        clsTest = New Test("KEY004", "NAME004", 444)
        HashTest.Add("KEY004", clsTest)

        clsTest = New Test("KEY001", "NAME001", 100)
        HashTest.Add("KEY001", clsTest)

        clsTest = New Test("KEY003", "NAME003", 333)
        HashTest.Add("KEY003", clsTest)

        clsTest = New Test("KEY002", "NAME002", 222)
        HashTest.Add("KEY002", clsTest)

        'KEY順番に指標で取り出す
        Debug.Print("**************************")
        For Each clsTest In HashTest.Values
            '内容を確認
            Debug.Print(clsTest.Key & " : " & clsTest.Name & " : " & clsTest.Data.ToString)
        Next

        '1このデータをKEYで内容を取り出し、そのクラスの中身を変更する
        clsTest = HashTest.Item("KEY002")
        '取り出した clsTest はクラスデータの参照なので、以下の処理でクラスの中身を変更
        clsTest.Name = "NAMEaaa"
        clsTest.Data = 555
        clsTest.Flag = True

        'KEY順番に指標で取り出す
        Debug.Print("**************************")
        For Each clsTest In HashTest.Values
            '内容を確認
            Debug.Print(clsTest.Key & " : " & clsTest.Name & " : " & clsTest.Data.ToString)
        Next
    End Sub

End Module

その他
0CM

2018/12/10

SerialPortコントロールの使い方その６(ハンドシェィクによるデータ送受信)

シリアル通信を利用して外部装置とデータの送受信を行う場合、パソコン側が主で、外部装置が従となる関係が多いと思います。外部装置は、パソコン側から送信されてくるコマンドに対応して処理等を行い、処理結果を返してくるやり方です。

私の経験上、この外部装置との通信で多いのはシーケンサ（PLC）等とのデータの送受信がありました。シーケンサはメーカ毎にデータの送受信を行うコマンドが全く異なります。その為、各メーカ毎のコマンドの規約に合わせて処理を行う様にプログラムするわけです。

今回の例は、下図の様なPLCからのデータ読み出しと書込みの簡単なコマンドを想定しています。

読み出しコマンドも書き込みコマンドも、最初にPLC側にコマンドを送信し、結果を受信することを想定しています。
さて、このコマンドを処理するクラスを作成するのですが、今までのクラスを大部分生かすわけですが、以下のメソッドを作成します。

Open シリアルポートのオープン処理を行う。(今までと同様)
Close シリアルポートのクローズ処理を行う。(今までと同様)
ReadData PLCのアドレスを与えて、PLCデータの読込処理を行う。
WriteData PLCのアドレス・データを与えて、PLCデータへの書込処理を行う。

今回のクラスにおいてデータ受信ハンドラの処理内では、専ら応答データを受信することとしています。受信データの最終文字としての CR(0DH) を検知した時点で応答受信が在ったものとしています。

ReadData WriteData 共に最初にPLC側にコマンドを送信しますので、この部分を別関数 SendData として宣言しています。また、応答受信用には別関数 ReceiveData として宣言しています。

ReceiveData では応答受信を待つために、100msecの待ちをシステムの Sleep 関数で50回ループしています。そのループの中に応答受信フラグがONするのをみて、受信が在ったことを検知しています。（この待ち時間を短くすればプログラムの応答速度はよくなります。）

SerialPortコントロールの使い方その６(シリアル通信クラス・ハンドシェィク受信クラス)

Imports System.IO.Ports

''' -----------------------------------------------------------------------
''' 
''' シリアル通信クラス・ハンドシェィク受信
''' 
''' -----------------------------------------------------------------------
Public Class ClsSerialRcvHandshake
    ''' 
    ''' シリアルポートクラス
    ''' 
    ''' 
    Private SerialPort As SerialPort

    ''' 
    ''' コマンド応答受信フラグ
    ''' 
    ''' 
    ''' コマンドを送信した後での応答を受信したフラグ。送受信文字列のターミネータ[ETX]（0x03）を発見した時にオンする
    ''' 
    Private fRxResponse As Boolean = False

    ''' 
    ''' 読込データ格納先
    ''' 
    ''' データ受信イベントで蓄えられる
    Private RxBuf() As Byte

    ''' 
    ''' エラーメッセージ
    ''' 
    Private strLastError As String = ""

    ''' 
    ''' 応答メッセージ
    ''' 
    Private strLastResponse As String = ""

    ''' 
    ''' 送受信文字列のターミネータ（0x0d）
    ''' 
    Private Const CMD_TERM As Byte = &HD

    ''' -----------------------------------------------------------------------
    ''' 
    ''' コンストラクタ
    ''' 
    ''' <param name="SerialPort">シリアルポートコントロール</param>
    ''' -----------------------------------------------------------------------
    Sub New(ByVal SerialPort As SerialPort)
        'シリアルポートの退避
        Me.SerialPort = SerialPort
        '受信イベントのハンドラ設定
        AddHandler Me.SerialPort.DataReceived, AddressOf DataReceivedHandler
    End Sub

    ''' -----------------------------------------------------------------------
    ''' 
    ''' エラーメッセージプロパティ
    ''' 
    ''' -----------------------------------------------------------------------
    ReadOnly Property LastError As String
        Get
            Return Me.strLastError
        End Get
    End Property

    ''' -----------------------------------------------------------------------
    ''' 
    ''' 応答メッセージプロパティ
    ''' 
    ''' -----------------------------------------------------------------------
    ReadOnly Property LastResponse As String
        Get
            Return Me.strLastResponse
        End Get
    End Property

    ''' -----------------------------------------------------------------------
    ''' 
    ''' ポートオープン
    ''' 
    ''' True:正常終了, False:エラー
    ''' -----------------------------------------------------------------------
    Function Open() As Boolean
        '戻り値初期化
        Open = False
        Try
            'ポートチェック
            If Me.SerialPort.IsOpen = False Then
                '未オープンならば、オープンする

                'ポート設定(ここは通信相手に合わせる)
                Me.SerialPort.PortName = "COM7"
                Me.SerialPort.BaudRate = 9600
                Me.SerialPort.DataBits = 8
                Me.SerialPort.Parity = Parity.None
                Me.SerialPort.StopBits = StopBits.One
                'オープン
                Me.SerialPort.Open()
            End If
            '結果を返す
            Open = Me.SerialPort.IsOpen

        Catch ex As Exception
            'エラー処理
        End Try
    End Function

    ''' -----------------------------------------------------------------------
    ''' 
    ''' ポートクローズ
    ''' 
    ''' True:正常終了, False:エラー
    ''' -----------------------------------------------------------------------
    Function Close() As Boolean
        '戻り値初期化
        Close = False
        Try
            'ポートチェック
            If Me.SerialPort.IsOpen = True Then
                'オープン済みならば、クローズする
                Me.SerialPort.Close()
            End If
            '結果を返す
            Close = Not (Me.SerialPort.IsOpen)

        Catch ex As Exception
            'エラー処理
        End Try
    End Function

    ''' -----------------------------------------------------------------------
    ''' 
    ''' データ受信ハンドラ
    ''' 
    ''' 
    ''' [STX]から始まるデータをコマンドバッファに格納し[ETX]受信時に文字列に変換
    ''' 
    ''' -----------------------------------------------------------------------
    Private Sub DataReceivedHandler(sender As Object, e As SerialDataReceivedEventArgs)
        Try
            Dim SP As SerialPort = CType(sender, SerialPort)

            'バッファのバイト数チェック
            Dim DataLen As Integer = SP.BytesToRead
            If DataLen = 0 Then
                Exit Sub
            End If

            'データ長チェック
            If DataLen > 4096 Then
                DataLen = 4096
            End If

            '読込バッファの確保
            Dim Buf(DataLen) As Byte
            '読込
            SP.Read(Buf, 0, DataLen)
            '
            If RxBuf Is Nothing Then
                '格納バッファの領域確保
                RxBuf = Array.CreateInstance(GetType(Byte), DataLen)
                'コピー
                Array.Copy(Buf, RxBuf, DataLen)
            Else
                '後ろに追加する
                Dim Length As Integer = RxBuf.Length
                ReDim Preserve RxBuf(Length + DataLen - 1)
                Buf.CopyTo(RxBuf, Length)
            End If

            '格納先の最後の文字が「CR」(0x0d)か確認する
            If RxBuf(UBound(RxBuf)) = CMD_TERM Then
                'コマンド応答受信フラグON
                Me.fRxResponse = True
            End If

        Catch ex As Exception
            'エラー処理
        End Try
    End Sub

    ''' -----------------------------------------------------------------------
    ''' 
    ''' 接点エリアリード
    ''' 
    ''' <param name="Addr">接点アドレス(4文字:[10^3][10^2][10^1][16^0]</param>
    ''' <param name="Data">接点データ</param>
    ''' 応答受信結果(True:OK, False:NG)
    ''' 
    ''' 送信コマンド:"RD" + NNNN + CR
    ''' 受信コマンド:"OK" + MMMM + CR ⇒ データが正常の場合(MMMM:データ値)
    ''' 　　　　　　:"NG" + 0000 + CR ⇒ データがエラーの場合(エラーでは0000:ゼロ)
    ''' 
    ''' -----------------------------------------------------------------------
    Public Function ReadData(ByVal Addr As String, ByRef Data As Integer) As Boolean
        '戻り値初期化
        ReadData = False
        Try
            '最終応答,エラーをクリア
            Me.strLastResponse = ""
            Me.strLastError = ""

            '接点NOの4文字チェック
            If Addr.Length <> 4 Then
                Exit Function
            End If
            '送信コマンド生成
            Dim strCMD As String = "RD" & Addr

            'コマンド送信
            If Me.SendData(strCMD) = False Then
                Return False
            End If

            'コマンド受信
            Dim strRX As String = ""
            If Me.ReceiveData(strRX) = False Then
                Return False
            End If
            '最終応答を退避
            Me.strLastResponse = strRX

            '接点結果を返す
            If strRX.Substring(0, 2) = "OK" Then
                'データ値をInteger変換
                Data = CInt(strRX.Substring(2, 4))
                '正常を返す
                ReadData = True
            Else
                'エラー受信
                Me.strLastError = "NG応答"
            End If

        Catch ex As Exception
            'エラー処理
        End Try
    End Function

    ''' -----------------------------------------------------------------------
    ''' 
    ''' 接点への書込み
    ''' 
    ''' <param name="Addr">接点アドレス(4文字:[10^3][10^2][10^1][16^0]</param>
    ''' <param name="Data">接点データ</param>
    ''' 応答受信結果(True:OK, False:NG)
    ''' 
    ''' 送信コマンド:"WR" + NNNN + ":" + MMMM + CR
    ''' 受信コマンド:"OK" + CR ⇒ 書込み正常の場合
    ''' 　　　　　　:"NG" + CR ⇒ 書込みエラーの場合
    ''' 
    ''' -----------------------------------------------------------------------
    Public Function WriteData(ByVal Addr As String, ByVal Data As Integer) As Boolean
        '戻り値初期化
        WriteData = False
        Try
            '最終応答,エラーをクリア
            Me.strLastResponse = ""
            Me.strLastError = ""

            'アドレス4文字チェック
            If Addr.Length <> 4 Then
                Exit Function
            End If
            '送信コマンド生成
            Dim strCMD As String = "WR" & Addr & ":" + Data.ToString("0000")

            'コマンド送信
            If Me.SendData(strCMD) = False Then
                Return False
            End If

            'コマンド受信
            Dim strRX As String = ""
            If Me.ReceiveData(strRX) = False Then
                Return False
            End If
            '最終応答を退避
            Me.strLastResponse = strRX

            '接点結果を返す
            If strRX.Substring(0, 2) = "NG" Then
                'エラー受信
                Me.strLastError = "NG応答"
                'エラーを返す
                Return False
            End If

            '正常を返す
            Return True

        Catch ex As Exception
            'エラー処理
        End Try
    End Function

    ''' -----------------------------------------------------------------------
    ''' 
    ''' コマンド送信
    ''' 
    ''' <param name="strSend">送信文字列</param>
    ''' 送信結果(True:OK, False:NG)
    ''' 
    ''' -----------------------------------------------------------------------
    Private Function SendData(ByVal strSend As String) As Boolean
        '戻り値初期化
        SendData = False
        Try
            'ポートオープンチェック
            If Me.SerialPort.IsOpen = False Then
                Return False
            End If

            'Shift JISとしてバイト型配列に変換
            Dim bytesData As Byte()
            bytesData = System.Text.Encoding.GetEncoding(932).GetBytes(strSend)

            'CRの1バイト分領域拡張
            Dim nIdx As Integer = UBound(bytesData)
            ReDim Preserve bytesData(nIdx + 1)
            bytesData(nIdx + 1) = CMD_TERM

            'コマンド応答受信フラグOFF
            Me.fRxResponse = False

            'コマンド送信
            Me.RxBuf = Nothing  '受信バッファのクリア
            Me.SerialPort.Write(bytesData, 0, bytesData.Length)
            '正常
            Return True

        Catch ex As Exception
            'エラー処理
        End Try
    End Function

    ''' -----------------------------------------------------------------------
    ''' 
    ''' レスポンス受信処理
    ''' 
    ''' <param name="RcvRes">受信レスポンス</param>
    ''' 受信結果(True:OK, False:NG)
    ''' 
    ''' -----------------------------------------------------------------------
    Private Function ReceiveData(ByRef RcvRes As String) As Boolean
        '戻り値初期化
        ReceiveData = False
        Try
            '-----
            '受信フラグがONするまで待つ
            '-----
            'リトライ件数
            Dim nRetry As Integer = 50  '50×100msec＝5sec

            While nRetry > 0
                System.Threading.Thread.Sleep(100)
                Application.DoEvents()
                If Me.fRxResponse = True Then
                    '受信フラグONの場合、ループを抜ける
                    Exit While
                End If
                nRetry -= 1
            End While

            '-----
            'タイムアウトチェック
            '-----
            If nRetry = 0 Then
                'タイムアウト表示
                Me.strLastError = "Receive Time Out Error!"
                Return False
            End If

            '受信バイトを文字列変換
            Dim strRx As String = System.Text.Encoding.GetEncoding(932).GetString(Me.RxBuf)
            strRx = strRx.Substring(0, strRx.Length - 1)    '最後の「CR」は省く

            '-----
            '受信データ処理
            '-----
            ''BCCの計算

            '受信レスポンスを返す
            RcvRes = strRx

            '結果正常
            Return True

        Catch ex As Exception
            'エラー処理
        End Try
    End Function

End Class

このクラスを使用した例を以下のソースに示します。

SerialPortコントロールの使い方その６(シリアル通信クラス・ハンドシェィク受信クラス)使用例

Public Class frmSerialRcvHandshake

    'シリアル通信クラス
    Private mclsSerial As ClsSerialRcvHandshake

    ''' 
    ''' フォームクローズイベント
    ''' 
    Private Sub frmSerialRcv_FormClosed(sender As Object, e As FormClosedEventArgs) Handles Me.FormClosed
        'シリアル通信のクローズ
        mclsSerial.Close()
    End Sub

    ''' 
    ''' フォームロードイベント
    ''' 
    Private Sub frmSerialRcv_Load(sender As Object, e As EventArgs) Handles Me.Load
        'シリアル通信クラスの生成
        mclsSerial = New ClsSerialRcvHandshake(Me.SerialPort1)
        'シリアル通信のオープン
        If mclsSerial.Open() = False Then
            'オープンエラー(必要があれば処理する)
        End If
    End Sub

    ''' 
    ''' 受信処理
    ''' 
    Private Sub btnRX_Click(sender As Object, e As EventArgs) Handles btnRX.Click
        Try
            Dim nData As Integer
            Dim strAddr As String = CInt(txtRxAddr.Text).ToString("0000")
            Me.txtRxData.Text = ""
            Me.txtRxRes.Text = ""
            Me.txtRxErr.Text = ""
            '受信
            If Me.mclsSerial.ReadData(strAddr, nData) = True Then
                Me.txtRxData.Text = nData.ToString("0000")
                Me.txtRxRes.Text = Me.mclsSerial.LastResponse
                Me.txtRxErr.Text = ""
            Else
                Me.txtRxData.Text = ""
                Me.txtRxRes.Text = Me.mclsSerial.LastResponse
                Me.txtRxErr.Text = Me.mclsSerial.LastError
            End If

        Catch ex As Exception
            MsgBox(ex.Message)
        End Try
    End Sub

    ''' 
    ''' 送信処理
    ''' 
    Private Sub btnTX_Click(sender As Object, e As EventArgs) Handles btnTX.Click
        Try
            Dim nData As Integer = CInt(Me.txtTxData.Text)
            Dim strAddr As String = CInt(txtTxAddr.Text).ToString("0000")
            Me.txtTxRes.Text = ""
            Me.txtTxErr.Text = ""
            '送信 
            If Me.mclsSerial.WriteData(strAddr, nData) = True Then
                Me.txtTxRes.Text = Me.mclsSerial.LastResponse
                Me.txtTxErr.Text = ""
            Else
                Me.txtTxRes.Text = Me.mclsSerial.LastResponse
                Me.txtTxErr.Text = Me.mclsSerial.LastError
            End If

        Catch ex As Exception
            MsgBox(ex.Message)
        End Try
    End Sub

End Class

このフォームは、以下の図の様に、シリアルコントロール及び、受信処理用のアドレス、受信結果表示データ、応答結果文字列表示用、エラー表示用の各テキストボックスと、送信処理用にアドレス、送信データ、応答結果文字列表示用、エラー表示用の各テキストボックスを画面に張り付けてあります。

シリアル通信クラスをフォームの静的変数として宣言します。受信ボタンをクリックした時には、アドレス値を取得し、シリアル通信クラスの ReadData メソッドにそのアドレスを渡して、受信を行います。メソッドが正常に終了した時には、データ値と受信文字列を表示し、エラーが在った場合にはエラー内容を表示しています。
また、送信ボタンをクリックした時には、アドレス値及びデータ値を取得し、シリアル通信クラスの WriteData メソッドにアドレス、データ値を渡して、送信を行います。メソッドが正常に終了した時には、受信文字列を表示し、エラーが在った場合にはエラー内容を表示しています。

以下の図は、受信処理での正常時・エラー発生時・タイムアウトエラー時の表示を示します。
（尚、外部装置の外部装置の替わりとして、前回まで使用してきたRS232Cのテストツールを同様に使用しています。）

また、以下の図は、送信処理での正常時・エラー発生時・タイムアウトエラー時の表示を示します。

最後に、このシリアル通信クラスの問題となるかもしれない点として、受信処理及び送信処理で装置側から応答が返るまでその処理からは抜け出してこないことがあります。応答が返るまで待つことが特に問題無い場合はこのままでも利用できると思います。

もし速度的に問題があり、受信・送信コマンドを送ってすぐにそのメソッドから戻りたい場合には、応答を受信したタイミングでイベントを発生させればできるとは思います。
ただ、パソコン側が主導的に外部装置を制御する場合でしたら、そこまでは必要ないとも思います。

USB ⇒ RS232C 変換ケーブル

シリアル通信に関連してですが、最近のPC、特にノートPCの場合ではRS232Cのコネクタがついていることは殆んどありません。
そのため、以下の様なUSBを使ったRS232Cの変換ケーブルが使えそうです。
⇒iBUFFALO USBシリアルケーブル(USBtypeA to D-sub9ピン)1.0m ブラックスケルトン BSUSRC0610BS
⇒サンワサプライ USB-RS232Cコンバータ USB-CVRS9
⇒Plugable USB‐9ピンRS232シリアルアダプター (Prolific社製 PL2303HX Rev Dチップセット採用)

制御信号イベント・通知アーギュメント用クラス

Public Class SerialCTSChangeEventArgs
    Inherits EventArgs

    Private mblnCTS As Boolean

    ' 制御信号データを取得
    Public Property CTS() As Boolean
        Get
            Return mblnCTS
        End Get
        Set(ByVal value As Boolean)
            mblnCTS = value
        End Set
    End Property
End Class

Public Class SerialDSRChangeEventArgs
    Inherits EventArgs

    Private mblnDSR As Boolean

    ' 制御信号受信データを取得
    Public Property DSR() As Boolean
        Get
            Return mblnDSR
        End Get
        Set(ByVal value As Boolean)
            mblnDSR = value
        End Set
    End Property
End Class

この通知アーギュメントクラスを利用して、「その４」のシリアル通信クラスを変更します。変更内容は以下の通りです。

Event を使ってイベントを定義を行う。
制御信号アーギュメントクラスを生成し、制御信号データをその中に設定する。
制御信号の変化時に、RaiseEvent を使って各CTS、DSR信号イベントを発生する。

SerialPortコントロールの使い方その５(通信用クラス)

Imports System.IO.Ports

''' -----------------------------------------------------------------------
''' 
''' シリアル通信クラス・垂れ流し受信イベント付き２
''' 
''' -----------------------------------------------------------------------
Public Class ClsSerialRcvEvent2
    ''' 
    ''' シリアルポートクラス
    ''' 
    ''' 
    Private SerialPort As SerialPort

    ''' 
    ''' 読込データ格納先
    ''' 
    ''' データ受信イベントで蓄えられる
    Private CmdBuf() As Byte

    ''' 
    ''' STX受信フラグ(装置の送信が開始された証拠)
    ''' 
    Private fSTX As Boolean = False

    ''' 
    ''' 最終受信文字列(受信データからSTX,ETXを除いたもの)
    ''' 
    ''' 
    Private strLastRxData As String = ""

    ''' 
    ''' 送受信文字列の開始コード（STX:0x02）
    ''' 
    Private Const CMD_STX As Byte = &H2

    ''' 
    ''' 送受信文字列の終了コード（ETX:0x03）
    ''' 
    Private Const CMD_ETX As Byte = &H3

    ''' 
    ''' データ受信イベント定義
    ''' 
    Public Event ReceivedData(ByVal sender As Object, ByVal e As SerialEventArgs)

    ''' 
    ''' CTS受信イベント定義
    ''' 
    Public Event CTSChanged(ByVal sender As Object, ByVal e As SerialCTSChangeEventArgs)

    ''' 
    ''' DSR受信イベント定義
    ''' 
    Public Event DSRChanged(ByVal sender As Object, ByVal e As SerialDSRChangeEventArgs)

    ''' -----------------------------------------------------------------------
    ''' 
    ''' コンストラクタ
    ''' 
    ''' <param name="SerialPort">シリアルポートコントロール</param>
    ''' -----------------------------------------------------------------------
    Sub New(ByVal SerialPort As SerialPort)
        'シリアルポートの退避
        Me.SerialPort = SerialPort
        '受信イベントのハンドラ設定
        AddHandler Me.SerialPort.DataReceived, AddressOf DataReceivedHandler
        '信号PINの変化イベント
        AddHandler Me.SerialPort.PinChanged, AddressOf PinChangedHandler
    End Sub

    ''' -----------------------------------------------------------------------
    ''' 
    ''' 最終受信データプロパティ
    ''' 
    ''' 受信データ文字列
    ''' -----------------------------------------------------------------------
    ReadOnly Property LastRxData As String
        Get
            Return Me.strLastRxData
        End Get
    End Property

    ''' -----------------------------------------------------------------------
    ''' 
    ''' ポートオープン
    ''' 
    ''' True:正常終了, False:エラー
    ''' -----------------------------------------------------------------------
    Function Open() As Boolean
        '戻り値初期化
        Open = False
        Try
            'ポートチェック
            If Me.SerialPort.IsOpen = False Then
                '未オープンならば、オープンする

                'ポート設定(ここは通信相手に合わせる)
                Me.SerialPort.PortName = "COM7"
                Me.SerialPort.BaudRate = 9600
                Me.SerialPort.DataBits = 8
                Me.SerialPort.Parity = Parity.None
                Me.SerialPort.StopBits = StopBits.One

                '制御信号のON
                Me.SerialPort.DtrEnable = True  'DTR(Data Terminal Ready)
                Me.SerialPort.RtsEnable = True  'RTS(Request To Send)

                'オープン
                Me.SerialPort.Open()
            End If
            '結果を返す
            Open = Me.SerialPort.IsOpen

        Catch ex As Exception
            'エラー処理
        End Try
    End Function

    ''' -----------------------------------------------------------------------
    ''' 
    ''' ポートクローズ
    ''' 
    ''' True:正常終了, False:エラー
    ''' -----------------------------------------------------------------------
    Function Close() As Boolean
        '戻り値初期化
        Close = False
        Try
            'ポートチェック
            If Me.SerialPort.IsOpen = True Then
                'オープン済みならば、クローズする
                Me.SerialPort.Close()
            End If
            '結果を返す
            Close = Not (Me.SerialPort.IsOpen)

        Catch ex As Exception
            'エラー処理
        End Try
    End Function

    ''' -----------------------------------------------------------------------
    ''' 
    ''' データ受信ハンドラ
    ''' 
    ''' 
    ''' [STX]から始まるデータをコマンドバッファに格納し[ETX]受信時に文字列に変換
    ''' 
    ''' -----------------------------------------------------------------------
    Private Sub DataReceivedHandler(sender As Object, e As SerialDataReceivedEventArgs)
        Try
            Dim SP As SerialPort = CType(sender, SerialPort)

            'バッファのバイト数チェック
            Dim DataLen As Integer = SP.BytesToRead
            If DataLen = 0 Then
                Exit Sub
            End If

            'データ長チェック
            If DataLen > 4096 Then
                DataLen = 4096
            End If

            '読込バッファの確保
            Dim Buf(DataLen - 1) As Byte
            '読込
            SP.Read(Buf, 0, DataLen)
            '
            '受信バッファを先頭からチェックする
            For i As Integer = 0 To Buf.Length - 1
                Select Case Buf(i)
                    Case CMD_STX
                        If Me.fSTX = True Then
                            '再度のSTXはコマンドバッファをクリア
                            Me.CmdBuf = Nothing
                        End If
                        'STXフラグON
                        Me.fSTX = True

                    Case CMD_ETX
                        If Me.fSTX = True Then
                            'STXフラグONの場合
                            'コマンドバッファを文字列変換(最終受信文字列に退避)
                            Me.strLastRxData = System.Text.Encoding.GetEncoding(932).GetString(Me.CmdBuf)

                            '*** データ受信イベントを発生 ***
                            Dim se As New SerialEventArgs
                            se.ReceivedData = Me.strLastRxData '受信データの値をセット
                            RaiseEvent ReceivedData(Me, se)

                            'STXフラグOFF
                            Me.fSTX = False
                        End If
                        'コマンドバッファクリア
                        Me.CmdBuf = Nothing

                    Case Else
                        '[STX][ETX]以外
                        If Me.fSTX = True Then
                            'STXフラグONの場合
                            Dim intIdx As Integer = 0
                            If Me.CmdBuf Is Nothing Then
                                '格納バッファの領域確保
                                Me.CmdBuf = Array.CreateInstance(GetType(Byte), 1)
                                '先頭指定
                                intIdx = 0
                            Else
                                '後ろに追加する
                                Dim Length As Integer = Me.CmdBuf.Length
                                ReDim Preserve Me.CmdBuf(Length)
                                '最後尾指定
                                intIdx = Length
                            End If
                            '1文字コピー
                            Me.CmdBuf(intIdx) = Buf(i)
                        End If
                End Select
            Next

        Catch ex As Exception
            'エラー処理
        End Try
    End Sub

    ''' -----------------------------------------------------------------------
    ''' 
    ''' 信号PIN変化ハンドラ
    ''' 
    ''' -----------------------------------------------------------------------
    Private Sub PinChangedHandler(sender As Object, e As SerialPinChangedEventArgs)
        Try
            '信号PIN変化判別
            Select Case e.EventType

                Case SerialPinChange.CtsChanged
                    'CTSのPinが変更された場合、CTS信号イベントを発生
                    Dim se As New SerialCTSChangeEventArgs
                    se.CTS = Me.SerialPort.CtsHolding    '信号値をセット
                    RaiseEvent CTSChanged(Me, se)

                Case SerialPinChange.DsrChanged
                    'DSRのPinが変更された場合、CTS信号イベントを発生
                    Dim se As New SerialDSRChangeEventArgs
                    se.DSR = Me.SerialPort.DsrHolding    '信号値をセット
                    RaiseEvent DSRChanged(Me, se)
            End Select

        Catch ex As Exception
            'エラー処理
        End Try
    End Sub

End Class

このクラスを使用した例を以下のソースに示します。

SerialPortコントロールの使い方その４(通信用クラスの使用例)

Public Class frmSerialRcvEvent2

    'シリアル通信クラス
    Private WithEvents mclsSerialRcv As ClsSerialRcvEvent2

    'Invokeメソッドで使用するデリゲート宣言  
    Delegate Sub DisplayTextDelegate(ByVal strDisp As String)

    'Invokeメソッドで使用するデリゲート宣言  
    Delegate Sub SetSignalLabelDelegate(lblSig As Label, ByVal blnSig As Boolean)

    ''' 
    ''' フォームクローズイベント
    ''' 
    Private Sub frmSerialRcv_FormClosed(sender As Object, e As FormClosedEventArgs) Handles Me.FormClosed
        'シリアル通信のクローズ
        mclsSerialRcv.Close()
    End Sub

    ''' 
    ''' フォームロードイベント
    ''' 
    Private Sub frmSerialRcv_Load(sender As Object, e As EventArgs) Handles Me.Load
        'CTS,DSR信号ラベルOFF
        SetSignalLabel(Me.lblCTS, False)
        SetSignalLabel(Me.lblDSR, False)

        'シリアル通信クラスの生成
        mclsSerialRcv = New ClsSerialRcvEvent2(Me.SerialPort1)
        'シリアル通信のオープン
        If mclsSerialRcv.Open() = False Then
            'オープンエラー(必要があれば処理する)
        End If
    End Sub

    ''' 
    ''' リッチテキストBOXに文字列表示関数
    ''' 
    ''' <param name="strDisp">表示文字列</param>
    Private Sub DisplayText(ByVal strDisp As String)
        'リッチテキストBOXに文字列を追加  
        Me.RichTextBox1.Text &= strDisp & vbCrLf
    End Sub

    ''' 
    ''' データ受信のイベント処理(この処理は別スレッドでコールされる!!)
    ''' 
    Private Sub mclsSerialRcv_ReceivedData(sender As Object, e As SerialEventArgs) Handles mclsSerialRcv.ReceivedData
        Try
            'データ表示:デリゲート生成  
            Dim dlg As New DisplayTextDelegate(AddressOf DisplayText)
            'デリゲート関数をコールする  
            Me.Invoke(dlg, New Object() {e.ReceivedData})

        Catch ex As Exception
            MsgBox(ex.Message)
        End Try
    End Sub

    ''' 
    ''' CTS信号イベント処理
    ''' 
    Private Sub mclsSerialRcv_CTSChanged(sender As Object, e As SerialCTSChangeEventArgs) Handles mclsSerialRcv.CTSChanged
        Try
            'CTS信号ラベル表示:デリゲート生成  
            Dim dlg As New SetSignalLabelDelegate(AddressOf SetSignalLabel)
            'デリゲート関数をコールする  
            Me.Invoke(dlg, New Object() {Me.lblCTS, e.CTS})

        Catch ex As Exception
            MsgBox(ex.Message)
        End Try
    End Sub

    ''' 
    ''' DSR信号イベント処理
    ''' 
    Private Sub mclsSerialRcv_DSRChanged(sender As Object, e As SerialDSRChangeEventArgs) Handles mclsSerialRcv.DSRChanged
        Try
            'DSR信号ラベル表示:デリゲート生成  
            Dim dlg As New SetSignalLabelDelegate(AddressOf SetSignalLabel)
            'デリゲート関数をコールする  
            Me.Invoke(dlg, New Object() {Me.lblDSR, e.DSR})

        Catch ex As Exception
            MsgBox(ex.Message)
        End Try
    End Sub

    Private Sub SetSignalLabel(lblSig As Label, ByVal blnSig As Boolean)
        Try
            If blnSig = True Then
                lblSig.Text = "ON"
                lblSig.BackColor = Color.Yellow
            Else
                lblSig.Text = "OFF"
                lblSig.BackColor = SystemColors.Control
            End If

        Catch ex As Exception
            MsgBox(ex.Message)
        End Try
    End Sub

End Class

このフォームは、シリアルコントロール及び、受信データ表示用のリッチテキストボックスを画面に張り付けてあります。シリアル通信クラスを WithEvents で宣言し、データ受信イベントの関数宣言が出来る様にします。その関数 mclsSerialRcv_ReceivedData 中で、受信データの処理を行います。

尚、追加で CTS DSR の信号状態を表示する為のラベルを設置しています。 CTS DSR の信号イベントでこのラベルの状態を変化させるため、デリゲート処理でラベルの Text と BackColor の値を設定しています。

以下はプログラムを起動した後で、機器側の制御信号をOFFのままにしています。

以下は機器側の制御信号 CTS DSR をONし、データを送信した結果です。

USB ⇒ RS232C 変換ケーブル

基本Word処理用クラス：以下のソースをクラスモジュール（clsWord）として宣言

Option Compare Database
Option Explicit

' Wordオブジェクト
Private WithEvents WordApp As Word.Application

' Word.Documentオブジェクト
Private WordDoc As Word.Document


'------------------------------------------------------------------------------
' クラス初期化時処理
'------------------------------------------------------------------------------
Private Sub Class_Initialize()
    'word起動
    Set WordApp = CreateObject("Word.application")
End Sub

'------------------------------------------------------------------------------
' Word・保存前イベント処理
'------------------------------------------------------------------------------
Private Sub WordApp_DocumentBeforeSave(ByVal Doc As Word.Document, SaveAsUI As Boolean, Cancel As Boolean)
    Dim strPath As String

    '日付・時刻を[yyyymmdd-hhnnss-]形式でファイル名の先頭に付加
    strPath = Doc.path & "\" & format$(Now, "yyyymmdd-hhnnss-") & Doc.name

    '自分で新しいファイル名でDialogを呼出す
    With WordApp.Dialogs(wdDialogFileSaveAs)
        .name = strPath
        .Show
    End With

    '通常のDialogの非表示
    Cancel = True
End Sub

'------------------------------------------------------------------------------
' Word・終了イベント処理
'------------------------------------------------------------------------------
Private Sub WordApp_Quit()
    'Wordオブジェクト解放
    Set WordDoc = Nothing
    Set WordApp = Nothing
End Sub

'******************************************************************************
' Word文書オープン処理
'******************************************************************************
' 関数名 : WordOpen()
' 引数   : P_strFileName          'Word文書ファイル名
'     　 : P_blnVisible           '初期表示フラグ
'******************************************************************************
Public Sub WordOpen(ByVal P_strFileName As String, ByVal P_blnVisible As Boolean)
    On Error GoTo Err_WordOpen
    
    'word起動
    If WordApp Is Nothing Then
        Call Class_Initialize
    End If
    
    'ワードファイルを読み込み、文章を編集する状態にする
    Set WordDoc = WordApp.Documents.Open(P_strFileName) '編集モードで開く
    
    If P_blnVisible = True Then
        'Word文書表示処理
        Call WordDisplay
    End If

Exit_WordOpen:
    Exit Sub

Err_WordOpen:
    MsgBox Err.Description
    Resume Exit_WordOpen
End Sub

'******************************************************************************
' Word文書表示処理
'******************************************************************************
' 関数名 : WordDisplay()
'******************************************************************************
Public Sub WordDisplay()
    On Error GoTo Err_WordDisplay
    
    WordApp.Visible = True
    WordApp.Activate

Exit_WordDisplay:
    Exit Sub

Err_WordDisplay:
    MsgBox Err.Description
    Resume Exit_WordDisplay
End Sub

'******************************************************************************
' Word文書クローズ処理
'******************************************************************************
' 関数名 : WordClose()
'******************************************************************************
Public Sub WordClose()
    On Error GoTo Err_WordClose
    
    'word閉じる
    If Not WordDoc Is Nothing Then
        'ドキュメントをSAVE無しで閉じる
        WordDoc.Close False
        Set WordDoc = Nothing
        
        'Wordを閉じる
        WordApp.Quit
        Set WordApp = Nothing
    End If
    
Exit_WordClose:
    Exit Sub

Err_WordClose:
    MsgBox Err.Description
    Resume Exit_WordClose
End Sub

このクラスを使用する例として、access フォームに１個のボタンのみを設置し、そのクリックイベントでワード文書を開く様にしてみます。

基本Word処理用クラスの使用例

Option Compare Database

' クラスWordオブジェクト
Private mclsWord As clsWord

'------------------------------------------------------------------------------
' フォームロード時イベント
'------------------------------------------------------------------------------
Private Sub Form_Load()
    Set mclsWord = New clsWord
End Sub

'------------------------------------------------------------------------------
' フォームクローズイベント
'------------------------------------------------------------------------------
Private Sub Form_Close()
    'ワードクローズ
    mclsWord.WordClose
    'Wordオブジェクト解放
    Set mclsWord = Nothing
End Sub

'------------------------------------------------------------------------------
' コマンド1開始
'------------------------------------------------------------------------------
Private Sub コマンド1_Click()
    Dim strPath As String
    'ワードファイルを読み込み、文章を編集する状態にする
    strPath = Application.CurrentProject.path & "\" & "sample.docx"
    'ワードファイルを読込み編集状態で表示する
    mclsWord.WordOpen strPath, True
End Sub

上記のソースでの注意点は、クラスWordオブジェクトの変数をフォームの静的変数として宣言しているところです。
なぜならば、コマンドボタンでワードを起動した後で、本クラス内での保存前イベント処理(DocumentBeforeSave)が起こらなくなるからです。後は、フォームのクローズ時には後片付けも必要になります。

このWord用クラスに各種の関数を追加すれば、いろんな用途に使えると思います。今後は便利な関数をこのクラスに追加する予定です。