Attribute VB_Name = "Win32Comm"
Option Explicit
Option Base 0

'================================================
' Win32Comm V1.0
'
' VBA module for serial port access
'
' Copyright(c) Chris Kwon
' Last update: 2007.9.28
'=================================================

'--------------------
' API constants
'--------------------

Public Const INVALID_HANDLE_VALUE = -1
Public Const GENERIC_READ = &H80000000
Public Const GENERIC_WRITE = &H40000000
Public Const OPEN_EXISTING = 3

'  PURGE function flags.
Public Const PURGE_TXCLEAR = &H4
Public Const PURGE_RXCLEAR = &H8

'  Modem Status Flags
Public Const MS_CTS_ON = &H10&
Public Const MS_DSR_ON = &H20&
Public Const MS_RING_ON = &H40&
Public Const MS_RLSD_ON = &H80&

'--------------------
' API structures
'--------------------

Type DCB
    DCBlength As Long
    baudrate As Long
    fBitFields As Long 'See Comments in Win32API.Txt
    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 'Reserved; Do Not Use
End Type

'not used in this module
'Type COMMTIMEOUTS
'    ReadIntervalTimeout As Long
'    ReadTotalTimeoutMultiplier As Long
'    ReadTotalTimeoutConstant As Long
'    WriteTotalTimeoutMultiplier As Long
'    WriteTotalTimeoutConstant As Long
'End Type

Type COMSTAT
    fBitFields As Long 'See Comment in Win32API.Txt
    cbInQue As Long
    cbOutQue As Long
End Type

'not used in this module
'Type COMMPROP
'    wPacketLength As Integer
'    wPacketVersion As Integer
'    dwServiceMask As Long
'    dwReserved1 As Long
'    dwMaxTxQueue As Long
'    dwMaxRxQueue As Long
'    dwMaxBaud As Long
'    dwProvSubType As Long
'    dwProvCapabilities As Long
'    dwSettableParams As Long
'    dwSettableBaud As Long
'    wSettableData As Integer
'    wSettableStopParity As Integer
'    dwCurrentTxQueue As Long
'    dwCurrentRxQueue As Long
'    dwProvSpec1 As Long
'    dwProvSpec2 As Long
'    wcProvChar(1) As Integer
'End Type

'--------------------
' API routines
'--------------------
Public 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
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Public Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, ByRef lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, ByRef lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) As Long
Public Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, ByRef lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, ByRef lecActiveOfBytesRead As Long, ByVal lpOverlapped As Long) As Long

' COMM declarations
Public Declare Function GetCommState Lib "kernel32" (ByVal nCid As Long, ByRef lfDCB As DCB) As Long
Public Declare Function SetCommState Lib "kernel32" (ByVal hCommDev As Long, ByRef lfDCB As DCB) As Long
Public Declare Function BuildCommDCB Lib "kernel32" Alias "BuildCommDCBA" (ByVal lpDef As String, ByRef lfDCB As DCB) As Long
Public Declare Function PurgeComm Lib "kernel32" (ByVal hFile As Long, ByVal dwFlags As Long) As Long
Public Declare Function ClearCommError Lib "kernel32" (ByVal hFile As Long, ByRef lpErrors As Long, ByRef lpStat As COMSTAT) As Long
Public Declare Function SetupComm Lib "kernel32" (ByVal hFile As Long, ByVal dwInQueue As Long, ByVal dwOutQueue As Long) As Long
Public Declare Function GetCommModemStatus Lib "kernel32" (ByVal hFile As Long, lpModemStat As Long) As Long
Public Declare Function SetCommBreak Lib "kernel32" (ByVal nCid As Long) As Long
Public Declare Function ClearCommBreak Lib "kernel32" (ByVal nCid As Long) As Long

' not use in this module but maybe useful
'Declare Function GetCommTimeouts Lib "kernel32" (ByVal hFile As Long, ByRef lfCOMMTIMEOUTS As COMMTIMEOUTS) As Long
'Declare Function SetCommTimeouts Lib "kernel32" (ByVal hFile As Long, ByRef lfCOMMTIMEOUTS As COMMTIMEOUTS) As Long
'Declare Function GetCommProperties Lib "kernel32" (ByVal hFile As Long, ByRef lfCOMMPROP As COMMPROP) As Long
'Declare Function BuildCommDCBAndTimeouts Lib "kernel32" Alias "BuildCommDCBAndTimeoutsA" (ByVal lpDef As String, lpDCB As DCB, lpCommTimeouts As COMMTIMEOUTS) As Long
'Declare Function TransmitCommChar Lib "kernel32" (ByVal nCid As Long, ByVal cChar As Byte) As Long
'Declare Function EscapeCommFunction Lib "kernel32" (ByVal nCid As Long, ByVal nFunc As Long) As Long
'Declare Function GetCommMask Lib "kernel32" (ByVal hFile As Long, lpEvtMask As Long) As Long
'Declare Function SetCommMask Lib "kernel32" (ByVal hFile As Long, ByVal dwEvtMask As Long) As Long
'Declare Function WaitCommEvent Lib "kernel32" (ByVal hFile As Long, lpEvtMask As Long, lpOverlapped As OVERLAPPED) As Long

