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

[IanS]

Hi,

Is there a way to copy and paste this code without the line numbers ?

Cheers
Ian

[Dave Sell]

Give me a few mins and I will upload the modules.

[IanS]

I've just noticed that if I click the "Quote" button it displays all the text in the box without the line numbers - I suppose it would be easy enough to pull the text out that way - on the other hand, isn't there an 'official' way to copy code samples from the forum ?

By the way, the first line is going to give me an error isn't it ?

Private WithEvents m_COMPort As cls_COMPort

Only allowed in an Object Module

I'm doing this in a standard exe project - should I be doing it in an activex exe project ?

[Dave Sell]

Standard EXE project is perfect. I always use a Main Form to host all the main WithEvents Objects. The Quote trick is the official way to do it LOLz...

[Dave Sell]

OK I'm uploading the project files. Note I altered CountDownTimer.cls to use Strings instead of Variants, which are not compatible with .NET

[IanS]

Hi Dave - I just downloaded that and took a quick look at the code.

I haven't actually tested it yet with a slow port but would you just clarify for me - what you're saying is that (when I click the "Open Async" button) if the API CreateFile function hangs (ie does not return for any length of time) then the application will still remain responsive and can periodically check to see if the port opened yet.

So, in theory, one could use that sample code to do practically 'anything' on an async basis.

You said you wrote much of that code some time ago - was that its purpose ? to do api tasks asynchronously ? Where is that code, I couldn't see it in the codebank.

Thanks
Ian

[Dave Sell]

Hi Dave - I just downloaded that and took a quick look at the code.

I haven't actually tested it yet with a slow port but would you just clarify for me - what you're saying is that (when I click the "Open Async" button) if the API CreateFile function hangs (ie does not return for any length of time) then the application will still remain responsive and can periodically check to see if the port opened yet.

Short answer is yes, but I would not "check periodically". I would set up my own timer on the form that alerts me that n seconds have gone by and I should try again later, etc. However I don't think there is much you can do besides wait for the API call to return. Like I don't think you can cancel that call or anything, you just gotta let it run its course.

So, in theory, one could use that sample code to do practically 'anything' on an async basis.

Yes!

You said you wrote much of that code some time ago - was that its purpose ? to do api tasks asynchronously ? Where is that code, I couldn't see it in the codebank.

I made 2 Classes many years ago that used bits of that code; One was the CountDownTimer to be used as a non-graphical Windows Timer, and the other is clsPerformanceCounter, which can be used to measure the time it takes code to execute, and is accurate down to 300 nanoseconds.

[IanS]

Originally Posted by IanS
So, in theory, one could use that sample code to do practically 'anything' on an async basis.

Yes!

This sounds interesting. I don't have a slow port ready to test so I thought of some 'other' api call I could test this with. Sleep() should do it. So I added the declaration for the API Sleep() function.

So, calling Sleep(10000) instead of CreateFile would make the application hang for 10 seconds - but, according to you, the main form should remain responsive while we're waiting for the API call to return.

But it doesn't, the call makes everything hang for 10 seconds.

Maybe Sleep isn't a good one to test this with - can you think of some other slow api call we could use to test this ?

[Dave Sell]

Post code and I will try it sometime next week.

[IanS]

I've just added the Sleep function to your code.

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

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

and commented out the call to CreateFile and called Sleep() instead because we know that, in this case, the api call with take 10 seconds to return

Public Function OpenPort() As Boolean
    
    ' Instead of CreateFile, lets call Sleep(10000)
    ' Obviously this isn't going to open a port but we can be sure that this api call will take 10 seconds to return
    
     Sleep (10000)
    
    '
    '
    ' 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

[Dave Sell]

OpenPort() is not an Asynchronous routine.

[IanS]

OpenPort() is not an Asynchronous routine.

If I click the OpenAsync button on your sample form that eventually calls OpenPort - I assumed you did that because that's the only place anywhere in your code that CreateFile() appears.

[Dave Sell]

Oh ya, sorry. I don't have VB6 installed anymore, so next week I will install it and look into this.

[IanS]

This function calls OpenPort()

Private Sub m_OpenTimer_Finsihed()
    '
    Dim blnReturn As Boolean
    '
    blnReturn = OpenPort
    RaiseEvent PortOpenDone(blnReturn)
    '
End Sub

[Dave Sell]

This function calls OpenPort()

Private Sub m_OpenTimer_Finsihed()
    '
    Dim blnReturn As Boolean
    '
    blnReturn = OpenPort
    RaiseEvent PortOpenDone(blnReturn)
    '
End Sub

OK but the main form should not be "hung up" not matter how long this takes.

[IanS]

With the above changes (using Sleep instead of CreateFile) the main form hangs for 10 seconds when I click the OpenAsync button

[Dave Sell]

If that is really true then I will try it using an out-of-process EXE object instead of the in-process way we are doing it now.

