dwdcb.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 = "dwDCB"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'
'dwDCB -设备控制块类 目的：分解fBitFields属性和设定获得串口状态
'
Option Explicit

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 DCBStr As DCB
Private BufferSize As Integer

Private Const ERR_INVALIDPROPERTY = 31000
Private Const CLASS_NAME$ = "dwDCB"
'与fBitFields属性相与的标志，参见fBitFields属性的说明
Private Const FLAG_fBinary& = &H1
Private Const FLAG_fParity& = &H2
Private Const FLAG_fOutxCtsFlow = &H4
Private Const FLAG_fOutxDsrFlow = &H8
Private Const FLAG_fDtrControl = &H30
Private Const FLAG_fDsrSensitivity = &H40
Private Const FLAG_fTXContinueOnXoff = &H80
Private Const FLAG_fOutX = &H100
Private Const FLAG_fInX = &H200
Private Const FLAG_fErrorChar = &H400
Private Const FLAG_fNull = &H800
Private Const FLAG_fRtsControl = &H3000
Private Const FLAG_fAbortOnError = &H4000

Private Declare Function apiSetCommState Lib "kernel32" Alias "SetCommState" (ByVal hCommDev As Long, lpDCB As DCB) As Long
Private Declare Function apiGetCommState Lib "kernel32" Alias "GetCommState" (ByVal nCid As Long, lpDCB As DCB) As Long


Private Sub Class_Initialize()
    '设置长度
    DCBStr.DCBlength = Len(DCBStr)
    ' 默认值
  
    BufferSize = 2048
    fParity = False
    fOutxCtsFlow = True
    fOutxDsrFlow = True
    fDtrControl = 1
    fDsrSensitivity = True
    fTXContinueOnXoff = True
    fOutX = True
    fInX = True
    fErrorChar = True
    fNull = True
    fRtsControl = 1
    fAbortOnError = True
    DCBStr.XonLim = 100
    DCBStr.XoffLim = BufferSize - 100
    DCBStr.ByteSize = 8
    DCBStr.Parity = 0
    DCBStr.StopBits = 0
    DCBStr.XonChar = 17
    DCBStr.XoffChar = 19
    DCBStr.ErrorChar = Asc("~")
    DCBStr.EofChar = 26 ' ^Z
    DCBStr.EvtChar = 255
    DCBStr.BaudRate = 2400
End Sub


Public Property Get BaudRate() As Long
    BaudRate = DCBStr.BaudRate
End Property

'检查波特率的合法性
Public Property Let BaudRate(vNewValue As Long)
    Select Case vNewValue
        Case 110, 300, 600, 1200, 2400, 4800, 9600, 14400, 19200, 38400, 56000, 57600, 115200, 128000, 256000
            DCBStr.BaudRate = vNewValue
        Case Else
            Err.Raise vbObjectError + ERR_INVALIDPROPERTY, CLASS_NAME, "无效的波特率设定"
    End Select
End Property

'分解fBitFields结构
Public Property Get fParity() As Boolean
    If DCBStr.fBitFields And FLAG_fParity Then
        fParity = True
    End If
End Property

Public Property Let fParity(vNewValue As Boolean)
    DCBStr.fBitFields = DCBStr.fBitFields And (Not FLAG_fParity)
    If vNewValue Then DCBStr.fBitFields = DCBStr.fBitFields Or FLAG_fParity
End Property

Public Property Get fOutxCtsFlow() As Boolean
    If DCBStr.fBitFields And FLAG_fOutxCtsFlow Then
        fOutxCtsFlow = True
    End If
End Property

Public Property Let fOutxCtsFlow(vNewValue As Boolean)
    DCBStr.fBitFields = DCBStr.fBitFields And (Not FLAG_fOutxCtsFlow)
    If vNewValue Then DCBStr.fBitFields = DCBStr.fBitFields Or FLAG_fOutxCtsFlow
End Property

Public Property Get fOutxDsrFlow() As Boolean
    If DCBStr.fBitFields And FLAG_fOutxDsrFlow Then
        fOutxDsrFlow = True
    End If
End Property

