dwcom.cls

一个水情自动测报系统的接收例程

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "dwCom"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' dwCom-串口通信类
Option Explicit

'重叠结构
Private Type OVERLAPPED
        Internal As Long
        InternalHigh As Long
        offset As Long
        OffsetHigh As Long
        hEvent 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 timeouts As COMMTIMEOUTS
'Com1 和Com2以及其他的一些兼容的设备（如串口卡等）； Com1, com2 or other compatible comm device
Private devname$
' Comm句柄Comm handle
Private handle As Long
' 共有成员
Public dcbclass As dwDCB
Public be_open As Boolean
Public zijie As Integer
Public kou As Integer
Public ID As Integer
'Current state indicators
Private inx(1 To 12) As Byte
Private inx2(1 To 8) As Byte
Private inx3(0 To 50) As Byte
Private Rflx As Integer
Private imm As Integer
Private imm2 As Integer
Private imm3 As Integer

'Current state indicators
Private PendingOutput$
Private CurrentEventMask&
'输入输出缓冲区
Private CurrentInputBuffer&
Private CurrentOutputBuffer&
'数据传递数目
Private DataWritten&
Private DataRead&
Private EventResults&

Private TriggeredEvents&    '装载事件结果的变量

' 重叠结构的数组
' 0 ：读操作, 1 = 写操作, 2 = 等待事件
Private overlaps(2) As OVERLAPPED

' 表明后台操作是否在进行
' 0 ：读操作, 1 = 写操作, 2 = 等待事件
Private inprogress(2) As Boolean


Private CallbackObject As Object

' API的声明
Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" _
   (ToVar As Any, FromVar As Any, ByVal cbLen As Long)

'Private Declare Function lstrcpyFromBuffer Lib "kernel32" Alias "lstrcpynA" (ByVal lpString1 As String, ByVal buffer As Long, ByVal iMaxLength As Long) As Long
Private Declare Function lstrcpyFromBuffer Lib "kernel32" Alias "lstrcpynA" (ByRef lpString1 As Byte, ByVal buffer As Long, ByVal iMaxLength As Long) As Long

