1,486
社区成员
发帖
与我相关
我的任务
分享
Private Const DEFAULT_QUEUE = 1024
Private Const DEFAULT_WAIT_TIME = 50
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const OPEN_EXISTING = 3 '
Private Const PURGE_RXABORT = &H2
Private Const PURGE_RXCLEAR = &H8
'Private Const PURGE_TXABORT = &H1
'Private Const PURGE_TXCLEAR = &H4
'Utils
Private Const SYNCHRONIZE = &H100000
Private Const STANDARD_RIGHTS_READ = &H20000
'Private Const STANDARD_RIGHTS_WRITE = &H20000
'Private Const STANDARD_RIGHTS_EXECUTE = &H20000
'Private Const STANDARD_RIGHTS_REQUIRED = &HF0000
'Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const ERROR_SUCCESS = 0&
'Private Const HKEY_CLASSES_ROOT = &H80000000
'Private Const HKEY_CURRENT_USER = &H80000001
Private Const HKEY_LOCAL_MACHINE = &H80000002
'Private Const HKEY_USERS = &H80000003
'Private Const KEY_CREATE_LINK = &H20
'Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_NOTIFY = &H10
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))
'Private Const KEY_SET_VALUE = &H2
Private Const REG_DWORD = 4
'Private Const REG_BINARY = 3
'Private Const REG_SZ = 1
'COM
Private Type COMMTIMEOUTS
ReadIntervalTimeout As Long
WriteTotalTimeoutConstant As Long
ReadTotalTimeoutConstant As Long
WriteTotalTimeoutMultiplier As Long
ReadTotalTimeoutMultiplier As Long
End Type
Private Type COMSTAT
fBitFields As Long
cbInQue As Long
cbOutQue As Long
End Type
Private Type DCB
DCBlength As Long
BaudRate As Long
fBitFields As Long 'See Comments in Win32API.Txt
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 'Reserved; Do Not Use
End Type
Private Type OVERLAPPED
ternal As Long
hEvent As Long
offset As Long
OffsetHigh As Long
ternalHigh As Long
End Type
Private Type SECURITY_ATTRIBUTES
nLength As Long
bInheritHandle As Long
lpSecurityDescriptor As Long
End Type
'Common
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'COM
Private Declare Function BuildCommDCB Lib "kernel32" Alias "BuildCommDCBA" (ByVal lpDef As String, lpDCB As DCB) As Long
Private Declare Function ClearCommError Lib "kernel32" (ByVal hFile As Long, lpErrors As Long, lpStat As COMSTAT) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function GetCommState Lib "kernel32" (ByVal nCid As Long, lpDCB As DCB) As Long
Private Declare Function PurgeComm Lib "kernel32" (ByVal hFile As Long, ByVal dwFlags As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As OVERLAPPED) As Long
Private Declare Function SetCommState Lib "kernel32" (ByVal hCommDev As Long, lpDCB As DCB) As Long
Private Declare Function SetCommTimeouts Lib "kernel32" (ByVal hFile As Long, lpCommTimeouts As COMMTIMEOUTS) As Long
Private Declare Function SetupComm Lib "kernel32" (ByVal hFile As Long, ByVal dwInQueue As Long, ByVal dwOutQueue As Long) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, ByRef lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As OVERLAPPED) As Long
'Utils
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, lpData As String, lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
'Utils
Public Function EnumSerialPorts() As String() '枚举已存在的串口
Dim hKey As Long, ID As Long, Result As String
Dim Value As String, ValueLength As Long, Data As String, DataLength As Long
Result = ""
If RegOpenKeyEx(HKEY_LOCAL_MACHINE, "HARDWARE\DEVICEMAP\SERIALCOMM", 0&, KEY_READ, hKey) = ERROR_SUCCESS Then
Do
ValueLength = 2000
DataLength = 2000
Value = String(ValueLength, Chr(32)) '注册项
Data = String(DataLength, Chr(32)) '值 Com 名称
If RegEnumValue(hKey, ID, ByVal Value, ValueLength, 0&, REG_DWORD, ByVal Data, DataLength) = ERROR_SUCCESS Then
Result = Result & IIf(Len(Result) = 0, "", ",") & Trim(Left(Data, DataLength))
Else
Exit Do
End If
ID = ID + 1
Loop
RegCloseKey hKey
End If
EnumSerialPorts = Split(Result, ",")
End Function
'COM
Public Sub ComClose(ByRef Handle As Long)
CloseHandle Handle
Handle = -1
End Sub
Public Function ComOpen(ByVal Port As String, Optional ByVal Settings As String = "9600,n,8,1", Optional ByVal dwInQueue As Long = DEFAULT_QUEUE, Optional ByVal dwOutQueue As Long = DEFAULT_QUEUE) As Long
Dim Result As Long, lpDCB As DCB, lpCommTimeouts As COMMTIMEOUTS, lpSA As SECURITY_ATTRIBUTES
ComOpen = -1
If IsNumeric(Port) Then
Port = "\\.\Com" & Port
Else
Port = "\\.\" & Port
End If
Result = CreateFile(Port, GENERIC_READ Or GENERIC_WRITE, 0&, lpSA, OPEN_EXISTING, 0, 0&)
If Result = -1 Then Exit Function
If GetCommState(Result, lpDCB) = 0 Then
CloseHandle Result
Exit Function
End If
BuildCommDCB Settings, lpDCB
If SetCommState(Result, lpDCB) = 0 Then
CloseHandle Result
Exit Function
End If
SetupComm Result, dwInQueue, dwOutQueue '分配串口缓冲区
'设定通讯超时参数
lpCommTimeouts.ReadIntervalTimeout = 2
lpCommTimeouts.ReadTotalTimeoutConstant = 4
lpCommTimeouts.WriteTotalTimeoutConstant = 5000 '一次写入串口数据的固定超时。
lpCommTimeouts.WriteTotalTimeoutMultiplier = 50 '写入每字符间的超时。
SetCommTimeouts Result, lpCommTimeouts
ComOpen = Result
End Function
Public Function ComReadByte(ByVal Handle As Long, Optional ByVal WaitTime As Long = DEFAULT_WAIT_TIME) As Byte()
Dim I As Long, Result() As Byte, lpOverlapped As OVERLAPPED, lpStat As COMSTAT, lpErrors As Long
If Handle = -1 Then Exit Function
ReDim Result(DEFAULT_QUEUE - 1) '设置缓冲区大小1K
I = 0
If WaitTime > 0 Then Sleep WaitTime
ClearCommError Handle, lpErrors, lpStat
If lpStat.cbInQue > 0 Then
ReadFile Handle, Result(0), lpStat.cbInQue, I, lpOverlapped
If I > 0 Then
ReDim Preserve Result(I - 1)
ComReadByte = Result
End If
End If
End Function
Public Function ComWriteByte(ByVal Handle As Long, ByRef Data() As Byte) As Long
Dim lpOverlapped As OVERLAPPED, lpErrors As Long, lpStat As COMSTAT
If (Handle = -1) Or (Len(StrConv(Data, vbUnicode)) = 0) Then Exit Function
PurgeComm Handle, PURGE_RXABORT Or PURGE_RXCLEAR '清空输入缓冲区
WriteFile Handle, Data(0), UBound(Data) + 1, ComWriteByte, lpOverlapped
Do
ClearCommError Handle, lpErrors, lpStat
Loop Until lpStat.cbOutQue = 0 '等待输出结束
End Function
Option Explicit
Private Declare Function PeekNamedPipe Lib "kernel32.dll" (ByVal hNamedPipe As Long, ByRef lpBuffer As Any, ByVal nBufferSize As Long, ByRef lpBytesRead As Long, ByRef lpTotalBytesAvail As Long, ByRef lpBytesLeftThisMessage As Long) As Long
Function GetCommDataLen(ByVal hComm As Long) As Long
Dim lBytesAvail As Long
PeekNamedPipe hComm, ByVal 0&, 0, ByVal 0&, lBytesAvail, ByVal 0&
GetCommDataLen = lBytesAvail
End Function