mcomm32api.bas

VB编写的手机短信源码

Attribute VB_Name = "mComm32API"
'*/-------------------------------------------------------------
'*/模 块 名:mComm32API.bas
'*/功    能:API串口打开、关闭、写数据、读数据等函数
'*/-------------------------------------------------------------

Option Explicit

'定义端口
Public 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

'定义超时溢出
Public Type COMMTimeOuts
 ReadIntervalTimeout As Long
 ReadTotalTimeoutMultiplier As Long
 ReadTotalTimeoutConstant As Long
 WriteTotalTimeoutMultiplier As Long
 WriteTotalTimeoutConstant As Long
End Type

'定义DCB块
Public 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

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

'端口全局变量
Public ComNum As Long
Public bRead(255) As Byte
Public statuGSM As Boolean

'*/-------------------------------------------------------------
'*/函 数 名:StartCOM32
'*/功    能:打开指定端口
'*/返 回 值:Long
'*/         1---串口号无效;
'*/         2---串口连接超时;
'*/         3---波特率设置无效(DCB无法建立);
'*/         4---波特率设置无效(DCB无法设置);
'*/         5---发送AT指令不响应(端口打开不成功);
'*/参    数:ComNumber      指定端口号
'*/         Comsettings    端口参数，波特率，数据位，停止位，奇偶校验
'*/-------------------------------------------------------------

Public Function StartCOM32(ComNumber As String, Comsettings As String) As Long
    On Error GoTo HandelInitCOM
    Dim ComSetup As DCB, BarDCB As DCB
    Dim Answer, Stat As COMStat
    Dim CtimeOut As COMMTimeOuts
    Dim retval As Long, RetBytes As Long
    
    ComNum = CreateFile(ComNumber, &HC0000000, 0, 0&, &H3, 0, 0)
    If ComNum = -1 Then
        StartCOM32 = 1
        Exit Function
    End If
    CtimeOut.ReadIntervalTimeout = 2
    CtimeOut.ReadTotalTimeoutConstant = 1
    CtimeOut.ReadTotalTimeoutMultiplier = 1
    CtimeOut.WriteTotalTimeoutConstant = 10
    CtimeOut.WriteTotalTimeoutMultiplier = 1
    retval = SetCommTimeouts(ComNum, CtimeOut)
    If retval = -1 Then
        retval = GetLastError()
        retval = CloseHandle(ComNum)
        StartCOM32 = 2
        Exit Function
    End If
    retval = BuildCommDCB(Comsettings, BarDCB)
    If retval = -1 Then
        retval = GetLastError()
        retval = CloseHandle(ComNum)
        StartCOM32 = 3
        Exit Function
    End If
    retval = SetCommState(ComNum, BarDCB)
    If retval = -1 Then
        retval = GetLastError()
        retval = CloseHandle(ComNum)
        StartCOM32 = 4
        Exit Function
    End If
    If InStr(SendAT("AT", 5), "OK") > 0 Then
       If inDevice Then StartCOM32 = 0
    Else
       If InStr(SendAT("AT", 5), "OK") > 0 Then
          If inDevice Then StartCOM32 = 0
       Else
          StartCOM32 = -1
      End If
    End If
HandelInitCOM:
    Exit Function
End Function

'*/-------------------------------------------------------------
'*/函 数 名:ReadCOM32
'*/功    能:读取端口返回的数据
'*/返 回 值:字符
'*/-------------------------------------------------------------
Public Function ReadCOM32() As String
    On Error GoTo HandelPureCOM
    Dim RetBytes As Long, i As Integer, ReadStr As String, retval As Long
    Dim CheckTotal As Integer, CheckDigitLC As Integer
    
    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
        Call FlushCOM32
    End If
    ReadCOM32 = ReadStr
HandelPureCOM:
    Exit Function
End Function

'*/-------------------------------------------------------------
'*/函 数 名:WriteCOM32
'*/功    能:向指定端口写入数据
'*/返 回 值:整型
'*/参    数:COMString   向端口发送的指定字符
'*/-------------------------------------------------------------
Public Function WriteCOM32(COMString As String) As Integer
    On Error GoTo HandelWriteLPT
    Dim RetBytes As Long, LenVal As Long, 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

'*/-------------------------------------------------------------
'*/函 数 名:CloseCOM32
'*/功    能:关闭指定端口
'*/-------------------------------------------------------------
Public Function CloseCOM32()
    CloseCOM32 = CloseHandle(ComNum)
End Function

'*/-------------------------------------------------------------
'*/函 数 名:FlushCOM32
'*/功    能:关闭指定端口数据栈和清除缓冲区
'*/-------------------------------------------------------------
Public Function FlushCOM32()
    Call FlushFileBuffers(ComNum)
End Function

'*/-------------------------------------------------------------
'*/函 数 名:SendAT
'*/功    能:发送AT指令函数
'*/返 回 值:字符
'*/参    数:sAT          AT指令字符 不带回车，程序自动加入
'*/         DeleyTime    延时值，在某些返回值需要等待，默认为5,
'*/                      读取短信时要加大,如20
'*/-------------------------------------------------------------
Public Function SendAT(sAT As String, DeleyTime As Integer) As String
    Dim tTimeOut As Long, DataCOM32 As String
    Call WriteCOM32(sAT & vbCr)
    Pause 0.1   '写入时延时
    DataCOM32 = DataCOM32 & ReadCOM32()
    Pause 0.1   '读取延时
    Debug.Print DataCOM32
    tTimeOut = Timer
    DoEvents
    If InStr(DataCOM32, "ERROR") = 0 Then
      Do While Not InStr(DataCOM32, "OK") > 0
        DataCOM32 = DataCOM32 & ReadCOM32()
        If Timer > tTimeOut + DeleyTime Then
          DataCOM32 = "超时!" & vbCrLf
          Exit Do
        End If
      Loop
    End If
    Call FlushCOM32
    SendAT = DataCOM32
End Function

'*/-------------------------------------------------------------
'*/过 程 名:Pause
'*/功    能:暂停函数，延时用
'*/返 回 值:无
'*/参    数:Dauer 延时值
'*/-------------------------------------------------------------
Sub Pause(Dauer)
    Dim Start As Long
    Start = Timer
    Do While Timer < Start + Dauer
        DoEvents
    Loop
End Sub