概要

Excelでシリアル通信をするためのVBAコードの紹介です。

構成

シリアル通信用のクラスを"clsCOM_Port"という名称で定義し、インスタンスして使用しています。

注意事項

COMポート番号が２桁だと上手く動きません。。。
対策はクラスライブラリのコードの冒頭にコメントしてます。

シリアル通信クラス

クラスモジュールを作成し以下のコードを張り付ける

'COMポートが２ケタだとうまく行かないので１ケタにする対策
'ターミナルから以下コマンドを入力
'   Set devmgr_show_nonpresent_devices = 1
'   Start devmgmt.msc
'
'   注）windows7以降では、すべてのプログラム→アクセサリ→コマンドプロンプトの部分で右クリックして管理者として実行が必要
'
'表示→非表示デバイスの表示 で接続されていないすべてのデバイスが表示される｡あどは不要なCOMポートを消していく


'********************************************************************************
' COMポートから送受信するマクロ
'********************************************************************************
'WindowsAPI参照定義
'クリエイト（オープン）
Private Declare PtrSafe Function CreateFile Lib "kernel32" Alias "CreateFileA" _
    (ByVal lpFileName As String, _
     ByVal dwDesiredAccess As Long, _
     ByVal dwShareMode As Long, _
     ByVal lpSecurityAttributes As Long, _
     ByVal dwCreationDisposition As Long, _
     ByVal dwFlagsAndAttributes As Long, _
     ByVal hTemplateFile As Long) As Long

Private Declare PtrSafe Function SetCommState Lib "kernel32" _
    (ByVal hCommDev As Long, _
     lpDCB As typDeviceControlBlock) As Long

Private Declare PtrSafe Function SetupComm Lib "kernel32.dll" _
    (ByVal hFile As Long, _
     ByVal dwInQueue As Long, _
     ByVal dwOutQueue As Long) As Long
'パージ(クリア)
Private Declare PtrSafe Function PurgeComm Lib "kernel32.dll" _
    (ByVal hFile As Long, _
     ByVal dwFlags As Long) As Long
'タイムアウト設定
Private Declare PtrSafe Function SetCommTimeouts Lib "kernel32" _
    (ByVal hFile As Long, _
     lpCommTimeouts As COMMTIMEOUTS) As Long
'エラークリア
Private Declare PtrSafe Function ClearCommError Lib "kernel32" ( _
    ByVal hPort As Long, _
    lpErrors As Long, _
    lpStat As COMSTAT _
    ) As Long
'リードアクセス
Private Declare PtrSafe Function ReadFile Lib "kernel32" _
    (ByVal hFile As Long, _
    lpBuffer As Any, _
    ByVal nNumberOfBytesToRead As Long, _
    lpNumberOfBytesRead As Long, _
    lpOverlapped As Long) As Long
'ライトアクセス
Private Declare PtrSafe Function WriteFile Lib "kernel32" _
    (ByVal hFile As Long, _
    lpBuffer As Any, _
    ByVal nNumberOfBytesToWrite As Long, _
    lpNumberOfBytesWritten As Long, _
    lpOverlapped As Long) As Long
'クローズ
Private Declare PtrSafe Function CloseHandle Lib "kernel32" _
    (ByVal hObject As Long) As Long
        
'デバイス制御ブロック構造体の定義
Private Type typDeviceControlBlock
    DCBlength As Long   '構造体のサイズ
    BaudRate As Long    'ボーレイト（bps）の設定
    fBitFields As Long  'ビット単位のフィールド定義
        'fBinary           :1 ; バイナリモードかどうか
        'fParity           :1 ; パリティチェックの有無
        'fOutxCtsFlow      :1 ; CTSを監視するかどうか
        'fOutxDsrFlow      :1 ; DSRを監視するかどうか
        'fDtrControl       :2 ; DTRによるハンドシェーク(2ビット)
        'fDsrSensitivity   :1 ; TrueのときDSRがオフのときの受信データを無視する
        'fTXContinueOnXoff :1 ;Xoff文字を送信した後も送信を続けるかどうか
        'fOutX             :1 ; TrueのときXoff文字を受信すると送信を停止しXon文字で再開
        'fInX              :1 ; Trueのとき受信バッファの空きに応じてXoff､Xon文字が送信される
        'fErrorChar        :1 ; Trueのときパリティエラーの処理をする
        'fNull             :1 ; Trueのときヌル文字は破棄される
        'fRtsControl       :2 ; RTSによるハンドシェーク(2ビット)
        'fAbortOnError     :1 ; Trueのときエラーが発生したら読み書きを終了する
        'fDummy2           :17; 未使用
    wReserved As Integer '予約
    XonLim As Integer    '受信バッファ中のデータが何バイトになったらXon文字を送るかを指定
    XoffLim As Integer   '受信バッファの空きが何バイトになったらXoff文字を送るかを指定
    ByteSize As Byte     '1データのビット数(5,6,7,8)を指定
    Parity As Byte       'パリティの方式を指定
        '0・・・NOPARITY(パリティなし)
        '1・・・ODDPARITY(奇数パリティ)
        '2・・・EVENPARITY(偶数パリティ)
        '3・・・MARKPARITY(常にマーク)
    StopBits As Byte 'ストップビット数を指定    '0=1ビット、1=1.5ビット、2=2ビット
    XonChar As Byte         'Xon文字を指定
    XoffChar As Byte        'Xoff文字を指定
    ErrorChar As Byte       'パリティエラーの場合に使う文字を指定
    EofChar As Byte         '非バイナリモードの場合のデータ終了文字の指定
    EvtChar As Byte         'イベントを生成する文字を指定
    wReserved1 As Integer   '予約
