概要
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