sccomm.ctl

非常好的串口控件

    Dim sstemp As String

    Dim stmp As String
    rlen = sio_read(mCommData.port, buf(0), 512)
    If rlen > 0 Then
'        ReDim tmp(0 To rlen - 1) As Byte
        ReDim tmp(0 To rlen + 1) As Byte
        ReDim sUnicode(0 To rlen - 1) As String
        For nI = 0 To rlen - 1
            tmp(nI) = buf(nI)
            sstemp = StrConv(tmp(nI), vbUnicode)
            sUnicode(nI) = sstemp
             Debug.Print tmp(nI)
        Next nI

'    tmp(nI) = 0
'    tmp(nI + 1) = 26
'     msDataBuf = msDataBuf & StrConv(tmp, vbUnicode)
'        Debug.Print msDataBuf
'    tmp(nI) = 0
'    tmp(nI + 1) = 26
    stmp = tmp
    msDataBuf = msDataBuf & stmp
 '       msDataBuf = sUnicode
        m_CommEvent = comEvReceive
        RaiseEvent OnComm
    End If
End Sub

Private Sub UserControl_Initialize()
    Call InitTable
    mbOpened = False
End Sub

'为用户控件初始化属性
Private Sub UserControl_InitProperties()
    m_Port = m_def_Port
    m_BaudRate = m_def_BaudRate
    m_Parity = m_def_Parity
    m_DataBits = m_def_DataBits
    m_StopBits = m_def_StopBits
    m_DTR = m_def_DTR
    m_RTS = m_def_RTS
    m_FlowControl = m_def_FlowControl
    m_CommEvent = m_def_CommEvent
End Sub

'从存贮器中加载属性值
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

    m_Port = PropBag.ReadProperty("Port", m_def_Port)
    m_BaudRate = PropBag.ReadProperty("BaudRate", m_def_BaudRate)
    m_Parity = PropBag.ReadProperty("Parity", m_def_Parity)
    m_DataBits = PropBag.ReadProperty("DataBits", m_def_DataBits)
    m_StopBits = PropBag.ReadProperty("StopBits", m_def_StopBits)
    m_DTR = PropBag.ReadProperty("DTR", m_def_DTR)
    m_RTS = PropBag.ReadProperty("RTS", m_def_RTS)
    m_FlowControl = PropBag.ReadProperty("FlowControl", m_def_FlowControl)
    m_CommEvent = PropBag.ReadProperty("CommEvent", m_def_CommEvent)
    With mCommData
        .port = m_Port + 1
        .ibaudrate = m_BaudRate
        .iparity = m_Parity
        .ibytesize = m_DataBits
        .istopbits = m_StopBits
        .BaudRate = mBaudTable(.ibaudrate)
        .ByteSize = mByteSizeTable(.ibytesize)
        .Parity = mParityTable(.iparity)
        .StopBits = mStopBitsTable(.istopbits)
        .Dtr = m_DTR
        .Rts = m_RTS
        Select Case m_FlowControl
            Case 0
                .Hw = 0
                .Sw = 0
            Case 1
                .Sw = 1
                .Hw = 0
            Case 2
                .Sw = 0
                .Hw = 1
        End Select
    End With
End Sub

Private Sub UserControl_Resize()
    Height = 480
    Width = 480
End Sub

'将属性值写到存储器
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

    Call PropBag.WriteProperty("Port", m_Port, m_def_Port)
    Call PropBag.WriteProperty("BaudRate", m_BaudRate, m_def_BaudRate)
    Call PropBag.WriteProperty("Parity", m_Parity, m_def_Parity)
    Call PropBag.WriteProperty("DataBits", m_DataBits, m_def_DataBits)
    Call PropBag.WriteProperty("StopBits", m_StopBits, m_def_StopBits)
    Call PropBag.WriteProperty("DTR", m_DTR, m_def_DTR)
    Call PropBag.WriteProperty("RTS", m_RTS, m_def_RTS)
    Call PropBag.WriteProperty("FlowControl", m_FlowControl, m_def_FlowControl)
    Call PropBag.WriteProperty("CommEvent", m_CommEvent, m_def_CommEvent)
End Sub

'注意！不要删除或修改下列被注释的行！
'MemberInfo=7,1,2,0
Public Property Get CommEvent() As Integer
Attribute CommEvent.VB_Description = "事件类型"
Attribute CommEvent.VB_MemberFlags = "400"
    CommEvent = m_CommEvent
End Property

Public Property Let CommEvent(ByVal New_CommEvent As Integer)
    If Ambient.UserMode = False Then Err.Raise 387
    If Ambient.UserMode Then Err.Raise 382
    m_CommEvent = New_CommEvent
    PropertyChanged "CommEvent"
End Property