End Type

'***** タイムアウト設定構造体の定義 *****
Private Type COMMTIMEOUTS
    ReadIntervalTimeout As Long         '文字の読み込みの待ち時間
    ReadTotalTimeoutMultiplier As Long  '読み込みの1文字あたりの時間
    ReadTotalTimeoutConstant As Long    '読み込みの定数時間
    WriteTotalTimeoutMultiplier As Long '書き込みの1文字あたりの時間
    WriteTotalTimeoutConstant As Long   '書き込みの定数時間
End Type

'バッファサイズ
Private Const INP_BUFSIZE As Long = 65536 '入力バッファサイズ
Private Const OUT_BUFSIZE As Long = 2048 '出力バッファサイズ
    
Private Const PURGE_TXCLEAR As Long = &H4 '送信バッファクリア
Private Const PURGE_RXCLEAR As Long = &H8 '受信バッファクリア
'ファイルアクセスモード
Private Const GENERIC_READ = &H80000000 '読み取り用定数
Private Const GENERIC_WRITE = &H40000000 '書き込み用定数
Private Const OPEN_EXISTING = 3 '既存のファイルの処理
'パリティ
Private Const NOPARITY = 0    'パリティなし
Private Const ODDPARITY = 1   '奇数パリティ
Private Const EVENPARITY = 2  '偶数パリティ
Private Const MARKPARITY = 3  '常にマーク
Private Const SPACEPARITY = 4 'スペース
'ストップbit幅
Private Const ONESTOPBIT = 0   '1ビット
Private Const ONE5STOPBITS = 1 '1.5ビット
Private Const TWOSTOPBITS = 2  '2ビット


Private pDCB As typDeviceControlBlock   'デバイス制御ブロック構造体
Private pTIMEOUT As COMMTIMEOUTS        'タイムアウト設定構造体
Private pComm As Long                   'ハンドル


Private Type COMSTAT
    fCtsHold As Long
    fDsrHold As Long
    fRlsHold As Long
    fXoffHold As Long
    fXoffSent As Long
    fEof As Long
    fTxim As Long
    fReserved As Long
    cbInQue As Long
    cbOutQue As Long
End Type
  
  
'********************************************************************************
'オープン:引数1 COMポート名称("COM5"とか) 引数2:ボーレート
'********************************************************************************
Public Sub OpenCOM(ByVal iPortNum As String, ByVal iRate As Long)

    'シリアルポートをオープンする
    pComm = CreateFile(iPortNum, GENERIC_READ Or GENERIC_WRITE, 0, 0, OPEN_EXISTING, 0, 0)
    If (pComm = -1) Then 'ポートのオープン失敗
        MsgBox "COM port open error!!": End
    End If

    '***** 通信条件の設定 *****
    With pDCB
        .BaudRate = iRate                       'ボーレート
        .fBitFields = &H1                       'バイナリモード
        .fBitFields = pDCB.fBitFields Or &H2    'パリティチェックなし
        .ByteSize = 8                           'ビット長の指定
        .Parity = NOPARITY                      'パリティなし
        .StopBits = ONESTOPBIT                  'ストップビット数を1指定
    End With
    
    '状態確認
    If (SetCommState(pComm, pDCB) = 0) Then
        Call CloseCOM: MsgBox "COM state error!!": End
    End If

    'バッファの設定
    If (SetupComm(pComm, INP_BUFSIZE, OUT_BUFSIZE) = 0) Then
        Call CloseCOM: MsgBox "COM buffer error!!": End
    End If

    'バッファのクリア
    If (PurgeComm(pComm, PURGE_TXCLEAR) = 0) Then
        Call CloseCOM: MsgBox "COM purge error!!": End
    End If

    'タイムアウトの設定
    pTIMEOUT.ReadIntervalTimeout = 0            '文字の読み込み待ち時間
    pTIMEOUT.ReadTotalTimeoutMultiplier = 10    '読み込みの１文字あたりの時間
    pTIMEOUT.ReadTotalTimeoutConstant = 10      '読み込みの定数時間
    pTIMEOUT.WriteTotalTimeoutMultiplier = 10   '書き込みの１文字あたりの時間
    pTIMEOUT.WriteTotalTimeoutConstant = 10     '書き込みの定数時間
    
    If (SetCommTimeouts(pComm, pTIMEOUT) = 0) Then
        Call CloseCOM: MsgBox "COM timeout setting error!!": End
    End If