'--------------------
' User routines
'--------------------

' CommOpen
' portname: "COM1", "COM2",...
' setting:
'   baud = number
'   parity = N, O, E, M, S
'   data = 5, 6, 7, 8
'   stop = 1, 1.5, 2
' ex1. CommOpen "COM1", "9600, n, 8, 1"  'keep order
' ex2. CommOpen "COM1", "parity=n stop=1 data=8 baud=9600" 'free order
Public Function CommOpen(PortName As String, Optional Setting As String = "9600, n, 8, 1") As Long
    Dim Handle As Long
    Dim fdcb As DCB
    
    CommOpen = 0 ' set to return error
    Handle = CreateFile("\\.\" & PortName, GENERIC_READ Or GENERIC_WRITE, 0&, 0&, OPEN_EXISTING, 0&, 0&)
    If Handle = INVALID_HANDLE_VALUE Then Exit Function
    
    'if CommOpen turn outs to be zero at the end, release handle before return
    CommOpen = Handle
    
    'default communcation settings
    If GetCommState(Handle, fdcb) = 0 Then CommOpen = 0
    If BuildCommDCB(Setting, fdcb) = False Then CommOpen = 0
    'fdcb.fBitFields = &H1011
    If SetCommState(Handle, fdcb) = False Then CommOpen = 0
    
    'flow & buffer settings
    If CommSetFlowControl(Handle, "N") = 0 Then CommOpen = 0    'no flow control
    If CommSetBuffers(Handle, 1024, 1024) = 0 Then CommOpen = 0 '1k in & out buffers
    If CommClear(Handle) = 0 Then CommOpen = 0
    
    'release handle if error
    If CommOpen = 0 Then CommClose Handle
End Function

'CommSetFlowControl
' flow: "No", "XonXoff", "RTS", "DTR". internally use only first characters. So "N", "X", "R", "D" is okay.
Public Function CommSetFlowControl(Handle As Long, Flow As String, _
        Optional xonChar As Byte = &H11, Optional xoffChar As Byte = &H13, _
        Optional xonlim As Integer = 128, Optional xofflim As Integer = 128) As Long
    Dim fdcb As DCB
    
    CommSetFlowControl = 0
    Flow = Left(UCase(Flow), 1)         'use only first character
    If GetCommState(Handle, fdcb) = False Then Exit Function
    With fdcb
        .fBitFields = .fBitFields And &HCC83            'reset bits
        Select Case Flow
            Case Is = "N"   'no control
                .fBitFields = .fBitFields Or &H1010     'set correspondant bit
            Case Is = "X"   'Xon/Xoff
                .fBitFields = .fBitFields Or &H1310     'set correspondant bit
            Case Is = "R"   'RTS
                .fBitFields = .fBitFields Or &H2014     'set correspondant bit
            Case Is = "D"   'DTR
                .fBitFields = .fBitFields Or &H1028     'set correspondant bit
        End Select
    End With
    fdcb.xonlim = xonlim
    fdcb.xofflim = xofflim
    fdcb.xonChar = xonChar
    fdcb.xoffChar = xoffChar
    If SetCommState(Handle, fdcb) = False Then Exit Function
    CommSetFlowControl = 1
End Function

Public Function CommSetBuffers(Handle As Long, InBufferSize As Long, OutBufferSize As Long) As Long
    CommSetBuffers = 0
    If SetupComm(Handle, InBufferSize, OutBufferSize) = False Then Exit Function
    CommSetBuffers = 1
End Function

'CommWrite
'byteData:  accepts Byte, Integer, Long, Single, Double & the arrays.
'           Data over 255 or below 0 are truncated.
'           String is converted into ANSI string
Public Function CommWrite(Handle As Long, ByteData As Variant, Optional length As Long = 0) As Long
    Dim bdata() As Byte, StrTemp As String
    Dim WriteBytes As Long, WrittenBytes As Long, rv As Long, i As Long
    
    CommWrite = 0
    Select Case TypeName(ByteData)
        Case "Byte"
            ReDim bdata(0 To 0)
            bdata(0) = ByteData
        Case "Integer", "Long", "Single", "Double"
            ReDim bdata(0 To 0)
            If ByteData < 0 Then bdata(0) = 0 _
            Else If ByteData > 255 Then bdata(0) = 255 _
            Else bdata(0) = CByte(ByteData)
        Case "Byte()"
            bdata = ByteData
        Case "String"
            If ByteData = "" Then Exit Function
            bdata = StrConv(ByteData, vbFromUnicode) 'ANSI
        Case "Integer()", "Long()", "Single()", "Double()", "Variant()"
            ReDim bdata(LBound(ByteData) To UBound(ByteData))
            For i = LBound(ByteData) To UBound(ByteData)
                If ByteData(i) < 0 Then bdata(i) = 0 _
                Else If ByteData(i) > 255 Then bdata(i) = 255 _
                Else bdata(i) = CByte(ByteData(i))
            Next i
            ReDim Preserve bdata(0 To UBound(bdata) - LBound(bdata))
        Case Else
            Exit Function
    End Select
    
    WriteBytes = UBound(bdata) + 1
    If length = 0 Then length = WriteBytes
    If length < WriteBytes Then WriteBytes = length
    rv = WriteFile(Handle, bdata(0), WriteBytes, WrittenBytes, 0&)
    If WriteBytes = WrittenBytes Then CommWrite = WrittenBytes
End Function

Public Function CommWriteRTS(Handle As Long, level As Long) As Long
    Dim Stat As Long    ' Status
    Dim fdcb As DCB
    
    CommWriteRTS = 0
    If GetCommState(Handle, fdcb) = False Then Exit Function
    fdcb.fBitFields = .fBitFields And &HCFFB
    If level <> 0 Then fdcb.fBitFields = fdcb.fBitFields Or &H1000
    If SetCommState(Handle, fdcb) = False Then Exit Function
    CommWriteRTS = 1
End Function

Public Function CommWriteDTR(Handle As Long, level As Long) As Long
    Dim Stat As Long    ' Status
    Dim fdcb As DCB
    
    CommWriteDTR = 0
    If GetCommState(Handle, fdcb) = False Then Exit Function
    fdcb.fBitFields = .fBitFields And &HFFC7
    If level <> 0 Then fdcb.fBitFields = fdcb.fBitFields Or &H10
    If SetCommState(Handle, fdcb) = False Then Exit Function
    CommWriteDTR = 1
End Function

Public Function CommNumRcv(Handle As Long) As Long
    Dim fcomstat As COMSTAT
    Dim Er As Long
        
    CommNumRcv = 0
    If ClearCommError(Handle, Er, fcomstat) = False Then Exit Function
    CommNumRcv = fcomstat.cbInQue
End Function

Public Function CommReadBytes(Handle As Long, Optional length As Long = 0) As Byte()
    Dim ByteData() As Byte
    Dim ReadedBytes As Long, numInQue As Long
    
    ReDim CommReadBytes(0 To 0)
    numInQue = CommNumRcv(Handle)
    If numInQue = 0 Then Exit Function
    If length = 0 Then length = numInQue 'size of array
    If length > numInQue Then length = numInQue
    
    ReDim ByteData(1 To length)
    
    If ReadFile(Handle, ByteData(1), length, ReadedBytes, 0&) = False Then Exit Function
    If length <> ReadedBytes Then Exit Function
    CommReadBytes = ByteData
End Function

Public Function CommReadStr(Handle As Long, Optional length As Long = 0) As String
    Dim ByteData() As Byte
    
    CommReadStr = ""
    ByteData = CommReadBytes(Handle, length)
    If UBound(ByteData) = 0 Then Exit Function
    CommReadStr = StrConv(ByteData, vbUnicode)
End Function

Public Function CommReadCTS(Handle As Long) As Long
    Dim Stat As Long    ' Status
    
    CommReadCTS = 0
    If GetCommModemStatus(Handle, Stat) = False Then Exit Function
    If (Stat And MS_CTS_ON) = 0 Then CommReadCTS = -1 Else CommReadCTS = 1
End Function

Public Function CommReadDSR(Handle As Long) As Long
    Dim Stat As Long    ' Status
    
    CommReadDSR = 0
    If GetCommModemStatus(Handle, Stat) = False Then Exit Function
    If (Stat And MS_DSR_ON) = 0 Then CommReadDSR = -1 Else CommReadDSR = 1
End Function

Public Function CommReadDCD(Handle As Long) As Long
    Dim Stat As Long    ' Status
    
    CommReadDCD = 0
    If GetCommModemStatus(Handle, Stat) = False Then Exit Function
    If (Stat And MS_RLSD_ON) = 0 Then CommReadDCD = -1 Else CommReadDCD = 1
End Function

Public Function CommReadRI(Handle As Long) As Long
    Dim Stat As Long    ' Status
    
    CommReadRI = 0
    If GetCommModemStatus(Handle, Stat) = False Then Exit Function
    If (Stat And MS_RING_ON) = 0 Then CommReadRI = -1 Else CommReadRI = 1
End Function

Public Function CommClear(Handle As Long) As Long
    CommClear = 1
    If CommClearRx(Handle) = 0 Then CommClear = 0
    If CommClearTx(Handle) = 0 Then CommClear = 0
End Function

Public Function CommClearRx(Handle As Long) As Long
    CommClearRx = 1
    If PurgeComm(Handle, PURGE_RXCLEAR) = False Then CommClearRx = 0
End Function

Public Function CommClearTx(Handle As Long) As Long
    CommClearTx = 1
    If PurgeComm(Handle, PURGE_TXCLEAR) = False Then CommClearTx = 0
End Function

Public Function CommClose(Handle As Long) As Long
    CommClose = CloseHandle(Handle)
End Function