StopBitsVBA 中使用 API 串口通信 Serial Port (英文)

declare_serial  时间:2021-02-14  阅读:()

'

-------------------------------------------------------------------------------

'

' This VB module is a collection of routines to perform serial port I/O without' using the Microsoft Comm Control component. This module uses the Windows API' to perform the overlapped I/O operations necessary for serial communications.'

' The routine can handle up to 4 serial ports which are identified with a

' Port ID.

'

'All routines (with the exception of CommRead and CommWrite) return an error' code or 0 if no error occurs. The routine CommGetError can be used to get' the complete error message.

'

-------------------------------------------------------------------------------

'

-------------------------------------------------------------------------------

' Public Constants

'

-------------------------------------------------------------------------------

'Output Control Lines (CommSetLine)

Const LINE_BREAK= 1

Const LINE_DTR= 2

Const LINE_RTS = 3

' Input Control Lines (CommGetLine)

Const LINE_CTS =&H10&

Const LINE_DSR=&H20&

Const LINE_RING=&H40&

Const LINE_RLSD=&H80&

Const LINE_CD=&H80&

'

-------------------------------------------------------------------------------

' System Constants

'

-------------------------------------------------------------------------------

Private Const ERROR_IO_INCOMPLETE = 996&

Private Const ERROR_IO_PENDING= 997

Private Const GENERIC_READ=&H80000000

Private Const GENERIC_WRITE=&H40000000

Private Const FILE_ATTRIBUTE_NORMAL =&H80

Private Const FILE_FLAG_OVERLAPPED=&H40000000

Private Const FORMAT_MESSAGE_FROM_SYSTEM=&H1000

Private Const OPEN_EXISTING= 3

' COMM Functions

Private Const MS_CTS_ON=&H10&

Private Const MS_DSR_ON=&H20&

Private Const MS_RING_ON=&H40&

Private Const MS_RLSD_ON=&H80&

Private Const PURGE_RXABORT =&H2

Private Const PURGE_RXCLEAR=&H8

Private Const PURGE_TXABORT =&H1

Private Const PURGE_TXCLEAR=&H4

' COMM Escape Functions

Private Const CLRBREAK= 9

Private Const CLRDTR= 6

Private Const CLRRTS = 4

Private Const SETBREAK= 8

Private Const SETDTR= 5

Private Const SETRTS = 3

'

-------------------------------------------------------------------------------

' System Structures

'

-------------------------------------------------------------------------------

Private Type COMSTATfBitFields As Long ' See Comment in Win32API.TxtcbInQue As LongcbOutQue As Long

End Type

Private Type COMMTIMEOUTS

ReadIntervalTimeout As Long

ReadTotalTimeoutMultiplier As Long

ReadTotalTimeoutConstant As Long

WriteTotalTimeoutMultiplier As Long

WriteTotalTimeoutConstant As Long

End Type

'

' The DCB structure defines the control setting for a serial

' communications device.

'

Private Type DCB

DCBlength As Long

BaudRate As LongfBitFields As Long ' See Comments in Win32API.TxtwReserved 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 BytewReserved1 As Integer 'Reserved;Do Not Use

End Type

Private Type OVERLAPPED

Internal As Long

InternalHigh As Longoffset As Long

OffsetHigh As LonghEvent As Long

End Type

Private Type SECURITY_ATTRIBUTESnLength As LonglpSecurityDescriptor As LongbInheritHandle As Long

End Type

'

-------------------------------------------------------------------------------

' System Functions

'

-------------------------------------------------------------------------------

'

' Fills a specified DCB structure with values specified in

' a device-control string.

'

Private Declare Function BuildCommDCB Lib "kernel32"Alias "BuildCommDCBA"

_

(ByVal lpDef As String, lpDCB As DCB)As Long

'

'Retrieves information about a communications error and reports

' the current status of a communications device. The function is

' called when a communications error occurs, and it clears the

' device's error flag to enable additional input and output

' (I/O) operations.

'

Private Declare Function ClearCommError Lib "kernel32" _

(ByVal hFile As Long, lpErrors As Long, lpStat As COMSTAT)As Long

'

' Closes an open communications device or file handle.

'

Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long)As Long'

' Creates or opens a communications resource and returns a handle

' that can be used to access the resource.

'

Private Declare Function CreateFile Lib "kernel32"Alias "CreateFileA" _