'==================================================================
Private Sub InitTable()
    mstrBaudTable(0) = "50"
    mstrBaudTable(1) = "75"
    mstrBaudTable(2) = "110"
    mstrBaudTable(3) = "134"
    mstrBaudTable(4) = "150"
    mstrBaudTable(5) = "300"
    mstrBaudTable(6) = "600"
    mstrBaudTable(7) = "1200"
    mstrBaudTable(8) = "1800"
    mstrBaudTable(9) = "2400"
    mstrBaudTable(10) = "4800"
    mstrBaudTable(11) = "7200"
    mstrBaudTable(12) = "9600"
    mstrBaudTable(13) = "19200"
    mstrBaudTable(14) = "38400"
    mstrBaudTable(15) = "57600"
    mstrBaudTable(16) = "115200"
    mstrBaudTable(17) = "230400"
    mstrBaudTable(18) = "460800"
    mstrBaudTable(19) = "921600"
    
    mstrParityTable(0) = "无"
    mstrParityTable(1) = "奇校验"
    mstrParityTable(2) = "偶校验"
    mstrParityTable(3) = "标记"
    mstrParityTable(4) = "空格"

    mstrByteSizeTable(0) = "5"
    mstrByteSizeTable(1) = "6"
    mstrByteSizeTable(2) = "7"
    mstrByteSizeTable(3) = "8"

    mstrStopBitsTable(0) = "1"
    mstrStopBitsTable(1) = "2"
    
    mBaudTable(0) = B50
    mBaudTable(1) = B75
    mBaudTable(2) = B110
    mBaudTable(3) = B134
    mBaudTable(4) = B150
    mBaudTable(5) = B300
    mBaudTable(6) = B600
    mBaudTable(7) = B1200
    mBaudTable(8) = B1800
    mBaudTable(9) = B2400
    mBaudTable(10) = B4800
    mBaudTable(11) = B7200
    mBaudTable(12) = B9600
    mBaudTable(13) = B19200
    mBaudTable(14) = B38400
    mBaudTable(15) = B57600
    mBaudTable(16) = B115200
    mBaudTable(17) = B230400
    mBaudTable(18) = B460800
    mBaudTable(19) = B921600
    
    mParityTable(0) = P_NONE
    mParityTable(1) = P_EVEN
    mParityTable(2) = P_ODD
    mParityTable(3) = P_MRK
    mParityTable(4) = P_SPC

    mByteSizeTable(0) = BIT_5
    mByteSizeTable(1) = BIT_6
    mByteSizeTable(2) = BIT_7
    mByteSizeTable(3) = BIT_8

    mStopBitsTable(0) = STOP_1
    mStopBitsTable(1) = STOP_2
End Sub

Private Function fb_LetProperty(ByVal sName As String, ByVal nValue As Integer, ByVal nMin As Integer, ByVal nMax As Integer) As Boolean
    If nValue < nMin Or nValue > nMax Then
        Err.Raise &H1 + 513, , "无效属性赋值给" & sName & "，必须在（" & nMin & "-" & nMax & "）之间。"
        fb_LetProperty = False
        Exit Function
    End If
    fb_LetProperty = True
End Function

Private Function PortSet() As Boolean
    Dim port As Long
    Dim mode As Long
    Dim Hw  As Long, Sw As Long
    Dim ret As Long
    Dim tout As Long

    port = mCommData.port
    mode = mCommData.Parity Or mCommData.ByteSize Or mCommData.StopBits
    If mCommData.Hw = 1 Then
        Hw = 3      'bit0 and bit1
    Else
        Hw = 0
    End If
    If mCommData.Sw = 1 Then
        Sw = 12     'bit2 and bit3
    Else
        Sw = 0
    End If
    
    PortSet = False
    
    ret = sio_ioctl(port, mCommData.BaudRate, mode)
    If ret <> SIO_OK Then
        Call MxShowError("sio_ioctl", ret, GetLastError())
        Exit Function
    End If

    ret = sio_flowctrl(port, Hw Or Sw)
    If ret <> SIO_OK Then
        Call MxShowError("sio_flowctrl", ret, GetLastError())
        Exit Function
    End If

    ret = sio_DTR(port, mCommData.Dtr)
    If ret <> SIO_OK Then
        Call MxShowError("sio_DTR", ret, GetLastError())
        Exit Function
    End If

    If mCommData.Hw = 0 Then
        ret = sio_RTS(port, mCommData.Rts)
        If ret <> SIO_OK Then
            Call MxShowError("sio_RTS", ret, GetLastError())
            Exit Function
        End If
    End If
    
    tout = 1000 / sio_getbaud(mCommData.port)  'ms /byte'
    If tout < 1 Then
        tout = 1
    End If
    tout = tout * 1 * 3             ' 1 byte; '*3' is for delay
    If tout < 100 Then
        tout = 100
    End If
    Call sio_SetWriteTimeouts(mCommData.port, tout)

    PortSet = True
End Function

'==================================================================
Public Function GetPort() As Long
    GetPort = m_Port + 1
End Function

Public Function GetBaudRate() As String
    GetBaudRate = mstrBaudTable(m_BaudRate)
End Function

Public Function GetParity() As String
    GetParity = mstrParityTable(m_Parity)
End Function

Public Function GetDataBits() As String
    GetDataBits = mstrByteSizeTable(m_DataBits)
End Function

Public Function GetStopBits() As String
    GetStopBits = mstrStopBitsTable(m_StopBits)
End Function

Public Function GetFlowControl() As String
    Select Case m_FlowControl
        Case 0
            GetFlowControl = "无"
        Case 1
            GetFlowControl = "Xon/Xoff"
        Case 2
            GetFlowControl = "RTS/CTS"
    End Select
End Function

Private Function ChangeBytes(ByVal str As String, Bytes() As Byte) As Long
    
    'Changes a VB unicode $ to an byte array Returns True if it truncates str
    
    Dim lenBs As Long   'length of the byte array
    Dim lenStr As Long  'length of the string
    ChangeBytes = 0
    lenBs = UBound(Bytes) - LBound(Bytes)
    lenStr = LenB(VBA.StrConv(str, vbFromUnicode))
    
    If lenBs > lenStr Then
        CopyMemoryA Bytes(0), str, lenStr
        ZeroMemory Bytes(lenStr), lenBs - lenStr
        ChangeBytes = lenStr
    ElseIf lenBs = lenStr Then
        CopyMemoryA Bytes(0), str, lenStr
        ChangeBytes = lenStr
    Else
        CopyMemoryA Bytes(0), str, lenBs
        ChangeBytes = lenBs
    End If
End Function