Excel VBAでRS232C通信しよう（kernel32を使用）

Option Explicit

Public CommError As Long
Public CommStatus As COMSTAT

Public Const GENERIC_READ = &H80000000
Public Const GENERIC_WRITE = &H40000000
Public Const FILE_ATTRIBUTE_NORMAL = &H80
Public Const OPEN_EXISTING = 3

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

Declare PtrSafe Function WriteFile Lib "kernel32" _
                         (ByVal hFile As Long, _
                         lpBuffer As Any, _
                         ByVal nNumberOfBytesToWrite As Long, _
                         lpNumberOfBytesWritten As Long, _
                         ByVal lpOverlapped As Long) As Boolean

Declare PtrSafe Function ReadFile Lib "kernel32" _
                         (ByVal hFile As Long, lpBuffer As Any, _
                         ByVal nNumberOfBytesToRead As Long, _
                         lpNumberOfBytesRead As Long, _
                         ByVal lpOverlapped As Long) As Boolean

Declare PtrSafe Function CloseHandle Lib "kernel32" _
                         (ByVal hObject As Long) As Long

Declare PtrSafe Function FlushFileBuffers Lib "kernel32" _
                         (ByVal hFile As Long) As Long

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

Declare PtrSafe Function SetCommTimeouts Lib "kernel32" _
                         (ByVal hFile As Long, _
                         lpCommTimeouts As COMMTIMEOUTS) As Long

Declare PtrSafe Function SetCommMask Lib "kernel32" _
                         (ByVal hFile As Long, _
                         ByVal dwEvtMask As Long) As Long

Declare PtrSafe Function SetupComm Lib "kernel32" _
                         (ByVal hFile As Long, _
                         ByVal dwInQueue As Long, _
                         ByVal dwOutQueue As Long) As Long

Declare PtrSafe Function GetCommState Lib "kernel32" _
                         (ByVal nCid As Long, lpDCB As DCB) As Long

Declare PtrSafe Function ClearCommError Lib "kernel32" _
                         (ByVal hFile As Long, _
                         lpErrors As Long, _
                         lpStat As COMSTAT) As Long

Type DCB
    DCBlength As Long
    BaudRate As Long
    bfModeCTL 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

Type COMMTIMEOUTS
    ReadIntervalTimeout As Long
    ReadTotalTimeoutMultiplier As Long
    ReadTotalTimeoutConstant As Long
    WriteTotalTimeoutMultiplier As Long
    WriteTotalTimeoutConstant As Long
End Type

Type COMSTAT
    bfHold As Long
    cbInQue As Long
    cbOutQue As Long
End Type

'ポートオープン
Public Function portOpen() As Long
    Dim Tmo As COMMTIMEOUTS
    Dim CommCB As DCB
    Dim strPort As String
    Dim lngBaud As Long
    
    strPort = "\\.\COM1"
    lngBaud = 38400
    
    portOpen = CreateFile(strPort, (GENERIC_READ Or GENERIC_WRITE), _
                                 0&, 0&, OPEN_EXISTING, _
                                 FILE_ATTRIBUTE_NORMAL, 0&)
    
    If portOpen = -1 Then Exit Function
    SetCommMask portOpen, 0&
    SetupComm portOpen, 10000, 1024&
    
    Tmo.ReadIntervalTimeout = 0
    Tmo.ReadTotalTimeoutMultiplier = CLng(40000 / lngBaud + 1)
    Tmo.ReadTotalTimeoutConstant = 1000&
    Tmo.WriteTotalTimeoutMultiplier = CLng(40000 / lngBaud + 1)
    Tmo.WriteTotalTimeoutConstant = 1000&
    
    SetCommTimeouts portOpen, Tmo
    GetCommState portOpen, CommCB
    
    CommCB.DCBlength = LenB(CommCB)
    CommCB.BaudRate = lngBaud
    CommCB.bfModeCTL = &H2055
    CommCB.XoffLim = 64
    CommCB.XonLim = 64
    CommCB.ByteSize = 8
    CommCB.Parity = 0
    CommCB.StopBits = 0
    
    If SetCommState(portOpen, CommCB) = 0 Then GoTo CommOpenErr
    Exit Function
    
CommOpenErr:
    CloseHandle (portOpen)
    portOpen = -2
    
End Function

'ポートクローズ
Public Sub portClose(ByVal hcomm As Long)
    CloseHandle hcomm
End Sub

'送受信
Public Function wrkRsComm(ByVal hdlComm As Long, _
                                strSend As String, strRet As String) As Long
    Dim bolRet As Boolean
    Dim lngLen As Long
    Dim lngCnt As Long
    Dim strRev As String * 1000
    Dim sttmr As Single
    Dim ctmr As Single
    
    wrkRsComm = 0
    strRet = ""
    
    '送信
    lngLen = Len(strSend)
    bolRet = WriteFile(hdlComm, ByVal strSend, lngLen, lngCnt, 0&)
    
    '送信エラー
    If lngCnt < lngLen Then
        Call ClearCommError(hdlComm, CommError, CommStatus)
        strRet = "ERROR"
        Call portClose(hdlComm)
        Exit Function
    End If
    
    'ウェイト
    sttmr = Timer
    
    '受信
    Do
        ctmr = Timer
        DoEvents
        bolRet = ReadFile(hdlComm, ByVal strRev, 1000, lngCnt, 0)
        
        If lngCnt <> 0 Then
            strRet = strRet & Left$(strRev, lngCnt)
            wrkRsComm = wrkRsComm + lngCnt
            If InStr(strRet, vbCrLf) > 0 Then Exit Do
        End If
        
        'タイムアウト
        If ctmr > sttmr + 2 Then
            strRet = "time out"
            Exit Do
        End If
    Loop
    
End Function

Option Explicit

'ファイルハンドル
Private fileHandle As Long

'ポートオープン
Private Sub CommandButton1_Click()
    fileHandle = portOpen()
    
    If fileHandle < 0 Then
        Range("C7") = "NG"
    else
        Range("C7") = "OK"
    End If
End Sub

'ポートクローズ
Private Sub cmdButton2_Click()
    Call portClose(fileHandle)
    Range("C7") = ""
End Sub

'コマンド送受信
Private Sub CommandButton3_Click()
    Dim lngRet As Long
    Dim strCmd As String
    Dim strRev As String
    
    strCmd = Range("C9") & vbCrLf
    lngRet = wrkRsComm(fileHandle, strCmd, strRev)

    If lngRet <> 0 Then
        '返送ﾃﾞｰﾀを表示
        Range("C10") = strRev
    EndIf

End Function