VB Forum / General / July 2008

Hi

I am trying to develop a simple thread server using

http://www.vbaccelerator.com/home/Vb/Code/Libraries/Threading/Multi-threading_us
ing_classes_in_ActiveX_EXEs/article.asp

(I've pasted the code at the bottom of this just-in-case)

I have a simple form with 3 buttons and 3 text boxes. I want to create 3
processes on 3 threads so that all of the text boxes are updated
simultaneously.

So I've tried to wrap up the VBAccelerator's approach a bit. I've
introduced an IProcess public interface inside a ThreadServer
activeX.exe. Ideally I'd be able to implement this on any class in
others project to be able to run several instances of that class on
different threads. This interface requires the inheriting class to
receive a CThread Object.

So I have a Worker class with the following code

++++ MyWorker.Cls ++++

Implements MyThreadServer.IProcess

Public Event WorkerWorking(ByVal Value As Long)

Private m_oThread               As IfxThreadServer.CThread

Private m_bCancel               As Boolean
Private m_nCounter              As Long

Private Sub Class_Terminate()
    Set m_oThread = Nothing
End Sub

Private Sub IProcess_Terminate()
    m_bCancel = True
End Sub

Private Sub IProcess_Run()
    StartCounting
End Sub

Private Property Set IProcess_Thread(ByVal RHS As IfxThreadServer.CThread)
    Set m_oThread = RHS
End Property

Private Sub StartCounting()

    Dim i As Long

    Do While True
        If i > 10000000 Then i = 0
        If m_bCancel Then Exit Do
        i = i + 1
        If i Mod 1000 = 0 Then
            DoEvents
            RaiseEvent WorkerWorking(i)
        End If
    Loop

End Sub

What is happening is that the threads are starting up correctly but only
one of the text boxes is being updated at a time. As soon as I stop that
thread, then the second one begins. The processes are obviously queue up
and ready to run fine, but I am effectively trapped in the loop in the
StartCounting proc.

Is my problem that I am calling back into my worker class which is in a
activeX dll to do the work rather than doing it in the CThread class. If
so, is there another way to do this more generically, so all I need to
do is inherit and interface and/or instantiate a class. Or is there some
other deeper problem going on which I'm not aware of.

I hope that's sufficiently clear.

Many thanks

Simon

Here's the other salient code:

++++  CThreadManager.Cls ++++

Public Function CreateThreadedProcess(ByVal p_oProcess As IProcess) As
IProcess

    Dim l_oThread As CThread

    Set l_oThread = New CThread

    Set p_oProcess.Thread = l_oThread
    l_oThread.Start p_oProcess

    Set CreateThreadedProcess = p_oProcess

End Function

++++  CThread.Cls ++++

Implements Runnable

Private m_oProcess      As IProcess

Private m_bRunning      As Boolean

Public Sub Start(ByVal p_oProcess As IProcess)

   If Not m_bRunning Then
      m_bRunning = True

      Set m_oProcess = p_oProcess

      ' Call the mStart module.  This uses a timer to
      ' fire the Runnable_Start() implementation,
      ' which ensures we yield control back to the
      ' caller before the processing starts.  This
      ' ensures that the processing runs asynchronously
      ' to the client.  Easy!!!
      MThread.Start Me
   Else
      ' Just checking....
      Err.Raise 32540, App.EXEName & ".CThread", "Already running."
   End If

End Sub

Private Sub Runnable_Start()

    m_oProcess.Run

    m_bRunning = False

End Sub

++++ MThread.bas ++++

' To prevent object going out of scope whilst the timer fires:
Private Declare Function CoLockObjectExternal Lib "ole32" ( _
      ByVal pUnk As IUnknown, ByVal fLock As Long, _
      ByVal fLastUnlockReleases As Long) As Long

' Timer API:
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

' Collection of Runnable items to start:
Private m_colRunnables As Collection
' The ID of our API Timer:
Private m_lTimerID As Long

Private Sub TimerProc(ByVal lHwnd As Long, ByVal lMsg As Long, _
         ByVal lTimerID As Long, ByVal lTime As Long)
   Dim this As Runnable
   ' Enumerate through the collection, firing the
   ' Runnable_Start method for each item in it and
   ' releasing our extra lock on the object:
   With m_colRunnables
      Do While .Count > 0
         Set this = .Item(1)
         .Remove 1
         this.Start
         'Ask the system to release its lock on the object
         CoLockObjectExternal this, 0, 1
      Loop
   End With
   ' Remove the timer:
   KillTimer 0, lTimerID
   m_lTimerID = 0
End Sub

Public Sub Start(this As Runnable)
   ' Ask the system to lock the object so that
   ' it will still perform its work even if it
   ' is released
   CoLockObjectExternal this, 1, 1
   ' Add this to runnables:
   If m_colRunnables Is Nothing Then
      Set m_colRunnables = New Collection
   End If
   m_colRunnables.Add this
   ' Create a timer to start running the object:
   If Not m_lTimerID Then
      m_lTimerID = SetTimer(0, 0, 1, AddressOf TimerProc)
   End If
End Sub