Excel VBAとRS-232Cでキーエンスのレーザセンサから測定値を取得する

#作ったきっかけ
前任者が作った寸法測定器(キーエンスIG-028+DL-RS1A構成)を使っていたが、7セグLEDで表示される測定値を紙にメモしたりPCへ手入力するのがめんどくさくて、

「天下のキーエンス様がPCへ値を出力する方法を用意してないわけがないよな…？」

と思ったところから始まりました。

件の測定器の構成をよく見ると、IG-028の機能しか使っていなくてDL-RS1Aは全く機能してない状態でした。
恐らく前任者はPCで測定値を取得するつもりでRS-232C通信ユニット(DL-RS1A)を買ったものの、諦めてしまったのでしょう。

社内のいろんな人が使う事や、測定値をまとめる事を考えるとExcelに直接取り込めた方がよさそうです。
でも、Excel VBAでRS-232C通信ってどうやるの…？？

#仕組み
VBA単体でRS-232C通信を実現するのは無理です。
なので、Win32APIというWindowsが提供しているAPIを使います。

また、RS-232C通信ユニット(DL-RS1A)に繋げたレーザセンサ(IG-028)の測定値を取得するには、RS-232Cで「M0(エムゼロ)」と送ってやるだけで、測定値が返って来ます。

キーエンスの機器の詳しい仕様については取扱い説明書を読もう！
他にも色んなコマンドがあるようです。

ちなみに、コマンドの送受信だけならTera Termで出来ます。

#Excelの準備
Sheet1シートに測定値を出力していきます。
A1セルに測定No.、B1セルに測定値と入力しておいてください。

設定シートにはB1～B6に通信の設定を入力しておいて下さい。

#コード

• comm()
  →M0コマンドを送信して測定値をセルに出力するマクロ
• dataClear()
  →A列とB列の1行目の残して以降の行を消すマクロ(オマケです)
• buf = String(4096, vbNullChar)の4096は受信するデータ長に合わせて変更して下さい。無駄にデカいと無駄に時間がかかります。

'RS-232C通信用のWIN32API定義
Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" _
  (ByVal filename As String, ByVal rw As Long, _
   ByVal d1 As Long, ByVal d2 As Long, ByVal d3 As Long, _
   ByVal d4 As Long, ByVal d5 As Long) As Long
Declare Sub CloseHandle Lib "kernel32" (ByVal handle As Long)
Declare Sub ReadFile Lib "kernel32" _
  (ByVal handle As Long, ByVal buf As String, _
   ByVal bytes As Long, readbytes As Long, ByVal d1 As Long)
Declare Sub WriteFile Lib "kernel32" _
  (ByVal handle As Long, ByVal buf As String, _
   ByVal bytes As Long, writebytes As Long, ByVal d1 As Long)
Private Type DCB
    DCBlength As Long
    BaudRate As Long
    Fields As Long
    wReserved As Integer
    XonLim As Integer
    XoffLim As Integer
    ByteSize As Byte
    Parity As Byte
    StopBits As Byte
    XonChar As Byte
    XoffChar As Byte
    ErrorChar As Byte
    EofChar As Byte
    EvtChar As Byte
    wReserved1 As Integer
End Type
Declare Function SetCommState Lib "kernel32" _
   (ByVal h As Long, _
    ByRef lpDCB As DCB) As Long
Declare Sub SetCommTimeouts Lib "kernel32" _
  (ByVal handle As Long, ct As COMMTIMEOUTS)

'CreateFileパラメータ用定数
Const GENERIC_READ = (&H80000000)
Const GENERIC_WRITE = (&H40000000)
Const OPEN_EXISTING = 3

'SetCommTimeouts関数用構造体定義
Type COMMTIMEOUTS
    ReadIntervalTimeout As Long
    ReadTotalTimeoutMultiplier As Long
    ReadTotalTimeoutConstant As Long
    WriteTotalTimeoutMultiplier As Long
    WriteTotalTimeoutConstant As Long