(ByVal lpFileName As String,ByVal dwDesiredAccess As Long, _

ByVal dwShareMode As Long, lpSecurityAttributes As Any, _

ByVal dwCreationDisposition As Long,ByVal dwFlagsAndAttributes As Long, _

ByVal hTemplateFile As Long)As Long

'

'Directs a specified communications device to perform a function.

'

Private Declare Function EscapeCommFunction Lib "kernel32" _

(ByVal nCid As Long,ByVal nFunc As Long)As Long

'

' by anoher function.

'

Private Declare Function FormatMessage Lib "kernel32"Alias "FormatMessageA" _(ByVal dwFlags As Long, lpSource As Any,ByVal dwMessageId As Long, _ByVal dwLanguageId As Long,ByVal lpBuffer As String,ByVal nSize As Long, _Arguments As Long)As Long

'

'Retrieves modem control-register values.

'

Private Declare Function GetCommModemStatus Lib "kernel32" _

(ByVal hFile As Long, lpModemStat As Long)As Long

'

'Retrieves the current control settings for a specified

' communications device.

'

Private Declare Function GetCommState Lib "kernel32" _

(ByVal nCid As Long, lpDCB As DCB)As Long

'

'Retrieves the calling thread's last-error code value.

'

Private Declare Function GetLastError Lib "kernel32" ()As Long

'

'Retrieves the results of an overlapped operation on the

' specified file, named pipe, or communications device.

'

Private Declare Function GetOverlappedResult Lib "kernel32" _

(ByVal hFile As Long, lpOverlapped As OVERLAPPED, _lpNumberOfBytesTransferred As Long,ByVal bWait As Long)As Long

'

'Discards all characters from the output or input buffer of a

' specified communications resource. It can also terminate

' pending read or write operations on the resource.

'

Private Declare Function PurgeComm Lib "kernel32" _

(ByVal hFile As Long,ByVal dwFlags As Long)As Long

'

'Reads data from a file, starting at the position indicated by the

' file pointer.After the read operation has been completed, the

' file pointer is adjusted by the number of bytes actually read,

' unless the file handle is created with the overlapped attribute.

' If the file handle is created for overlapped input and output

' (I/O), the application must adjust the position of the file pointer

' after the read operation.

'

Private Declare Function ReadFile Lib "kernel32" _

(ByVal hFile As Long,ByVal lpBuffer As String, _

ByVal nNumberOfBytesToRead As Long,ByRef lpNumberOfBytesRead As Long, _lpOverlapped As OVERLAPPED)As Long

'

' Configures a communications device according to the specifications

' in a device-control block (a DCB structure). The function

' reinitializes all hardware and control settings, but it does not

' empty output or input queues.

'

Private Declare Function SetCommState Lib "kernel32" _

(ByVal hCommDev As Long, lpDCB As DCB)As Long

'

' Sets the time-out parameters for all read and write operations on a

' specified communications device.

'

Private Declare Function SetCommTimeouts Lib "kernel32" _

(ByVal hFile As Long, lpCommTimeouts As COMMTIMEOUTS)As Long

'

' Initializes the communications parameters for a specified

' communications device.

'

Private Declare Function SetupComm Lib "kernel32" _

(ByVal hFile As Long,ByVal dwInQueue As Long,ByVal dwOutQueue As Long)As Long'

'Writes data to a file and is designed for both synchronous and a

' synchronous operation.The function starts writing data to the file

' at the position indicated by the file pointer.After the write

' operation has been completed, the file pointer is adjusted by the

' number of bytes actually written, except when the file is opened with

' FILE_FLAG_OVERLAPPED. If the file handle was created for overlapped

' input and output (I/O), the application must adjust the position of

' the file pointer after the write operation is finished.

'

Private Declare Function WriteFile Lib "kernel32" _

(ByVal hFile As Long,ByVal lpBuffer As String, _

ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, _lpOverlapped As OVERLAPPED)As Long

Private Declare Sub AppSleep Lib "kernel32"Alias "Sleep" (ByVal dwMilliseconds As Long)'

-------------------------------------------------------------------------------

'

-------------------------------------------------------------------------------

Private Const MAX_PORTS = 4

'

-------------------------------------------------------------------------------

' Program Structures

'

-------------------------------------------------------------------------------

Private Type COMM_ERRORlngErrorCode As LongstrFunction As String

