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

2018/11/27

SerialPortコントロールの使い方その５(データ受信時及び、信号変化時にイベントを発生させる)

前回のSerialPortコントロールを使い方その４では、データ受信時にイベントを発生させる様にしましたが、今回は通信の制御信号の変化を捉えられる様にイベントを追加しました。

シリアル通信の接続にはＤサブコネクタが用いられますが、昔はRS232Cと呼ばれていた規格がありましてパソコン同士では以下の様な接続が一般的でした。ピンの番号はＤサブ２５ピンを元にしていますので、いわゆるPC-AT互換機のＤサブ９ピンで考える場合は、信号名で合わせて下さい。（私自身は昔の人間ですので、Ｄサブ２５ピンが普通でした）

パソコン同士の接続を示しますが、外部機器との接続も大体これで問題無いと思います。
データ線の TXD と RXD をテレコにして、 RTS と CTS DSR と DTR も同様にテレコに接続します。
こちら側の送信データは相手側の受信データですし、相手側の送信データはこちら側の受信データになるという考えです。制御信号の線も同様となります。

制御信号を見ないのであれば、究極以下の接続でも可能です。制御信号をそれぞれのコネクタの中でループバックして接続します。 FG と GND は必ず接続しますが、FG は無くても動作します。FG はケーブルの被服のシールドの部分を接続するのですが、雑音対策としては推奨します。

今まで各種機器の接続を行ったことがありますが、意外とこの方法が多かったりします。外部機器側でも制御信号をコントロールするプログラムを組むのも面倒なのかと思います。（実際、装置側のプログラムは面倒です）
制御信号を見なくても機器側ではデータを送信する為に、先ずパソコン側から送信要求コマンドを送ってから機器側でコマンドに従ってデータを送信する場合が一般的です。パソコン側からコマンドを送ってデータが送信されてこない場合、タイムアウトで機器が接続されていないか、または機器が何かの原因で反応しないかが分かります。

それでは、「その４」のシリアル通信クラスに制御信号の変化イベントを追加します。イベントアーギュメントの元クラスの EventArgs を継承し SerialCTSChangeEventArgs と SerialDSRChangeEventArgs を宣言します。追加するプロパティとして各信号の値を宣言します。

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

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 変換ケーブル

シリアル通信に関連してですが、最近の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チップセット採用)

基本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用クラスに各種の関数を追加すれば、いろんな用途に使えると思います。今後は便利な関数をこのクラスに追加する予定です。