sccomm.ctl

非常好的串口控件

VERSION 5.00
Begin VB.UserControl scCOMM 
   ClientHeight    =   480
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   495
   InvisibleAtRuntime=   -1  'True
   Picture         =   "scCOMM.ctx":0000
   PropertyPages   =   "scCOMM.ctx":0442
   ScaleHeight     =   480
   ScaleWidth      =   495
   ToolboxBitmap   =   "scCOMM.ctx":044D
   Begin VB.Timer tmrRead 
      Left            =   120
      Top             =   120
   End
End
Attribute VB_Name = "scCOMM"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Ext_KEY = "PropPageWizardRun" ,"Yes"
Option Explicit

Private Declare Sub ZeroMemory Lib "kernel32.dll" Alias "RtlZeroMemory" (Destination As Any, ByVal Length As Long)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Private Declare Sub CopyMemoryA Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, ByVal pSrc As String, ByVal ByteLen As Long)


'================================================
Private Type COMMDATA
    port As Long
    
    BaudRate As Integer
    Parity As Integer
    ByteSize As Integer
    StopBits As Integer
    
    ibaudrate As Integer
    iparity As Integer
    ibytesize As Integer
    istopbits As Integer
    
    Hw As Integer
    Sw As Integer
    Dtr As Integer
    Rts As Integer
End Type

Private mCommData As COMMDATA
Private mbOpened As Boolean
Private msDataBuf As String
'Private msDataBuf() As String

Private mBaudTable(0 To 19) As Integer
Private mParityTable(0 To 4) As Integer
Private mByteSizeTable(0 To 3) As Integer
Private mStopBitsTable(0 To 1) As Integer

Private mstrBaudTable(0 To 19) As String
Private mstrParityTable(0 To 4) As String
Private mstrByteSizeTable(0 To 3) As String
Private mstrStopBitsTable(0 To 1) As String
'================================================

'缺省属性值:
Const m_def_CommEvent = 0
Const m_def_Port = 0
Const m_def_BaudRate = 12
Const m_def_Parity = 0
Const m_def_DataBits = 3
Const m_def_StopBits = 0
Const m_def_DTR = 1
Const m_def_RTS = 1
Const m_def_FlowControl = 0
'属性变量:
Dim m_CommEvent As Integer
Dim m_Port As Integer
Dim m_BaudRate As Integer
Dim m_Parity As Integer
Dim m_DataBits As Integer
Dim m_StopBits As Integer
Dim m_DTR As Integer
Dim m_RTS As Integer
Dim m_FlowControl As Integer
'事件声明:
Event OnComm()




'注意！不要删除或修改下列被注释的行！
'MemberInfo=7,0,0,1
Public Property Get port() As Integer
Attribute port.VB_Description = "端口号"
Attribute port.VB_ProcData.VB_Invoke_Property = "通用"
    port = m_Port
End Property

Public Property Let port(ByVal New_Port As Integer)
    If Not fb_LetProperty("port", New_Port, 0, 254) Then Exit Property
    m_Port = New_Port
    mCommData.port = New_Port + 1
    PropertyChanged "Port"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=7,0,0,9600
Public Property Get BaudRate() As Integer
Attribute BaudRate.VB_Description = "波特率"
Attribute BaudRate.VB_ProcData.VB_Invoke_Property = "通用"
    BaudRate = m_BaudRate
End Property

Public Property Let BaudRate(ByVal New_BaudRate As Integer)
    If Not fb_LetProperty("BaudRate", New_BaudRate, 0, 19) Then Exit Property
    m_BaudRate = New_BaudRate
    mCommData.BaudRate = mBaudTable(New_BaudRate)
    PropertyChanged "BaudRate"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=7,0,0,0
Public Property Get Parity() As Integer
Attribute Parity.VB_Description = "校验位"
Attribute Parity.VB_ProcData.VB_Invoke_Property = "通用"
    Parity = m_Parity
End Property

Public Property Let Parity(ByVal New_Parity As Integer)
    If Not fb_LetProperty("Parity", New_Parity, 0, 4) Then Exit Property
    m_Parity = New_Parity
    mCommData.Parity = mParityTable(New_Parity)
    PropertyChanged "Parity"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=7,0,0,8
Public Property Get DataBits() As Integer
Attribute DataBits.VB_Description = "数据位"
Attribute DataBits.VB_ProcData.VB_Invoke_Property = "通用"
    DataBits = m_DataBits
End Property

Public Property Let DataBits(ByVal New_DataBits As Integer)
    If Not fb_LetProperty("DataBits", New_DataBits, 0, 3) Then Exit Property
    m_DataBits = New_DataBits
    mCommData.ByteSize = mByteSizeTable(New_DataBits)
    PropertyChanged "DataBits"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=7,0,0,1
Public Property Get StopBits() As Integer
Attribute StopBits.VB_Description = "停止位"
Attribute StopBits.VB_ProcData.VB_Invoke_Property = "通用"
    StopBits = m_StopBits
End Property