Private Declare Function lstrcpyToBuffer Lib "kernel32" Alias "lstrcpynA" (ByVal buffer As Long, ByVal lpString2 As String, ByVal iMaxLength As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
Private Declare Function CreateEvent Lib "kernel32" Alias "CreateEventA" (ByVal lpEventAttributes As Long, ByVal bManualReset As Long, ByVal bInitialState As Long, ByVal lpName As String) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, ByVal lpBuffer As Long, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As OVERLAPPED) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, ByVal lpBuffer As Long, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As OVERLAPPED) As Long
Private Declare Function SetCommMask Lib "kernel32" (ByVal hFile As Long, ByVal dwEvtMask As Long) As Long
Private Declare Function ClearCommError Lib "kernel32" (ByVal hFile As Long, lpErrors As Long, ByVal l As Long) As Long
Private Declare Function WaitCommEvent Lib "kernel32" (ByVal hFile As Long, lpEvtMask As Long, lpOverlapped As OVERLAPPED) As Long
Private Declare Function apiSetCommTimeouts Lib "kernel32" Alias "SetCommTimeouts" (ByVal hFile As Long, lpCommTimeouts As COMMTIMEOUTS) As Long
Private Declare Function apiGetCommTimeouts Lib "kernel32" Alias "GetCommTimeouts" (ByVal hFile As Long, lpCommTimeouts As COMMTIMEOUTS) 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, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile 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 GetCommModemStatus Lib "kernel32" (ByVal hFile As Long, lpModemStat As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long

'API常量的声明
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const OPEN_EXISTING = 3
Private Const FILE_FLAG_OVERLAPPED = &H40000000
Private Const INVALID_HANDLE_VALUE = -1
Private Const GMEM_FIXED = &H0
Private Const ClassBufferSizes% = 1024
Private Const ERROR_IO_PENDING = 997 '  dderror
Private Const WAIT_TIMEOUT = &H102&

Private Const CLASS_NAME$ = "dwCom"
Private Const ERR_NOCOMMACCESS = 31010
Private Const ERR_UNINITIALIZED = 31011
Private Const ERR_MODEMSTATUS = 31012
Private Const ERR_READFAIL = 31013
Private Const ERR_EVENTFAIL = 31014

Private Const EV_RXCHAR = &H1                '  Any Character received
Private Const EV_RXFLAG = &H2                '  Received certain character
Private Const EV_TXEMPTY = &H4               '  Transmitt Queue Empty
Private Const EV_CTS = &H8                   '  CTS changed state
Private Const EV_DSR = &H10                  '  DSR changed state
Private Const EV_RLSD = &H20                 '  RLSD changed state
Private Const EV_BREAK = &H40                '  BREAK received
Private Const EV_ERR = &H80                  '  Line status error occurred
Private Const EV_RING = &H100                '  Ring signal detected
Private Const EV_PERR = &H200                '  Printer error occured
Private Const EV_RX80FULL = &H400            '  Receive buffer is 80 percent full
Private Const EV_EVENT1 = &H800              '  Provider specific event 1
Private Const EV_EVENT2 = &H1000             '  Provider specific event 2

Private Const CE_RXOVER = &H1                '  Receive Queue overflow
Private Const CE_OVERRUN = &H2               '  Receive Overrun Error
Private Const CE_RXPARITY = &H4              '  Receive Parity Error
Private Const CE_FRAME = &H8                 '  Receive Framing error
Private Const CE_BREAK = &H10                '  Break Detected
Private Const CE_TXFULL = &H100              '  TX Queue is full

Private EmptyString As String * 1

'初始化类模块
Private Sub Class_Initialize()
    Dim olnum%
    Set dcbclass = New dwDCB
      be_open = True
    CurrentInputBuffer = GlobalAlloc(GMEM_FIXED, ClassBufferSizes + 1)
    CurrentOutputBuffer = GlobalAlloc(GMEM_FIXED, ClassBufferSizes + 1)
    CurrentEventMask = EV_ERR
    EmptyString = Chr$(0)
    ' 创建重叠结构事件对象
    For olnum = 0 To 2
        overlaps(olnum).hEvent = CreateEvent(0, True, False, vbNullString)
    Next olnum
End Sub

Private Sub Class_Terminate()
    Dim olnum
    '关闭已打开的
    Call CloseComm
    ' 关闭事件对象的句柄
    For olnum = 0 To 2
        Call CloseHandle(overlaps(olnum).hEvent)
    Next olnum
    Set dcbclass = Nothing   ' Be sure dcbclass is free
    Call GlobalFree(CurrentInputBuffer)
    Call GlobalFree(CurrentOutputBuffer)
    
End Sub

' 串口设备错误消息
Private Sub DeviceNotOpenedError()
    Err.Raise vbObjectError + ERR_UNINITIALIZED, CLASS_NAME, "串口设备不能打开"
End Sub

'-----------------------------------------------
'超时数据获取
'-----------------------------------------------
Public Property Get ReadIntervalTimeout() As Long
    ReadIntervalTimeout = timeouts.ReadIntervalTimeout
End Property

Public Property Let ReadIntervalTimeout(vNewValue As Long)
    timeouts.ReadIntervalTimeout = vNewValue
End Property

Public Property Get ReadTotalTimeoutMultiplier() As Long
    ReadTotalTimeoutMultiplier = timeouts.ReadTotalTimeoutMultiplier
End Property

Public Property Let ReadTotalTimeoutMultiplier(vNewValue As Long)
    timeouts.ReadTotalTimeoutMultiplier = vNewValue
End Property


Public Property Get ReadTotalTimeoutConstant() As Long
    ReadTotalTimeoutConstant = timeouts.ReadTotalTimeoutConstant
End Property

Public Property Let ReadTotalTimeoutConstant(vNewValue As Long)
    timeouts.ReadTotalTimeoutConstant = ReadTotalTimeoutConstant
End Property

Public Property Get WriteTotalTimeoutMultiplier() As Long
    WriteTotalTimeoutMultiplier = timeouts.WriteTotalTimeoutMultiplier
End Property

Public Property Let WriteTotalTimeoutMultiplier(vNewValue As Long)
    timeouts.WriteTotalTimeoutMultiplier = WriteTotalTimeoutMultiplier
End Property

Public Property Get WriteTotalTimeoutConstant() As Long
    WriteTotalTimeoutConstant = timeouts.WriteTotalTimeoutConstant
End Property

Public Property Let WriteTotalTimeoutConstant(vNewValue As Long)
    timeouts.WriteTotalTimeoutConstant = WriteTotalTimeoutConstant
End Property

'赋句柄
Public Property Get hCommDev() As Long
    hCommDev = handle
End Property

'赋设备
Public Property Get DeviceName() As String
    DeviceName = devname
End Property

Public Sub GetCommTimeouts()
    ' 如果超时报告超时错误时
    If handle = 0 Then Exit Sub
    Call apiGetCommTimeouts(handle, timeouts)
End Sub
'设置超时
Public Function SetCommTimeouts() As Long
    If handle = 0 Then Exit Function
    SetCommTimeouts = apiSetCommTimeouts(handle, timeouts) <> 0
End Function

'打开串口以及初始化操作
Public Function OpenComm(CommDeviceName As String, Notify As Object, Optional cbInQueue, Optional cbOutQueue) As Long
    ' Close an existing port when reopening
    If handle <> 0 Then CloseComm
    devname = CommDeviceName
    Set CallbackObject = Notify
    handle = CreateFile(devname, GENERIC_READ Or GENERIC_WRITE, 0, 0, OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0)
    If handle = INVALID_HANDLE_VALUE Then be_open = False 'Err.Raise vbObjectError + ERR_NOCOMMACCESS, CLASS_NAME, "不能打开串口"
    ' 如果没设置输入输出缓冲区，就设置输入输出缓冲区
    If Not (IsMissing(cbInQueue) Or IsMissing(cbOutQueue)) Then
        Call SetupComm(handle, cbInQueue, cbOutQueue)
    Else
        Call SetupComm(handle, 8192, 1024)
    End If
    ' 获得超时结构
    GetCommTimeouts
    '设置超时
    timeouts.ReadIntervalTimeout = 1
    timeouts.ReadTotalTimeoutMultiplier = 0
    timeouts.ReadTotalTimeoutConstant = 10
    timeouts.WriteTotalTimeoutMultiplier = 1
    timeouts.WriteTotalTimeoutConstant = 1
    SetCommTimeouts
    ' 初始化串口类
    Call dcbclass.GetCommState(Me)
   ' 设置通信事件掩膜
    Call SetCommMask(handle, CurrentEventMask)
   ' StartInput
    'be_open = True
End Function

'关闭串口
Public Function CloseComm() As Long
    If handle = 0 Then Exit Function
    Set CallbackObject = Nothing
    Call CloseHandle(handle)
    handle = 0
End Function



' 获得串口状态

Public Function GetCommState() As Long
    If handle = 0 Then DeviceNotOpenedError
    GetCommState = dcbclass.GetCommState(Me)
End Function

'设置串口状态
Public Function SetCommState() As Long
    If handle = 0 Then DeviceNotOpenedError
    SetCommState = dcbclass.SetCommState(Me)
End Function


' 输出数据函数
Public Function CommOutput(outputdata As String) As Long
    Dim bytestosend&
    Dim res&
    Dim addnull As Boolean
    If handle = 0 Then DeviceNotOpenedError
    PendingOutput = PendingOutput & outputdata
    If inprogress(1) Then    ' 写操作正在进行
        CommOutput = True    '退出
        Exit Function
    End If
    ' 开始一个新的写操作
    bytestosend = LenB(StrConv(PendingOutput, vbFromUnicode)) ' Len(PendingOutput)
    '无数据输出，退出
    If bytestosend = 0 Then
        CommOutput = True
        Exit Function
    End If
    '防止缓冲区过界
    If bytestosend > ClassBufferSizes Then bytestosend = ClassBufferSizes
    ' null字符，也送
    If lstrlen(PendingOutput) < bytestosend Then
        bytestosend = lstrlen(PendingOutput)
        addnull = True '表明送出null字符
    End If
    '复制到缓冲区
    If bytestosend > 0 Then Call lstrcpyToBuffer(CurrentOutputBuffer, PendingOutput, bytestosend + 1)
    If bytestosend = LenB(StrConv(PendingOutput, vbFromUnicode)) Then
        PendingOutput = ""
    Else
        PendingOutput = Mid(PendingOutput, bytestosend + 1)
    End If
    If addnull Then bytestosend = bytestosend + 1
    '送出数据
    res = WriteFile(handle, CurrentOutputBuffer, bytestosend, DataWritten, overlaps(1))
    If res <> 0 Then
       '正常结束，处理后续
        ProcessWriteComplete
        CommOutput = True
    Else
        '函数返回时操作任在继续
        If GetLastError() = ERROR_IO_PENDING Then
            inprogress(1) = True
            CommOutput = True
            '#If DEBUGMODE Then
            '   Debug.Print "后台正在写"
            '#End If
        End If
    End If
End Function

'写后处理
Public Sub ProcessWriteComplete()
    inprogress(1) = False
    '通过CommOutput函数退出写操作
    Call CommOutput("")
End Sub

'检测所有的后台操作
Public Sub Detect()
    'DetectWrite
    DetectRead
    DetectEvent
End Sub