[Dave Sell]

With the above changes (using Sleep instead of CreateFile) the main form hangs for 10 seconds when I click the OpenAsync button

According to MSDN: here, Sleep() kills the entire thread, parental ownership not excluded.

Ergo, what you are witnessing is by design and should not in any way correlate to the CreateFile API. Sleep is intended to kill the entire thread.

I suggest you ignore this test, even though I thought it was a pretty good shot at simulating the hung-up nature of the CreateFile() API call.

I believe you cannot have a true test of the true behavior until you run it against a problematic COM port, as I originally suggested.

I will try to simulate this using CreateFile against a broken mapped network drive and see what happens.

[IanS]

According to MSDN: here, Sleep() kills the entire thread, parental ownership not excluded.

Ergo, what you are witnessing is by design and should not in any way correlate to the CreateFile API. Sleep is intended to kill the entire thread.

I suggest you ignore this test, even though I thought it was a pretty good shot at simulating the hung-up nature of the CreateFile() API call.

I believe you cannot have a true test of the true behavior until you run it against a problematic COM port, as I originally suggested.

I will try to simulate this using CreateFile against a broken mapped network drive and see what happens.

Mentioning the word 'Thread' - I think you hit the nail on the head.

The ability to run a 'slow-to-return' CreateFile function AND remain responsive within the application while you're waiting would, in my mind, require two threads.

If we were doing this in C we'd call the CreateThread API to do the async task. Actually, in VB5 you could also call CreateThread and pass it AddressOf a function in a module to do the async task - basically running two threads.

VB6 is more thread-safe so that crashes if you try (although there are ways around it but it requires a bit more code but still possible - I may look at that route)

Without multithreading I really can't see how we can be running code in the API CreateFile function AND running code in the VB form at the same time with just one thread.

I really do appreciate your input on this - but please don't spend too much time on it because I kinda feel we're going down the wrong route.

[CDRIVE]

Using Sleep for more than a few mS is an awful idea. Take a look at the WaitMessage API used in conjunction with a Timer or use this Pause sub, which is a modified of version of what's found in your library. This sub will not freeze your app. You can click buttons etc. while Pause is active.

Private Sub Pause(ByVal Delay As Single)
   Delay = Timer + Delay
   If Delay > 86400 Then 'more than number of seconds in a day
      Delay = Delay - 86400
      Do
          DoEvents ' to process events.
          Sleep 1 ' to not eat cpu
      Loop Until Timer < 1
   End If
   Do
       DoEvents ' to process events.
       Sleep 1 ' to not eat cpu
   Loop While Delay > Timer
End Sub

Private Sub Form_Load()
   Pause 10                    ' pause for 10 seconds
   MsgBox "Time Out"
End Sub

[Dave Sell]

Using Sleep for more than a few mS is an awful idea. Take a look at the WaitMessage API used in conjunction with a Timer or use this Pause sub, which is a modified of version of what's found in your library. This sub will not freeze your app. You can click buttons etc. while Pause is active.

Ya actually IanS was intentionally freezing the app to run a test, or prove a point. I am not convinced the test is a valid comparison to the behavior of a hung-up API call to CreateFile(). I have not tried it yet.

[IanS]

Using Sleep for more than a few mS is an awful idea.....

LOL yeah we know - you'd need to read the whole thread from the start to see what we're talking about.

Dave is trying to put some code together that would allow a VB6 app to call a 'blocking function' while still remaining responsive. By 'Blocking Function' I mean calling some API function that might take a very (very) long time to return without blocking the calling application. To test Dave's code I thought we could use the Sleep function (that will block for as long as we tell it to)

I've come to the conclusion it can only be done by actually creating another thread to make the api call - Dave is doing it in just one thread.

Please join in though - all suggestions welcome

[CDRIVE]

Well, we know that VB6 can't multi-thread but I did mention the WaitMessage API in that post. Admittedly, I'm not sure if it's applicable here.

Quote: From the KPD API Guide:

"The WaitMessage function yields control to other threads when a thread has no other messages in its message queue. The WaitMessage function suspends the thread and does not return until a new message is placed in the thread’s message queue".

[IanS]

Well, we know that VB6 can't multi-thread

Actually it can - You can call the CreateThread API function passing it AddressOf a sub or function in a module.

That worked quite well under VB5 but crashes when you try it with VB6 - interesting thing is it's the new thread that crashes while the calling thread remains responsive That kinda feels strange seeing the error messages pop open but still have full control of your application - LOL

Anyway, it is still possible with vb6 to call the CreateThread api function. It just needs a bit more code to set it up before calling it.

[CDRIVE]

Actually it can - You can call the CreateThread API function passing it AddressOf a sub or function in a module.

That worked quite well under VB5 but crashes when you try it with VB6

That's unfortunate, because if it worked under VB6 it could be used to generate DTFM codes and a host of other applications.