modtool.bas

非常好的串口控件

Attribute VB_Name = "modTool"
'************************************************************
'    Mxtool.bas
'     -- Process PComm Lib function return value
'
'
'    History:   Date       Author         Comment
'               3/10/98     Casper         Wrote it.
'               12/08/98    Casper         Modify message.
'
'************************************************************
Option Explicit

Public Const comEvSend = 1 '发送事件。
Public Const comEvReceive = 2 ' 接收事件。
Public Const comEvCTS = 3 'clear-to-send 线变化。
Public Const comEvDSR = 4 'data-set ready 线变化。
Public Const comEvCD = 5 ' carrier detect 线变化。
Public Const comEvRing = 6 '振铃检测。
Public Const comEvEOF = 7 '文件结束。


Public Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Public Const LANG_NEUTRAL = &H0
Public Const SUBLANG_DEFAULT = &H1

Public Declare Function GetLastError Lib "kernel32" () As Long
Public Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" _
    (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, _
    ByVal dwLanguageId As Long, ByVal lpBuffer As String, _
    ByVal nSize As Long, Arguments As Long) As Long
'Private Declare Sub ZeroMemory Lib "kernel32.dll" Alias "RtlZeroMemory" (Destination As Any, ByVal Length As Long)
'Private Declare Sub CopyMemoryA Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, ByVal pSrc As String, ByVal ByteLen As Long)

Public Sub ShowSysErr(title As String, syserr As Long)
    Dim lpMsgBuf As String * 80
    Dim lang As Integer
    
    'lang = {MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT) }
    lang = SUBLANG_DEFAULT * 2 ^ 10 + LANG_NEUTRAL
    Call FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, _
        0, syserr, lang, lpMsgBuf, 80, 0)
    Call MsgBox(lpMsgBuf, vbOKOnly Or vbExclamation, title)
End Sub

Public Sub MxShowError(title As String, errcode As Long, syserr As Long)
    Dim buf As String
    
    If errcode <> SIO_WIN32FAIL Then
        Select Case errcode
        Case SIO_BADPORT
'            buf = "Port number is invalid or port is not opened in advance"
            buf = "无效端口号或者端口已经打开。"
        Case SIO_OUTCONTROL:
'            buf = "The board does not support this function"
            buf = "不支持的波特率。"
        Case SIO_NODATA:
'            buf = "No data to read"
            buf = "没有数据可以读取。"
        Case SIO_OPENFAIL:
'            buf = "No such port or port is occupied by other program"
            buf = "无此端口或者此端口被别的程序占用。"
        Case SIO_RTS_BY_HW:
'            buf = "RTS can't be set because H/W Flowctrl"
            buf = "RTS无法设置"
        Case SIO_BADPARM:
'            buf = "Bad parameter"
            buf = "错误的参数"
        Case SIO_BOARDNOTSUPPORT:
'            buf = "The board does not support this function"
            buf = "不支持的波特率。"
        Case SIO_ABORT_WRITE:
'            buf = "Write has blocked, and user abort write"
            buf = "发送数据堵塞，用户中断发送操作"
        Case SIO_WRITETIMEOUT:
'            buf = "Write timeout has happened"
            buf = "发送超时"
        Case Else
'            buf = "Unknown Error:" & errcode
            buf = "未知错误：" & errcode
        End Select
        Call MsgBox(buf, vbOKOnly Or vbExclamation, title)
    Else
        Call ShowSysErr(title, syserr)
    End If
End Sub

'Public Function ChangeBytes(ByVal str As String, Bytes() As Byte) As Boolean
'
'    '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
'
'    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
'    ElseIf lenBs = lenStr Then
'        CopyMemoryA Bytes(0), str, lenStr
'    Else
'        CopyMemoryA Bytes(0), str, lenBs
'        ChangeBytes = True
'    End If
'
'End Function