Option Explicit
Public PortMemory As String Public AllBlueMemory As String Public BlueMemory As String
Private Type COMSTAT
fBitFields As Long
COMSTAT cbInQue As Long
cbOutQue As Long
End Type
Private Type COMMTIMEOUTS
ReadIntervalTimeout As Long
ReadTotalTimeoutMultiplier As Long
ReadTotalTimeoutConstant As Long
WriteTotalTimeoutMultiplier As Long
WriteTotalTimeoutConstant As Long
End Type
Private Type DCB
DCBlength As Long
BaudRate As Long
fBitFields 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
wReserved1 As Integer
End Type
Private Type OVERLAPPED
Internal As Long
InternalHigh As Long
offset As Long
OffsetHigh As Long
hEvent As Long
End Type
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Public Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Public Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function GetLastError Lib "kernel32" () 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 WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As OVERLAPPED) As Long 'OVERLAPPED
Private Declare Function SetCommTimeouts Lib "kernel32" (ByVal hFile As Long, lpCommTimeouts As COMMTIMEOUTS) As Long
Private Declare Function GetCommTimeouts Lib "kernel32" (ByVal hFile As Long, lpCommTimeouts As COMMTIMEOUTS) As Long
Private Declare Function GetOverlappedResult Lib "kernel32" (ByVal hFile As Long, lpOverlapped As OVERLAPPED, lpNumberOfBytesTransferred As Long, ByVal bWait As Long) As Long
Private Declare Function BuildCommDCB Lib "kernel32" Alias "BuildCommDCBA" (ByVal lpDef As String, lpDCB As DCB) As Long
Private Declare Function SetCommState Lib "kernel32" (ByVal hCommDev As Long, lpDCB As DCB) As Long
Private Declare Function GetCommState Lib "kernel32" (ByVal nCid As Long, lpDCB As DCB) As Long
Private 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
Private Declare Function FlushFileBuffers Lib "kernel32" (ByVal hFile As Long) As Long
Private Declare Function CreateEvent Lib "kernel32" Alias "CreateEventA" (lpEventAttributes As SECURITY_ATTRIBUTES, ByVal bManualReset As Long, ByVal bInitialState As Long, ByVal lpName As String) As Long
Private Declare Function SetCommMask Lib "kernel32" (ByVal hFile As Long, ByVal dwEvtMask As Long) As Long
Private Declare Function SetEvent Lib "kernel32" (ByVal hEvent As Long) 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 PurgeComm Lib "kernel32" (ByVal hFile As Long, ByVal dwFlags As Long) As Long
Private Declare Function ClearCommError Lib "kernel32" (ByVal hFile As Long, lpErrors As Long, lpStat As COMSTAT) As Long
Private Declare Function WaitCommEvent Lib "kernel32 " (ByVal hFile As Long, lpEvtMask As Long, lpOverlapped As OVERLAPPED) As Long
Private Declare Function ResetEvent Lib "kernel32 " (ByVal hFile As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long Private Declare Function GetTickCount Lib "kernel32" () As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Const INVALID_HANDLE_VALUE = -1
Private Const GENERIC_WRITE = &H40000000
Private Const GENERIC_READ = &H80000000
Private Const OPEN_EXISTING = 3
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_FLAG_OVERLAPPED = &H40000000
Private Const DTR_CONTROL_DISABLE = &H0
Private Const RTS_CONTROL_ENABLE = &H1
Private Const PURGE_RXABORT = &H2
Private Const PURGE_RXCLEAR = &H8
Private Const PURGE_TXABORT = &H1
Private Const PURGE_TXCLEAR = &H4
Private Const ERROR_IO_PENDING = 997
Private Const STATUS_WAIT_0 = &H0
Private Const WAIT_OBJECT_0 = (STATUS_WAIT_0 + 0)
Private Const WAIT_TIMEOUT = 258&
Public Const PROCESS_QUERY_INFORMATION = &H400
Public Const PROCESS_TERMINATE = &H1
Private Const EV_RXCHAR = &H1 ' Any Character received
Private m_OverlappedRead As OVERLAPPED
Private m_OverlappedWrite As OVERLAPPED
Private com_Handle As Long
Private com_RxBy As Long Private com_TxBy As Long
Public Property Get ReceivedByte() As Long
ReceivedByte = com_RxBy
End Property
Public Property Get SendedByte() As Long
SendedByte = com_TxBy
End Property
Public Property Let ReceivedByte(X As Long)
com_RxBy = 0
End Property
Public Property Let SendedByte(X As Long)
com_TxBy = 0
End Property
Public Property Get Handle() As Long
Handle = com_Handle
End Property
'Public Property Let Handle(id As Long)
' com_Handle = id 'End Property
'*************************************************************************
'**函 數 名：OpenPort '**ComPort:形式如：COM1、COM2、LPT1等等
'**Comsettings：形式如："9600,n,8,1"
'**lngInSize:寫入緩沖區大小
'**lngOutSize:寫出緩沖區大小
'*************************************************************************
Public Function OpenPort(ComPort As String, Comsettings As String, Optional lngInSize As Long = 1024, Optional lngOutSize As Long = 1024) As Long
On Error GoTo handelinitcom
Dim RetVal As Long '定義標志值
Dim flag As Long
'定義設備控制塊
Dim typDCB As DCB
Dim CtimeOut As COMMTIMEOUTS, dcbs As DCB
Dim strCOM As String, strConfig As String
' strCOM = "COM" & Format(ComNumber, "0") strCOM = ComPort
' Com_Handle = CreateFile(strCOM, GENERIC_READ Or GENERIC_WRITE, 0, ByVal 0, _
' OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL Or FILE_FLAG_OVERLAPPED, 0)
com_Handle = CreateFile(strCOM, _
GENERIC_READ Or GENERIC_WRITE, 0, ByVal 0, _
OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL Or FILE_FLAG_OVERLAPPED, 0)
If com_Handle = INVALID_HANDLE_VALUE Then
OpenPort = -1
Exit Function
End If
'********獲取出錯信息********
Dim errNum As Long errNum = GetLastError()
' Debug.Print "出錯信息：" & errNum
'********獲取設備控制塊********
flag = GetCommState(com_Handle, typDCB)
' Debug.Print "獲取串口DCB：" & flag
Dim SetDb() As String
SetDb = Split(Comsettings, ",")
If UBound(SetDb) >= 3 Then
typDCB.BaudRate = CLng(SetDb(0))
'定義波特率
If UCase(SetDb(1)) = "N" Then
'NOPARITY
typDCB.Parity = 0
'NOPARITY '無校驗位
Else
typDCB.Parity = 1
End If
typDCB.ByteSize = CByte(SetDb(2)) '數據位
typDCB.StopBits = CByte(SetDb(3))'停止位 0/1/2 = 1/1.5/2
Else
typDCB.BaudRate = 460800 '定義波特率
typDCB.Parity = 0 'NOPARITY '無校驗位
typDCB.ByteSize = 8 '數據位
typDCB.StopBits = 0 '停止位 0/1/2 = 1/1.5/2 End If
'********設置串口參數********
flag = SetCommState(com_Handle, typDCB) ' Debug.Print "設置串口參數：" & flag
'********設置緩沖區大小********
flag = SetupComm(com_Handle, lngInSize, lngOutSize) ' flag = SetupComm(com_Handle, 8192, 8192)
CtimeOut.ReadIntervalTimeout = -1 '0
CtimeOut.ReadTotalTimeoutConstant = 0 '2500
CtimeOut.ReadTotalTimeoutMultiplier = 0 '0
CtimeOut.WriteTotalTimeoutConstant = 0 '20 '2500
CtimeOut.WriteTotalTimeoutMultiplier = 0 '200 '0
'********超時設置********
flag = SetCommTimeouts(com_Handle, CtimeOut)
flag = SetCommMask(com_Handle, EV_RXCHAR) '設置監視的事件為接收到字符
'********清空讀寫緩沖區********
Call PurgeComm(com_Handle, PURGE_RXABORT Or PURGE_RXCLEAR Or PURGE_TXABORT Or PURGE_TXCLEAR) '清除緩沖區
If flag = -1 Then
RetVal = GetLastError()
OpenPort = flag
RetVal = CloseHandle(com_Handle)
Exit Function
End If
'獲取信號句柄
Dim lpEventAttributes1 As SECURITY_ATTRIBUTES
Dim lpEventAttributes2 As SECURITY_ATTRIBUTES
m_OverlappedRead.hEvent = CreateEvent(lpEventAttributes1, 1, 0, 0) m_OverlappedWrite.hEvent = CreateEvent(lpEventAttributes2, 1, 0, 0)
'判斷設置參數是否成功 設置輸入和輸出緩沖區是否成功
If m_OverlappedRead.hEvent = 0 Or m_OverlappedWrite.hEvent = 0 Then
RetVal = GetLastError()
OpenPort = RetVal
If (m_OverlappedRead.hEvent <> 0) Then
CloseHandle (m_OverlappedRead.hEvent)
If (m_OverlappedWrite.hEvent <> 0) Then
CloseHandle (m_OverlappedWrite.hEvent)
Call CloseHandle(com_Handle)
com_Handle = 0
Exit Function
End If
OpenPort = 0
Exit Function
handelinitcom:
Call CloseHandle(com_Handle)
com_Handle = 0
OpenPort = -1
Exit Function
End Function
'*************************************************************************
'**函 數 名：ClosePort
'*************************************************************************
Public Function ClosePort() As Long
If com_Handle = INVALID_HANDLE_VALUE Then
Exit Function
End If
Call SetCommMask(com_Handle, 0)
Call SetEvent(m_OverlappedRead.hEvent)
Call SetEvent(m_OverlappedWrite.hEvent)
If (m_OverlappedRead.hEvent <> 0) Then
CloseHandle (m_OverlappedRead.hEvent)
If (m_OverlappedWrite.hEvent <> 0) Then
CloseHandle (m_OverlappedWrite.hEvent)
If CloseHandle(com_Handle) <> 0 Then
ClosePort = 0
Else
ClosePort = -1
End If
com_Handle = INVALID_HANDLE_VALUE
frmConnection.CHUANKOUFLAG = 0
End Function
'*************************************************************************
'**函 數 名：ClearInBuf
'**輸 入：無
'**輸 出：無
'**功能描述：清空輸入緩沖區
'*************************************************************************
Public Function ClearInBuf() As Long
If (com_Handle = INVALID_HANDLE_VALUE) Then
ClearInBuf = 1
Exit Function
End If
Call PurgeComm(com_Handle, PURGE_RXABORT Or PURGE_RXCLEAR)
ClearInBuf = 0
End Function
'*************************************************************************
'**函 數 名：ClearOutBuf
'**輸 入：無
'**輸 出：(Long) -
'**功能描述：清空輸出緩沖區
'*************************************************************************
Public Function ClearOutBuf() As Long
If (com_Handle = INVALID_HANDLE_VALUE) Then
ClearOutBuf = 1
Exit Function
End If
Call PurgeComm(com_Handle, PURGE_TXABORT Or PURGE_TXCLEAR)
ClearOutBuf = 0
End Function
'*************************************************************************
'**函 數 名：SendData
'**輸 入：bytBuffer()(Byte) - 數據
'** ：lngSize(Long) - 數據長度
'**輸 出：(Long) -
'**功能描述：發送數據
'*************************************************************************
Public Function SendData(bytBuffer() As Byte, lngSize As Long) As Long
On Error GoTo Routine_Exit '打開錯誤陷阱
Dim errNum As Long
Dim flag As Long
Dim i As Long
If (com_Handle = 0) Then
SendData = 1
Exit Function
End If
Dim dwBytesWritten As Long
Dim bWriteStat As Long
Dim ComStats As COMSTAT
Dim dwErrorFlags As Long
' dwBytesWritten = lngSize
Call ClearCommError(com_Handle, dwErrorFlags, ComStats)
bWriteStat = WriteFile(com_Handle, bytBuffer(0), lngSize, dwBytesWritten, m_OverlappedWrite) '>>正常編譯時候就這樣就可以了
Call GetOverlappedResult(com_Handle, m_OverlappedWrite, dwBytesWritten, 1)
'等待直到發送完畢
'<<正常編譯時候就這樣就可以了
' ''>>這樣在調試狀態下可以的或在編譯為P代碼的情況下是可以正常運行
' If Not bWriteStat Then
' If GetLastError() = ERROR_IO_PENDING Then
' Call GetOverlappedResult(com_Handle, m_OverlappedWrite, dwBytesWritten, 1) '等待直到發送完畢
' End If
' End If
' ''<<這樣在調試狀態下可以的或在編譯為P代碼的情況下是可以正常運行
com_TxBy = com_TxBy + dwBytesWritten
SendData = dwBytesWritten
ClearOutBuf '清除緩沖區
''
'發送數據 ''
For i = 0 To UBound(bytBuffer) ''
flag = WriteFile(Com_Handle, bytBuffer(i), 1, dwBytesWritten, m_OverlappedWrite)
'' If Not flag Then
'' '獲取出錯碼 ''
errNum = GetLastError() ''
If (errNum = ERROR_IO_PENDING) Then ''
flag = 0 ''
flag = GetOverlappedResult(Com_Handle, m_OverlappedWrite, dwBytesWritten, 1) ''
SendData = SendData + dwBytesWritten ''
Debug.Print "errNum = ERROR_IO_PENDING" ''
Else ''
End If ''
End If '' '' ' '間隔時間（用於需要設定每字節間間隔時間的發送協議） '' ' Sleep (intIntervalTime) '' Next
Exit Function '----------------
Routine_Exit:
SendData = -1
End Function
'*************************************************************************
'**函 數 名：ReadData
'**輸 入：bytBuffer()(Byte) - 讀取到的數據
'** ：Outtime(Long) - 等待時間ms
'**輸 出：(Long) -讀取的字節數量
'**功能描述：讀取數據 '*************************************************************************
'Public Function ReadData(bytBuffer() As Byte, lngSize As Long, Optional Outtime As Long = 2000) As Long
Public Function ReadData(bytBuffer() As Byte, Optional lngSize As Long = 255, Optional Outtime As Long = 2000) As Long
On Error GoTo Routine_Exit '打開錯誤陷阱
If (com_Handle = 0) Then
ReadData = 0
Exit Function
End If
Dim lngBytesRead As Long
Dim fReadStat As Long
Dim dwRes As Long
Dim lngErrorFlags As Long
Dim lngStatus As Long
Dim udtCommStat As COMSTAT
Dim evtMask As Long
Dim ret As Long
' lngBytesRead = lngSize
' 清除之前的一切錯誤與獲取當前的狀態
lngStatus = ClearCommError(com_Handle, lngErrorFlags, _ udtCommStat)
Debug.Print "udtCommStat.cbInQue " & udtCommStat.cbInQue
' 讀數據
If lngStatus <> 0 And udtCommStat.cbInQue > 0 And lngSize > 0 Then
If lngSize = 255 And udtCommStat.cbInQue > 255 Then
lngSize = udtCommStat.cbInQue
End If
ReDim Preserve bytBuffer(lngSize) As Byte
fReadStat = ReadFile(com_Handle, bytBuffer(0), lngSize, lngBytesRead, m_OverlappedRead)
com_RxBy = com_RxBy + lngBytesRead
If fReadStat = 0 Then
Call PurgeComm(com_Handle, PURGE_RXABORT Or PURGE_RXCLEAR Or PURGE_TXABORT Or PURGE_TXCLEAR) '清除緩沖區
' lngStatus = GetLastError
' If lngStatus = ERROR_IO_PENDING Then
' Call PurgeComm(com_Handle, PURGE_RXABORT Or PURGE_RXCLEAR Or PURGE_TXABORT Or PURGE_TXCLEAR) '清除緩沖區
' Else
'
' Some other error occurred.
' lngBytesRead = -1
'
' lngStatus = SetCommErrorEx("CommRead (ReadFile)", _
'
' Com_Handle)
' GoTo Routine_Exit
' End If
End If
ClearInBuf '清除緩沖區
End If
ReadData = lngBytesRead
Exit Function
Routine_Exit:
ReadData = 0
End Function
'*************************************************************************
'**函 數 名：Class_Initialize
'*************************************************************************
Private Sub Class_Initialize()
com_Handle = INVALID_HANDLE_VALUE
com_RxBy = 0
com_TxBy = 0
End Sub
'*************************************************************************
'**函 數 名：Class_Terminate
'*************************************************************************
Private Sub Class_Terminate()
Call ClosePort
End Sub