serialport.bas

自己编写的通过串口发送短信的源代码

Attribute VB_Name = "SerialPort"
Option Explicit

Global ComNum As Long
Global bRead(255) As Byte

Public Const GENERIC_READ = &H80000000
Public Const GENERIC_WRITE = &H40000000
Public Const OPEN_EXISTING = 3

Type COMSTAT
        fCtsHold As Long
        fDsrHold As Long
        fRlsdHold As Long
        fXoffHold As Long
        fXoffSent As Long
        fEof As Long
        fTxim As Long
        fReserved As Long
        cbInQue As Long
        cbOutQue As Long
End Type

Type COMMTIMEOUTS
        ReadIntervalTimeout As Long
        ReadTotalTimeoutMultiplier As Long
        ReadTotalTimeoutConstant As Long
        WriteTotalTimeoutMultiplier As Long
        WriteTotalTimeoutConstant As Long
End Type

Type DCB
        DCBlength As Long
        BaudRate As Long
        fBinary As Long
        fParity As Long
        fOutxCtsFlow As Long
        fOutxDsrFlow As Long
        fDtrControl As Long
        fDsrSensitivity As Long
        fTXContinueOnXoff As Long
        fOutX As Long
        fInX As Long
        fErrorChar As Long
        fNull As Long
        fRtsControl As Long
        fAbortOnError As Long
        fDummy2 As Long
        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
End Type

Type OVERLAPPED
        Internal As Long
        InternalHigh As Long
        offset As Long
        OffsetHigh As Long
        hEvent As Long
End Type
Type SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescriptor As Long
        bInheritHandle As Long
End Type

Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Declare Function GetLastError Lib "kernel32" () As Long
Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Long) As Long
Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Long) As Long
Declare Function SetCommTimeouts Lib "kernel32" (ByVal hFile As Long, lpCommTimeouts As COMMTIMEOUTS) As Long
Declare Function GetCommTimeouts Lib "kernel32" (ByVal hFile As Long, lpCommTimeouts As COMMTIMEOUTS) As Long
Declare Function BuildCommDCB Lib "kernel32" Alias "BuildCommDCBA" (ByVal lpDef As String, lpDCB As DCB) As Long
Declare Function SetCommState Lib "kernel32" (ByVal hCommDev As Long, lpDCB As DCB) As Long
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
Declare Function FlushFileBuffers Lib "kernel32" (ByVal hFile As Long) As Long


Function fin_com()
    fin_com = CloseHandle(ComNum)
End Function

'关闭端口
Function FlushComm()
    FlushFileBuffers (ComNum)
End Function

'初始化端口
Public Function Init_Com(ComNumber As String, ComSettings As String) As Boolean
On Error GoTo handelinitcom
    Dim ComSetup As DCB, Answer, Stat As COMSTAT, RetBytes As Long
    Dim RetVal As Long
    Dim CtimeOut As COMMTIMEOUTS, BarDCB As DCB
    ' 打开通讯口读/写(&HC0000000).
    ' 必须指定存在的文件 (3).
    ComNum = CreateFile(ComNumber, &HC0000000, 0, 0&, &H3, 0, 0)
    If ComNum = -1 Then
        MsgBox "端口 " & ComNumber & "无效. 请设置正确.", 48
        Init_Com = False
        Exit Function
    End If
    '超时
    CtimeOut.ReadIntervalTimeout = 200
    CtimeOut.ReadTotalTimeoutConstant = 1
    CtimeOut.ReadTotalTimeoutMultiplier = 500
    CtimeOut.WriteTotalTimeoutConstant = 10
    CtimeOut.WriteTotalTimeoutMultiplier = 100
    RetVal = SetCommTimeouts(ComNum, CtimeOut)
    If RetVal = -1 Then
        RetVal = GetLastError()
        MsgBox "端口超时设定无效 " & ComNumber & " 错误: " & RetVal
        RetVal = CloseHandle(ComNum)
        Init_Com = False
        Exit Function
    End If
    RetVal = BuildCommDCB(ComSettings, BarDCB)
    If RetVal = -1 Then
        RetVal = GetLastError()
        MsgBox "无效设备 DCB 块 " & ComSettings & " 错误: " & RetVal
        RetVal = CloseHandle(ComNum)
        Init_Com = False
        Exit Function
    End If
    RetVal = SetCommState(ComNum, BarDCB)
    If RetVal = -1 Then
        RetVal = GetLastError()
        MsgBox "无效设备 DCB 块 " & ComSettings & " 错误: " & RetVal
        RetVal = CloseHandle(ComNum)
        Init_Com = False
        Exit Function
    End If
    
    Init_Com = True
handelinitcom:
    Exit Function
End Function

Public Function OpenThePort(cPort As String, cBaud As String, cParity As String, cData As String, tStops As String) As Boolean
    Dim lResult As Long
    Dim lHandle As Long
    Dim DCB_COMM As DCB
    Dim cDCBConfig As String
    lHandle = CreateFile(cPort, GENERIC_READ Or GENERIC_WRITE, 0, 0&, OPEN_EXISTING, 0, 0)
    If lHandle = -1 Then '打开串口失败
        OpenThePort = False
        MsgBox "串口可能正被其他应用程序占用！"
        lResult = CloseHandle(lHandle)   '先关闭串口后再打开
        If lResult = 0 Then
            OpenThePort = False
            Exit Function
        End If
    End If
    DCB_COMM.BaudRate = 19200 '设置DCB
    DCB_COMM.Parity = 0
    DCB_COMM.ByteSize = 8
    DCB_COMM.StopBits = 1
    lResult = BuildCommDCB(cDCBConfig, DCB_COMM) '按用户设定配置一个DCB结构
    If lResult = 0 Then
        OpenThePort = False
        MsgBox "无法建立DCB设备控制块"
        Exit Function
    End If
    lResult = SetCommState(lHandle, DCB_COMM)  '实际设置一个串口的DCB
    If lResult = 0 Then
        OpenThePort = False
        MsgBox "无法建立DCB设备控制块"
        Exit Function
    End If
    OpenThePort = True
End Function
'从串口读取数据
Function ReadCommPure() As String
On Error GoTo handelpurecom
    Dim RetBytes As Long, i As Integer, ReadStr As String, RetVal As Long

    RetVal = ReadFile(ComNum, bRead(0), 255, RetBytes, 0)
    ReadStr = ""
    If (RetBytes > 0) Then
        For i = 0 To RetBytes - 1
            ReadStr = ReadStr & Chr(bRead(i))
        Next i
    Else
        FlushComm
    End If
    ReadCommPure = ReadStr
handelpurecom:
    Exit Function
End Function

'向串口写数据
Function WriteCOM32(ComString As String) As Integer
On Error GoTo handelWritelpt
    Dim RetBytes As Long, LenVal As Long
    Dim RetVal As Long
    
    If Len(ComString) > 255 Then
        WriteCOM32 Left$(ComString, 255)
        WriteCOM32 Right$(ComString, Len(ComString) - 255)
        Exit Function
    End If
    
    For LenVal = 0 To Len(ComString) - 1
        bRead(LenVal) = Asc(Mid$(ComString, LenVal + 1, 1))
    Next LenVal

    RetVal = WriteFile(ComNum, bRead(0), Len(ComString), RetBytes, 0)
    
    WriteCOM32 = RetBytes
handelWritelpt:
    Exit Function
End Function