ok, here a solution by usig directly Win API
'---------------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 Integer
Parity As Integer
StopBits As Integer
XonChar As Integer
XoffChar As Integer
ErrorChar As Integer
EofChar As Integer
EvtChar As Integer
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("\\.\COM1", 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 = 9600
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 8 bytes to a remote device.
Dim bWrite(1 To 4) As Integer
bWrite(1) = &H0601
bWrite(2) = &H0100
bWrite(3) = &H0400
bWrite(4) = &HC9D9
Dim wr As Long
rc = WriteFile(h, bWrite(1), 8, 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
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
Guest