End Sub
'********************************************************************************
'クローズ
'********************************************************************************
Public Sub CloseCOM()
    Call CloseHandle(pComm)
    pComm = 0 'ハンドルをクリアしておく
End Sub

'********************************************************************************
'受信バッファクリア
'********************************************************************************
Public Function ClearBuffer() As Boolean
    Dim rtn As Boolean
    Rt = PurgeComm(pComm, PURGE_RXCLEAR)
    If (Rt = 0) Then
        rtn = False '0が返ってきたら失敗
    Else
        rtn = True
    End If
    ClearBuffer = rtn
End Function

'********************************************************************************
'リード
'********************************************************************************
Public Function Read()
    Dim ByteBuffer() As Byte    '受信バッファ
    Dim StrBuffer As String     '受信バッファ
    ByteBuffer = ReadByte()     'バイナリで受信
    StrBuffer = StrConv(ByteBuffer, vbUnicode)  'Ascii文字列をユニコード文字列に変換
    Read = StrBuffer
End Function
'********************************************************************************
'バイナリリード
'********************************************************************************
Public Function ReadByte()
    Const PACKETSIZE As Integer = 64
    Dim ByteBuf() As Byte         '受信バッファ
    Dim getSize As Long           '受信データサイズ
    Dim totalSize As Long
    totalSize = 0
    Do
        '受信バッファをパケットサイズ分だけ広げる
        ReDim Preserve ByteBuf(totalSize + PACKETSIZE)
        'パケットサイズ
        If (ReadFile(pComm, ByteBuf(totalSize), PACKETSIZE, getSize, ByVal 0) = 0) Then 'データの受信
            Call CloseCOM: End
        End If
        '受信したサイズを累積カウントする
        totalSize = totalSize + getSize
        '取得サイズがゼロになったら終了する
        If getSize <= 0 Then
            Exit Do
        End If
    Loop
    'バッファサイズを実受信サイズに合わせて余分を削ぎ落とす
    If (totalSize > 0) Then
        ReDim Preserve ByteBuf(totalSize - 1)
    Else
        ReDim ByteBuf(0)
    End If
    ReadByte = ByteBuf
End Function

'********************************************************************************
'バイナリ送信
'********************************************************************************
Public Function SendByte(ByRef mData() As Byte) As Boolean
    Dim PACKETSIZE As Long  '一度にまとめて送るデータのサイズ
    Dim remainSize As Long  'まだ送信してない残りのデータサイズ
    Dim fLen As Long        '送信されたバイト数
    Dim fLoc As Long        '送信するバイト位置
    Dim ret As Boolean
    ret = True
    PACKETSIZE = 16                 '一度にまとめて送るサイズの設定(上限はPCスペックと受信側の都合で決まる)
    remainSize = UBound(mData) + 1  '未送信データサイズ＝全データサイズ
    fLoc = 0
    Do
        '残データ量がパケットサイズ以下ならパケットサイズ縮小する
        If (remainSize < PACKETSIZE) Then
            PACKETSIZE = remainSize
        End If
        
        '送信処理
        If (WriteFile(pComm, mData(fLoc), PACKETSIZE, fLen, ByVal 0) = 0) Then 'データの送信
            Call CloseCOM
            ret = False
            Exit Do
        End If
        fLoc = fLoc + PACKETSIZE                '次に送信するバイト位置
        remainSize = remainSize - PACKETSIZE    '残データサイズ更新
        '残データ量がなくなったら送信完了
        If (remainSize <= 0) Then
            Exit Do
        End If
    Loop
    SendBin = ret
End Function
'********************************************************************************
'アスキー送信
'********************************************************************************
Public Function SendAscii(ByVal iAscii As String) As Boolean
    Dim ByteBuffer() As Byte
    Dim ByteBufferSize As Integer
    'バイナリバッファのサイズを決定
    ByteBufferSize = Len(iAscii)
    ReDim ByteBuffer(ByteBufferSize)
    'アスキーをバイナリに変換
    For i = 0 To ByteBufferSize - 1
        ByteBuffer(i) = Asc(Mid(iAscii, i + 1, 1))
    Next
    'バイナリ送信
    Call SendByte(ByteBuffer)
End Function

使い方

Sub testCOM()
    'COMポートを開く
    Dim CP As clsCOM_Port
    Set CP = New clsCOM_Port
    Call CP.OpenCOM("COM5", 115200) '引数:COM番号,ボーレート
    'バッファクリア
    Call CP.ClearBuffer
    '文字列送信
    CP.SendAscii ("r" & vbCrLf)
    '受信バッファからバイナリ配列としてデータ取得
    x = CP.ReadByte()
    'COMポートを閉じる
    CP.CloseCOM
End Sub