Класс для COM-порта с поддержкой событий - VB
Формулировка задачи:
Доброго. Мне нужен класс для работы с COM-портом с поддержкой событий.
У меня есть вариант: Serial Port Communication in Excel (VBA). Я его использую в Excel. Проблема в том, что нужно ручками регулировать время между командой и ответом, чтобы гарантировано принять данные во входной буфер. Хотелось бы иметь событие OnReceive(), которое основано на WaitCommEvent(). Без событийного решения трудно реализовать оптимальный по скорости алгоритм работы с устройствами. Мне нужно с определённой частотой читать данные и желательно получать их по мере заполнения входного буфера нужной посылкой.
Можно ли что-то такое сделать на vb6? Мне не нужны сторонние решения в готовом виде (ActiveX, dll и т.п.). Нужно всё реализовать на макросах в таблице.
Решение задачи: «Класс для COM-порта с поддержкой событий»
textual
Листинг программы
Public Function CommRead(intPortID As Integer, strData As String, _
lngSize As Long) As Long
Dim lngStatus As Long
Dim lngRdSize As Long, lngBytesRead As Long
Dim lngRdStatus As Long, strRdBuffer As String * 1024
Dim lngErrorFlags As Long, udtCommStat As COMSTAT
Dim osReader As OVERLAPPED
osReader.hEvent = 0
osReader.Internal = 0
osReader.InternalHigh = 0
osReader.offset = 0
osReader.OffsetHigh = 0
On Error GoTo Routine_Error
strData = ""
lngBytesRead = 0
' ' Clear any previous errors and get current status.
' lngStatus = ClearCommError(udtPorts(intPortID).lngHandle, lngErrorFlags, _
' udtCommStat)
'
' If lngStatus = 0 Then
'
' lngBytesRead = -1
' lngStatus = SetCommError("CommRead (ClearCommError)")
' GoTo Routine_Exit
'
' End If
' If udtCommStat.cbInQue > 0 Then
'
' If udtCommStat.cbInQue > lngSize Then
'
' lngRdSize = udtCommStat.cbInQue
'
' Else
'
' lngRdSize = lngSize
'
' End If
'
' Else
'
' lngRdSize = 0
'
' End If
lngRdSize = lngSize
If lngRdSize Then
osReader.hEvent = CreateEvent(0, True, False, 0)
If osReader.hEvent = 0 Then
lngBytesRead = -1
lngStatus = SetCommErrorEx("CommRead (CreateEvent)", _
udtPorts(intPortID).lngHandle)
GoTo Routine_Exit
End If
lngRdStatus = ReadFile(udtPorts(intPortID).lngHandle, strRdBuffer, _
lngRdSize, 0, osReader)
If lngRdStatus = 0 Then
Dim dwRes As Long
' Wait for read to complete.
dwRes = WaitForSingleObject(osReader.hEvent, READ_TIMEOUT)
Select Case dwRes
' Read completed.
Case WAIT_OBJECT_0
If GetOverlappedResult(udtPorts(intPortID).lngHandle, _
osReader, lngBytesRead, False) = 0 Then
' Error in communications; report it.
lngBytesRead = -1
lngStatus = SetCommErrorEx("CommRead (GetOverlappedResult)", _
udtPorts(intPortID).lngHandle)
GoTo Routine_Exit
Else
' Read completed successfully.
End If
Case WAIT_TIMEOUT
lngBytesRead = -1
lngStatus = SetCommErrorEx("CommRead (WaitForSingleObject)", _
udtPorts(intPortID).lngHandle)
GoTo Routine_Exit
Case Else
lngBytesRead = -1
lngStatus = SetCommErrorEx("CommRead (WaitForSingleObject)", _
udtPorts(intPortID).lngHandle)
GoTo Routine_Exit
End Select
End If
strData = Left$(strRdBuffer, lngBytesRead)
End If
Routine_Exit:
If Not osReader.hEvent = 0 Then CloseHandle osReader.hEvent
CommRead = lngBytesRead
Exit Function
Routine_Error:
lngBytesRead = -1
lngStatus = Err.Number
With udtCommError
.lngErrorCode = lngStatus
.strFunction = "CommRead"
.strErrorMessage = Err.Description
End With
Resume Routine_Exit
End Function