Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

Multi-threading in VB6 using PowerBASIC DLL

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • Mike Doty
    replied
    Code:
    'MULTI-THREADING DLL FOR VB6    PBThread.BAS, PBThread.EXE, PBTHREAD.DLL
    '
    'Updated PBThreadClose to update gHandle array in a critical section. 6/11/15
     
    'This program allows safe threading using VB6 in or out of the environment
    'Critical section code is automatically loaded and released when ended
    'Thread handles are kept in the array g(%ExtraThreadsAllowed)
    'Closing a message box makes its slot available in g() for another thread with same number
    '
    'To test using PB set %EXE = 1
    'To test using VB set %EXE = 0 to create PbThread.DLL
    '
    'Mike Doty 10/9/2009 update 6/11/2015
    '
    'Save as PBTHREAD.BAS
    '%EXE = 1 'create PBTHREAD.EXE
    %EXE = 0  'create PBTHREAD.DLL for use with VB6
     %ExtraThreadsAllowed = 10 'creates message box in each thread
     #IF %EXE
     #COMPILE EXE
    #ELSE
     #COMPILE DLL
    #ENDIF
     #INCLUDE "win32api.inc"
    GLOBAL gCS AS CRITICAL_SECTION  'automatically init/destroyed
                                    'usage: EnterCritical:g=99:gs="something":LEAVE CRITICAL
    GLOBAL ghandle() AS LONG        'handles ÎÌC¼ny threads
    '=============================================================================
    #IF %EXE = 1
    FUNCTION PBMAIN () AS LONG
       LOCAL x AS LONG
      InitializeCriticalSection gCS   'critical section llocated
      LOCAL result     AS LONG
      LOCAL lResult    AS LONG
      REDIM gHandle(%ExtraThreadsAllowed)   AS LONG  'only 1 extra thread in this simple demo
      FOR x = 1 TO %ExtraThreadsAllowed  'start threads
        result = PBThreadCreate
      NEXT
      DO UNTIL THREADCOUNT = 1:SLEEP 1000:LOOP 'wait for all to finish
      FOR x = 1 TO UBOUND(gHandle())           'close thread handles
        IF gHandle(x) <> 0 THEN ? "Thread close error element" + STR$(x),,FUNCNAME$
      NEXT
      BEEP:SLEEP 250:BEEP:SLEEP 250:BEEP:SLEEP 250
      DeleteCriticalSection gCS  'critical section deallocated
    END FUNCTION
    #ENDIF
    '=============================================================================
    #IF %EXE = 0
    FUNCTION LIBMAIN(BYVAL hInstance AS DWORD, _
                     BYVAL lReason AS LONG,    _
                     BYVAL lReserved AS LONG) AS LONG
      SELECT CASE AS LONG lReason
        CASE %DLL_PROCESS_ATTACH
          InitializeCriticalSection gCS     'critical section automatically allocated
          REDIM gHandle(%ExtraThreadsAllowed) AS LONG          'normally dwords, but using long with VB6
          LIBMAIN = 1
          EXIT FUNCTION
        CASE %DLL_PROCESS_DETACH
          'make sure we closed all thread handles
          LOCAL x AS LONG
          FOR x = 1 TO %ExtraThreadsAllowed  'cleanup if handles were not closed
            IF gHandle(x) THEN
               PbThreadClose gHandle(x)
               ? "Handle closed by DLL in slot" + STR$(x)
            END IF
          NEXT
          DeleteCriticalSection gCS     'critical section automatically allocated
          EXIT FUNCTION
        CASE %DLL_THREAD_ATTACH
          EXIT FUNCTION
        CASE %DLL_THREAD_DETACH
          EXIT FUNCTION
      END SELECT
      LIBMAIN = 0: ? "failure to initialize the DLL!
    END FUNCTION
    #ENDIF
    '=============================================================================
    FUNCTION PBTHREADCLOSE(ElementNumber AS LONG) EXPORT AS LONG
      EnterCritical
      LOCAL result AS LONG
      THREAD CLOSE gHandle(ElementNumber) TO result   '0 = failure
      IF result THEN
        gHandle(ElementNumber) = 0 'make slot available
        FUNCTION = result
      END IF
      LeaveCritical
    END FUNCTION
    '=============================================================================
    FUNCTION PBTHREADCOUNT EXPORT AS LONG
      FUNCTION = THREADCOUNT
    END FUNCTION
    '=============================================================================
    SUB PBSLEEP(milliseconds AS LONG) EXPORT
      SLEEP milliseconds
    END SUB
    '=============================================================================
    SUB EnterCritical              'CALL EnterCritical:Set globals: CALL LeaveCritical
       EnterCriticalSection gCS
    END SUB
    '=============================================================================
    SUB LeaveCritical
       LeaveCriticalSection gCS
    END SUB
    '=============================================================================
    FUNCTION PBThreadCreate EXPORT AS LONG
      LOCAL x AS LONG
      LOCAL result AS LONG
      EnterCritical
      x = EmptySlot
      IF x THEN
         THREAD CREATE ExtraThread(x) TO gHandle(x) 'gHandle(x) = 0 if error
         SLEEP 50
         IF gHandle(x) THEN
           FUNCTION = gHandle(x)  '0 is invalid
         ELSE
           ? "Unable to create ExtraThread" + STR$(x)
         END IF
      ELSE
        BEEP
        ? "Extra threads limited to" + STR$(%ExtraThreadsAllowed),,FUNCNAME$
      END IF
      LeaveCritical
    END FUNCTION
    '=============================================================================
    FUNCTION EmptySlot AS LONG
      LOCAL x AS LONG
      FOR x = 1 TO %ExtraThreadsAllowed
        IF ghandle(x) = 0 THEN
          FUNCTION = x
          EXIT FOR
        END IF
      NEXT
    END FUNCTION
    '=============================================================================
    THREAD FUNCTION ExtraThread(BYVAL x AS LONG) AS LONG
      ? "Thread element" + STR$(x),,FUNCNAME$
      PbThreadClose x 'close handle and zero the element
    END FUNCTION

    Leave a comment:


  • Mike Doty
    started a topic Multi-threading in VB6 using PowerBASIC DLL

    Multi-threading in VB6 using PowerBASIC DLL

    Please post comments on this posting at http://www.powerbasic.com/support/pb...ad.php?t=41676

    Try ending the VB6 program before closing any message boxes (running in other threads) to see total threads still running.
    Clicking Yes to run multiple times will start a new thread for any open slots in the ghandle() array.

    In PB the program can be terminated by ending the main thread so THREAD CLOSE's may be executed.
    IN VB the program will not end if other threads are active so THREAD CLOSE cleanup is not needed.
    THREAD CLOSE is only executed when a thread is finishing so other PB thread functions can be added and tested.

    It is suggested that the PowerBASIC source code be saved as PBTHREAD.BAS so
    the DLL is created as PBTHREAD.DLL to match the declare statements in VB6.

    The Form_QueryUnload in VB6 should not allow ending the program if other threads are running.
    Code:
    Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
     
      'THIS CODE IS ABSOLUTELY REQUIRED
      Dim OtherThreads As Long
      OtherThreads = PBTHREADCOUNT - 1
      If OtherThreads Then
        Me.Caption = Str$(OtherThreads) + " other thread(s) still busy."
        Cancel = 1
      End If
     
    End Sub
    -------------------------------------------------------------------------------------------
    Here is the PB code to create the DLL or run as a stand-alone program to test the DLL code.

    Code:
    'MULTI-THREADING DLL FOR VB6    PBThread.BAS, PBThread.EXE, PBTHREAD.DLL
    '
    'This program allows safe threading using VB6 in or out of the environment
    'Critical section code is automatically loaded and released when ended
    'Thread handles are kept in the array g(%ExtraThreadsAllowed)
    'Closing a message box makes its slot available in g() for another thread with same number
    '
    'To test using PB set %EXE = 1
    'To test using VB set %EXE = 0 to create PbThread.DLL
    '
    'Mike Doty 10/9/2009
    '
    'Save as PBTHREAD.BAS
    %EXE = 1 'create PBTHREAD.EXE
    '%EXE = 0  'create PBTHREAD.DLL for use with VB6
     
    %ExtraThreadsAllowed = 2  'change to how many threads are allowed (creates message boxes)
     
    #IF %EXE
     #COMPILE EXE
    #ELSE
     #COMPILE DLL
    #ENDIF
     
    #INCLUDE "win32api.inc"
    GLOBAL gCS AS CRITICAL_SECTION  'automatically init/destroyed
                                    'usage: EnterCritical:g=99:gs="something":LEAVE CRITICAL
    GLOBAL ghandle() AS LONG        'handles to any threads
    '=============================================================================
    #IF %EXE = 1
    FUNCTION PBMAIN () AS LONG
     
      LOCAL x AS LONG
      InitializeCriticalSection gCS     'critical section automatically allocated
      LOCAL result     AS LONG
      LOCAL lResult    AS LONG
      REDIM gHandle(%ExtraThreadsAllowed)   AS LONG  'only 1 extra thread in this simple demo
     
      DO
        lResult = MSGBOX("Click YES to run or click NO to exit all threads",%MB_YESNO OR %MB_SYSTEMMODAL,"PB Threading with VB6")
        IF lResult <> %IDYES THEN EXIT DO
        FOR x = 1 TO %ExtraThreadsAllowed
          result = PBThreadCreate
        NEXT
      LOOP
      DeleteCriticalSection gCS     'critical section automatically allocated
     
      'In VB6 code this should not be necessary because the program can not end until THREADCOUNT is 1.
      FOR x = 1 TO %ExtraThreadsAllowed  'cleanup if handles were not closed
          IF gHandle(x) THEN PbThreadClose gHandle(x)
      NEXT                                                                   
     
    END FUNCTION
    #ENDIF
    '=============================================================================
    #IF %EXE = 0
    FUNCTION LIBMAIN(BYVAL hInstance AS DWORD, _
                     BYVAL lReason AS LONG,    _
                     BYVAL lReserved AS LONG) AS LONG
      SELECT CASE AS LONG lReason
        CASE %DLL_PROCESS_ATTACH
          InitializeCriticalSection gCS     'critical section automatically allocated
          REDIM gHandle(%ExtraThreadsAllowed) AS LONG          'normally dwords, but using long with VB6
          LIBMAIN = 1
          EXIT FUNCTION
        CASE %DLL_PROCESS_DETACH
           DeleteCriticalSection gCS     'critical section automatically allocated
          EXIT FUNCTION
        CASE %DLL_THREAD_ATTACH
          EXIT FUNCTION
        CASE %DLL_THREAD_DETACH
          EXIT FUNCTION
      END SELECT
      LIBMAIN = 0: ? "failure to initialize the DLL!
    END FUNCTION
    #ENDIF
    '=============================================================================
    FUNCTION PBTHREADCLOSE(ElementNumber AS LONG) EXPORT AS LONG
      LOCAL result AS LONG
      THREAD CLOSE gHandle(ElementNumber) TO result   '0 = failure
      FUNCTION = result
    END FUNCTION
    '=============================================================================
    FUNCTION PBTHREADCOUNT EXPORT AS LONG
      FUNCTION = THREADCOUNT
    END FUNCTION
    '=============================================================================
    SUB PBSLEEP(milliseconds AS LONG) EXPORT
      SLEEP milliseconds
    END SUB
    '=============================================================================
    SUB EnterCritical              'CALL EnterCritical:Set globals: CALL LeaveCritical
       EnterCriticalSection gCS
    END SUB
    '=============================================================================
    SUB LeaveCritical
       LeaveCriticalSection gCS
    END SUB
    '=============================================================================
    FUNCTION PBThreadCreate EXPORT AS LONG
      LOCAL x AS LONG
      LOCAL result AS LONG
      EnterCritical
      x = EmptySlot
      IF x THEN
         THREAD CREATE ExtraThread(x) TO gHandle(x) 'if invalid gHandle(x) remains 0
         SLEEP 50
         IF gHandle(x) THEN
           FUNCTION = gHandle(x)  '0 is invalid
           'Thread CLose gHandle(x) to result     'don't need the file handle
         ELSE
           ? "Unable to create ExtraThread" + STR$(x)
         END IF
      'ELSE
      '    ? "No more slots available"
      END IF
      LeaveCritical
    END FUNCTION
    '=============================================================================
    FUNCTION EmptySlot AS LONG
      LOCAL x AS LONG
      FOR x = 1 TO %ExtraThreadsAllowed
        IF ghandle(x) = 0 THEN
          FUNCTION = x
          EXIT FOR
        END IF
      NEXT
    END FUNCTION
    '=============================================================================
    THREAD FUNCTION ExtraThread(BYVAL x AS LONG) AS LONG
      LOCAL Result AS LONG
      ? "ExtraThread" + STR$(x) + "  Total running" + STR$(PbthreadCount)
     
      EnterCritical          'using a global array so using critical section
      Result = PBTHREADCLOSE(x)
      IF result THEN
        gHandle(x) = 0
        LeaveCritical
      ELSE
        LeaveCritical
        ? "THREAD CLOSE ERROR OF THREAD" + STR$(x)
      END IF
    END FUNCTION
    Code:
    REM  VB6 Test program
    Option Explicit
    Private Declare Function PBTHREADCREATE Lib "PBThread.dll" () As Long
    Private Declare Function PBTHREADCLOSE Lib "PBThread.dll" () As Long
    Private Declare Function PBTHREADCOUNT Lib "PBThread.dll" () As Long
    Private Declare Sub PBSLEEP Lib "PBThread.dll" (milliseconds As Long)
     
    Const ExtraThreadsAllowed = 5
    Dim gsTitle As String
    Dim ghandle() As Long
     
    Private Sub Command1_Click()
     
      Dim result As Long
      Dim x As Long
      For x = 1 To ExtraThreadsAllowed
         result = PBTHREADCREATE
      Next
     End Sub
     
    Private Sub Form_Load()  'Copy paste command button for control array of 3 buttons
      ReDim ghandle(ExtraThreadsAllowed)
      ChDir App.Path         'So DLL is found in current directory
      gsTitle = "Safe Threads for VB6 using PowerBASIC"
      Me.Caption = gsTitle
      Command1.Caption = "CREATE"
    End Sub
     
    Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
      'THIS CODE IS ABSOLUTELY REQUIRED
      Dim OtherThreads As Long
      OtherThreads = PBTHREADCOUNT - 1
      If OtherThreads Then
          Me.Caption = Str$(OtherThreads) + " other thread(s) still busy."
          Cancel = 1
      End If
    End Sub
    Last edited by Mike Doty; 11 Oct 2009, 09:47 AM. Reason: Reduce extra threads to 2 because it is just as effective.
Working...
X