Attribute VB_Name = "SerialPort"
Option Explicit
Global XpsHandle As Long 'манипулятор
Global XpsPort As String 'порт к которому подкл. Xps
Global bRead(255) As Byte 'приемный/передающий буфер
Global Count_bRead As Long 'колич. принятых байт
Type COMSTAT
fCtsHold As Long
fDsrHold As Long
fRlsdHold As Long
fXoffHold As Long
fXoffSent As Long
fEof As Long
fTxim As Long
fReserved As Long
cbInQue As Long
cbOutQue As Long
End Type
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
fBinary As Long
fParity As Long
fOutxCtsFlow As Long
fOutxDsrFlow As Long
fDtrControl As Long
fDsrSensitivity As Long
fTXContinueOnXoff As Long
fOutX As Long
fInX As Long
fErrorChar As Long
fNull As Long
fRtsControl As Long
fAbortOnError As Long
fDummy2 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
End Type
Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Declare Function GetLastError Lib "kernel32" () As Long
Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, ByRef lpBuffer As Byte, ByVal nNumberOfBytesToRead As Long, ByRef lpNumberOfBytesRead As Long, ByVal lpOverlapped As Long) As Long
Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, ByRef lpBuffer As Byte, ByVal nNumberOfBytesToWrite As Long, ByRef lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) As Long
Declare Function SetCommTimeouts Lib "kernel32" (ByVal hFile As Long, ByRef lpCommTimeouts As COMMTIMEOUTS) As Long
Declare Function GetCommTimeouts Lib "kernel32" (ByVal hFile As Long, ByRef lpCommTimeouts As COMMTIMEOUTS) As Long
Declare Function BuildCommDCB Lib "kernel32" Alias "BuildCommDCBA" (ByVal lpDef As String, lpDCB As DCB) As Long
Declare Function SetCommState Lib "kernel32" (ByVal hCommDev As Long, ByRef lpDCB As DCB) As Long
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 FlushFileBuffers Lib "kernel32" (ByVal hFile As Long) As Long
Function FlushComm(PortHandle As Long)
FlushFileBuffers (PortHandle)
End Function
Function Init_Com(ComPort As String, Comsettings As String) As Boolean
Dim ComSetup As DCB, Answer, Stat As COMSTAT, RetBytes As Long
Dim retval As Long, CtimeOut As COMMTIMEOUTS, BarDCB As DCB
Init_Com = False 'ошибка открытия порта
On Error GoTo handelinitcom
' Open the communications port for read/write (&HC0000000).
' Must specify existing file (3).
XpsHandle = CreateFile(ComPort, &HC0000000, 0, 0&, &H3, 0, 0)
If XpsHandle = -1 Then Exit Function
'Setup Time Outs for com port
CtimeOut.ReadIntervalTimeout = 20
CtimeOut.ReadTotalTimeoutConstant = 1
CtimeOut.ReadTotalTimeoutMultiplier = 1
CtimeOut.WriteTotalTimeoutConstant = 10
CtimeOut.WriteTotalTimeoutMultiplier = 1
retval = SetCommTimeouts(XpsHandle, CtimeOut)
If retval = -1 Then
retval = GetLastError()
MsgBox "Unable to set timeouts for port " & ComPort & " Error: " & retval
Exit Function
End If
retval = BuildCommDCB(Comsettings, BarDCB)
If retval = -1 Then
retval = GetLastError()
MsgBox "Unable to build Comm DCB " & Comsettings & " Error: " & retval
Exit Function
End If
retval = SetCommState(XpsHandle, BarDCB)
If retval = -1 Then
retval = GetLastError()
MsgBox "Unable to set Comm DCB " & Comsettings & " Error: " & retval
Exit Function
End If
Init_Com = True
Exit Function
handelinitcom:
Exit Function
End Function
Function Init_Com2(ComNumber As String, Comsettings As String) As Boolean
On Error GoTo handelinitcom
Dim ComSetup As DCB, Answer, Stat As COMSTAT, RetBytes As Long
Dim retval As Long
Dim CtimeOut As COMMTIMEOUTS, BarDCB As DCB
' Open the communications port for read/write (&HC0000000).
' Must specify existing file (3).
XpsHandle = CreateFile(ComNumber, &HC0000000, 0, 0&, &H3, 0, 0)
If XpsHandle = -1 Then
MsgBox "Нет платы телеметрии:" & ComNumber, 48
Init_Com2 = False
Exit Function
End If
'Setup Time Outs for com port
CtimeOut.ReadIntervalTimeout = 20
CtimeOut.ReadTotalTimeoutConstant = 1
CtimeOut.ReadTotalTimeoutMultiplier = 1
CtimeOut.WriteTotalTimeoutConstant = 10
CtimeOut.WriteTotalTimeoutMultiplier = 1
retval = SetCommTimeouts(XpsHandle, CtimeOut)
If retval = -1 Then
retval = GetLastError()
MsgBox "Unable to set timeouts for port " & ComNumber & " Error: " & retval
retval = CloseHandle(XpsHandle)
Init_Com2 = False
Exit Function
End If
retval = BuildCommDCB(Comsettings, BarDCB)
If retval = -1 Then
retval = GetLastError()
MsgBox "Unable to build Comm DCB " & Comsettings & " Error: " & retval
retval = CloseHandle(XpsHandle)
Init_Com2 = False
Exit Function
End If
retval = SetCommState(XpsHandle, BarDCB)
If retval = -1 Then
retval = GetLastError()
MsgBox "Unable to set Comm DCB " & Comsettings & " Error: " & retval
retval = CloseHandle(XpsHandle)
Init_Com2 = False
Exit Function
End If
Init_Com2 = True
handelinitcom:
Exit Function
End Function
Function WriteCOM32(CounByte As Long)
On Error GoTo handelwritelpt
Dim RetBytes As Long, retval As Long
retval = WriteFile(XpsHandle, bRead(0), CounByte, RetBytes, 0)
Exit Function
handelwritelpt:
Exit Function
End Function
Function SendGoneom(COMString As String)
On Error GoTo handelwritelpt
Dim RetBytes As Long, LenVal As Long
Dim retval As Long
If Len(COMString) > 255 Then
SendGoneom Left$(COMString, 255)
SendGoneom Right$(COMString, Len(COMString) - 255)
Exit Function
End If
For LenVal = 0 To Len(COMString) - 1
bRead(LenVal) = Asc(Mid$(COMString, LenVal + 1, 1))
Next LenVal
' bRead(LenVal) = 0
retval = WriteFile(XpsHandle, bRead(0), Len(COMString), RetBytes, 0)
' FlushComm
SendGoneom = RetBytes
handelwritelpt:
Exit Function
End Function
Function ReadSerial(PortHandle As Long, InpByte As Long)
Dim retval As Long
retval = ReadFile(PortHandle, bRead(0), InpByte, Count_bRead, 0)
End Function
Function WaitSerialData(PortHandle As Long, TimeVal As Single) As Boolean
Dim retval As Long, TimerTmp As Single
'если есть данные, то быстро получить и выход
WaitSerialData = True
retval = ReadFile(PortHandle, bRead(0), 1, Count_bRead, 0)
If Count_bRead > 0 Then Exit Function
'иначе ждать данные опред. время
TimerTmp = Timer
Do While Timer < TimerTmp + TimeVal
retval = ReadFile(PortHandle, bRead(0), 1, Count_bRead, 0)
If Count_bRead > 0 Then Exit Function
' FlushComm (PortHandle)
DoEvents
Loop
'не получены данные за опред. время
WaitSerialData = False
End Function
'Поиск портов в системе ***********************************************
Sub SearchCom()
Dim ComNum As Integer, PortHandle As Long
CloseHandle (XpsHandle) 'закрыть порт, чтоб был доступен в установках
'FormRobotSetngs.MousePointer = vbHourglass
FormRobotSetngs.ComboComPort.Clear 'очистить список
For ComNum = 1 To 20
PortHandle = CreateFile("COM" & ComNum, &HC0000000, 0, 0&, &H3, 0, 0)
If PortHandle > -1 Then
FormRobotSetngs.ComboComPort.AddItem "COM" & ComNum
End If
CloseHandle (PortHandle)
Next
'**********************************************************************
'FormRobotSetngs.MousePointer = vbDefault
End Sub