strErrorMessage As String

End Type

Private Type COMM_PORTlngHandle As LongblnPortOpen As BooleanudtDCB As DCB

End Type

'

-------------------------------------------------------------------------------

' Program Storage

'

-------------------------------------------------------------------------------

Private udtCommOverlap As OVERLAPPED

Private udtCommError As COMM_ERROR

Private udtPorts(1 To MAX_PORTS)As COMM_PORT

'

-------------------------------------------------------------------------------

'GetSystemMessage -Gets system error text for the specified error code.

'

-------------------------------------------------------------------------------

Public Function GetSystemMessage(lngErrorCode As Long)As String

Dim intPos As Integer

Dim strMessage As String, strMsgBuff As String * 256

Call FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, 0, lngErrorCode, 0, strMsgBuff,255, 0)intPos = InStr(1, strMsgBuff, vbNullChar)

If intPos > 0 ThenstrMessage = Trim$(Left$(strMsgBuff, intPos - 1))

ElsestrMessage = Trim$(strMsgBuff)

End If

GetSystemMessage = strMessage

End Function

Public Function PauseApp(PauseInSeconds As Long)

Call AppSleep(PauseInSeconds * 1000)

End Function

'

-------------------------------------------------------------------------------

' CommOpen -Opens/Initializes serial port.

'

'

' Parameters:

' intPortID - Port ID used when port was opened.

' strPort -COM port name. (COM1,COM2,COM3,COM4)

' strSettings -Communication settings.

' Example: "baud=9600 parity=N data=8 stop=1"

'

'Returns:

' Error Code - 0 =No Error.

'

'

-------------------------------------------------------------------------------

Public Function CommOpen(intPortID As Integer, strPort As String, _strSettings As String)As Long

Dim lngStatus As Long

Dim udtCommTimeOuts As COMMTIMEOUTS

On Error GoTo Routine_Error

' See if port already in use.

If udtPorts(intPortID).blnPortOpen ThenlngStatus = -1

With udtCommError

.lngErrorCode = lngStatus

.strFunction = "CommOpen"

.strErrorMessage = "Port in use."

End With

GoTo Routine_Exit

End If

'Open serial port.udtPorts(intPortID).lngHandle =CreateFile(strPort,GENERIC_READ Or _

GENERIC_WRITE, 0,ByVal 0&,OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)If udtPorts(intPortID).lngHandle = -1 ThenlngStatus = SetCommError("CommOpen (CreateFile)")

GoTo Routine_Exit

End IfudtPorts(intPortID).blnPortOpen = True

' Setup device buffers (1K each).lngStatus = SetupComm(udtPorts(intPortID).lngHandle, 1024, 1024)

If lngStatus = 0 ThenlngStatus = SetCommError("CommOpen (SetupComm)")

GoTo Routine_Exit

End If

' Purge buffers.lngStatus = PurgeComm(udtPorts(intPortID).lngHandle, PURGE_TXABORT Or _

PURGE_RXABORT Or PURGE_TXCLEAR Or PURGE_RXCLEAR)

If lngStatus = 0 ThenlngStatus = SetCommError("CommOpen (PurgeComm)")

GoTo Routine_Exit

End If

' Set serial port timeouts.

With udtCommTimeOuts

.ReadIntervalTimeout = -1

.ReadTotalTimeoutMultiplier = 0

.ReadTotalTimeoutConstant = 1000

.WriteTotalTimeoutMultiplier = 0

.WriteTotalTimeoutMultiplier = 1000

End WithlngStatus = SetCommTimeouts(udtPorts(intPortID).lngHandle, udtCommTimeOuts)If lngStatus = 0 ThenlngStatus = SetCommError("CommOpen (SetCommTimeouts)")

GoTo Routine_Exit

End If

'Get the current state (DCB).lngStatus =GetCommState(udtPorts(intPortID).lngHandle, _udtPorts(intPortID).udtDCB)

If lngStatus = 0 ThenlngStatus = SetCommError("CommOpen (GetCommState)")

GoTo Routine_Exit

End If

'Modify the DCB to reflect the desired settings.lngStatus = BuildCommDCB(strSettings, udtPorts(intPortID).udtDCB)

If lngStatus = 0 ThenlngStatus = SetCommError("CommOpen (BuildCommDCB)")

GoTo Routine_Exit

End If

