Asynchronous Open and Close of COM port

[Dave Sell]

OK Here is an Asynchronous way to do it. I did not put the Class in a DLL or EXE. Just inside the project which may be the best option for you after all

I wrote alot of this stuff years ago, but I just tested the project and it all works. Add the MODs, CLS, and the BAS files to your project.

Option Explicit
'
' frm_COM_Test.frm
'
Private WithEvents m_COMPort As cls_COMPort
'
 
Private Sub Form_Load()
    Set m_COMPort = New cls_COMPort
End Sub
 
Private Sub cmd_OpenPort_Click()
    If (Not m_COMPort.OpenPort) Then
        Me.Caption = "Open Port Unsuccessful"
    Else
        Me.Caption = "Open Port Successful"
    End If
End Sub
 
Private Sub cmd_ClosePort_Click()
    '
    Dim intReturn As Integer
    intReturn = m_COMPort.ClosePort
    '
    If Not (intReturn = 0) Then
        Me.Caption = "Can't Close Port: " & intReturn
    Else
        Me.Caption = "Close Port Successful"
    End If
    '
End Sub
 
Private Sub cmd_OpenAsync_Click()
    m_COMPort.OpenPort_Async
End Sub
 
Private Sub cmd_CloseAsync_Click()
    m_COMPort.ClosePort_Async
End Sub
 
Private Sub m_COMPort_PortCloseDone(intSuccessful As Integer)
    '
    If Not (intSuccessful = 0) Then
        Me.Caption = "Can't Close Port: " & intSuccessful
    Else
        Me.Caption = "Close Port Successful"
    End If
    '
End Sub
 
Private Sub m_COMPort_PortOpenDone(blnSuccessful As Boolean)
    If (Not blnSuccessful) Then
        Me.Caption = "Open Port Unsuccessful"
    Else
        Me.Caption = "Open Port Successful"
    End If
End Sub

Option Explicit
'
' VB Module: mod_ComTest.bas
'
Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" _
    (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, _
    ByVal dwShareMode As Long, lpSecurityAttributes As Any, _
    ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, _
    ByVal hTemplateFile As Long) As Long
'
'// This is the declaration to close the COM port
Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
'

Option Explicit
'
' VB Module: modTimers.bas
'
Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
'
Private mcolItems   As Collection
'
 
Public Sub AddTimer(ByRef pobjTimer As APITimer, ByVal plngInterval As Long)
    If mcolItems Is Nothing Then
        Set mcolItems = New Collection
    End If
    pobjTimer.ID = SetTimer(0, 0, plngInterval, AddressOf Timer_CBK)
    mcolItems.Add ObjPtr(pobjTimer), pobjTimer.ID & "K"
End Sub
 
Public Sub RemoveTimer(ByRef pobjTimer As APITimer)
On Error GoTo ErrHandler
    mcolItems.Remove pobjTimer.ID & "K"
    KillTimer 0, pobjTimer.ID
    pobjTimer.ID = 0
    If mcolItems.Count = 0 Then
        Set mcolItems = Nothing
    End If
    Exit Sub
ErrHandler:
    
End Sub
 
Public Sub Timer_CBK(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal SysTime As Long)
Dim lngPointer  As Long
Dim objTimer    As APITimer
On Error GoTo ErrHandler
    lngPointer = mcolItems.Item(idEvent & "K")
    Set objTimer = PtrObj(lngPointer)
    objTimer.RaiseTimerEvent
    Set objTimer = Nothing
    Exit Sub
ErrHandler:
 
End Sub
 
Private Function PtrObj(ByVal Pointer As Long) As Object
Dim objObject   As Object
    CopyMemory objObject, Pointer, 4&
    Set PtrObj = objObject
    CopyMemory objObject, 0&, 4&
End Function

Option Explicit
'
' <APITimer.cls>
'
' References:
'
'   - modTimers.bas
'
'
Public Event Refresh()
'
Private mlngTimerID As Long
'
 
Friend Property Let ID(ByVal plngValue As Long)
    mlngTimerID = plngValue
End Property
 
Friend Property Get ID() As Long
    ID = mlngTimerID
End Property
 
Public Sub StartTimer(ByVal Interval As Long)
    If mlngTimerID = 0 Then
        AddTimer Me, Interval
    End If
End Sub
 
Public Sub StopTimer()
    If mlngTimerID > 0 Then
        RemoveTimer Me
    End If
End Sub
 
