[MS ACCESS] Chia sẽ source code gởi và nhận tin nhắn SMS sử dụng VBA

Xin chào các bạn, bài viết hôm nay mình sẽ chia sẽ cho các bạn source code gởi và nhận tin nhắn SMS sử dụng DCom 3G.

Để gởi tin nhắn SMS, thì các bạn cần tìm hiểu qua tập lệnh AT Command.

Trong bài viết này, source code gởi và nhận tin nhắn mình viết bằng VBA. 

Nay mình share cho các bạn nào đang tìm hiểu có thể phát triển thêm.

Giao diện ứng dụng Form trên Microsoft Access:

1. Đầu tiên, các bạn cần tạo module bên dưới, để kết nối access với cổng COM 

Option Compare Database
Option Explicit

Global ComNum As Long           'This variable is used to store the Port number the API understand
Global ReadBytes(255) As Byte   'In this variable are stored the bytes replied from the device

'************************************************************************
'** Start of declaration of variables and Constants that the APIs need **
'************************************************************************

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

Public Const FILE_SHARE_READ = &H1
Public Const FILE_SHARE_WRITE = &H2
Public Const OPEN_EXISTING = 3
Public Const FILE_ATTRIBUTE_NORMAL = &H80

'**********************************************************************
'** End of declaration of variables and Constants that the APIs need **
'**********************************************************************


'*******************************************
'** Start of declaration of the APIs Used **
'*******************************************

Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Declare PtrSafe Function GetLastError Lib "kernel32" () As Long

Declare PtrSafe Function ReadFile Lib "kernel32" _
    (ByVal hFile As Long, _
    lpBuffer As Any, _
    ByVal nNumberOfBytesToRead As Long, _
    lpNumberOfBytesRead As Long, _
    lpOverlapped As Long) As Long
    
Declare PtrSafe Function WriteFile Lib "kernel32" _
    (ByVal hFile As Long, _
    lpBuffer As Any, _
    ByVal nNumberOfBytesToWrite As Long, _
    lpNumberOfBytesWritten As Long, _
    lpOverlapped As Long) As Long
    
Declare PtrSafe Function SetCommTimeouts Lib "kernel32" _
    (ByVal hFile As Long, _
    lpCommTimeouts As COMMTIMEOUTS) As Long
    
Declare PtrSafe Function GetCommTimeouts Lib "kernel32" _
    (ByVal hFile As Long, _
    lpCommTimeouts As COMMTIMEOUTS) As Long
    
Declare PtrSafe Function BuildCommDCB Lib "kernel32" _
    Alias "BuildCommDCBA" _
    (ByVal lpDef As String, _
    lpDCB As DCB) As Long
    
Declare PtrSafe Function SetCommState Lib "kernel32" (ByVal hCommDev As Long, lpDCB As DCB) As Long

Declare PtrSafe 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 PtrSafe Function FlushFileBuffers Lib "kernel32" (ByVal hFile As Long) As Long

'I had to replicate the fowling API CreateFile because an error
'produced by the CheckPort function that I couldn't understand

Declare PtrSafe Function CreateFile1 Lib "kernel32" _
   Alias "CreateFileA" _
  (ByVal lpFileName As String, _
   ByVal dwDesiredAccess As Long, _
   ByVal dwShareMode As Long, _
   lpSecurityAttributes As SECURITY_ATTRIBUTES, _
   ByVal dwCreationDisposition As Long, _
   ByVal dwFlagsAndAttributes As Long, _
   ByVal hTemplateFile As Long) As Long
   
'*****************************************
'** End of declaration of the APIs Used **
'*****************************************

Function Close_Port()
    Close_Port = CloseHandle(ComNum)
End Function

Function FlushComm()
    FlushFileBuffers (ComNum)
End Function

