Serial Port Programming on VB / VBA with Windows API

An example how to use Windows API to control a serial port or a USB VCP device from VB6 or VBA (Excel, Access, AutoCAD).

The code below shows how to declare WinAPI data structures (like DCB and COMMTIMEOUTS) in VB code and how to import some WinAPI functions that we will use to open a serial port and read the data.

How to Proceed

Create a VB or VBA module and paste the following code into the module;
Make sure you have specified a correct serial port number;
Check your port speed;
Check that you use correct parity settings;

Data Structures

We use the same field names in the data structures as they appear in the MSDN.

Since VB does not support C/C++ bitfields (fBinary, fParity, fOutxCtsFlow), these fields are grouped into a single fBitFields variable in the DCB structure and we use flags like F_BINARY, F_PARITY, F_OUTX_CTS_FLOW to set these bitfields:

dcb.fBitFields = F_BINARY Or F_PARITY Or F_OUTX_CTS_FLOW;

The Code Example

'---------------BEGIN-OF-DECLARATIONS------------------------------------------------------------------------------
Private Type DCB
  DCBlength As Long 
  BaudRate As Long
  fBitFields 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

' The structure of the fBitFields field. 
' FieldName             Bit #     Description
' -----------------     -----     ------------------------------
' fBinary                 1       Windows does not support nonbinary mode transfers, so this member must be =1.
' fParity                 2       If =1, parity checking is performed and errors are reported
' fOutxCtsFlow            3       If =1 and CTS is turned off, output is suspended until CTS is sent again.
' fOutxDsrFlow            4       If =1 and DSR is turned off, output is suspended until DSR is sent again.
' fDtrControl             5,6     DTR flow control (2 bits)
' fDsrSensitivity         7       The driver ignores any bytes received, unless the DSR modem input line is high.
' fTXContinueOnXoff       8       XOFF continues Tx
' fOutX                   9       If =1, TX stops when the XoffChar character is received and starts again when the XonChar character is received.
' fInX                   10       Indicates whether XON/XOFF flow control is used during reception.
' fErrorChar             11       Indicates whether bytes received with parity errors are replaced with the character specified by the ErrorChar.
' fNull                  12       If =1, null bytes are discarded when received.
' fRtsControl            13,14    RTS flow control (2 bits)
' fAbortOnError          15       If =1, the driver terminates all I/O operations with an error status if an error occurs.
' fDummy2                16       reserved

'---------fBitFields-------------
Const F_BINARY = 1
Const F_PARITY = 2
Const F_OUTX_CTS_FLOW = 4
Const F_OUTX_DSR_FLOW = 8

' DTR Control Flow Values.
Const F_DTR_CONTROL_ENABLE = &H10
Const F_DTR_CONTROL_HANDSHAKE = &H20

Const F_DSR_SENSITIVITY = &H40
Const F_TX_CONTINUE_ON_XOFF = &H80
Const F_OUT_X = &H100
Const F_IN_X = &H200
Const F_ERROR_CHAR = &H400
Const F_NULL = &H800

' RTS Control Flow Values
Const F_RTS_CONTROL_ENABLE = &H1000
Const F_RTS_CONTROL_HANDSHAKE = &H2000
Const F_RTS_CONTROL_TOGGLE = &H3000

Const F_ABORT_ON_ERROR = &H4000

'---------Parity flags--------
Const EVENPARITY = 2
Const MARKPARITY = 3
Const NOPARITY = 0
Const ODDPARITY = 1
Const SPACEPARITY = 4

'---------StopBits-----------
Const ONESTOPBIT = 0
Const ONE5STOPBITS = 1
Const TWOSTOPBITS = 2

'-----------------------------------------------------------------------------------------------
Private Type COMMTIMEOUTS
  ReadIntervalTimeout As Long
  ReadTotalTimeoutMultiplier As Long
  ReadTotalTimeoutConstant As Long
  WriteTotalTimeoutMultiplier As Long
  WriteTotalTimeoutConstant As Long
End Type
'-----------------------------------------------------------------------------------------------

' Constants for the dwDesiredAccess parameter of the CreateFile() function
Const GENERIC_READ = &H80000000
Const GENERIC_WRITE = &H40000000

' Constants for the dwShareMode parameter of the CreateFile() function
Const FILE_SHARE_READ = &H1
Const FILE_SHARE_WRITE = &H2

' Constants for the dwCreationDisposition parameter of the CreateFile() function
Const CREATE_NEW = 1
Const CREATE_ALWAYS = 2
Const OPEN_EXISTING = 3

' Constants for the dwFlagsAndAttributes parameter of the CreateFile() function
Const FILE_ATTRIBUTE_NORMAL = &H80
Const FILE_FLAG_OVERLAPPED = &H40000000