Private Sub Class_Terminate()
    StopTimer
End Sub
 
Friend Sub RaiseTimerEvent()
    RaiseEvent Refresh
End Sub

Option Explicit
'
' Class: cls_COMPort.cls
'
Public Event PortOpenDone(blnSuccessful As Boolean)
Public Event PortCloseDone(intSuccessful As Integer)
'
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const FILE_FLAG_OVERLAPPED = &H40000000
Private Const OPEN_EXISTING = 3
'
Private m_lngFileHandle As Long
'
Private WithEvents m_OpenTimer As CountDownTimer
Private WithEvents m_CloseTimer As CountDownTimer
'
 
Public Sub OpenPort_Async()
    '
    ' Asynchronous way to Open the COM port
    '
    Set m_OpenTimer = New CountDownTimer
    m_OpenTimer.Interval = 100
    m_OpenTimer.Increment
End Sub
 
Public Sub ClosePort_Async()
    '
    ' Asynchronous way to Close the COM port
    '
    Set m_CloseTimer = New CountDownTimer
    m_CloseTimer.Interval = 100
    m_CloseTimer.Increment
End Sub
 
Private Sub m_CloseTimer_Finsihed()
    '
    Dim intReturn As Integer
    '
    intReturn = ClosePort
    RaiseEvent PortCloseDone(intReturn)
    '
End Sub
 
Private Sub m_OpenTimer_Finsihed()
    '
    Dim blnReturn As Boolean
    '
    blnReturn = OpenPort
    RaiseEvent PortOpenDone(blnReturn)
    '
End Sub
 
Public Function OpenPort() As Boolean
    '
    ' Synchronous way to Open the COM port
    '
    m_lngFileHandle = CreateFile("\\.\COM1", GENERIC_READ Or GENERIC_WRITE, 0, ByVal 0&, OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0)
    '
    If m_lngFileHandle > 0 Then
        OpenPort = True
    End If
    '
End Function
 
Public Function ClosePort() As Integer
    '
    ' Synchronous way to Close the COM port
    '
    If CloseHandle(m_lngFileHandle) <> 0 Then
        ClosePort = 0
    Else
        ClosePort = Err.LastDllError
    End If
    '
End Function
 
Public Property Get FileHandle() As Long
    FileHandle = m_lngFileHandle
End Property

Option Explicit
'
' <CountDownTimer.cls>
'
' Author: Dave Sell
'
' References:
'
'   - APITimer.cls
'   - modTimers.bas
'
' Notes:
'
'   - Intervals are in ms
'
Public Event Refresh()
Public Event Finsihed()
Public Event Started()
'
Private WithEvents m_Timer As APITimer
'
Private m_CountDownInterval As Long
Private m_ActiveIntervals As Long
Private m_blnRunning As Boolean
'
 
Public Sub Reset()
    Set m_Timer = New APITimer
    m_ActiveIntervals = 0
    m_blnRunning = False
End Sub
 
Private Sub Class_Initialize()
    Reset
    m_CountDownInterval = 0
End Sub
 
Public Property Let Interval(ByVal vNewValue As Variant)
    m_CountDownInterval = vNewValue
    If m_CountDownInterval < 0 Then
        m_CountDownInterval = 0
    End If
End Property
 
Public Property Get Interval() As Variant
    Interval = m_CountDownInterval
End Property
 
Private Sub IncrementCountDown(lngIntervals As Long)
    '
    If Not m_blnRunning Then
        m_Timer.StartTimer m_CountDownInterval
        m_blnRunning = True
        RaiseEvent Started
    End If
    '
    m_ActiveIntervals = m_ActiveIntervals + lngIntervals
    '
End Sub
 
Public Sub Increment()
    IncrementCountDown 1
End Sub
 
Public Sub MultiIncrement(lngIntervals As Long)
    IncrementCountDown lngIntervals
End Sub
 
Private Sub m_Timer_Refresh()
    '
    If m_blnRunning = True Then
        m_ActiveIntervals = m_ActiveIntervals - 1
        RaiseEvent Refresh
    End If
    '
    If m_ActiveIntervals = 0 Then
        '
        m_Timer.StopTimer
        m_blnRunning = False
        RaiseEvent Finsihed
    End If
    '
    '
End Sub
 
Public Property Get ActiveIntervals() As Variant
    ActiveIntervals = m_ActiveIntervals
End Property
 
Public Property Get Running() As Boolean
    Running = m_blnRunning
End Property