Tweet
Hey all this is an example of how to do a multi-threaded com component with events for Visual Basic. Everyone knows if you create threads in vb it crashes.
Code:
'---------------------------------------------------------------------
' Author : Thomas Tierney
' Purpose : The source code is provided to show how to create a
' multi threaded com component that can be safely be used
' in VB. We all know that VB doesnt act nicely when it comes
' to threads so any event that needs to be triggered must
' be done from the main thread. The only part I do not like
' is the fact that the "EVENT HANDLER" sub "DOIT" is exposed
' in the type library. I would prefer it to be invisible.
' this is very close to the PREFERED way of doing it, as far as
' I can tell :)
' Date :
'---------------------------------------------------------------------
#COMPILE DLL
#DIM ALL
#COM NAME "VBASICEventLibrary", 1.0
#COM TLIB ON
#COM DOC "Visual Basic Event Test Server"
#COM GUID GUID$("{81587687-D0F2-43FB-8D8C-D163FFD0CFDE}"))
#INCLUDE "Win32API.inc"
GLOBAL ghInstance AS DWORD
GLOBAL hDlg AS DWORD
%MSG = %WM_USER + 500
FUNCTION LIBMAIN (BYVAL hInstance AS LONG, _
BYVAL fwdReason AS LONG, _
BYVAL lpvReserved AS LONG) AS LONG
SELECT CASE fwdReason
CASE %DLL_PROCESS_ATTACH
ghInstance = hInstance
FUNCTION = 1 'success!
CASE %DLL_PROCESS_DETACH
FUNCTION = 1 'success!
CASE %DLL_THREAD_ATTACH
FUNCTION = 1 'success!
CASE %DLL_THREAD_DETACH
FUNCTION = 1 'success!
END SELECT
END FUNCTION
FUNCTION TestThread(BYVAL OBJECTPTR AS DWORD) AS DWORD
'---------------------------------------------------------------------
' Author : Thomas Tierney
' Purpose : Test thread to send messages with the object pointer
' To the dialog
' Date :
'---------------------------------------------------------------------
LOCAL iCount AS LONG
LOCAL tObject AS DISPATCH
LOCAL lObject AS DWORD
LOCAL vResult AS VARIANT
LOCAL lReserved AS LONG
lReserved = 0
FOR iCount = 1 TO 5
DIALOG SEND hDlg, %MSG, OBJECTPTR, iCount
SLEEP 1000
NEXT iCount
END FUNCTION
THREAD FUNCTION DoeventsThread(BYVAL DUMMY AS DWORD) AS DWORD
'---------------------------------------------------------------------
' Author : Thomas Tierney
' Purpose : Do Events thread to keep the dialog from choking
' Date :
'---------------------------------------------------------------------
LOCAL X AS LONG
DO
DIALOG DOEVENTS
DIALOG GET SIZE hDlg TO x, x
LOOP WHILE x& ' When x& = 0, dialog has ended
END FUNCTION
CALLBACK FUNCTION ConnectProc() AS LONG
'---------------------------------------------------------------------
' Author : Thomas Tierney
' Purpose : Dialog Procedure to handle object messages and to fire
' Events on the main thread
' Date :
'---------------------------------------------------------------------
LOCAL tObject AS DISPATCH
LOCAL dObject AS DWORD
LOCAL lProgress AS LONG
SELECT CASE AS LONG CBMSG
CASE %MSG
dObject = CBWPARAM
POKE DWORD,VARPTR(tObject),dObject
OBJECT CALL tObject.Doit(lProgress)
POKE DWORD,VARPTR(tObject), 0
CASE ELSE
'Do nothing
END SELECT
END FUNCTION
INTERFACE EVENT_TEST GUID$("{39B83F43-1108-48B7-9751-0194B62339F8}") AS EVENT
'---------------------------------------------------------------------
' Author : Thomas Tierney
' Purpose : Main Event Interface
' Date :
'---------------------------------------------------------------------
INHERIT IUNKNOWN
METHOD Progress(BYVAL Percent AS LONG)
END INTERFACE
CLASS CAPPLICATION GUID$("{5BE00DB6-9E7B-47D9-8B18-76712765E86F}") AS COM
'---------------------------------------------------------------------
' Author : Thomas Tierney
' Purpose : The Application Class
' Date :
'---------------------------------------------------------------------
CLASS METHOD CREATE ALIAS "Create"()
'---------------------------------------------------------------------
' Author : Thomas Tierney
' Purpose : Create Our main dialog to handle object event messages
' Date :
'---------------------------------------------------------------------
LOCAL Result AS LONG
LOCAL lResult AS LONG
LOCAL lReserved AS LONG
lReserved = 0
CoinitializeEx lReserved,0
DIALOG NEW 0, "",,, 0, 0 TO hDlg
DIALOG SHOW MODELESS hDlg CALL ConnectProc TO Result
DIALOG SHOW STATE %SW_HIDE, hDlg
'now lets call our doevents thread
THREAD CREATE doeventsthread(1) TO lResult
THREAD CLOSE lResult TO lResult
END METHOD
CLASS METHOD Destroy ALIAS "Destroy"()
'---------------------------------------------------------------------
' Author : Thomas Tierney
' Purpose : Close the dialog when the object is destroyed
' Date :
'---------------------------------------------------------------------
'Close the dialog
DIALOG END hDlg,%TRUE
CoUninitialize
END METHOD
'CLASS METHOD TriggerEvent(BYVAL i AS LONG)
'---------------------------------------------------------------------
' Author :
' Purpose :
' Date :
'---------------------------------------------------------------------
' RAISEEVENT EVENT_TEST.Progress(i)
'END METHOD
INTERFACE APPLICATION GUID$("{85B6D13D-0E6A-4E9B-9934-F420DFE6C6F4}")
INHERIT DUAL
METHOD Doit ALIAS "Doit"(BYVAL lProgress AS LONG)
'---------------------------------------------------------------------
' Author : Thomas Tierney
' Purpose : Main "EVENT" handler function call.
' Date :
'---------------------------------------------------------------------
RAISEEVENT EVENT_TEST.Progress(lProgress)
END METHOD
METHOD Submit ALIAS "Submit"() AS LONG
'---------------------------------------------------------------------
' Author : Thomas Tierney
' Purpose : Sets the object to me, and passes "ME" off to the test thread
' This is so we can pass the entire object off in the CBWPARAM
' in the send message
' Date :
'---------------------------------------------------------------------
LOCAL tResult AS LONG
LOCAL tObject AS DISPATCH
LET tObject = ME
THREAD CREATE TestThread(OBJPTR(tObject)) TO tResult
THREAD CLOSE tResult TO tResult
END METHOD
END INTERFACE
EVENT SOURCE EVENT_TEST
END CLASS