Public Property Let StopBits(ByVal New_StopBits As Integer)
    If Not fb_LetProperty("StopBits", New_StopBits, 0, 1) Then Exit Property
    m_StopBits = New_StopBits
    mCommData.StopBits = mStopBitsTable(New_StopBits)
    PropertyChanged "StopBits"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=7,0,0,0
Public Property Get Dtr() As Integer
Attribute Dtr.VB_Description = "DTR有效"
Attribute Dtr.VB_ProcData.VB_Invoke_Property = "通用"
    Dtr = m_DTR
End Property

Public Property Let Dtr(ByVal New_DTR As Integer)
    If New_DTR Then
        New_DTR = 1
    Else
        New_DTR = 0
    End If
    m_DTR = New_DTR
    mCommData.Dtr = New_DTR
    PropertyChanged "DTR"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=7,0,0,0
Public Property Get Rts() As Integer
Attribute Rts.VB_Description = "RTS有效"
Attribute Rts.VB_ProcData.VB_Invoke_Property = "通用"
    Rts = m_RTS
End Property

Public Property Let Rts(ByVal New_RTS As Integer)
    If New_RTS Then
        New_RTS = 1
    Else
        New_RTS = 0
    End If
    m_RTS = New_RTS
    mCommData.Rts = New_RTS
    PropertyChanged "RTS"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=0
Public Function PortOpen() As Boolean
    Dim ret As Long
    Dim syserr As Long
    PortOpen = False
    ret = sio_open(mCommData.port)
    If ret <> SIO_OK Then
        Call MxShowError("sio_open", ret, GetLastError())
        sio_close (mCommData.port)
        Exit Function
    End If
    
    If PortSet() = False Then
        sio_close (mCommData.port)
        Exit Function
    End If
    
    PortOpen = True
    mbOpened = True
    tmrRead.Interval = 50
    tmrRead.Enabled = True
End Function

'注意！不要删除或修改下列被注释的行！
'MemberInfo=0
Public Function PortClose() As Boolean
    tmrRead.Enabled = False
    tmrRead.Interval = 0
    sio_close (mCommData.port)
    mbOpened = False
End Function

Public Function PortOpened() As Boolean
    PortOpened = mbOpened
End Function

Public Sub ClearRevBuf()
    msDataBuf = ""
End Sub

Public Function ReadData() As String
    ReadData = msDataBuf
    msDataBuf = ""
End Function

Public Sub SendDataByBytes(ByRef sDataBytes() As Byte)
    If Not mbOpened Then Err.Raise &H2 + 513, , "端口未打开。"
    Dim i As Integer
    For i = LBound(sDataBytes) To UBound(sDataBytes)
        Debug.Print Hex(sDataBytes(i)) & " ";
    Next i
    Call sio_write(mCommData.port, sDataBytes(LBound(sDataBytes)), UBound(sDataBytes) - LBound(sDataBytes) + 1)
End Sub

Public Sub SendData(ByVal sData As String)
    Dim buf(1024) As Byte
    If Not mbOpened Then Err.Raise &H2 + 513, , "端口未打开。"
    ChangeBytes sData, buf
    Dim i As Integer
    For i = 0 To 40
        Debug.Print Hex(buf(i)) & " ";
    Next i
    Call sio_write(mCommData.port, buf(0), UBound(buf) + 1)
End Sub

'注意！不要删除或修改下列被注释的行！
'MemberInfo=7,0,0,0
Public Property Get FlowControl() As Integer
Attribute FlowControl.VB_Description = "流控制"
Attribute FlowControl.VB_ProcData.VB_Invoke_Property = "通用"
    FlowControl = m_FlowControl
End Property

Public Property Let FlowControl(ByVal New_FlowControl As Integer)
    If Not fb_LetProperty("FlowControl", New_FlowControl, 0, 2) Then Exit Property
    m_FlowControl = New_FlowControl
    Select Case New_FlowControl
        Case 0
            mCommData.Hw = 0
            mCommData.Sw = 0
        Case 1
            mCommData.Sw = 1
            mCommData.Hw = 0
        Case 2
            mCommData.Sw = 0
            mCommData.Hw = 1
    End Select
    PropertyChanged "FlowControl"
End Property

Private Sub tmrRead_Timer()
'     Dim rlen As Long
'    Dim buf(0 To 511) As Byte
'    Dim tmp() As Byte
'    Dim nI As Integer
'    rlen = sio_read(mCommData.port, buf(0), 512)
'    If rlen > 0 Then
'        ReDim tmp(0 To rlen - 1) As Byte
'        For nI = 0 To rlen - 1
'            tmp(nI) = buf(nI)
'        Next nI
'        msDataBuf = msDataBuf & StrConv(tmp, vbUnicode)
'        m_CommEvent = comEvReceive
'        RaiseEvent OnComm
'    End If
    
    
    Dim rlen As Long
    Dim buf(0 To 511) As Byte
    Dim tmp() As Byte
    Dim sUnicode() As String

    Dim nI As Integer