Public Property Let fOutxDsrFlow(vNewValue As Boolean)
    DCBStr.fBitFields = DCBStr.fBitFields And (Not FLAG_fOutxDsrFlow)
    If vNewValue Then DCBStr.fBitFields = DCBStr.fBitFields Or FLAG_fOutxDsrFlow
End Property

Public Property Get fDtrControl() As Integer
    Dim ival&
    ival = DCBStr.fBitFields And FLAG_fDtrControl
    fDtrControl = ival \ 16    ' Shift right 4 bits
End Property

' 0 to disable, 1 to enable, 2 for handshake mode
Public Property Let fDtrControl(vNewValue As Integer)
    If vNewValue < 0 Or vNewValue > 2 Then
        Err.Raise vbObjectError + ERR_INVALIDPROPERTY, CLASS_NAME, "无效的DTR控制设定"
    End If
    DCBStr.fBitFields = DCBStr.fBitFields And FLAG_fDtrControl
    DCBStr.fBitFields = DCBStr.fBitFields Or (vNewValue * 16)
End Property

Public Property Get fDsrSensitivity() As Boolean
    If DCBStr.fBitFields And FLAG_fDsrSensitivity Then
        fDsrSensitivity = True
    End If
End Property

Public Property Let fDsrSensitivity(vNewValue As Boolean)
    DCBStr.fBitFields = DCBStr.fBitFields And (Not FLAG_fDsrSensitivity)
    If vNewValue Then DCBStr.fBitFields = DCBStr.fBitFields Or FLAG_fDsrSensitivity
End Property


Public Property Get fTXContinueOnXoff() As Boolean
    If DCBStr.fBitFields And FLAG_fTXContinueOnXoff Then
        fTXContinueOnXoff = True
    End If
End Property

Public Property Let fTXContinueOnXoff(vNewValue As Boolean)
    DCBStr.fBitFields = DCBStr.fBitFields And (Not FLAG_fTXContinueOnXoff)
    If vNewValue Then DCBStr.fBitFields = DCBStr.fBitFields Or FLAG_fTXContinueOnXoff
End Property

Public Property Get fOutX() As Boolean
    If DCBStr.fBitFields And FLAG_fOutX Then
        fOutX = True
    End If
End Property

Public Property Let fOutX(vNewValue As Boolean)
    DCBStr.fBitFields = DCBStr.fBitFields And (Not FLAG_fOutX)
    If vNewValue Then DCBStr.fBitFields = DCBStr.fBitFields Or FLAG_fOutX
End Property

Public Property Get fInX() As Boolean
    If DCBStr.fBitFields And FLAG_fInX Then
        fInX = True
    End If
End Property

Public Property Let fInX(vNewValue As Boolean)
    DCBStr.fBitFields = DCBStr.fBitFields And (Not FLAG_fInX)
    If vNewValue Then DCBStr.fBitFields = DCBStr.fBitFields Or FLAG_fInX
End Property

Public Property Get fErrorChar() As Boolean
    If DCBStr.fBitFields And FLAG_fErrorChar Then
        fErrorChar = True
    End If
End Property

Public Property Let fErrorChar(vNewValue As Boolean)
    DCBStr.fBitFields = DCBStr.fBitFields And (Not FLAG_fErrorChar)
    If vNewValue Then DCBStr.fBitFields = DCBStr.fBitFields Or FLAG_fErrorChar
End Property

Public Property Get fNull() As Boolean
    If DCBStr.fBitFields And FLAG_fNull Then
        fNull = True
    End If
End Property

Public Property Let fNull(vNewValue As Boolean)
    DCBStr.fBitFields = DCBStr.fBitFields And (Not FLAG_fNull)
    If vNewValue Then DCBStr.fBitFields = DCBStr.fBitFields Or FLAG_fNull
End Property

Public Property Get fRtsControl() As Integer
    Dim ival&
    ival = DCBStr.fBitFields And FLAG_fRtsControl
    fRtsControl = ival \ &H1000    ' Shift right 4 bits
End Property