Function Port_Initialization(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
    
    ' Open the comport for read/write access (&HC0000000).
    ' Must specify existing file (3).
    ComNum = CreateFile(ComNumber, &HC0000000, 0, 0&, &H3, 0, 0)
    
    If ComNum = -1 Then
        MsgBox "Com Port " & ComNumber & " not available.", 48
        Port_Initialization = False
        Exit Function
    End If
    
    'Setup Time Outs for comport
    
    CtimeOut.ReadIntervalTimeout = 20
    CtimeOut.ReadTotalTimeoutConstant = 1
    CtimeOut.ReadTotalTimeoutMultiplier = 1
    CtimeOut.WriteTotalTimeoutConstant = 10
    CtimeOut.WriteTotalTimeoutMultiplier = 1
    retval = SetCommTimeouts(ComNum, CtimeOut)
    
    If retval = -1 Then
        retval = GetLastError()
        MsgBox "Unable to set timeouts for port " & ComNumber & " Error: " & retval
        retval = CloseHandle(ComNum)
        Port_Initialization = False
        Exit Function
    End If
    
    retval = BuildCommDCB(Comsettings, BarDCB)
    
    If retval = -1 Then
        retval = GetLastError()
        MsgBox "Unable to build Comm DCB " & Comsettings & " Error: " & retval
        retval = CloseHandle(ComNum)
        Port_Initialization = False
        Exit Function
    End If
    
    retval = SetCommState(ComNum, BarDCB)
    
    If retval = -1 Then
        retval = GetLastError()
        MsgBox "Unable to set Comm DCB " & Comsettings & " Error: " & retval
        retval = CloseHandle(ComNum)
        Port_Initialization = False
        Exit Function
    End If
    
    Port_Initialization = True
handelinitcom:
    Exit Function
End Function

Function Read_Port() 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, ReadBytes(0), 255, RetBytes, 0)
    ReadStr = ""
    
    If (RetBytes > 0) Then
        For I = 0 To RetBytes - 1
            ReadStr = ReadStr & Chr(ReadBytes(I))
        Next I
    Else
        FlushComm
    End If
    
    'Return the bytes replied from serial port
    Read_Port = ReadStr
    
handelpurecom:
    Exit Function
End Function