' Set the new state.lngStatus = SetCommState(udtPorts(intPortID).lngHandle, _udtPorts(intPortID).udtDCB)

If lngStatus = 0 ThenlngStatus = SetCommError("CommOpen (SetCommState)")

GoTo Routine_Exit

End IflngStatus = 0

Routine_Exit:

CommOpen = lngStatus

Exit Function

Routine_Error:

lngStatus = Err.Number

With udtCommError

.lngErrorCode = lngStatus

.strFunction = "CommOpen"

.strErrorMessage =Err.Description

End With

Resume Routine_Exit

End Function

Private Function SetCommError(strFunction As String)As Long

With udtCommError

.lngErrorCode = Err.LastDllError

.strFunction = strFunction

.strErrorMessage =GetSystemMessage(.lngErrorCode)

SetCommError = .lngErrorCode

End With

End Function

Private Function SetCommErrorEx(strFunction As String, lngHnd As Long)As LongDim lngErrorFlags As Long

Dim udtCommStat As COMSTAT

With udtCommError

.lngErrorCode =GetLastError

.strFunction = strFunction

.strErrorMessage =GetSystemMessage(.lngErrorCode)

Call ClearCommError(lngHnd, lngErrorFlags, udtCommStat)

.strErrorMessage = .strErrorMessage&" COMM Error Flags = "&_

Hex$(lngErrorFlags)

SetCommErrorEx = .lngErrorCode

End With

End Function

'

-------------------------------------------------------------------------------

' CommSet -Modifies the serial port settings.

'

' Parameters:

' intPortID - Port ID used when port was opened.

乌云数据(10/月),香港cera 1核1G 10M带宽/美国cera 8核8G10M

乌云数据主营高性价比国内外云服务器,物理机,本着机器为主服务为辅的运营理念,将客户的体验放在第一位,提供性价比最高的云服务器,帮助各位站长上云,同时我们深知新人站长的不易,特此提供永久免费虚拟主机,已提供两年之久,帮助了上万名站长从零上云官网:https://wuvps.cn迎国庆豪礼一多款机型史上最低价,续费不加价 尽在wuvps.cn香港cera机房,香港沙田机房,超低延迟CN2线路地区CPU...

Megalayer(月599元)限时8月香港和美国大带宽服务器

第一、香港服务器机房这里我们可以看到有提供四个大带宽方案,是全向带宽和国际带宽,前者适合除了中国大陆地区的全网地区用户可以用,后者国际带宽适合欧美地区业务。如果我们是需要大陆地区速度CN2优化的,那就需要选择常规的优化带宽方案,参考这里。CPU内存硬盘带宽流量价格选择E3-12308GB240GB SSD50M全向带宽不限999元/月方案选择E3-12308GB240GB SSD100M国际带宽不...

CloudCone中国新年特别套餐,洛杉矶1G内存VPS年付13.5美元起

CloudCone针对中国农历新年推出了几款特别套餐, 其中2019年前注册的用户可以以13.5美元/年的价格购买一款1G内存特价套餐,以及另外提供了两款不限制注册时间的用户可购买年付套餐。CloudCone是Quadcone旗下成立于2017年的子品牌,提供VPS及独立服务器租用,也是较早提供按小时计费VPS的商家之一,支持使用PayPal或者支付宝等付款方式。下面列出几款特别套餐配置信息。CP...

declare_serial为你推荐
刷网站权重刷出来的流量会提高网站的权重吗?安装程序配置服务器失败SQL安装程序配置服务器失败支付宝查询余额我的支付宝如何查询余额深圳公交车路线深圳公交路线flash导航条如何用Flash制作简单的导航栏童之磊华硕的四核平板电脑,怎么样?苹果5怎么越狱苹果5怎么越狱iphone越狱后怎么恢复苹果手机越狱后怎么恢复怎么点亮qq空间图标怎么点亮QQ空间的图标怎么点亮qq空间图标QQ空间的图标怎么点亮
美国虚拟主机推荐 台湾服务器租用 欧洲欧洲vps 美国便宜货网站 日志分析软件 正版win8.1升级win10 NetSpeeder 英文站群 元旦促销 圣诞促销 699美元 什么是服务器托管 100m独享 服务器干什么用的 上海联通宽带测速 www789 华为云建站 谷歌台湾 徐州电信 江苏徐州移动 更多