Public Property Let fRtsControl(vNewValue As Integer)
    If vNewValue < 0 Or vNewValue > 3 Then
        Err.Raise vbObjectError + ERR_INVALIDPROPERTY, CLASS_NAME, "无效的RTS控制设定"
    End If
    DCBStr.fBitFields = DCBStr.fBitFields And FLAG_fRtsControl
    DCBStr.fBitFields = DCBStr.fBitFields Or (vNewValue * &H1000)
End Property

Public Property Get fAbortOnError() As Boolean
    If DCBStr.fBitFields And FLAG_fAbortOnError Then
        fAbortOnError = True
    End If
End Property

Public Property Let fAbortOnError(vNewValue As Boolean)
    DCBStr.fBitFields = DCBStr.fBitFields And (Not FLAG_fAbortOnError)
    If vNewValue Then DCBStr.fBitFields = DCBStr.fBitFields Or FLAG_fAbortOnError
End Property

Public Property Get XonLim() As Integer
    XonLim = DCBStr.XonLim
End Property

Public Property Let XonLim(vNewValue As Integer)
    DCBStr.XonLim = vNewValue
End Property

Public Property Get XoffLim() As Integer
    XoffLim = DCBStr.XoffLim
End Property

Public Property Let XoffLim(vNewValue As Integer)
    DCBStr.XoffLim = vNewValue
End Property

Public Property Get ByteSize() As Byte
    ByteSize = DCBStr.ByteSize
End Property

Public Property Let ByteSize(vNewValue As Byte)
    If vNewValue < 4 Or vNewValue > 8 Then
        Err.Raise vbObjectError + ERR_INVALIDPROPERTY, CLASS_NAME, "无效的字节长设定"
    End If
    DCBStr.ByteSize = vNewValue
End Property


Public Property Get Parity() As Byte
    Parity = DCBStr.Parity
End Property

' 0 - 4 = No, odd, even, mark, space
Public Property Let Parity(vNewValue As Byte)
    If vNewValue < 0 Or vNewValue > 4 Then
        Err.Raise vbObjectError + ERR_INVALIDPROPERTY, CLASS_NAME, "无效的奇偶检验设定"
    End If
    DCBStr.Parity = vNewValue
End Property

Public Property Get StopBits() As Byte
    StopBits = DCBStr.StopBits
End Property

' 0 = 1, 1 = 1.5, 2 = 2
Public Property Let StopBits(vNewValue As Byte)
    If vNewValue < 0 Or vNewValue > 4 Then
        Err.Raise vbObjectError + ERR_INVALIDPROPERTY, CLASS_NAME, "无效的停止位设定"
    End If
    DCBStr.StopBits = vNewValue
End Property

Public Property Get XonChar() As String
    XonChar = Chr$(DCBStr.XonChar)
End Property

Public Property Let XonChar(vNewValue As String)
    DCBStr.XonChar = Asc(vNewValue)
End Property

Public Property Get XoffChar() As String
    XoffChar = Chr$(DCBStr.XoffChar)
End Property

Public Property Let XoffChar(vNewValue As String)
    DCBStr.XoffChar = Asc(vNewValue)
End Property

Public Property Get ErrorChar() As String
    ErrorChar = Chr$(DCBStr.ErrorChar)
End Property

Public Property Let ErrorChar(vNewValue As String)
    DCBStr.ErrorChar = Asc(vNewValue)
End Property

Public Property Get EofChar() As String
    EofChar = Chr$(DCBStr.EofChar)
End Property

Public Property Let EofChar(vNewValue As String)
    DCBStr.EofChar = Asc(vNewValue)
End Property

Public Property Get EvtChar() As String
    EvtChar = Chr$(DCBStr.EvtChar)
End Property

Public Property Let EvtChar(vNewValue As String)
    DCBStr.EvtChar = Asc(vNewValue)
End Property

' 获得串口状态
Public Function GetCommState(Comm As dwCom) As Boolean
    Dim res&
       If Comm.hCommDev = 0 Then Exit Function
    res = apiGetCommState(Comm.hCommDev, DCBStr)
    GetCommState = res <> 0
End Function

'设定串口
Public Function SetCommState(Comm As dwCom) As Boolean
    Dim res&
     If Comm.hCommDev = 0 Then Exit Function
    res = apiSetCommState(Comm.hCommDev, DCBStr)
    SetCommState = res <> 0
End Function