' МОДУЛЬ ДЛЯ РАБОТЫ С COM-ПОРТОМ
' при помощи API.
'Где взял модуль, не помню. Довёл до ума.
'--------------------------------------------------------
Option Explicit
'глобальные переменные
Global ComNum As Long 'хэндл открытого порта; >0, если порт открыт.
Global BarDCB As DCB 'таблица параметров порта
Global CtimeOut As COMMTIMEOUTS 'таймауты порта
Public bWrite(1 To 10) As Byte 'Буфер отправляемой дейтаграммы
Global bRead(254) As Byte 'буфер принятых символов
Public rc As Long 'Переменная для получения результатов работы функций
Public wr As Long 'Количество отправленных байт
Public err As Boolean 'Ошибка
Public rd As Long 'Количество принятых байт
'Структуры для параметров настройки порта
Type COMMTIMEOUTS
ReadIntervalTimeout As Long
ReadTotalTimeoutMultiplier As Long
ReadTotalTimeoutConstant As Long
WriteTotalTimeoutMultiplier As Long
WriteTotalTimeoutConstant As Long
End Type
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
' 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
'объявления функций API
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
Declare Function PurgeComm Lib "kernel32" (ByVal hFile As Long, ByVal dwFlags As Long) As Long
Public Declare Function SetCommTimeouts Lib "kernel32" (ByVal hFile As Long, lpCommTimeouts As COMMTIMEOUTS) As Long
Public Declare Function SetCommState Lib "kernel32" (ByVal hCommDev As Long, lpDCB As DCB) As Long
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
Public 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
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Public Declare Function GetLastError Lib "kernel32" () As Long
' Error codes reported by the CreateFile().
Const ERROR_FILE_NOT_FOUND = 2
Const ERROR_ACCESS_DENIED = 5
Const ERROR_INVALID_HANDLE = 6
Public Function OpenCOM(ByVal com As String) As Long 'Открытие COM-порта
Dim retval As Long
ComNum = CreateFile(("\\." & com), GENERIC_READ Or GENERIC_WRITE, 0, 0&, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)
If ComNum = -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", vbCritical
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", vbCritical
Case Else
MsgBox "CreateFile failed, the error code is " & Str(rc), vbCritical
End Select
MsgBox "Ошибка открытия порта " + com, vbCritical
OpenCOM = ComNum
Exit Function
Else
retval = PurgeComm(ComNum, 0) 'очистка очередей порта
End If
' Начальное заполнение таблицы параметров приемопередачи
BarDCB.DCBlength = 28 'длина блока DCB
BarDCB.fBitFields = &H83 'Битовое поле, биты которого означают следующее:
BarDCB.ByteSize = 8 'разрядность данных (кол-во бит)
BarDCB.parity = 0 '1-проверять нечетность, 2-проверять четность, 0-не проверять ничего
BarDCB.StopBits = 0 'количество стоповых бит: 0 -один, 1 -полтора, 2 -два
BarDCB.wReserved1 = 0 'зарезервировано. Не используется.
'Времена ожидания (Time Outs) в миллисекундах
CtimeOut.ReadIntervalTimeout = 5 'максимальное время между двумя принимаемыми символами.
CtimeOut.ReadTotalTimeoutConstant = 500 'постоянная часть таймаута на прием
CtimeOut.ReadTotalTimeoutMultiplier = 0 '5 'время на прием одного символа (для вычисления переменной части таймаута)
CtimeOut.WriteTotalTimeoutConstant = 20 'постоянная часть таймаута на передачу
'нулевые времена означают, что таймауты не используются.
OpenCOM = ComNum
End Function
Public Function SetCommParam(baud As Long, parity As Long, bits As Long, stops As Long) As Long
'подпрограмма установки параметров порту
Dim retval As Long
'установка таймаутов
CtimeOut.WriteTotalTimeoutMultiplier = 1 + Int(12000 / baud)
retval = SetCommTimeouts(ComNum, CtimeOut)
If retval = -1 Then
retval = GetLastError()
MsgBox "Ошибка при установке таймаутов, Error: " & retval
SetCommParam = retval
Exit Function
End If
BarDCB.fBitFields = 1
BarDCB.BaudRate = baud 'скорость приемопередачи в бодах
BarDCB.ByteSize = 8 'bits 'разрядность данных (кол-во бит)
BarDCB.parity = 0 'parity '1-проверять нечетность, 2-проверять четность, 0-не проверять ничего
BarDCB.StopBits = 0 'stops 'количество стоповых бит: 0 -один, 1 -полтора, 2 -два
retval = SetCommState(ComNum, BarDCB)
If retval = -1 Then
retval = GetLastError()
MsgBox "Не удается настроить порт на заданные параметры Error: " & retval, vbCritical, "Error!"
SetCommParam = retval
Exit Function
End If
' Call PrintDCB(BarDCB, CtimeOut)
End Function
Public Sub Sending(SendStr() As Byte, NumBytes As Long)
' Sending an array of 8 bytes to a remote device.
rc = WriteFile(ComNum, SendStr(1), NumBytes, 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
Exit Sub
close_and_exit:
rc = CloseHandle(ComNum)
End Sub
Public Sub Receiving(NumBytes As Long)
' Получаем ответ от девайса.
rc = ReadFile(ComNum, bRead(1), NumBytes, 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
'Debug.Print rd
Exit Sub
close_and_exit:
rc = CloseHandle(ComNum)
End Sub