End Type

Sub comm()
    Dim buf As String
    Dim port As String
    Dim cs As DCB
    Dim ct As COMMTIMEOUTS
    Dim l As Long
    Dim sendStr As String
    Dim a As String
    Dim row As Long
    Dim col As Long
    Dim sheet As Worksheet
    Dim settingSheet As Worksheet
    
    'シートオブジェクトの設定
    Set sheet = Worksheets("Sheet1")
    Set settingSheet = Worksheets("設定")
    
    'ポートオープン
    port = settingSheet.Range("B1").Value
    h = CreateFile(port, GENERIC_READ + GENERIC_WRITE, _
                   0, 0, OPEN_EXISTING, 0, 0)
    If h = 0 Then
        MsgBox "通信ポート " & port & " がオープンできません", _
               vbExclamation + vbOKOnly, "通信テスト"
        Exit Sub
    End If
    
    'RS-232C通信設定
    cs.BaudRate = settingSheet.Range("B2").Value
    cs.ByteSize = settingSheet.Range("B3").Value
    cs.Parity = settingSheet.Range("B4").Value
    cs.StopBits = settingSheet.Range("B5").Value
    cs.Fields = settingSheet.Range("B6").Value
    SetCommState h, cs
      
    'タイムアウト時間の設定
    ct.ReadIntervalTimeout = 0
    ct.ReadTotalTimeoutMultiplier = 1
    ct.ReadTotalTimeoutConstant = 100
    ct.WriteTotalTimeoutConstant = 100
    ct.WriteTotalTimeoutMultiplier = 1
    SetCommTimeouts h, ct

    'コマンドの送出
    sendStr = "M0"
    buf = sendStr + Chr(13) + Chr(10)
    WriteFile h, buf, Len(buf), l, 0

    'レスポンスの受信(4096の部分は受信するデータ長に合わせて短くして下さい。通信時間が無駄に長くなります)
    buf = String(4096, vbNullChar)
    ReadFile h, buf, Len(buf), l, 0
    
    'ポートのクローズ
    CloseHandle h

    
    '受信データ(buf)のパース
    buf = Replace(buf, vbNullChar, "")
    buf = Replace(buf, Chr(10), "")
    buf = Replace(buf, Chr(13), "")
    buf = Replace(buf, sendStr + ",", "")
    
    '結果を指定セルにセット
    'B列の最終行を取得して、1列下を指定
    row = sheet.Cells(Rows.Count, 2).End(xlUp).row + 1
    col = 2
    If buf <> "" Then
        sheet.Cells(row, col).NumberFormatLocal = "0.000"
        sheet.Cells(row, col).HorizontalAlignment = xlCenter
        sheet.Cells(row, col - 1).HorizontalAlignment = xlCenter
        Range(Cells(row, col - 1), Cells(row, col)).Borders.LineStyle = xlContinuous
        sheet.Cells(row, col).Value = buf
        If row = 2 And sheet.Cells(row, col - 1).Value = "" Then
            sheet.Cells(row, col - 1).Value = 1
        ElseIf sheet.Cells(row, col - 1).Value <> 1 Then
            sheet.Cells(row, col - 1).Value = sheet.Cells(row - 1, col - 1).Value + 1
        End If
    End If
End Sub

Sub dataClear()
    Dim sheet As Worksheet
    Dim lastRow As Double
    Dim rc As Integer
    
    Set sheet = Worksheets("Sheet1")
    
    rc = MsgBox("測定データを消去しますか？", vbYesNo + vbQuestion, "確認")
    If rc = vbYes Then
        lastRow = sheet.Cells(Rows.Count, 2).End(xlUp).row
        sheet.Range("A2", Cells(lastRow, 2)).Clear
        MsgBox "測定データを消去しました"
    Else
        MsgBox "処理を中断します"
    End If
End Sub

#参考文献
https://qiita.com/pbjpkas/items/f81947ce38941356ebe4
http://shoji.blog1.fc2.com/blog-entry-34.html