But This example is pedagogic.
Vector.bas
Code: Select all
#include Once "windows.bi"
#include Once "crt.bi"
#Include Once "win/ocidl.bi"
#include Once "olevariant.bi"
#include Once "comwrapper.bi"
#include Once "Vector.bi" 'GUIDs and INTERFACES definitions
'Define COM_DEBUG to get a trace of component activity in log file
#define COM_DEBUG
#ifdef COM_DEBUG
#define COM_DEBUG_LOG "Vector_debug.txt"
Dim Shared As integer fin
#EndIf
Dim Shared TypeLibName As Zstring*128=>"Vector.dll"
Dim Shared filename As Zstring*MAX_PATH
'GLOBAL OBJECT COUNTER
static Shared As integer vcObjects = 0
Static Shared As integer cfLock = 0
'Only for DLLRegisterServer to find its own path
'Iobjet instance data''''''''''/
Type VECTOR_OBJ
As ICalculator itrfCalc
cRef As Integer
x As Double
y As Double
m_var As VARIANT
End Type
Type LPVECTOR As VECTOR_OBJ Ptr
'IOBJECT INTERFACE1 METHODS'''''''''''
'IUNKNOWN IMPLEMENTATION
Function CalcQueryInterface(pif As ICalculator ptr,riid As REFIID , ppv As LPVOID Ptr) As HRESULT PURE
#Ifdef COM_DEBUG
Print #fin, "I1_QUERYINTERFACE IN ", pif
#EndIf
if(IsEqualIID(riid,@IID_IUnknown) Or IsEqualIID(riid,@IID_ICalculator)) Then
*ppv=@Cast(LPVECTOR,pif)->itrfCalc
Else
*ppv=0
Return E_NOINTERFACE
End If
pif->lpVtbl->AddRef(pif)
#ifdef COM_DEBUG
print #fin ,"Calculator_QUERYINTERFACE OUT ",pif,*ppv
#EndIf
Return NOERROR
End Function
Function CalcAddRef(pif As ICalculator ptr) As HRESULT PURE
#ifdef COM_DEBUG
print #fin ,"Calculator_ADDREF: ",pif,((Cast(LPVECTOR,pif))->cRef)+1
#EndIf
Cast(LPVECTOR,pif)->cRef =Cast(LPVECTOR,pif)->cRef+1
Return Cast(LPVECTOR,pif)->cRef
End Function
Function CalcRelease(pif As ICalculator Ptr ) As HRESULT PURE
#Ifdef COM_DEBUG
print #fin ,"Calculator_RELEASE: ",pif,Cast(LPVECTOR,pif)->cRef-1
#EndIf
Cast(LPVECTOR,pif)->cRef -=1
VariantClear(@(Cast(LPVECTOR,pif)->m_var) )
if Cast(LPVECTOR,pif)->cRef <= 0 Then
vcObjects -=1
GlobalFree (pif)
return 0
End If
return Cast(LPVECTOR,pif)->cRef
End Function
'OBJECT SPECIFIC METHODS
' As ZString Ptr not com object
Function CalcToString(pif As ICalculator ptr, pValue As ZString Ptr)As HRESULT PURE
*pValue="x= "+ Str(Cast(LPVECTOR,pif)->x) + " y = "+Str(Cast(LPVECTOR,pif)->y)
#ifdef COM_DEBUG
Print #fin, "Calculator_ToString: ", pif, pValue
#EndIf
Return NOERROR
End Function
Function CalcProduit(pif As ICalculator ptr, pValue As Double Ptr)As HRESULT PURE
*pValue=(Cast(LPVECTOR,pif)->x) * (Cast(LPVECTOR,pif)->y)
#ifdef COM_DEBUG
Print #fin, "Calculator Produit: ", pif, pValue
#EndIf
Return NOERROR
End Function
Function CalcSet_x(pif As ICalculator Ptr, value As double)As HRESULT PURE
Cast(LPVECTOR,pif)->x=value
#ifdef COM_DEBUG
print #fin ,"Calculator_SET_X: ,",pif,Cast(LPVECTOR,pif)->x
#EndIf
return NOERROR
End Function
Function CalcGet_x(pif As ICalculator Ptr , pValue As Double Ptr)As HRESULT PURE
*pValue=cast(LPVECTOR,pif)->x
#ifdef COM_DEBUG
print #fin ,!"Calculator Get_x: %p %lf\n",pif,*pValue
#EndIf
return NOERROR
End Function
Function CalcSet_y(pif As ICalculator Ptr, value As double)As HRESULT PURE
Cast(LPVECTOR,pif)->y=value
#ifdef COM_DEBUG
print #fin ,!"CalcSet_y:%p %lf ,",pif,Cast(LPVECTOR,pif)->y
#EndIf
return NOERROR
End Function
Function CalcGet_y(pif As ICalculator Ptr , pValue As Double Ptr)As HRESULT PURE
*pValue=cast(LPVECTOR,pif)->y
#ifdef COM_DEBUG
print #fin ,!"Calculator Get_y: %p %lf\n",pif,*pValue
#EndIf
return NOERROR
End Function
Function CalcSetArray (pif As ICalculator Ptr , Value As VARIANT) As HRESULT PURE
' Make sure that caller passed a string
if (0=@Value) then return(E_POINTER)
variantcopy(@(Cast(LPVECTOR,pif)->m_var),@value)
#ifdef COM_DEBUG
print #fin ,!"CalcSetArray :%p %s ,",pif, @(Cast(LPVECTOR,pif)->m_var)
#EndIf
return NOERROR
End Function
Function CalcGetArray(pif As ICalculator Ptr , pValue As VARIANT Ptr) As HRESULT PURE
variantcopy(pvalue,@(Cast(LPVECTOR,pif)->m_var))
If pValue=0 Then return E_OUTOFMEMORY
#ifdef COM_DEBUG
print #fin ,!"CalcGetArray: %p %s\n",pif,pValue
#EndIf
return NOERROR
End Function
Function CalcDeterminant(pif As ICalculator ptr, pValue As Double Ptr)As HRESULT PURE
Dim value As Double
Gauss_Jordan(Cast(LPVECTOR,pif)->m_var,Value)
*pValue=value
#ifdef COM_DEBUG
Print #fin, "Calculator Produit: ", pif, pValue
#EndIf
Return NOERROR
End Function
static Shared As ICalculatorVtbl vtblI1 = (@CalcQueryInterface, @CalcAddRef, @CalcRelease, @CalcToString, @CalcSet_x, @CalcGet_x, @CalcSet_y, @CalcGet_y,@CalcProduit, _
@CalcSetArray,@CalcGetArray,@CalcDeterminant)
'CLASS FACTORY''''''''''''''''''''''''''''''''
'OBJECT CLASS FACTORY DEFINITION
Type CF
As IClassFactory icf
As integer cRef
End Type
type LPCF As CF Ptr
static Shared As IClassFactory Ptr vpcfOutside = NULL
'OBJECT CLASS FACTORY METHODS
Function CFQueryInterface(pcf As IClassFactory Ptr ,riid As REFIID , ppv As PVOID Ptr)As Long
Dim pthis As LPCF =Cast(LPCF,pcf)
#ifdef COM_DEBUG
Print #fin, "CF_QUERYINTERFACE IN ", pthis
#EndIf
if(IsEqualIID(riid, @IID_IUnknown) and IsEqualIID(riid, @IID_IClassFactory)) Then
*ppv=pthis
pthis->icf.lpVtbl->AddRef(pcf)
Else
*ppv = 0
return E_NOINTERFACE
End If
#ifdef COM_DEBUG
print #fin ,"CF_QUERYINTERFACE OUT ",pcf,*ppv
#EndIf
return NOERROR
End Function
Function CFAddRef(pcf As IClassFactory Ptr ) As ULong
Dim pthis As LPCF= Cast(LPCF,pcf)
Cast(LPCF,pcf)->cRef +=1
#ifdef COM_DEBUG
print #fin ,"CF_ADDREF: ",pcf,pthis->cRef
#EndIf
return pthis->cRef
End Function
Function CFRelease(pcf As IClassFactory Ptr ) As ULong
Dim pthis As LPCF= Cast(LPCF,pcf)
#Ifdef COM_DEBUG
print #fin ,"CF_RELEASE: ",pcf,cast(LPCF,pcf)->cRef-1
#EndIf
pthis->cRef-=1
if pthis->cRef = 0 Then
localFree (pcf)
vpcfOutside = Null
return 0
End If
return pthis->cRef
End Function
'THE OBJECT CREATOR (class factory CREATEINSTANCE member)
Function CFCreateInstance(pcf As IClassFactory ptr,punkOuter As LPUNKNOWN ,riid as REFIID , ppv As PVOID Ptr)As HRESULT
Dim As HRESULT hr
Dim As VECTOR_OBJ Ptr thiss
#ifdef COM_DEBUG
Print #fin, "CF_CreateInstance IN"
#EndIf
*ppv=0
If (punkOuter) Then
Return CLASS_E_NOAGGREGATION
End If
thiss = Cast(VECTOR_OBJ Ptr,mAlloc(SizeOf(VECTOR_OBJ)))
If thiss=NULL Then return E_OUTOFMEMORY
'Bump up global object count to keep DLL in memory
vcObjects +=1
'Set up object's vTables
thiss->itrfCalc.lpVtbl=@vtblI1
'Set up count ref to allow self destruction if QueryInterface goes wrong
(thiss->cRef) = 1
'Initialize object's internal attributs
(thiss->x)=0
(thiss->y)=0
variantinit(@(thiss->m_var))
'Ask for the required interface
If S_OK<>thiss->itrfCalc.lpVtbl->QueryInterface(@(Thiss->itrfCalc),riid,ppv)Then
Free(thiss)
Return E_NOINTERFACE
EndIf
'DONT CALL RELEASE THROUGH ppv because QueryInterface can fail !!!
thiss->itrfCalc.lpVtbl->Release(@(Thiss->itrfCalc)) 'If no PB cRef is back to 1, else object is destroyed
#ifdef COM_DEBUG
print #fin ,"OBJ_CREATE OUT ",thiss,*ppv,hr
#EndIf
return S_OK
End Function
Function CFLockServer(pcf As IClassFactory Ptr ,flock As BOOL ) As HRESULT
If (flock) Then
cfLock = cfLock + 1
Else
cfLock = cfLock - 1
End If
#ifdef COM_DEBUG
Print #fin, "CF_LOCKSERVER ", cfLock
#EndIf
return NOERROR
End Function
static Shared As IClassFactoryVtbl vtblClassFactory = (@CFQueryInterface,@CFAddRef,@CFRelease,@CFCreateInstance,@CFLockServer)
'CLASS FACTORY CREATOR
Function CFCreate(riid As REFIID , ppv As LPVOID ptr)As HRESULT
Dim As CF Ptr thiss
Dim As HRESULT hr
*ppv = 0
#ifdef COM_DEBUG
Print #fin, "CF_CREATE IN"
#EndIf
thiss= localAlloc(LMEM_FIXED,sizeof(CF Ptr))
If thiss = 0 Then Return E_OUTOFMEMORY
thiss->icf.lpVtbl = @vtblClassFactory
thiss->cRef = 1
hr = thiss->icf.lpVtbl->QueryInterface(@Thiss->icf, riid, ppv)
thiss->icf.lpVtbl->Release(@Thiss->icf) 'If no PB cRef is back to 1, else object is destroyed
#ifdef COM_DEBUG
print #fin ,"CF_CREATE OUT ",thiss,*ppv,hr
#EndIf
return hr
End Function
Extern "windows-ms"
'DLL REQUIRED EXPORTS
#Undef DllGetClassObject
Function DllGetClassObject(rclsid As REFCLSID ,riid As REFIID , ppv As LPVOID Ptr) As HRESULT Export
Dim As HRESULT hr
Static As LPCF pcf = NULL
#ifdef COM_DEBUG
Print #fin, "DLL_GETCLASSOBJECT IN"
#EndIf
*ppv = 0
if(IsEqualCLSID(rclsid, @CLSID_CALCULATOR)) Then
If (pcf = 0) Then 'If no ClassFActory object exists yet
pcf=malloc(SizeOf(pcf))
If (pcf = 0) Then
Return E_OUTOFMEMORY
EndIf
End If
pcf->icf.lpVtbl = @vtblClassFactory
pcf->cRef = 1
#ifdef COM_DEBUG
Print #fin, "DLL_GETCLASSOBJECT 1ST OUT ", vpcfOutside, hr
#EndIf
Return CFQueryInterface(Cast(IClassFactory Ptr,pcf), riid, ppv)
#Ifdef COM_DEBUG
print #fin ,"DLL_GETCLASSOBJECT OUT ",*ppv,hr
#EndIf
End If
#ifdef COM_DEBUG
Print #fin, "DLL_GETCLASSOBJECT OUT WRONG CLSID"
#EndIf
return CLASS_E_CLASSNOTAVAILABLE
End Function
#Undef DllCanUnloadNow
Function DllCanUnloadNow()As HRESULT Export
#ifdef COM_DEBUG
Print #fin, "DLL_CANUNLOAD ", vcObjects, cfLock
#EndIf
return IIf(vcObjects=0 and (cfLock=0) , S_OK , S_FALSE)
End Function
'Called by regsvr32 to set up registry
#Undef DllRegisterServer
Function DllRegisterServer()As HRESULT Export
Return DllRegister("vector.dll", CLSIDS_CALCULATOR,"",PROGID_CALCULATOR)
End Function
'Called by regsvr32 to clear registry
#Undef DllUnregisterServer
Function DllUnregisterServer() As Long Export
Return DllUnregister(CLSIDS_CALCULATOR,"",PROGID_CALCULATOR)
End Function
End Extern
Sub Initialize Constructor
#Ifdef COM_DEBUG
fin = FreeFile
Open COM_DEBUG_LOG For Output As #fin
Print #fin, " DLL_ATTACH"
#EndIf
End Sub
Sub finalize Destructor
#Ifdef COM_DEBUG
Print #fin, "DLL_DETACH ", vcObjects, cfLock
Close (fin)
#EndIf
End Sub
Code: Select all
#ifndef _Vector_bi_
#Define _Vector_bi_
#Include Once "win/ocidl.bi"
#Define PROGID_CALCULATOR "VECTOR.Calculator"
#Define MAX_NAMES_LEN 25
#Ifndef STDMETHOD_
#Define STDMETHOD_(type_not_eused,func_name) func_name As Function
#EndIf
'INTERFACE DEFINITIONS
#undef INTERFACE
#define INTERFACE ICalculator
DECLARE_INTERFACE_ (INTERFACE, IUnknown)
'IUnknown methods
STDMETHOD (QueryInterface) (As THIS_ As REFIID, As Any Ptr Ptr) As HRESULT PURE
STDMETHOD_ (ULONG, AddRef) (As This) As HRESULT PURE
STDMETHOD_ (ULONG, Release) (As This) As HRESULT PURE
'ICalculator Interface Methods
STDMETHOD (ToString) (As THIS_ As ZString Ptr)As HRESULT PURE
STDMETHOD (Set_X) (As THIS_ As Double) As HRESULT PURE
STDMETHOD (Get_X) (As THIS_ As Double Ptr)As HRESULT PURE
STDMETHOD (Set_Y) (As THIS_ As Double) As HRESULT PURE
STDMETHOD (Get_Y) (As THIS_ As Double Ptr)As HRESULT PURE
STDMETHOD (Produit) (As THIS_ As Double Ptr)As HRESULT PURE
STDMETHOD (SetArray) (As THIS_ As VARIANT) As HRESULT PURE
STDMETHOD (GetArray) (As THIS_ As VARIANT Ptr)As HRESULT PURE
STDMETHOD (Determinant)(As THIS_ As Double Ptr)As HRESULT PURE
End Type
Const CLSIDS_CALCULATOR = "{F3CC86AC-AF41-48A3-9CD7-6E94D68E181D}"
Dim Shared CLSID_CALCULATOR As GUID=Type(&hf3cc86ac, &haf41,&h48a3,{&h9c, &hd7, &h6e, &h94, &hd6, &h8e, &h18, &h1d})
Const IIDS_ICalculator = "{A24E8F39-DB3E-475D-91B3-4CBDA589370D}"
Dim Shared IID_ICalculator As GUID=Type(&ha24e8f39, &hdb3e, &h475d, {&h91, &hb3, &h4c, &hbd, &ha5, &h89, &h37, &hd})
Const IIDS_TypeLib ="{440776EB-369D-4ED6-978F-46A3F6DD62FF}"
#DEFINE MatOk 0
' No error
#DEFINE MatSing -2
' Quasi-singular matrix
#DEFINE MatErrDim -3
' Non-compatible dimensions
' ------------------------------------------------------------------
' Machine-dependent constant
' ------------------------------------------------------------------
#DEFINE MachEp 2.220446049250313D-16
' Floating point precision: 2^(-52)
' ------------------------------------------------------------------
' Global variable
' ------------------------------------------------------------------
COMMON SHARED ErrCode AS INTEGER
' Error code from the latest function evaluation
' ******************************************************************
SUB GaussJordan (A() AS DOUBLE, ByRef Det AS DOUBLE)
' ------------------------------------------------------------------
' Gauss-Jordan algorithm for a matrix A(L..N, L..M) with M >= N
' ------------------------------------------------------------------
' On input:
' * The submatrix A(L..N, L..N) contains the system matrix
' * The submatrix A(L..N, (N+1)..M) contains the constant vector(s)
'
' On output:
' * The submatrix A(L..N, L..N) contains the inverse matrix
' * The submatrix A(L..N, (N+1)..M) contains the solution vector(s)
' * The determinant of the system matrix is returned in Det
' * The error code is returned in the global variable ErrCode:
' ErrCode = MatOk ==> no error
' ErrCode = MatErrDim ==> non-compatible dimensions (N < M)
' ErrCode = MatSing ==> quasi-singular matrix
' ------------------------------------------------------------------
DIM AS INTEGER L, N, M ' Bounds of A
DIM AS INTEGER I, J, K ' Loop variables
DIM AS INTEGER Ik, Jk ' Pivot coordinates
DIM AS DOUBLE Pvt ' Pivot
DIM AS DOUBLE T ' Auxiliary variable
L = LBOUND(A, 1)
N = UBOUND(A, 1)
M = UBOUND(A, 2)
IF N > M THEN
ErrCode = MatErrDim
EXIT SUB
END IF
DIM AS INTEGER PRow(L TO N) ' Stores line of pivot
DIM AS INTEGER PCol(L TO N) ' Stores column of pivot
DIM AS DOUBLE MCol(L TO N) ' Stores a column of the matrix
Det = 1
K = L
DO WHILE K <= N
' Search for largest pivot in submatrix A[K..N, K..N]
Pvt = A(K, K)
Ik = K
Jk = K
FOR I = K TO N
FOR J = K TO N
IF ABS(A(I, J)) > ABS(Pvt) THEN
Pvt = A(I, J)
Ik = I
Jk = J
END IF
NEXT J
NEXT I
' Pivot too small ==> quasi-singular matrix
IF ABS(Pvt) < MachEp THEN
Det = 0
ErrCode = MatSing
EXIT SUB
END IF
' Save pivot position
PRow(K) = Ik
PCol(K) = Jk
' Update determinant
Det = Det * Pvt
IF Ik <> K THEN Det = -Det
IF Jk <> K THEN Det = -Det
' Exchange current row (K) with pivot row (Ik)
IF Ik <> K THEN
FOR J = L TO M
SWAP A(K, J), A(Ik, J)
NEXT J
END IF
' Exchange current column (K) with pivot column (Jk)
IF Jk <> K THEN
FOR I = L TO N
SWAP A(I, K), A(I, Jk)
NEXT I
END IF
' Store col. K of A into MCol and set this col. to 0
FOR I = L TO N
IF I <> K THEN
MCol(I) = A(I, K)
A(I, K) = 0
ELSE
MCol(I) = 0
A(I, K) = 1
END IF
NEXT I
' Transform pivot row
FOR J = L TO M
A(K, J) = A(K, J) / Pvt
NEXT J
' Transform other rows
FOR I = L TO N
IF I <> K THEN
T = MCol(I)
FOR J = L TO M
A(I, J) = A(I, J) - T * A(K, J)
NEXT J
END IF
NEXT I
K = K + 1
LOOP
' Exchange lines of whole matrix
FOR I = N TO L STEP -1
Ik = PCol(I)
IF Ik <> I THEN
FOR J = L TO M
SWAP A(I, J), A(Ik, J)
NEXT J
END IF
NEXT I
' Exchange columns of inverse matrix
FOR J = N TO L STEP -1
Jk = PRow(J)
IF Jk <> J THEN
FOR I = L TO N
SWAP A(I, J), A(I, Jk)
NEXT I
END IF
NEXT J
ErrCode = MatOk
END Sub
Sub Gauss_Jordan(ByRef V As VARIANT ,Byref det As Double )
Dim A() As Double
VariantToArray (A() , V)
GaussJordan(A(),det)
V=ArrayToVariant(A())
End Sub
#EndIf /'_Vector_bi_'/Code: Select all
fbc -s gui -dll -export "Vector.bas"
REGSVR32 Vector.dll
pexports Vector.dll>Vector.def
Code: Select all
#Include Once "windows.bi"
#Include Once "win/ocidl.bi"
' MUST BE DEFINED BEFORE #Include "Vector.bi"
#Define IID_BOTH_MODE
#Define CO_DEBUG
#Include Once "Vector.bi"
Dim Shared As ICalculator Ptr pCalc
Dim Shared As Double result
'DON'T FORGET
CoInitialize(NULL)
'FIRST, the simplest way using static IDs and ignoring classFactory:
CoCreateInstance(@CLSID_VECTOR_OBJ, NULL, CLSCTX_ALL, @IID_ICalculator, Cast (Any Ptr, @pCalc))
Dim s As ZString*25
pCalc->lpVtbl->Set_X(pCalc,250)
pCalc->lpVtbl->Set_Y(pCalc,30)
pCalc->lpVtbl->Produit(pCalc,@result)
pCalc->lpVtbl->ToString(pCalc,@s)
pCalc->lpVtbl->Release(pCalc)
print "Called pCalc.Produit, value:";result ; " (should be 750.00) "
Print
Print "called pCalc.Tostring: "; s
CoUninitialize()
Sleep