'-----------------------------------------------------------------------------------------------
' Error codes reported by the CreateFile().
' More error codes with descriptions are available at MSDN
Const ERROR_FILE_NOT_FOUND = 2
Const ERROR_ACCESS_DENIED = 5
Const ERROR_INVALID_HANDLE = 6


Private Declare 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 Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function SetCommState Lib "kernel32" (ByVal hFile As Long, lpDCB As DCB) As Long
Private Declare Function GetCommState Lib "kernel32" (ByVal hFile As Long, lpDCB As DCB) As Long

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

Private Declare Function GetCommTimeouts Lib "kernel32" (ByVal hFile As Long, _
        lpCommTimeouts As COMMTIMEOUTS) As Long

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

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

'---------------END-OF-DECLARATIONS------------------------------------------------------------------------------ 

Public Sub Init_Com()
    Dim rc As Long
    
    Dim h As Long
    h = CreateFile("\\.\COM24", GENERIC_READ Or GENERIC_WRITE, 0, 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)
    ' For serial port numbers higher than 9, see this HOWTO

    If h = -1 Then
        rc = Err.LastDllError
        Select Case rc ' Two typical error codes when trying to open a serial port:
         Case ERROR_ACCESS_DENIED  ' - The serial port opened by another application
           MsgBox "The serial port is used by another program"
         Case ERROR_FILE_NOT_FOUND ' - The serial port does not exist, check the port name specified in the CreateFile()
           MsgBox "The serial port does not exist"
         Case Else
           MsgBox "CreateFile failed, the error code is " & Str(rc)
        End Select
        Exit Sub
    End If

    Dim d As DCB ' The DCB structure and the SetCommState() function allow to set the baud rate and the byte size of the serial port.
    rc = GetCommState(h, d)
    d.ByteSize = 8
    d.BaudRate = 115200
    d.fBitFields = F_BINARY ' Windows does not support non-binary data transfers so the flag must always be set in the DCB structure.

    ' Another example how to set some flags in the DCB:
    ' d.fBitFields = F_BINARY Or F_PARITY Or F_RTS_CONTROL_ENABLE

    d.StopBits = ONESTOPBIT
    d.Parity = NOPARITY
    rc = SetCommState(h, d)
    If rc = 0 Then
      rc = Err.LastDllError
      MsgBox "SetCommState failed, the error code is " & Str(rc)
    End If


    Dim timeouts As COMMTIMEOUTS ' Because we don't want communication timeouts to hang the VB code,
    rc = GetCommTimeouts(h, timeouts)  ' we need to specify the maximum time Windows will wait for incoming data
    timeouts.ReadIntervalTimeout = 3  ' The max. time in milliseconds between arrival of any two bytes
    timeouts.ReadTotalTimeoutConstant = 20 ' The max. time the ReadFile() function will wait for data.
    timeouts.ReadTotalTimeoutMultiplier = 0
    rc = SetCommTimeouts(h, timeouts)
    If rc = 0 Then
      rc = Err.LastDllError
      MsgBox "SetCommTimeouts failed, the error code is " & Str(rc)
      GoTo close_and_exit
    End If

    
    ' Sending an array of 3 bytes to a remote device.

    Dim bWrite(1 To 3) As Byte 
    bWrite(1) = &HA1
    bWrite(2) = &HB2
    bWrite(3) = &HC3
    Dim wr As Long
    rc = WriteFile(h, bWrite(1), 3, wr, 0) ' The wr indicates how many bytes were went to the port.
    If rc = 0 Then
      rc = Err.LastDllError
      MsgBox "WriteFile failed, the error code is " & Str(rc)
      GoTo close_and_exit
    End If
    

    ' Now we want to receive an answer from the remote device.

    Dim bRead(1 To 10) As Byte  ' We want to receive up to 10 bytes.
    Dim rd As Long
    rc = ReadFile(h, bRead(1), 10, rd, 0) ' The rd indicates how many bytes were received from the port.
    If rc = 0 Then
      rc = Err.LastDllError
      MsgBox "ReadFile failed, the error code is " & Str(rc)
      GoTo close_and_exit
    End If
    
    Dim s As String ' Printing the received data in hexadecimal form.
    Dim i As Long
    For i = 1 To rd
      s = s & Hex(bRead(i)) & " "
    Next i
    MsgBox s
    
close_and_exit:
    rc = CloseHandle(h) ' In VBA, always execute this call. Or you will receive the ERROR_ACCESS_DENIED next time when opening the port
                        ' and you will need to reload Word/Excel/Access to free the port.
End Sub