Function Write_Port(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
        Write_Port Left$(COMString, 255)
        Write_Port Right$(COMString, Len(COMString) - 255)
        Exit Function
    End If
    
    For LenVal = 0 To Len(COMString) - 1
        ReadBytes(LenVal) = Asc(Mid$(COMString, LenVal + 1, 1))
    Next LenVal
    
    ReadBytes(LenVal) = 0
    retval = WriteFile(ComNum, ReadBytes(0), Len(COMString), RetBytes, ByVal CLng(0))
    FlushComm
    Write_Port = RetBytes
    
handelwritelpt:
    Exit Function
End Function


Function CheckPort(Port As Long) As Boolean
    Dim hPort As Long
   
  
    Dim sPort As String              'In this variable is stored the port's number
    Dim sa As SECURITY_ATTRIBUTES
  
    If Val(Port) > 0 Then
        sPort = "\.COM" & Port      'The port number should be something like "\.COM1"
     
        'The API that opens the port
        'If the CreateFile API succeeds then it close the port again
     
        hPort = CreateFile1(sPort, _
            0, _
            FILE_SHARE_READ Or FILE_SHARE_WRITE, _
            sa, _
            OPEN_EXISTING, _
            FILE_ATTRIBUTE_NORMAL, 0)
                         
        If hPort Then CloseHandle hPort
      
            CheckPort = hPort > 0
       
        Else
            CheckPort = False
    End If
   
End Function

2. Source code cho các chức năng gởi, nhận, gọi và check money 

Option Compare Database
Dim PortsFound As Integer
Dim PortConfig As String
Dim PortNumber As String
Public ONNER As Boolean
Public RECEIVE_MESSAGE As Boolean
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Function GetPorts(list As ListBox) As Long
    
    
    Dim Port As Long
    For Port = 1 To 100
                       
        If CheckPort(Port) Then
            list.AddItem "COM" & Port & "  available"
            PortsFound = PortsFound + 1
        End If
      
    Next
    NumOfPorts.Caption = PortsFound
End Function


Private Sub btn_ReadMessage_Click()
   'Write_Port ("AT+CMGL=" & Chr(34) & "REC UNREAD" & Chr(34))
   Write_Port ("ATD 0933913122;")
    Write_Port (Chr$(13))
  
End Sub

Private Sub btn_call_Click()
    Write_Port ("ATD " & txt_phone.Value & ";")
    Write_Port (Chr$(13))
End Sub

Private Sub btn_ReceiveMessage_Click()
    If btn_ReceiveMessage.Caption = "OPEN RECEIVE" Then
        RECEIVE_MESSAGE = True
        btn_ReceiveMessage.Caption = "CLOSE RECEIVE"
    Else
        RECEIVE_MESSAGE = False
        btn_ReceiveMessage.Caption = "OPEN RECEIVE"
    End If
    
End Sub

Private Sub CMD_checkmoney_Click()
 Write_Port ("AT+CUSD=1," & Chr(34) & "*101#" & Chr(34))
    Write_Port (Chr$(13))
End Sub

Private Sub CmdClose_Click()
    
    Call Close_Port
    ONNER = True
        TxtCommand.SetFocus
    TxtCommand.SetFocus

    CmdClose.Enabled = False
    CmdOpen.Enabled = True
    CmdGet.Enabled = True
    LstPorts.Enabled = True
    cboBaubRate.Enabled = True
    cboDataBits.Enabled = True
    cboParity.Enabled = True
    cboStopBits.Enabled = True

End Sub

Private Sub CmdGet_Click()
      
    On Error Resume Next
    For I = 1 To 20000
    LstPorts.RemoveItem (I)
    Next I
    LstPorts.Requery
    PortsFound = 0
    Call GetPorts(LstPorts)
    CmdOpen.Enabled = True
End Sub

Private Sub CmdOpen_Click()
    PortConfig = cboBaubRate.Value & _
        "," & cboParity.Value & _
        "," & cboDataBits.Value & _
        "," & cboStopBits.Value
    
    If Me.LstPorts = "" Then
        MsgBox "Please Select a Port first"
        Exit Sub
    End If
    
   
    PortNumber = "\." & Mid(Me.LstPorts, 1, (Len(Me.LstPorts) - 11))
    
    
    If Not Port_Initialization(PortNumber, PortConfig) Then
        MsgBox PortNumber & " Not available!"
        Exit Sub
    End If
    ONNER = True
    TxtCommand.SetFocus
    CmdClose.Enabled = True
    CmdOpen.Enabled = False
    CmdGet.Enabled = False
    LstPorts.Enabled = False
    cboBaubRate.Enabled = False
    cboDataBits.Enabled = False
    cboParity.Enabled = False
    cboStopBits.Enabled = False

End Sub

Private Sub CmdSend_Click()

    If Write_Port(Me.TxtCommand) <> Len(Me.TxtCommand) Then
        MsgBox "Error writing to comm's"
        Exit Sub
    End If
    
    Write_Port (Chr$(13))
                            
                           
    Me.TxtCommand = ""

End Sub

Private Sub Command3_Click()
    'LstPorts.Clear
    PortsFound = 0
    Call GetPorts(LstPorts)
    CmdOpen.Enabled = True

End Sub

Private Sub ReadMessage()
    Write_Port ("AT+CMGL=" & Chr(34) & "REC UNREAD" & Chr(34))
    Write_Port (Chr$(13))
    Dim Reply As String
    Reply = Read_Port()
    
    MsgBox Reply
End Sub

Private Sub Command31_Click()
    Write_Port ("AT+CMGF=1") 'chedotext, pdu
    Write_Port (Chr$(13))
    Write_Port ("AT+CMGS=" & Chr(34) & txt_phone.Value & Chr(34))
    Write_Port (Chr$(13))
    Sleep 1000
    Write_Port (txt_message.Value & Chr(26))
    Write_Port (Chr$(13))
    Dim Reply As String
    Reply = Read_Port()
    
    MsgBox Reply
    
End Sub

Private Sub Command32_Click()
txt_phone.Value = Null
txt_message.Value = Null
TxtReply.Value = Null
TxtCommand.Value = Null
End Sub

Private Sub Form_Open(Cancel As Integer)
ONNER = False
RECEIVE_MESSAGE = False
Page34.SetFocus
Call CmdClose_Click
    cboBaubRate.Value = "9600"
    cboDataBits.Value = "8"
    cboParity.Value = "n"
    cboStopBits.Value = "1"

End Sub

Private Sub Form_Timer()
           
    If ONNER = False Then Exit Sub
    If RECEIVE_MESSAGE = True Then
      Write_Port ("AT+CMGL=" & Chr(34) & "REC UNREAD" & Chr(34))
      Write_Port (Chr$(13))
      Dim str_receive_message As String
        str_receive_message = Read_Port()
        If str_receive_message = "" Then Exit Sub
        Dim posOf_A As Integer
    
       posOf_A = InStr(1, str_receive_message, "UNREAD", vbTextCompare)
    If posOf_A > 0 Then
     Debug.Print str_receive_message
        txt_receiveMessage.Value = str_receive_message & txt_receiveMessage.Value
        FlushComm
    End If
        
        
       
     
       
    End If
     Dim Reply As String
        Reply = Read_Port()
        If Reply = "" Then Exit Sub
        Debug.Print Reply
        TxtReply.Value = TxtReply.Value & Reply
        FlushComm
    
   

End Sub

Private Sub Form_Unload(Cancel As Integer)
Call Close_Port
End Sub

HAPPY CODING 

DOWNLOAD SOURCE