roboforum.ru

Madf писал(а):В VB6 + VCP - проблем нет (простыни с инициализацией порта не заметил, всё просто)

Код: Выделить всё • Развернуть

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

Madf писал(а):может есть какие-нить конкуретны типа цирус лоджика?