Building com objects with FB

Windows specific questions.
aloberoger
Posts: 495
Joined: Jan 13, 2009 19:23

Building com objects with FB

Postby aloberoger » Nov 24, 2011 18:13

I have created somme dll com with FB, but this simplified exemple in test.bas have a problem of memory leack.
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








Vector.bi

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_'/

bath for compilation

Code: Select all

fbc -s gui -dll -export "Vector.bas"   
REGSVR32  Vector.dll
pexports Vector.dll>Vector.def

test.bas

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
Last edited by aloberoger on Feb 13, 2012 12:02, edited 1 time in total.
aloberoger
Posts: 495
Joined: Jan 13, 2009 19:23

Re: Building com objects with FB

Postby aloberoger » Feb 01, 2012 9:23

Au Bout du compte où en sommes-nous avec les dll com en FB ?
Here is another example

fbpoint.bas

Code: Select all

' InProc COM Server Component
' Supports IUnknown interface - minimum for com components
 
' advises: becarfull when editing without knowledges of com rules
 ' Just compile the dll in the current path. advise:  avoid to copy the dll to another place without unregister it
  'the good thing is to create a fbedit project and set the path of the dll in system32 by doing so we don't have to worry about ...
 
 /' TODO:
  Implement:
     - multiple interfaces
     - callings object in parameters
     - Idispatch --> to use with VB
     - embeding .tlb
     - collections
     
 
 '/
 
 #Include Once "windows.bi"
 #Include Once "crt.bi"
 #Include Once "win/ocidl.bi"
 


CONST MY_DLL_NAME = "fbpoint.dll"

CONST ProgID_POINT = "fbpoint.point"

                                 '' {B7356EE6-2222-4441-8A2C-E7C7BD4A5E3E}
Dim Shared  IID_POINT As IID =Type(&hb7356ee6, &h2222, &h4441, {&h8a, &h2c, &he7, &hc7, &hbd, &h4a, &h5e, &h3e})


                                '' {5C35001F-6D3A-4f67-92C4-FEB629AB932C}
Dim Shared  CLSID_POINT As IID=Type(&h5c35001f, &h6d3a, &h4f67, {&h92, &hc4, &hfe, &hb6, &h29, &hab, &h93, &h2c})
Static Shared CLSIDS_POINT As ZString*2048 = "{5C35001F-6D3A-4f67-92C4-FEB629AB932C}"



 
#define _UNICODE

'convert string to bstr
'please follow with sysfreestring(bstr) after use to avoid memory leak
Function StringToBSTR(cnv_string As String) As BSTR
    Dim sb As BSTR
    Dim As Integer n
    n = (MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, cnv_string, -1, NULL, 0))-1
    sb=SysAllocStringLen(sb,n)
    MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, cnv_string, -1, sb, n)
    Return sb
End Function

Function BstrToStr(ByVal szW As BSTR ) As String
   Static szA As ZString*256
   If szW=NULL Then Return ""
   WideCharToMultiByte(CP_ACP,0,SzW,-1,SzA,256,NULL,NULL)
   Return szA
End Function


Type POINTVtbl_ As POINTVtbl

type  POINTD
     lpVtbl  As  POINTVtbl_ Ptr
End Type

Type POINTVtbl
 
/'implements IUnknown interface'/
  QueryInterface As Function (As POINTD Ptr, As REFIID ,  As LPVOID Ptr)  As HRESULT
  AddRef  As Function(As POINTD Ptr) As ULong
  Release  As Function(As POINTD Ptr)  As ULong

/'POINTD functions'/
  Affiche As Function(As POINTD Ptr) As HRESULT
  Get_x  As Function(As POINTD Ptr, Byval As Double Ptr )  As HRESULT
  put_x  As Function (As POINTD Ptr, As Double )  As HRESULT
  Get_y  As Function(As POINTD Ptr, Byval As Double Ptr )  As HRESULT
  put_y  As Function (As POINTD Ptr, As Double )  As HRESULT
  Norme As Function(As POINTD Ptr, Byval As Double Ptr  )  As HRESULT
  Angle As Function(As POINTD Ptr, Byval As Double Ptr  )  As HRESULT
  put_Name As Function(As POINTD Ptr, Byval As BSTR) As HRESULT
  Get_Name  As Function(As POINTD Ptr, Byval As BSTR Ptr) As HRESULT
End Type

 
TYPE POINT_ClassFactory
          icf         AS IClassFactory
          cRef        AS Integer
END TYPE


TYPE OBJ_POINT 
       Im  As POINTD
       cRef AS INTEGER
       m_x AS Double
       m_y AS Double
       tex As BSTR
End Type

TYPE CLASS_POINT
    Im AS POINTD
    cRef As Integer
    m_x AS Double
    m_y AS Double
    tex As BSTR
END TYPE





DIM SHARED OBJECT_USAGE_COUNTER AS UINT





#Include "pointclassfactory.bas"




Function RegString (hKey As HKEY , RegPath As ZString Ptr,SubKey  As ZString Ptr)As String
  Dim Result As ZString*2048 
  Dim As integer BufferLen=2048
  if(0=RegOpenKeyEx(hKey,RegPath,0,KEY_QUERY_VALUE,@hKey))Then
      RegQueryValueEx(hKey,SubKey,0,0,cast(LPBYTE,@Result),cast(LPDWORD,@BufferLen))
  End If
  RegCloseKey(hKey)
  return Result
End function


Sub CreateRegString (HK As HKEY ,Key  As ZString Ptr,VarName  As ZString Ptr,Value  As ZString Ptr)
  Dim As HKEY  hKey
  dim Buff As ZString*100 
  Dim As DWORD  Result
  RegCreateKeyEx(HK,Key,0,@Buff,REG_OPTION_NON_VOLATILE,KEY_ALL_ACCESS,0,@hKey,@Result)
  RegSetValueEx(hKey,VarName,0,REG_SZ,Cast(LPBYTE,Value),cast(DWORD,lstrlen(Value))+1)
  RegCloseKey(hKey)
End Sub


Sub DeleteRegKey (HK As HKEY , Key As ZString Ptr)
  RegDeleteKey(HK,Key)
End Sub




Extern "windows-ms"
' *************************************************************************************************************
' called by REGSVR32.exe when registering com inproc server;  Example: REGSVR32 fbpoint.dll
' *************************************************************************************************************
FUNCTION DllRegisterServer() AS Long  EXPORT
Dim lv_temp_str As ZString*2048
Dim lv_varstr As ZString*2048


CREATEREGSTRING(HKEY_CLASSES_ROOT,ProgID_POINT,NULL,ProgID_POINT)
CREATEREGSTRING(HKEY_CLASSES_ROOT,ProgID_POINT & "\CLSID",NULL,CLSIDS_POINT)
' prepare entery for HKEY_CLASSES_ROOT
lv_varstr = ProgID_POINT
lv_temp_str = "CLSID\" & CLSIDS_POINT
CREATEREGSTRING(HKEY_CLASSES_ROOT,lv_temp_str,NULL,lv_varstr)
CREATEREGSTRING(HKEY_CLASSES_ROOT,lv_temp_str,"AppID",CLSIDS_POINT) ' aa
' define localtion of dll in system32
lv_temp_str = "CLSID\" & CLSIDS_POINT & "\InprocServer32"

lv_varstr = SPACE$(1024)
GetModuleFileName(GetModuleHandle(MY_DLL_NAME),lv_varstr,LEN(lv_varstr))

lv_varstr = TRIM$(lv_varstr)
CREATEREGSTRING(HKEY_CLASSES_ROOT,lv_temp_str,NULL,lv_varstr)


lv_temp_str = TRIM$(REGSTRING(HKEY_CLASSES_ROOT,lv_temp_str,NULL))

IF lv_temp_str <> lv_varstr THEN ' VERIFY THAT CORRECT VALUE IS WRITTEN IN REGISTRY
    Return  S_FALSE
END IF

lv_temp_str = "CLSID\" & CLSIDS_POINT & "\ProgID"
CREATEREGSTRING(HKEY_CLASSES_ROOT,lv_temp_str,NULL,ProgID_POINT)

 Return  S_OK
END FUNCTION


' *************************************************************************************************************
' called by REGSVR32.exe when /U parameter is specified (uninstall);  Example: REGSVR32 /U fbpoint.dll
' *************************************************************************************************************
FUNCTION DllUnregisterServer() AS HRESULT  EXPORT
Dim lv_temp_str As ZString*2048

DeleteRegKey(HKEY_CLASSES_ROOT,ProgID_POINT & "\CLSID")
DeleteRegKey(HKEY_CLASSES_ROOT,"\" & ProgID_POINT)




'''''''''''''
  lv_temp_str  = "CLSID\" & CLSIDS_POINT & "\InprocServer32"
  DELETEREGKEY (HKEY_CLASSES_ROOT,lv_temp_str)
   
  lv_temp_str = "CLSID\" & CLSIDS_POINT & "\ProgID"
  DeleteRegKey (HKEY_CLASSES_ROOT,lv_temp_str) 
   
  lv_temp_str = "CLSID\" & CLSIDS_POINT
  DeleteRegKey (HKEY_CLASSES_ROOT,lv_temp_str)
  FUNCTION =  S_OK
END FUNCTION


' *************************************************************************************************************
'             DllCanUnloadNow function tests if all copies of object are released, before unloading dll
' *************************************************************************************************************
#Undef DllCanUnloadNow
FUNCTION DllCanUnloadNow() AS HRESULT  EXPORT
    IF OBJECT_USAGE_COUNTER = 0 THEN  ' ALL COPIES OF OBJECTS ARE RELEASED, RETURN S_OK
        Return  S_OK
    END IF   
        Return S_FALSE ' NOT ALL OBJECTS RELEASED, RETURN S_FALSE
END FUNCTION



' *************************************************************************************************************
' interface for class factory
' *************************************************************************************************************
#Undef DllGetClassObject
FUNCTION DllGetClassObject(rclsid AS REFCLSID, riid AS REFIID , ppv AS LPVOID PTR) AS HRESULT  EXPORT
 Static As POINT_ClassFactory ptr  pCF = NULL

IF IsEqualCLSID( @CLSID_POINT, rclsid ) THEN
    IF pCF = NULL THEN
            pCF = malloc(sizeof(pCF))
            IF pCF = NULL THEN
                Return E_OUTOFMEMORY
            END IF
    END IF
    pCF->icf.lpVtbl = @(POINTCFVT)
    pCF->cRef = 0
   
    Return  POINT_CFQueryInterface(Cast(IClassFactory Ptr,pCF), riid, ppv )
END IF
   
    Return  CLASS_E_CLASSNOTAVAILABLE
End FUNCTION

End Extern


pointclassfactory.bas

Code: Select all

' INTERFACE AND FUNCTIONS
Function POINT_QueryInterface (pIm as POINTD PTR, iid AS REFIID, ppv AS LPVOID Ptr) AS HRESULT
Dim  iidIBCX as IID
DIM  pThis as OBJ_POINT  PTR

iidIBCX = IID_POINT
pThis   = Cast(OBJ_POINT  ptr,pIm)

IF IsEqualIID( iid, @IID_IUnknown) Then
   *ppv = @(pThis->Im)
  pIm->lpVtbl->AddRef(pIm)
 Return  S_OK

ElseIF IsEqualIID( iid, @IID_POINT) THEN
         *ppv = @(pThis->Im)
         pIm->lpVtbl->AddRef(pIm)
   Return  S_OK
END IF

ppv = NULL
FUNCTION =  E_NOINTERFACE
End Function


Function POINT_AddRef(pIm AS POINTD PTR) AS ULONG
Dim   pThis as OBJ_POINT  PTR
pThis = Cast(OBJ_POINT  Ptr,pIm)
  pThis->cRef +=1
Function =  pThis->cRef
End Function


Function POINT_Release(pIm AS POINTD PTR) AS ULONG
Dim   pThis as OBJ_POINT  PTR
pThis = Cast(OBJ_POINT  Ptr,pIm)
  pThis->cRef -=1
  If pThis->tex Then SysFreeString(pthis->tex)
IF pThis->cRef <= 0 THEN
  OBJECT_USAGE_COUNTER -=1
free(pThis)
  Return 0
END IF

FUNCTION = pThis->cRef
End Function

FUNCTION POINT_Affiche(pIm as POINTD PTR)As HRESULT
  DIM   pThis as OBJ_POINT  PTR
   pThis = Cast(OBJ_POINT  Ptr,pIm)
  Dim s As ZString*256
  s = BstrToStr(pThis->tex) &  " x = " & pThis->m_x & "  y = " & pThis->m_y
    MessageBox(GetActivewindow(),s,"POINT COM WITH FB",MB_OK)
    Function = S_OK
End Function


FUNCTION POINT_Get_x(pIm as POINTD PTR, BYVAL invalue AS DOUBLE Ptr) AS HRESULT
   
   DIM   pThis as OBJ_POINT  PTR
   pThis = Cast(OBJ_POINT  Ptr,pIm)
   *invalue =  pThis->m_x
    FUNCTION = S_OK
END FUNCTION


Function POINT_put_x(pIm as POINTD PTR,  NewValue AS DOUBLE) AS HRESULT
   Dim   pThis as OBJ_POINT  PTR
   pThis   = cast(OBJ_POINT  Ptr,pIm)
   pThis->m_x = NewValue
   Function = S_OK
End Function

FUNCTION POINT_Get_y(pIm as POINTD PTR, BYVAL invalue AS DOUBLE Ptr) AS HRESULT
   
   DIM   pThis as OBJ_POINT  PTR
   pThis = Cast(OBJ_POINT  Ptr,pIm)
   *invalue =  pThis->m_y
    FUNCTION = S_OK
END FUNCTION


Function POINT_put_y(pIm as POINTD PTR,  NewValue AS DOUBLE) AS HRESULT
   Dim   pThis as OBJ_POINT  PTR
   pThis   = cast(OBJ_POINT  Ptr,pIm)
   pThis->m_y = NewValue
   Function = S_OK
End Function

Function POINT_Norme(pIm As POINTD Ptr, ByVal retvalue As DOUBLE Ptr  )  As HRESULT
   DIM   pThis as OBJ_POINT  PTR
   pThis   = cast(OBJ_POINT  Ptr,pIm)
  *retValue = (pThis->m_x) * (pThis->m_y)
Function = S_OK
End Function
 
 Function POINT_Angle(pIm As POINTD Ptr, ByVal retvalue As DOUBLE Ptr  )  As HRESULT
   DIM   pThis as OBJ_POINT  PTR
   pThis   = cast(OBJ_POINT  Ptr,pIm)
  *retValue = ATan2(pThis->m_y,pThis->m_x)
Function = S_OK
 End Function
 
 Function POINT_put_Name(pIm As POINTD Ptr, Byval  lpstr As BSTR) As HRESULT
        DIM   pThis as OBJ_POINT  PTR
        pThis   = cast(OBJ_POINT  Ptr,pIm)
        If  pthis->tex Then SysFreeString(pThis->tex)
        pThis->tex = SysAllocString(lpstr) ' store a copy of the string
        If pThis->tex = 0 Then Function= E_OUTOFMEMORY Else Function=NOERROR
End Function

Function POINT_Get_Name(pIm As POINTD Ptr, Byval buffer As BSTR Ptr) As HRESULT
      DIM   pThis as OBJ_POINT  PTR
      pThis   = cast(OBJ_POINT  Ptr,pIm) 
        If buffer=0 Then Return E_POINTER
        *buffer=SysAllocString(pThis->tex)
        If *buffer=0 Then Function = E_OUTOFMEMORY Else Function=NOERROR
End Function

Dim Shared As POINTVtbl POINTVT = Type(@POINT_QueryInterface, _
                                   @POINT_AddRef, _
                                   @POINT_Release, _
                                   @POINT_Affiche, _
                                   @POINT_Get_x, _
                                   @POINT_put_x , @POINT_Get_y,@POINT_put_y,@POINT_Norme,@POINT_Angle, _
                                   @POINT_put_Name,@POINT_Get_Name)
 

' ------------------------------------------------------------------------------------------------------------------
' *********************************************   CLASS FACTORY    *************************************************
' ------------------------------------------------------------------------------------------------------------------
FUNCTION POINT_CFQueryInterface(pCF AS IClassFactory PTR, iid AS REFIID, ppvObject AS LPVOID PTR) AS HRESULT
Dim   pThis as POINT_ClassFactory PTR
pThis = Cast(POINT_ClassFactory Ptr,pCF)
IF IsEqualIID( iid, @IID_IUnknown) Or IsEqualIID( iid, @IID_IClassFactory) THEN
 *ppvObject = pThis
pThis->icf.lpVtbl->AddRef(pCF)
 Return  S_OK
End IF

*ppvObject = NULL
FUNCTION =  E_NOINTERFACE
END FUNCTION

FUNCTION POINT_CFAddRef(pCF AS IClassFactory PTR) AS ULONG
Dim   pThis as POINT_ClassFactory PTR
pThis = cast(POINT_ClassFactory Ptr,pCF)
  pThis->cRef +=1
FUNCTION = pThis->cRef
END FUNCTION

FUNCTION  POINT_CFRelease( pCF AS IClassFactory PTR) AS ULONG
Dim   pThis as POINT_ClassFactory PTR
pThis = Cast(POINT_ClassFactory Ptr,pCF)
  pThis->cRef -=1
IF pThis->cRef = 0 THEN
free( pThis )
  Return  0
END IF
FUNCTION = pThis->cRef
END FUNCTION


FUNCTION POINT_CFCreateInstance( pICF AS IClassFactory PTR, pUnkOuter AS IUnknown PTR, riid AS REFIID, ppvObject AS LPVOID PTR) AS HRESULT
Dim   pThis as POINT_ClassFactory PTR
DIM   pCM AS CLASS_POINT  PTR

pThis = cast(POINT_ClassFactory Ptr,pICF)
IF pUnkOuter <> NULL then
   Return  CLASS_E_NOAGGREGATION
END IF

pCM = Cast(CLASS_POINT  Ptr,malloc(SizeOf(CLASS_POINT)))
IF NULL = pCM THEN
 Return  E_OUTOFMEMORY
END IF

pCM->Im.lpVtbl = @POINTVT
pCM->cRef = 1
' Initialisations
pCM->m_x=0.0
pCM->m_y=0.0
pCM->tex =stringtobstr("Point1")
If  S_OK <> pCM->Im.lpVtbl->QueryInterface(@(pCM->Im), riid, ppvObject) THEN
free( pCM )
   Return  E_NOINTERFACE
END IF

pCM->Im.lpVtbl->Release(@(pCM->Im))
  OBJECT_USAGE_COUNTER +=1

 ' increment the count of OBJECT_USAGE_COUNTER so we know when to return TRUE in DllCanUnloadNow 
Function =  S_OK
END FUNCTION

FUNCTION POINT_CFLockServer( pICF AS IClassFactory PTR, fLock AS BOOL) AS HRESULT
If fLock = TRUE THEN
  OBJECT_USAGE_COUNTER +=1
ELSE
  OBJECT_USAGE_COUNTER -=1
END IF
FUNCTION = S_OK
END FUNCTION


 

Static Shared As IClassFactoryVtbl POINTCFVT = Type(@POINT_CFQueryInterface, _
                                                @POINT_CFAddRef, _
                                                @POINT_CFRelease, _
                                                @POINT_CFCreateInstance,  _
                                                @POINT_CFLockServer)
 


Register the dll you can use:
REM CD %WINDIR%\SYSTEM32
REGSVR32 FBPoint.dll
in a .bat file

fbpoint_test1.bas

Code: Select all

' This example show how to use com fbpoint with IID and CoCreateInstance



#include Once "windows.bi"
#include Once "win/ocidl.bi"
 


 

                                 '' {B7356EE6-2222-4441-8A2C-E7C7BD4A5E3E}
Dim Shared  IID_POINT As IID =Type(&hb7356ee6, &h2222, &h4441, {&h8a, &h2c, &he7, &hc7, &hbd, &h4a, &h5e, &h3e})


                                '' {5C35001F-6D3A-4f67-92C4-FEB629AB932C}
Dim Shared  CLSID_POINT As IID=Type(&h5c35001f, &h6d3a, &h4f67, {&h92, &hc4, &hfe, &hb6, &h29, &hab, &h93, &h2c})


 
 



Type POINTVtbl_ As POINTVtbl

type  POINTD
     lpVtbl  As  POINTVtbl_ Ptr
End Type

Type POINTVtbl
  QueryInterface As Function (As POINTD Ptr, As REFIID ,  As LPVOID Ptr)  As HRESULT
  AddRef  As Function(As POINTD Ptr) As ULong
  Release  As Function(As POINTD Ptr)  As ULong

  Affiche As Function(As POINTD Ptr) As HRESULT
  Get_x  As Function(As POINTD Ptr, Byval As Double Ptr )  As HRESULT
  put_x  As Function (As POINTD Ptr, As Double )  As HRESULT
  Get_y  As Function(As POINTD Ptr, ByVal As Double Ptr )  As HRESULT
  put_y  As Function (As POINTD Ptr, As Double )  As HRESULT
  Norme As Function(As POINTD Ptr, Byval As Double Ptr  )  As HRESULT
  Angle As Function(As POINTD Ptr, Byval As Double Ptr  )  As HRESULT
  put_Name As Function(As POINTD Ptr, Byval As BSTR) As HRESULT
  Get_Name  As Function(As POINTD Ptr, Byval As BSTR Ptr) As HRESULT
End Type


'convert string to bstr
'please follow with sysfreestring(bstr) after use to avoid memory leak
Function StringToBSTR(cnv_string As String) As BSTR
    Dim sb As BSTR
    Dim As Integer n
    n = (MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, cnv_string, -1, NULL, 0))-1
    sb=SysAllocStringLen(sb,n)
    MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, cnv_string, -1, sb, n)
    Return sb
End Function

Function BstrToStr(ByVal szW As BSTR ) As String
   Static szA As ZString*256
   If szW=NULL Then Return ""
   WideCharToMultiByte(CP_ACP,0,SzW,-1,SzA,256,NULL,NULL)
   Return szA
End Function




''''''''''' START '''''''''''''''''''''''''''''''''''''''
DIM  pd as POINTD Ptr

Dim hr AS HRESULT

If S_OK <> OleInitialize( 0 )  Then
    Print "Error: Couldn't initialize OLE!" 
End if

pd = NULL

hr = CoCreateInstance(@CLSID_POINT,0,CLSCTX_INPROC_SERVER,@IID_POINT,cast(LPVOID PTR,@pd))
If hr=S_OK Then
     
    DIM dResult AS Double
    Dim mbstr As BSTR
   
    pd->lpVtbl->Affiche(pd)   'messagebox
   
   
    pd->lpVtbl->put_x(pd, 5.0)
    pd->lpVtbl->put_y(pd,4.0)
    mbstr=StringToBSTR("POINT N° 1 ")
    pd->lpVtbl->put_Name(pd,mbstr)
   
    pd->lpVtbl->Norme(pd,@dResult)
    Print "Norme: " ; Str(dResult)
    pd->lpVtbl->Angle(pd,@dResult)
    Print "POINT Angle: " ; Str(dResult)
   
    pd->lpVtbl->Affiche(pd) 'messagebox
   
    SysFreeString(mbstr)
End IF   

  pd->lpVtbl->Release(pd)
  OleUninitialize()

Sleep







fbpoit_test2.bas

Code: Select all

' This example show How to use Programmatic ID and createobject like in vb


#include Once "windows.bi"
#include Once "win/ocidl.bi"
 


CONST  ProgID_POINT = "fbpoint.point"
Const  IID_POINT    = "{B7356EE6-2222-4441-8A2C-E7C7BD4A5E3E}"
CONST  CLSIDS_POINT = "{5C35001F-6D3A-4f67-92C4-FEB629AB932C}"



 
Type POINTVtbl_ As POINTVtbl

type  POINTD
     lpVtbl  As  POINTVtbl_ Ptr
End Type

Type POINTVtbl
  QueryInterface As Function (As POINTD Ptr, As REFIID ,  As LPVOID Ptr)  As HRESULT
  AddRef  As Function(As POINTD Ptr) As ULong
  Release  As Function(As POINTD Ptr)  As ULong

  Affiche As Function(As POINTD Ptr) As HRESULT
  Get_x  As Function(As POINTD Ptr, Byval As Double Ptr )  As HRESULT
  put_x  As Function (As POINTD Ptr, As Double )  As HRESULT
  Get_y  As Function(As POINTD Ptr, ByVal As Double Ptr )  As HRESULT
  put_y  As Function (As POINTD Ptr, As Double )  As HRESULT
  Norme As Function(As POINTD Ptr, Byval As Double Ptr  )  As HRESULT
  Angle As Function(As POINTD Ptr, Byval As Double Ptr  )  As HRESULT
  put_Name As Function(As POINTD Ptr, Byval As BSTR) As HRESULT
  Get_Name  As Function(As POINTD Ptr, Byval As BSTR Ptr) As HRESULT
End Type





' HELPER FUNCTIONS

#define W2Ansi(A,W)  WideCharToMultiByte(CP_ACP,0,W,-1,A,2047,0,0)
#define A2Wide(A,W,L)  MultiByteToWideChar(CP_ACP,0,A,-1,W,L)


Function UnicodeToAnsi(ByVal szW As OLECHAR Ptr ) As String
   Static szA As ZString*256
   If szW=NULL Then Return ""
   WideCharToMultiByte(CP_ACP,0,SzW,-1,SzA,256,NULL,NULL)
   Return szA
End Function

Function AnsiToUnicode(A As String) As OLECHAR Ptr
   Dim W As  OLECHAR Ptr
   Dim length As Integer
   length=(2 * Len(A)) + 1
   A2Wide(StrPtr(A),W,length)
   Return W
End Function

/' Convert a string to a GUID '/

function StringToGUID(S As const  string)as GUID
   Dim Result As GUID
  CLSIDFromString(WStr(S), @Result)
  Return Result
end function

/' Convert a GUID to a string '/

function GUIDToString( ClassID As GUID) As string
  dim P As Wstring Ptr
  StringFromCLSID(@ClassID, Cast(LPOLESTR Ptr,@P))
  GUIDToString = *P
  CoTaskMemFree(P)
end function

/' Convert a programmatic ID to a class ID '/

function ProgIDToClassID( ProgID As Const String)As GUID
   Dim Result As GUID
  CLSIDFromProgID(WStr(ProgID), @Result)
  Return Result
end function

/' Convert a class ID to a programmatic ID '/

function ClassIDToProgID(ClassID As GUID)As string
 
 dim P As Wstring Ptr
 
  ProgIDFromCLSID(@ClassID, Cast(LPOLESTR Ptr,@P))
  ClassIDToProgID = *P
  CoTaskMemFree(P)
end function



function CreateComObject(ClassID as GUID)as IUnknown Ptr
  Dim Result as IUnknown
  CoCreateInstance(@ClassID, NULL, CLSCTX_INPROC_SERVER or CLSCTX_LOCAL_SERVER, @IID_IUnknown, @Result)
  Return @Result
end function

function CreateOleObject(ClassName As const  string)As IDispatch Ptr
 Dim Result As IDispatch
 dim ClassID As CLSID
   ClassID = ProgIDToClassID(ClassName)
   CoCreateInstance(@ClassID, NULL, CLSCTX_INPROC_SERVER Or CLSCTX_LOCAL_SERVER, @IID_IDispatch, @Result)
  Return  @Result
end function



SUB CreateObject OverLoad(BYVAL strProgID AS String,byref ppv as lpvoid,ByVal clsctx As Integer=CLSCTX_INPROC_SERVER Or CLSCTX_LOCAL_SERVER OR CLSCTX_REMOTE_SERVER)
   Dim pDispatch As IDispatch Ptr
   Dim pUnknown As IUnknown Ptr
   Dim hr As HRESULT
 dim ClassID As CLSID
   ClassID = ProgIDToClassID(strProgID)
   
  hr = CoCreateInstance(@ClassID,null,clsctx, @IID_IUnknown, @pUnknown)
   IF hr<>0 OR pUnknown=0 THEN EXIT Sub
   
   ' Ask for the dispatch interface
   hr = IUnknown_QueryInterface(pUnknown, @IID_IDispatch, @pDispatch)
   ' If it fails, return the Iunknown interface
   IF hr<>0 OR pDispatch=0 Then      
      ppv = pUnknown
      Exit SUB
   End IF
   ' Release the IUnknown interface
   IUnknown_Release(pUnknown)
   ' Return a pointer to the dispatch interface
   ppv = pDispatch
   
END Sub

Function CreateObject (BYVAL strProgID AS String,ByVal clsctx As Integer=CLSCTX_INPROC_SERVER Or CLSCTX_LOCAL_SERVER OR CLSCTX_REMOTE_SERVER)as lpvoid
   Dim pDispatch As IDispatch Ptr
   Dim pUnknown As IUnknown Ptr
   Dim ppv As lpvoid
   Dim hr As HRESULT
 dim ClassID As CLSID
   ClassID = ProgIDToClassID(strProgID)
 
  hr = CoCreateInstance(@ClassID,null,clsctx, @IID_IUnknown, @pUnknown)
   IF hr<>0 OR pUnknown=0 THEN Return NULL
   
   ' Ask for the dispatch interface
   hr = IUnknown_QueryInterface(pUnknown, @IID_IDispatch, @pDispatch)
   ' If it fails, return the Iunknown interface
   IF hr<>0 OR pDispatch=0 Then      
      Return pUnknown
      
   End If
   ' Release the IUnknown interface
   IUnknown_Release(pUnknown)
   ' Return a pointer to the dispatch interface
   Return pDispatch
   
END Function






''''''''''''''''''''''''MAIN PROG '''''''''''''''''''''''''''''''''''

DIM SHARED pd as POINTD Ptr 
Dim s As ZString*40
 

       OleInitialize(NULL)
       pd=CreateObject(ProgID_POINT)

      s=GUIDToString(ProgIDToClassID(ProgID_POINT))
      Print s
        
    DIM dResult AS DOUBLE
    pd->lpVtbl->Affiche(pd)
    pd->lpVtbl->put_x(pd, 5.0)
    pd->lpVtbl->put_y(pd,4.0)
   
    pd->lpVtbl->Norme(pd,@dResult)
   
    Print "Norme: " & Str(dResult)
    pd->lpVtbl->Angle(pd,@dResult)
    Print "POINT Angle: " & Str(dResult)
    pd->lpVtbl->Affiche(pd)
     

  pd->lpVtbl->Release(pd)
  OleUninitialize()


Sleep


VANYA
Posts: 1465
Joined: Oct 24, 2010 15:16
Location: Ярославль
Contact:

Re: Building com objects with FB

Postby VANYA » Feb 01, 2012 10:07

aloberoger!

I can not. I have run the BAT file. DLL is created. However, registration must be done manually from the CMD. In fact, if Vector.dll registered, you can not remove the DLL without unregistering but the file can be easily removed. Example File test.bas throws out the error.

freebasic 0.22
Windows7 home edition
aloberoger
Posts: 495
Joined: Jan 13, 2009 19:23

Re: Building com objects with FB

Postby aloberoger » Feb 03, 2012 8:28

I have noticed that because FB call automaticaly Libmain, there is somme troubles implementing libmain in a dll. I Will give you somme examples(creating controls , or dll of ressources) to justify this. However I advise you to try with FBpoint simply compile the file FBpoint.bas to a dll and register it, the things work perfectly. You can back to the vector example and remove libmain,but with appropriate a correction.
VANYA
Posts: 1465
Joined: Oct 24, 2010 15:16
Location: Ярославль
Contact:

Re: Building com objects with FB

Postby VANYA » Feb 03, 2012 9:37

aloberoger wrote:I have noticed that because FB call automaticaly Libmain, there is somme troubles implementing libmain in a dll. I Will give you somme examples(creating controls , or dll of ressources) to justify this. However I advise you to try with FBpoint simply compile the file FBpoint.bas to a dll and register it, the things work perfectly. You can back to the vector example and remove libmain,but with appropriate a correction.


Yes, your example FBpoint works fine, thanks. A very useful example.
Interacting with COM - NOT easy to understand. I hope you will please us to have other examples.
aloberoger
Posts: 495
Joined: Jan 13, 2009 19:23

Re: Building com objects with FB

Postby aloberoger » Feb 03, 2012 12:48

Here is another example, I wil answer of your desires very soon.
This is example a Loé example "welcom.dll"

WelCOM.bas

Code: Select all


#Include Once "windows.bi"
#Include Once "win/ocidl.bi"
#Include Once "crt.bi"

#define INITGUID



Static Shared OutstandingObjects As DWORD
Static Shared LockCount As DWORD

Dim Shared CLSID_TypeLib As GUID=Type(&h26a8002a, &h83d7, &h45eb,{ &h98, &he1, &h9, &hcf, &h47, &ha4, &he, &he3})
Dim Shared CLSID_MyObject As GUID=Type(&hf2e0ac34, &h64ba, &h4871,{ &hbb, &hfc, &hb9, &hde, &h5b, &hd9, &hc8, &hb})
Dim Shared IID_MyObject As GUID=Type(&h2a2af189, &hc5a1, &h4a4e,{ &h92, &h77, &hb4, &hfd, &h87, &h1a, &h51, &h19})

Const CLSIDS_TypeLib  = "{26A8002A-83D7-45eb-98E1-09CF47A40EE3}"
Const CLSIDS_MyObject = "{F2E0AC34-64BA-4871-BBFC-B9DE5BD9C80B}"
Const IIDS_MyObject   = "{2A2AF189-C5A1-4a4e-9277-B4FD871A5119}"


'==========================================================
'registry
'==========================================================
Dim Shared DllName As Zstring*128=>"WellCOM.dll"
Dim Shared ObjDescription As Zstring*128=>"Intermediary between DLL host and COM client"
Dim Shared FileDlgTitle As Zstring*128=>"Locate WellCOM.dll to register it"
Dim Shared FileDlgExt As Zstring*128=>"DLL files\000*.dll\000\000"
Dim Shared CLSID_Str As Zstring*128=>"CLSID"
Dim Shared ClassKeyName As Zstring*128=>"Software\\Classes"
Dim Shared InprocServer32Name As Zstring*128=>"InprocServer32"
Dim Shared ThreadingModel As Zstring*128=>"ThreadingModel"
Dim Shared BothStr As Zstring*128=>"both"
Dim Shared ProgID As Zstring*128=>"WellCOM.Object"
Dim Shared TypeLibName As Zstring*128=>"WellCOM.dll"

Dim Shared result As Long,ghDLLInst as HMODULE
Dim Shared filename As Zstring*MAX_PATH
Dim Shared rootKey As hkey
Dim Shared hKey1 As HKEY
Dim Shared hKey2 As HKEY
Dim Shared hkextra As HKEY
Dim Shared GUIDtxt As Zstring*39
Dim Shared disposition As DWORD
Dim Shared sa As SECURITY_ATTRIBUTES

Declare Function SetKeyAndValue(ByRef szKey As string, ByRef szSubKey As string, ByRef szValue As String) As Long
 
 

#define W2Ansi(A,W)  WideCharToMultiByte(CP_ACP,0,W,-1,A,2047,0,0)
#define A2Wide(A,W,L)  MultiByteToWideChar(CP_ACP,0,A,-1,W,L)

Function UnicodeToAnsi(ByVal szW As OLECHAR Ptr ) As String
   Static szA As ZString*256
   If szW=NULL Then Return ""
   WideCharToMultiByte(CP_ACP,0,SzW,-1,SzA,256,NULL,NULL)
   Return szA
End Function

Function AnsiToUnicode(A As String) As OLECHAR Ptr
   Dim W As  OLECHAR Ptr
   Dim length As Integer
   length=(2 * Len(A)) + 1
   A2Wide(StrPtr(A),W,length)
   Return W
End Function
'convert string to bstr
'please follow with sysfreestring(bstr) after use to avoid memory leak
Function StringToBSTR(cnv_string As String) As BSTR
    Dim sb As BSTR
    Dim As Integer n
    n = (MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, cnv_string, -1, NULL, 0))-1
    sb=SysAllocStringLen(sb,n)
    MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, cnv_string, -1, sb, n)
    Return sb
End Function

Function s2guid(txt As String)As guid
        Static oGuid As guid
        iidfromstring(wstr(txt),@oGuid)
        Return oGuid
End Function

Function guid2s(iguid As guid)As String
        Dim oGuids As Wstring Ptr
        stringfromiid(@iGuid,Cast(LPOLESTR Ptr,@oguids))
        Return *oGuids
End Function


Function RegString (hKey As HKEY , RegPath As ZString Ptr,SubKey  As ZString Ptr)As String
  Dim Result As ZString*2048 
  Dim As integer BufferLen=2048
  if(0=RegOpenKeyEx(hKey,RegPath,0,KEY_QUERY_VALUE,@hKey))Then
      RegQueryValueEx(hKey,SubKey,0,0,cast(LPBYTE,@Result),cast(LPDWORD,@BufferLen))
  End If
  RegCloseKey(hKey)
  return Result
End function


Sub CreateRegString (HK As HKEY ,Key  As ZString Ptr,VarName  As ZString Ptr,Value  As ZString Ptr)
  Dim As HKEY  hKey
  dim Buff As ZString*100 
  Dim As DWORD  Result
  RegCreateKeyEx(HK,Key,0,@Buff,REG_OPTION_NON_VOLATILE,KEY_ALL_ACCESS,0,@hKey,@Result)
  RegSetValueEx(hKey,VarName,0,REG_SZ,Cast(LPBYTE,Value),cast(DWORD,lstrlen(Value))+1)
  RegCloseKey(hKey)
End Sub


Sub DeleteRegKey (HK As HKEY , Key As ZString Ptr)
  RegDeleteKey(HK,Key)
End Sub

'==============================
'IObject function
'==============================
Type IObjectVTbl_ As IObjectVTbl
Type IObject
        lpVTbl As IObjectVTbl_ Ptr
End Type

Type IObjectVTbl
        ' functions for Unknown Interface
        QueryInterface As Function(Byval pthis As IObject Ptr,Byval vTableGuid As GUID Ptr,Byval ppv As lpvoid Ptr) As HRESULT
        AddRef As Function(Byval pthis As IObject Ptr) As HRESULT
        Release As Function(Byval pthis As IObject Ptr) As HRESULT
        ' our functions
        SetString As Function(Byval pthis As IObject Ptr, Byval  lpstr As LPOLESTR) As HRESULT
        GetString As Function(Byval pthis As IObject Ptr, Byval buffer As LPOLESTR Ptr) As HRESULT
       
End Type

Type LPOBJET As OBJ_OBJECT Ptr

Type OBJECT_ClassFactory
    icf As IclassFactory
    cRef As Integer
End Type

Type OBJ_OBJECT
   Ib As IObject
   count As Integer
   tex As BSTR
End Type

Type CLASS_OBJECT
   Ib As IObject
   count As Integer
   tex As bstr
End Type

Function IObject_AddRef   ( Byval pthis As IObject Ptr ) As HRESULT
    Cast(LPOBJET,pThis)->count+=1
     Function = Cast(LPOBJET,pThis)->count
End Function

Function IObject_QueryInterface( Byval pthis As IOBJECT Ptr, ByVal riid As GUID Ptr, _
                         Byval ppv As LPVOID Ptr ) As HRESULT
       
         
    If IsEqualIID(riid,@IID_IUnknown) Or IsEqualIID(riid,@IID_MyObject) Then ' Or IsEqualIID(riid,@IID_IDispatch) Then
        *ppv =@Cast(LPOBJET,pThis)->Ib
    Else
        *ppv = 0
        Function = E_NOINTERFACE: Exit Function
    End If
    pthis->lpVTbl->AddRef(pthis)
    Function = NOERROR
End Function

Function IObject_Release (ByVal pthis As IObject Ptr ) As HRESULT
    Cast(LPOBJET,pThis)->count-=1
   
    If Cast(LPOBJET,pThis)->tex Then SysFreeString(Cast(LPOBJET,pThis)->tex) 'win32api
       
    If Cast(LPOBJET,pThis)->count<=0 Then   
        InterlockedDecRement(@OutstandingObjects) 'win32api
        Free(pthis) 'win32api
        Function=0: Exit Function
    End If
    Function = Cast(LPOBJET,pThis)->count
End Function

Function IObject_SetString(Byval pthis As IObject Ptr, Byval  lpstr As lpolestr) As HRESULT
        If Cast(LPOBJET,pThis)->tex Then SysFreeString(Cast(LPOBJET,pThis)->tex)
        Cast(LPOBJET,pThis)->tex = SysAllocString(lpstr) ' store a copy of the string
        If Cast(LPOBJET,pThis)->tex = 0 Then Return E_OUTOFMEMORY Else Return NOERROR
End Function

Function IObject_GetString(Byval pthis As IObject Ptr, Byval buffer As lpolestr Ptr) As HRESULT
        'If buffer=0 Then Return E_POINTER
        *buffer=SysAllocString(Cast(LPOBJET,pThis)->tex)
        If *buffer=0 Then Return E_OUTOFMEMORY Else Return NOERROR
End Function

 

Static Shared MyObjectVTbl As IObjectVTbl=(@IObject_QueryInterface,@IObject_AddRef,@IObject_Release,@IObject_SetString,@IObject_GetString)

'===============================
' Class Factory Functions
'===============================
Static Shared MyClassFactory As IClassFactory
 
Function classAddRef (Byval pcF As IClassFactory Ptr) As ULong
        InterlockedIncRement(@OutstandingObjects)
        Function=1
End Function

Function classQueryInterface ( pcF  As IClassFactory Ptr,  riid As REFIID ,Byval ppv As PVOID Ptr) As Long
       
        If (IsEqualIID( riid,@IID_IUnknown) Or IsEqualIID( riid,@IID_IClassFactory)) Then
               *ppv = Cast(OBJECT_ClassFactory Ptr, pcF)
               Cast(OBJECT_ClassFactory Ptr, pcF)->icf.lpVTbl->AddRef(pcF)
               
                Return S_OK               
        End If
        *ppv = 0
        Return  E_NOINTERFACE
       
        'Cast(LPUNKNOWN,*ppv)->lpvtbl->AddRef(Cast(LPUNKNOWN,*ppv))
        'Return NOERROR
End Function

Function classRelease (pcF As IClassFactory Ptr) As ULong
   Dim pthis As OBJECT_ClassFactory Ptr =Cast(OBJECT_ClassFactory Ptr, pcF)
   Dim pcc As CLASS_OBJECT Ptr
   pthis->cRef -=1
   If pthis->cRef=0 Then
      free(pthis)
      Return 0
   EndIf
   Return pthis->cRef
        'Return  InterlockedDecRement(@OutstandingObjects)
End Function

Function classCreateInstance ( pcF As IClassFactory Ptr,punkOuter  As LPUNKNOWN ,Byval vTableGuid As REFIID ,Byval objHandle  As PVOID Ptr) As HRESULT
        Dim hr As HRESULT
        Dim pthis As OBJECT_ClassFactory Ptr =Cast(OBJECT_ClassFactory Ptr, pcF)
        Dim  thisobj As CLASS_OBJECT Ptr
        *objHandle = 0
        If punkOuter Then
                Return CLASS_E_NOAGGREGATION
        Else
                thisobj = Cast(CLASS_OBJECT ptr,malloc(SizeOf(CLASS_OBJECT)))
                If thisobj = 0 Then
                        Return E_OUTOFMEMORY
                Else
                        'intialise object properties
                        thisobj->ib.lpVTbl = @MyObjectVTbl
                        thisobj->count = 1
                        thisobj->tex =0
                        If S_OK<>thisobj->ib.lpVTbl->QueryInterface( @(thisobj->ib), vTableGuid, objHandle) Then
                           free(thisobj)
                           Return  E_NOINTERFACE
                        EndIf
                        thisobj->Ib.lpVTbl->Release(@(thisobj->ib))
                        OutstandingObjects +=1
                        'If hr = 0 Then InterlockedIncRement(@OutstandingObjects)
                End If
        End If
        Return  S_OK
End Function

Function classLockServer (pcF As IClassFactory Ptr, flock As BOOL) As HRESULT
    If flock Then
         OutstandingObjects +=1
        'InterlockedIncRement(@LockCount)
    Else
         OutstandingObjects -=1
        'InterlockedDecRement(@LockCount)
    End If
    Return  NOERROR
End Function

Static Shared  As IClassFactoryVTbl MyClassFactoryVTbl=(@classQueryInterface,@classAddRef,@classRelease,@classCreateInstance,@classLockServer)

'============================================
'dll function
'============================================
'Dim shared MyTypeInfo As ITypeInfo PTR

Extern "windows-ms"

#Undef DllGetClassObject
Function DllGetClassObject  Alias "DllGetClassObject"(objGuid As GUID Ptr, factoryGuid As GUID Ptr, Byval factoryHandle As LPVOID ptr)As HRESULT Export
         static pcF As OBJECT_ClassFactory Ptr =NULL
       
            *factoryHandle = 0
           If IsEqualCLSID(@CLSID_MyObject,objGuid) Then
                  If pCF=NULL Then
                     pcF=malloc(SizeOf(pcF))
                     If pCF=NULL Then
                        Return E_OUTOFMEMORY
                     EndIf
                  EndIf
                  pcF->icf.lpVtbl=@MyClassFactoryVTbl
                  pcF->cref=0
                Return classQueryInterface(Cast(IClassFactory Ptr,pcF), factoryGuid, factoryHandle)
               
           End If
             
                *factoryHandle = 0
                Return  CLASS_E_CLASSNOTAVAILABLE
       
End Function
 
     
#Undef DllCanUnloadNow
Function DllCanUnloadNow  Alias "DllCanUnloadNow" ()As HRESULT Export
   Return  IIF(OutstandingObjects Or LockCount, S_FALSE, S_OK)
End Function

 
Function DllRegisterServer() AS Long  EXPORT
Dim lv_temp_str As ZString*2048
Dim lv_varstr As ZString*2048


CREATEREGSTRING(HKEY_CLASSES_ROOT,ProgID,NULL,ProgID)
CREATEREGSTRING(HKEY_CLASSES_ROOT,ProgID & "\CLSID",NULL,CLSIDS_MyObject)
' prepare entery for HKEY_CLASSES_ROOT
lv_varstr = ProgID
lv_temp_str = "CLSID\" & CLSIDS_MyObject
CREATEREGSTRING(HKEY_CLASSES_ROOT,lv_temp_str,NULL,lv_varstr)
CREATEREGSTRING(HKEY_CLASSES_ROOT,lv_temp_str,"AppID",CLSIDS_MyObject) ' aa
' define localtion of dll in system32
lv_temp_str = "CLSID\" & CLSIDS_MyObject & "\InprocServer32"

lv_varstr = SPACE$(1024)
GetModuleFileName(GetModuleHandle("WellCOM.dll"),lv_varstr,LEN(lv_varstr))

lv_varstr = TRIM$(lv_varstr)
CREATEREGSTRING(HKEY_CLASSES_ROOT,lv_temp_str,NULL,lv_varstr)


lv_temp_str = TRIM$(REGSTRING(HKEY_CLASSES_ROOT,lv_temp_str,NULL))

IF lv_temp_str <> lv_varstr THEN ' VERIFY THAT CORRECT VALUE IS WRITTEN IN REGISTRY
    Return  S_FALSE
END IF

lv_temp_str = "CLSID\" & CLSIDS_MyObject & "\ProgID"
CREATEREGSTRING(HKEY_CLASSES_ROOT,lv_temp_str,NULL,ProgID)

 Return  S_OK
END FUNCTION

FUNCTION DllUnregisterServer() AS HRESULT  EXPORT
Dim lv_temp_str As ZString*2048

DeleteRegKey(HKEY_CLASSES_ROOT,ProgID & "\CLSID")
DeleteRegKey(HKEY_CLASSES_ROOT,"\" & ProgID)

  lv_temp_str  = "CLSID\" & CLSIDS_MyObject & "\InprocServer32"
  DELETEREGKEY (HKEY_CLASSES_ROOT,lv_temp_str)
   
  lv_temp_str = "CLSID\" & CLSIDS_MyObject & "\ProgID"
  DeleteRegKey (HKEY_CLASSES_ROOT,lv_temp_str) 
   
  lv_temp_str = "CLSID\" & CLSIDS_MyObject
  DeleteRegKey (HKEY_CLASSES_ROOT,lv_temp_str)
  FUNCTION =  S_OK
END Function

End Extern


MakeDllAndRegisterit.bat

Code: Select all

fbc -s gui -dll -export "WellCOM.bas"
REGSVR32  WellCOM.dll



testWelcom.bas

Code: Select all

#define INITGUID

#Include Once "windows.bi"
#Include Once "win/ocidl.bi"


Dim Shared CLSID_TypeLib As GUID=Type(&h26a8002a, &h83d7, &h45eb,{ &h98, &he1, &h9, &hcf, &h47, &ha4, &he, &he3})
Dim Shared CLSID_MyObject As GUID=Type(&hf2e0ac34, &h64ba, &h4871,{ &hbb, &hfc, &hb9, &hde, &h5b, &hd9, &hc8, &hb})
Dim Shared IID_MyObject As GUID=Type(&h2a2af189, &hc5a1, &h4a4e,{ &h92, &h77, &hb4, &hfd, &h87, &h1a, &h51, &h19})


 

Const CLSIDS_MyObject = "{F2E0AC34-64BA-4871-BBFC-B9DE5BD9C80B}"
Const CLSIDS_TypeLib = "{26A8002A-83D7-45eb-98E1-09CF47A40EE3}"
Const IIDS_MyObject = "{2A2AF189-C5A1-4a4e-9277-B4FD871A5119}"

'==============================
'IObject function
'==============================
Type IObjectVTbl_ As IObjectVTbl
Type IObject
        lpVTbl As IObjectVTbl_ Ptr
End Type

Type IObjectVTbl
        ' functions for Unknown Interface
        QueryInterface As Function(Byval pthis As IObject Ptr,Byval vTableGuid As GUID Ptr,Byval ppv As lpvoid Ptr) As HRESULT
        AddRef As Function(Byval pthis As IObject Ptr) As HRESULT
        Release As Function(Byval pthis As IObject Ptr) As HRESULT
        ' our functions
        SetString As Function(Byval pthis As IObject Ptr, Byval  lpstr As LPOLESTR) As HRESULT
        GetString As Function(Byval pthis As IObject Ptr, Byval buffer As LPOLESTR Ptr) As HRESULT
End Type





'convert string to bstr
'please follow with sysfreestring(bstr) after use to avoid memory leak
Function StringToBSTR(cnv_string As String) As BSTR
    Dim sb As BSTR
    Dim As Integer n
    n = (MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, cnv_string, -1, NULL, 0))-1
    sb=SysAllocStringLen(sb,n)
    MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, cnv_string, -1, sb, n)
    Return sb
End Function

Function BstrToStr(ByVal szW As BSTR ) As String
   Static szA As ZString*256
   If szW=NULL Then Return ""
   WideCharToMultiByte(CP_ACP,0,SzW,-1,SzA,256,NULL,NULL)
   Return szA
End Function








Dim g As IObject Ptr
Dim hr As HRESULT


CoInitialize(NULL)
hr=CoCreateInstance(@CLSID_MyObject,NULL,CLSCTX_ALL,@IID_MyObject,Cast(Any Ptr,@g))
If(SUCCEEDED(hr)) Then


  Dim As LPOLESTR bstrset =StringToBSTR("AYELMA 2012")
  Dim As LPOLESTR bstrget=NULL

 
  g->lpvtbl->SetString(g,bstrset)
  g->lpvtbl->GetString(g,@bstrget)
 
  Print "getting a string from COM: "; BstrToStr(bstrget) 
   
 
 
  SysFreeString(bstrset)
  SysFreeString(bstrget)
 
  g->lpvtbl->Release(g)
Else
    Print "UNABLE TO LAUNCH THE DLL OBJECT"
   
End If
 
 
 
  CoUninitialize()
 Sleep
VANYA
Posts: 1465
Joined: Oct 24, 2010 15:16
Location: Ярославль
Contact:

Re: Building com objects with FB

Postby VANYA » Feb 03, 2012 14:23

I can not :(
Dll created. Registered successfully , but:

UNABLE TO LAUNCH THE DLL OBJECT
aloberoger
Posts: 495
Joined: Jan 13, 2009 19:23

Re: Building com objects with FB

Postby aloberoger » Feb 03, 2012 14:48

I don't understand, testWelcom work perfectly.
VANYA
Posts: 1465
Joined: Oct 24, 2010 15:16
Location: Ярославль
Contact:

Re: Building com objects with FB

Postby VANYA » Feb 03, 2012 14:56

Excuse me, everything works fine. I just called the file WelCom instead of WellCOM. And there GetModuleHandle name WellCOM is used.
All is fine, thank you.
VANYA
Posts: 1465
Joined: Oct 24, 2010 15:16
Location: Ярославль
Contact:

Re: Building com objects with FB

Postby VANYA » Feb 03, 2012 15:20

If you are not hard to not be able to show how to use existing interfaces COM? Thank you.

IQueryInfo
IContextMenu
Cherry
Posts: 351
Joined: Oct 23, 2007 12:06
Location: Austria
Contact:

Re: Building com objects with FB

Postby Cherry » Feb 03, 2012 15:32

aloberoger wrote:I have noticed that because FB call automaticaly Libmain, there is somme troubles implementing libmain in a dll. I Will give you somme examples(creating controls , or dll of ressources) to justify this. However I advise you to try with FBpoint simply compile the file FBpoint.bas to a dll and register it, the things work perfectly. You can back to the vector example and remove libmain,but with appropriate a correction.


Use "-m dummy" as parameter to the compiler. This will put the default DllMain into the module "dummy", which doesn't exist, thus DllMain won't be defined until you define it manually.
aloberoger
Posts: 495
Joined: Jan 13, 2009 19:23

Re: Building com objects with FB

Postby aloberoger » Feb 04, 2012 9:28

OK thanks you both Cherry and WANYA.

Here is wellcom example with support of IDISPATCH, You have to build .tlb to be able to use it with vb(now i have a bug in vb) . You can lod the wellcom.tlb in Axsuite2.

wellcom.bas

Code: Select all



#Include Once "windows.bi"
#Include Once "win/ocidl.bi"
#Include Once "crt.bi"

#define INITGUID



Static Shared OutstandingObjects As DWORD
Static Shared LockCount As DWORD
' Where I store a pointer to my type library's TYPEINFO
Static Shared as ITypeInfo   Ptr MyTypeInfo

Dim Shared CLSID_TypeLib As GUID=Type(&h26a8002a, &h83d7, &h45eb,{ &h98, &he1, &h9, &hcf, &h47, &ha4, &he, &he3})
Dim Shared CLSID_MyObject As GUID=Type(&hf2e0ac34, &h64ba, &h4871,{ &hbb, &hfc, &hb9, &hde, &h5b, &hd9, &hc8, &hb})
Dim Shared IID_MyObject As GUID=Type(&h2a2af189, &hc5a1, &h4a4e,{ &h92, &h77, &hb4, &hfd, &h87, &h1a, &h51, &h19})

Const CLSIDS_TypeLib  = "{26A8002A-83D7-45eb-98E1-09CF47A40EE3}"
Const CLSIDS_MyObject = "{F2E0AC34-64BA-4871-BBFC-B9DE5BD9C80B}"
Const IIDS_MyObject   = "{2A2AF189-C5A1-4a4e-9277-B4FD871A5119}"


'==========================================================
'registry
'==========================================================
Dim Shared DllName As Zstring*128=>"WellCOM.dll"
Dim Shared ObjDescription As Zstring*128=>"Intermediary between DLL host and COM client"
Dim Shared FileDlgTitle As Zstring*128=>"Locate WellCOM.dll to register it"
Dim Shared FileDlgExt As Zstring*128=>"DLL files\000*.dll\000\000"
Dim Shared CLSID_Str As Zstring*128=>"CLSID"
Dim Shared ClassKeyName As Zstring*128=>"Software\\Classes"
Dim Shared InprocServer32Name As Zstring*128=>"InprocServer32"
Dim Shared ThreadingModel As Zstring*128=>"ThreadingModel"
Dim Shared BothStr As Zstring*128=>"both"
Dim Shared ProgID As Zstring*128=>"WellCOM.Object"
Dim Shared TypeLibName As Zstring*128=>"WellCOM.dll"

Dim Shared result As Long,ghDLLInst as HMODULE
Dim Shared filename As Zstring*MAX_PATH
Dim Shared rootKey As hkey
Dim Shared hKey1 As HKEY
Dim Shared hKey2 As HKEY
Dim Shared hkextra As HKEY
Dim Shared GUIDtxt As Zstring*39
Dim Shared disposition As DWORD
Dim Shared sa As SECURITY_ATTRIBUTES

Declare Function SetKeyAndValue(ByRef szKey As string, ByRef szSubKey As string, ByRef szValue As String) As Long
 
 

#define W2Ansi(A,W)  WideCharToMultiByte(CP_ACP,0,W,-1,A,2047,0,0)
#define A2Wide(A,W,L)  MultiByteToWideChar(CP_ACP,0,A,-1,W,L)

Function UnicodeToAnsi(ByVal szW As OLECHAR Ptr ) As String
   Static szA As ZString*256
   If szW=NULL Then Return ""
   WideCharToMultiByte(CP_ACP,0,SzW,-1,SzA,256,NULL,NULL)
   Return szA
End Function

Function AnsiToUnicode(A As String) As OLECHAR Ptr
   Dim W As  OLECHAR Ptr
   Dim length As Integer
   length=(2 * Len(A)) + 1
   A2Wide(StrPtr(A),W,length)
   Return W
End Function
'convert string to bstr
'please follow with sysfreestring(bstr) after use to avoid memory leak
Function StringToBSTR(cnv_string As String) As BSTR
    Dim sb As BSTR
    Dim As Integer n
    n = (MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, cnv_string, -1, NULL, 0))-1
    sb=SysAllocStringLen(sb,n)
    MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, cnv_string, -1, sb, n)
    Return sb
End Function

Function s2guid(txt As String)As guid
        Static oGuid As guid
        iidfromstring(wstr(txt),@oGuid)
        Return oGuid
End Function

Function guid2s(iguid As guid)As String
        Dim oGuids As Wstring Ptr
        stringfromiid(@iGuid,Cast(LPOLESTR Ptr,@oguids))
        Return *oGuids
End Function


Function RegString (hKey As HKEY , RegPath As ZString Ptr,SubKey  As ZString Ptr)As String
  Dim Result As ZString*2048 
  Dim As integer BufferLen=2048
  if(0=RegOpenKeyEx(hKey,RegPath,0,KEY_QUERY_VALUE,@hKey))Then
      RegQueryValueEx(hKey,SubKey,0,0,cast(LPBYTE,@Result),cast(LPDWORD,@BufferLen))
  End If
  RegCloseKey(hKey)
  return Result
End function


Sub CreateRegString (HK As HKEY ,Key  As ZString Ptr,VarName  As ZString Ptr,Value  As ZString Ptr)
  Dim As HKEY  hKey
  dim Buff As ZString*100 
  Dim As DWORD  Result
  RegCreateKeyEx(HK,Key,0,@Buff,REG_OPTION_NON_VOLATILE,KEY_ALL_ACCESS,0,@hKey,@Result)
  RegSetValueEx(hKey,VarName,0,REG_SZ,Cast(LPBYTE,Value),cast(DWORD,lstrlen(Value))+1)
  RegCloseKey(hKey)
End Sub


Sub DeleteRegKey (HK As HKEY , Key As ZString Ptr)
  RegDeleteKey(HK,Key)
End Sub

'==============================
'IObject function
'==============================
Type IObjectVTbl_ As IObjectVTbl
Type IObject
        lpVTbl As IObjectVTbl_ Ptr
End Type

Type IObjectVTbl
        ' functions for Unknown Interface
        QueryInterface As Function(Byval pthis As IObject Ptr,Byval vTableGuid As GUID Ptr,Byval ppv As lpvoid Ptr) As HRESULT
        AddRef As Function(Byval pthis As IObject Ptr) As HRESULT
        Release As Function(Byval pthis As IObject Ptr) As HRESULT
        ' IDispatch functions
        GetTypeInfoCount As Function ( Byval pthis As IOBJECT Ptr,pCount As UINT Ptr )As HRESULT
        GetTypeInfo  As Function ( Byval pthis As IOBJECT Ptr,itinfo as UINT ,lcid As LCID ,pTypeInfo As ITypeInfo Ptr Ptr )As HRESULT
        GetIDsOfNames  As Function ( ByVal pthis As IOBJECT Ptr,riid as REFIID ,rgszNames As LPOLESTR Ptr ,cNames as UINT ,lcid as LCID ,rgdispid As DISPID Ptr )As HRESULT
        Invoke  As Function ( Byval pthis As IOBJECT Ptr,dispid As DISPID ,riid As REFIID ,lcid As  LCID ,wFlags As WORD , params As DISPPARAMS Ptr ,result as VARIANT Ptr ,pexcepinfo as EXCEPINFO Ptr ,puArgErr As  UINT Ptr ) As HRESULT
 
   
        ' our functions
        SetString As Function(Byval pthis As IObject Ptr, Byval  lpstr As LPOLESTR) As HRESULT
        GetString As Function(ByVal pthis As IObject Ptr, Byval buffer As LPOLESTR Ptr) As HRESULT
       
End Type

Type LPOBJET As OBJ_OBJECT Ptr

Type OBJECT_ClassFactory
    icf As IclassFactory
    cRef As Integer
End Type

Type OBJ_OBJECT
   Ib As IObject
   count As Integer
   tex As BSTR
End Type

Type CLASS_OBJECT
   Ib As IObject
   count As Integer
   tex As bstr
End Type

Function IObject_AddRef   ( Byval pthis As IObject Ptr ) As HRESULT
    Cast(LPOBJET,pThis)->count+=1
     Function = Cast(LPOBJET,pThis)->count
End Function

Function IObject_QueryInterface( Byval pthis As IOBJECT Ptr, ByVal riid As GUID Ptr, _
                         Byval ppv As LPVOID Ptr ) As HRESULT
       
         
    If IsEqualIID(riid,@IID_IUnknown) Or IsEqualIID(riid,@IID_MyObject) Then ' Or IsEqualIID(riid,@IID_IDispatch) Then
        *ppv =@Cast(LPOBJET,pThis)->Ib
    Else
        *ppv = 0
        Function = E_NOINTERFACE: Exit Function
    End If
    pthis->lpVTbl->AddRef(pthis)
    Function = NOERROR
End Function

Function IObject_Release (ByVal pthis As IObject Ptr ) As HRESULT
    Cast(LPOBJET,pThis)->count-=1
   
    If Cast(LPOBJET,pThis)->tex Then SysFreeString(Cast(LPOBJET,pThis)->tex) 'win32api
       
    If Cast(LPOBJET,pThis)->count<=0 Then   
        InterlockedDecRement(@OutstandingObjects) 'win32api
        Free(pthis) 'win32api
        Function=0: Exit Function
    End If
    Function = Cast(LPOBJET,pThis)->count
End Function

' ================== The standard IDispatch functions

' This is just a helper function for the IDispatch functions below
Function loadMyTypeInfo()As HRESULT
 
   Dim As HRESULT   hr
   Dim As LPTYPELIB   pTypeLib

   ' Load our type library and get a ptr to its TYPELIB. Note: This does an
   ' implicit pTypeLib->lpVtbl->AddRef(pTypeLib)
   hr = LoadRegTypeLib(@CLSID_TypeLib, 1, 0, 0, @pTypeLib)
   if  hr=0 Then
   
      ' Get Microsoft's generic ITypeInfo, giving it our loaded type library. We only
      ' need one of these, and we'll store it in a global Tell Microsoft this is for
      ' our IExample2's VTable, by passing that VTable's GUID
      hr = pTypeLib->lpVtbl->GetTypeInfoOfGuid(pTypeLib, @IID_MyObject, @MyTypeInfo)
      if  hr=0 Then
      
         ' We no longer need the ptr to the TYPELIB now that we've given it
         ' to Microsoft's generic ITypeInfo. Note: The generic ITypeInfo has done
         ' a pTypeLib->lpVtbl->AddRef(pTypeLib), so this TYPELIB ain't going away
         ' until the generic ITypeInfo does a pTypeLib->lpVtbl->Release too
         pTypeLib->lpVtbl->Release(pTypeLib)

         ' Since caller wants us to return our ITypeInfo pointer,
         ' we need to increment its reference count. Caller is
         ' expected to Release() it when done
         MyTypeInfo->lpVtbl->AddRef(MyTypeInfo)
      End If
   End If

   return(hr)
End Function

 
Function IObject_GetTypeInfoCount( Byval pthis As IOBJECT Ptr,pCount As UINT Ptr )As HRESULT
 
   *pCount = 1
   return(S_OK)
End Function

 
Function IObject_GetTypeInfo( Byval pthis As IOBJECT Ptr,itinfo as UINT ,lcid As LCID ,pTypeInfo As ITypeInfo Ptr Ptr )As HRESULT
 
   Static As HRESULT   hr

   ' Assume an error
   *pTypeInfo = 0
   
   if (itinfo)Then
      hr = ResultFromScode(DISP_E_BADINDEX)

   ' If our ITypeInfo is already created, just increment its ref count. NOTE: We really should
   ' store the LCID of the currently created TYPEINFO and compare it to what the caller wants.
   ' If no match, unloaded the currently created TYPEINFO, and create the correct one. But since
   ' we support only one language in our IDL file anyway, we'll ignore this
   ElseIf (MyTypeInfo)Then
   
      MyTypeInfo->lpVtbl->AddRef(MyTypeInfo)
      hr = 0
   
   else
   
      ' Load our type library and get Microsoft's generic ITypeInfo object. NOTE: We really
      ' should pass the LCID to match, but since we support only one language in our IDL
      ' file anyway, we'll ignore this
      hr = loadMyTypeInfo()
   End If

   if (0=hr) Then *pTypeInfo = MyTypeInfo

   return(hr)
End Function

' IExample2's GetIDsOfNames()
Function IObject_GetIDsOfNames( Byval pthis As IOBJECT Ptr,riid as REFIID ,rgszNames As LPOLESTR Ptr ,cNames as UINT ,lcid as LCID ,rgdispid As DISPID Ptr )As HRESULT
 
   if (0=MyTypeInfo)Then
   
      dim as HRESULT   hr

      if ((hr = loadMyTypeInfo())) Then Return(hr)
   End if
   
   ' Let OLE32.DLL's DispGetIDsOfNames() do all the real work of using our type
   ' library to look up the DISPID of the requested function in our object
   return(DispGetIDsOfNames(MyTypeInfo, rgszNames, cNames, rgdispid))
End Function

 
Function IObject_Invoke( Byval pthis As IOBJECT Ptr,dispid As DISPID ,riid As REFIID ,lcid As  LCID ,wFlags As WORD , params As DISPPARAMS Ptr ,result as VARIANT Ptr ,pexcepinfo as EXCEPINFO Ptr ,puArgErr As  UINT Ptr ) As HRESULT
 
   ' We implement only a "default" interface
   if (0=IsEqualIID(riid, @IID_NULL))Then return(DISP_E_UNKNOWNINTERFACE)

   ' We need our type lib's TYPEINFO (to pass to DispInvoke)
   if (0=MyTypeInfo)then
   
      Dim As HRESULT   hr

      if ((hr = loadMyTypeInfo())) Then Return(hr)
   End If

   ' Let OLE32.DLL's DispInvoke() do all the real work of calling the appropriate
   ' function in our object, and massaging the passed args into the correct format
   return(DispInvoke(pthis, MyTypeInfo, dispid, wFlags, params, result, pexcepinfo, puArgErr))
End function


Function IObject_SetString(Byval pthis As IObject Ptr, Byval  lpstr As lpolestr) As HRESULT
        If Cast(LPOBJET,pThis)->tex Then SysFreeString(Cast(LPOBJET,pThis)->tex)
        Cast(LPOBJET,pThis)->tex = SysAllocString(lpstr) ' store a copy of the string
        If Cast(LPOBJET,pThis)->tex = 0 Then Return E_OUTOFMEMORY Else Return NOERROR
End Function

Function IObject_GetString(Byval pthis As IObject Ptr, Byval buffer As lpolestr Ptr) As HRESULT
        'If buffer=0 Then Return E_POINTER
        *buffer=SysAllocString(Cast(LPOBJET,pThis)->tex)
        If *buffer=0 Then Return E_OUTOFMEMORY Else Return NOERROR
End Function

 

Static Shared MyObjectVTbl As IObjectVTbl=(@IObject_QueryInterface, _
                                           @IObject_AddRef, _
                                           @IObject_Release, _
                                           @IObject_GetTypeInfoCount, _
                                           @IObject_GetTypeInfo, _
                                           @IObject_GetIDsOfNames, _
                                           @IObject_Invoke, _
                                           @IObject_SetString, _
                                           @IObject_GetString)

'===============================
' Class Factory Functions
'===============================
Static Shared MyClassFactory As IClassFactory
 
Function classAddRef (Byval pcF As IClassFactory Ptr) As ULong
        InterlockedIncRement(@OutstandingObjects)
        Function=1
End Function

Function classQueryInterface ( pcF  As IClassFactory Ptr,  riid As REFIID ,Byval ppv As PVOID Ptr) As Long
       
        If (IsEqualIID( riid,@IID_IUnknown) Or IsEqualIID( riid,@IID_IClassFactory)) Then
               *ppv = Cast(OBJECT_ClassFactory Ptr, pcF)
               Cast(OBJECT_ClassFactory Ptr, pcF)->icf.lpVTbl->AddRef(pcF)
               
                Return S_OK               
        End If
        *ppv = 0
        Return  E_NOINTERFACE
       
        'Cast(LPUNKNOWN,*ppv)->lpvtbl->AddRef(Cast(LPUNKNOWN,*ppv))
        'Return NOERROR
End Function

Function classRelease (pcF As IClassFactory Ptr) As ULong
   Dim pthis As OBJECT_ClassFactory Ptr =Cast(OBJECT_ClassFactory Ptr, pcF)
   Dim pcc As CLASS_OBJECT Ptr
   pthis->cRef -=1
   If pthis->cRef=0 Then
      free(pthis)
      Return 0
   EndIf
   Return pthis->cRef
        'Return  InterlockedDecRement(@OutstandingObjects)
End Function

Function classCreateInstance ( pcF As IClassFactory Ptr,punkOuter  As LPUNKNOWN ,Byval vTableGuid As REFIID ,Byval objHandle  As PVOID Ptr) As HRESULT
        Dim hr As HRESULT
        Dim pthis As OBJECT_ClassFactory Ptr =Cast(OBJECT_ClassFactory Ptr, pcF)
        Dim  thisobj As CLASS_OBJECT Ptr
        *objHandle = 0
        If punkOuter Then
                Return CLASS_E_NOAGGREGATION
        Else
                thisobj = Cast(CLASS_OBJECT ptr,malloc(SizeOf(CLASS_OBJECT)))
                If thisobj = 0 Then
                        Return E_OUTOFMEMORY
                Else
                        'intialise object properties
                        thisobj->ib.lpVTbl = @MyObjectVTbl
                        thisobj->count = 1
                        thisobj->tex =0
                        If S_OK<>thisobj->ib.lpVTbl->QueryInterface( @(thisobj->ib), vTableGuid, objHandle) Then
                           free(thisobj)
                           Return  E_NOINTERFACE
                        EndIf
                        thisobj->Ib.lpVTbl->Release(@(thisobj->ib))
                        OutstandingObjects +=1
                        'If hr = 0 Then InterlockedIncRement(@OutstandingObjects)
                End If
        End If
        Return  S_OK
End Function

Function classLockServer (pcF As IClassFactory Ptr, flock As BOOL) As HRESULT
    If flock Then
         OutstandingObjects +=1
        'InterlockedIncRement(@LockCount)
    Else
         OutstandingObjects -=1
        'InterlockedDecRement(@LockCount)
    End If
    Return  NOERROR
End Function

Static Shared  As IClassFactoryVTbl MyClassFactoryVTbl=(@classQueryInterface,@classAddRef,@classRelease,@classCreateInstance,@classLockServer)

'============================================
'dll function
'============================================
'Dim shared MyTypeInfo As ITypeInfo PTR

Extern "windows-ms"

#Undef DllGetClassObject
Function DllGetClassObject  Alias "DllGetClassObject"(objGuid As GUID Ptr, factoryGuid As GUID Ptr, Byval factoryHandle As LPVOID ptr)As HRESULT Export
         static pcF As OBJECT_ClassFactory Ptr =NULL
       
            *factoryHandle = 0
           If IsEqualCLSID(@CLSID_MyObject,objGuid) Then
                  If pCF=NULL Then
                     pcF=malloc(SizeOf(pcF))
                     If pCF=NULL Then
                        Return E_OUTOFMEMORY
                     EndIf
                  EndIf
                  pcF->icf.lpVtbl=@MyClassFactoryVTbl
                  pcF->cref=0
                Return classQueryInterface(Cast(IClassFactory Ptr,pcF), factoryGuid, factoryHandle)
               
           End If
             
                *factoryHandle = 0
                Return  CLASS_E_CLASSNOTAVAILABLE
       
End Function
 
     
#Undef DllCanUnloadNow
Function DllCanUnloadNow  Alias "DllCanUnloadNow" ()As HRESULT Export
   Return  IIF(OutstandingObjects Or LockCount, S_FALSE, S_OK)
End Function

 
Function DllRegisterServer() AS Long  EXPORT
Dim lv_temp_str As ZString*2048
Dim lv_varstr As ZString*2048


CREATEREGSTRING(HKEY_CLASSES_ROOT,ProgID,NULL,ProgID)
CREATEREGSTRING(HKEY_CLASSES_ROOT,ProgID & "\CLSID",NULL,CLSIDS_MyObject)
' prepare entery for HKEY_CLASSES_ROOT
lv_varstr = ProgID
lv_temp_str = "CLSID\" & CLSIDS_MyObject
CREATEREGSTRING(HKEY_CLASSES_ROOT,lv_temp_str,NULL,lv_varstr)
CREATEREGSTRING(HKEY_CLASSES_ROOT,lv_temp_str,"AppID",CLSIDS_MyObject) ' aa
' define localtion of dll in system32
lv_temp_str = "CLSID\" & CLSIDS_MyObject & "\InprocServer32"

lv_varstr = SPACE$(1024)
GetModuleFileName(GetModuleHandle("WellCOM.dll"),lv_varstr,LEN(lv_varstr))

lv_varstr = TRIM$(lv_varstr)
CREATEREGSTRING(HKEY_CLASSES_ROOT,lv_temp_str,NULL,lv_varstr)


lv_temp_str = TRIM$(REGSTRING(HKEY_CLASSES_ROOT,lv_temp_str,NULL))

IF lv_temp_str <> lv_varstr THEN ' VERIFY THAT CORRECT VALUE IS WRITTEN IN REGISTRY
    Return  S_FALSE
END IF

lv_temp_str = "CLSID\" & CLSIDS_MyObject & "\ProgID"
CREATEREGSTRING(HKEY_CLASSES_ROOT,lv_temp_str,NULL,ProgID)


 CREATEREGSTRING(HKEY_CLASSES_ROOT,"TypeLib\" ,NULL,CLSIDS_TypeLib)
 Return  S_OK
END FUNCTION

FUNCTION DllUnregisterServer() AS HRESULT  EXPORT
Dim lv_temp_str As ZString*2048

DeleteRegKey(HKEY_CLASSES_ROOT,ProgID & "\CLSID")
DeleteRegKey(HKEY_CLASSES_ROOT,"\" & ProgID)

  lv_temp_str  = "CLSID\" & CLSIDS_MyObject & "\InprocServer32"
  DELETEREGKEY (HKEY_CLASSES_ROOT,lv_temp_str)
   
  lv_temp_str = "CLSID\" & CLSIDS_MyObject & "\ProgID"
  DeleteRegKey (HKEY_CLASSES_ROOT,lv_temp_str) 
   
  lv_temp_str = "CLSID\" & CLSIDS_MyObject
  DeleteRegKey (HKEY_CLASSES_ROOT,lv_temp_str)
 
  lv_temp_str ="TypeLib\" & CLSIDS_TypeLib
  DeleteRegKey (HKEY_CLASSES_ROOT,lv_temp_str)
 
  FUNCTION =  S_OK
End Function

End Extern

wellcom.odl

Code: Select all

// The IDL file for wellCOM.DLL
//
// "{26A8002A-83D7-45eb-98E1-09CF47A40EE3}" = Type library's GUID
// "{F2E0AC34-64BA-4871-BBFC-B9DE5BD9C80B}" =CLSID_MyObject 
// "{2A2AF189-C5A1-4a4e-9277-B4FD871A5119}" = IID_MyObject

[
   uuid(26A8002A-83D7-45eb-98E1-09CF47A40EE3),
   version(1.0),
   helpstring("IObject COM server")
         
]
library IObject
{
   importlib("STDOLE2.TLB");

   [uuid(2A2AF189-C5A1-4a4e-9277-B4FD871A5119), dual, oleautomation, hidden, nonextensible]
   interface IObjectVTbl : IDispatch
   {
      [propput,helpstring("Sets the test string.")]
      HRESULT string([in] BSTR val);
      [ propget,helpstring("Gets the test string.")]
      HRESULT String([out, retval] BSTR * val);
   };

   [uuid(F2E0AC34-64BA-4871-BBFC-B9DE5BD9C80B), helpstring("IObject object."), appobject]
   coclass IObject
   {
      [default] interface IObjectVTbl;
   }
}


then compile the .odl with MkTypelib
Maketlb.bat

Code: Select all

MKTYPLIB /TLB wellcom.tlb /H wellcom.h wellCOM.odl
pause


After building the .tlb not forget to build again the dll and register it. If you have an error let me know.
aloberoger
Posts: 495
Joined: Jan 13, 2009 19:23

Re: Building com objects with FB

Postby aloberoger » Feb 04, 2012 12:00

Here is Version 2.0 of wellcom.dll

wellcom.bas

Code: Select all


#Include Once "windows.bi"
#Include Once "win/ocidl.bi"
#Include Once "crt.bi"

#define INITGUID



Static Shared OutstandingObjects As DWORD
Static Shared LockCount As DWORD
' Where I store a pointer to my type library's TYPEINFO
Static Shared as ITypeInfo   Ptr MyTypeInfo

Dim Shared CLSID_TypeLib As GUID=Type(&h26a8002a, &h83d7, &h45eb,{ &h98, &he1, &h9, &hcf, &h47, &ha4, &he, &he3})
Dim Shared CLSID_MyObject As GUID=Type(&hf2e0ac34, &h64ba, &h4871,{ &hbb, &hfc, &hb9, &hde, &h5b, &hd9, &hc8, &hb})
Dim Shared IID_MyObject As GUID=Type(&h2a2af189, &hc5a1, &h4a4e,{ &h92, &h77, &hb4, &hfd, &h87, &h1a, &h51, &h19})

Const CLSIDS_TypeLib  = "{26A8002A-83D7-45eb-98E1-09CF47A40EE3}"
Const CLSIDS_MyObject = "{F2E0AC34-64BA-4871-BBFC-B9DE5BD9C80B}"
Const IIDS_MyObject   = "{2A2AF189-C5A1-4a4e-9277-B4FD871A5119}"


'==========================================================
'registry
'==========================================================
Dim Shared DllName As Zstring*128=>"WellCOM.dll"
Dim Shared ObjDescription As Zstring*128=>"Intermediary between DLL host and COM client"
Dim Shared FileDlgTitle As Zstring*128=>"Locate WellCOM.dll to register it"
Dim Shared FileDlgExt As Zstring*128=>"DLL files\000*.dll\000\000"
Dim Shared CLSID_Str As Zstring*128=>"CLSID"
Dim Shared ClassKeyName As Zstring*128=>"Software\\Classes"
Dim Shared InprocServer32Name As Zstring*128=>"InprocServer32"
Dim Shared ThreadingModel As Zstring*128=>"ThreadingModel"
Dim Shared BothStr As Zstring*128=>"both"
Dim Shared ProgID As Zstring*128=>"WellCOM.Object"
Dim Shared TypeLibName As Zstring*128=>"WellCOM.dll"

Dim Shared result As Long,ghDLLInst as HMODULE
Dim Shared filename As Zstring*MAX_PATH
Dim Shared rootKey As hkey
Dim Shared hKey1 As HKEY
Dim Shared hKey2 As HKEY
Dim Shared hkextra As HKEY
Dim Shared GUIDtxt As Zstring*39
Dim Shared disposition As DWORD
Dim Shared sa As SECURITY_ATTRIBUTES

Declare Function SetKeyAndValue(ByRef szKey As string, ByRef szSubKey As string, ByRef szValue As String) As Long
 
 

#define W2Ansi(A,W)  WideCharToMultiByte(CP_ACP,0,W,-1,A,2047,0,0)
#define A2Wide(A,W,L)  MultiByteToWideChar(CP_ACP,0,A,-1,W,L)

Function UnicodeToAnsi(ByVal szW As OLECHAR Ptr ) As String
   Static szA As ZString*256
   If szW=NULL Then Return ""
   WideCharToMultiByte(CP_ACP,0,SzW,-1,SzA,256,NULL,NULL)
   Return szA
End Function

Function AnsiToUnicode(A As String) As OLECHAR Ptr
   Dim W As  OLECHAR Ptr
   Dim length As Integer
   length=(2 * Len(A)) + 1
   A2Wide(StrPtr(A),W,length)
   Return W
End Function
'convert string to bstr
'please follow with sysfreestring(bstr) after use to avoid memory leak
Function StringToBSTR(cnv_string As String) As BSTR
    Dim sb As BSTR
    Dim As Integer n
    n = (MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, cnv_string, -1, NULL, 0))-1
    sb=SysAllocStringLen(sb,n)
    MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, cnv_string, -1, sb, n)
    Return sb
End Function

Function s2guid(txt As String)As guid
        Static oGuid As guid
        iidfromstring(wstr(txt),@oGuid)
        Return oGuid
End Function

Function guid2s(iguid As guid)As String
        Dim oGuids As Wstring Ptr
        stringfromiid(@iGuid,Cast(LPOLESTR Ptr,@oguids))
        Return *oGuids
End Function


Function RegString (hKey As HKEY , RegPath As ZString Ptr,SubKey  As ZString Ptr)As String
  Dim Result As ZString*2048 
  Dim As integer BufferLen=2048
  if(0=RegOpenKeyEx(hKey,RegPath,0,KEY_QUERY_VALUE,@hKey))Then
      RegQueryValueEx(hKey,SubKey,0,0,cast(LPBYTE,@Result),cast(LPDWORD,@BufferLen))
  End If
  RegCloseKey(hKey)
  return Result
End function


Sub CreateRegString (HK As HKEY ,Key  As ZString Ptr,VarName  As ZString Ptr,Value  As ZString Ptr)
  Dim As HKEY  hKey
  dim Buff As ZString*100 
  Dim As DWORD  Result
  RegCreateKeyEx(HK,Key,0,@Buff,REG_OPTION_NON_VOLATILE,KEY_ALL_ACCESS,0,@hKey,@Result)
  RegSetValueEx(hKey,VarName,0,REG_SZ,Cast(LPBYTE,Value),cast(DWORD,lstrlen(Value))+1)
  RegCloseKey(hKey)
End Sub


Sub DeleteRegKey (HK As HKEY , Key As ZString Ptr)
  RegDeleteKey(HK,Key)
End Sub

'==============================
'IObject function
'==============================
Type IObjectVTbl_ As IObjectVTbl
Type IObject
        lpVTbl As IObjectVTbl_ Ptr
End Type

Type IObjectVTbl
        ' functions for Unknown Interface
        QueryInterface As Function(Byval pthis As IObject Ptr,Byval vTableGuid As GUID Ptr,Byval ppv As lpvoid Ptr) As HRESULT
        AddRef As Function(Byval pthis As IObject Ptr) As HRESULT
        Release As Function(Byval pthis As IObject Ptr) As HRESULT
        ' IDispatch functions
        GetTypeInfoCount As Function ( Byval pthis As IOBJECT Ptr,pCount As UINT Ptr )As HRESULT
        GetTypeInfo  As Function ( Byval pthis As IOBJECT Ptr,itinfo as UINT ,lcid As LCID ,pTypeInfo As ITypeInfo Ptr Ptr )As HRESULT
        GetIDsOfNames  As Function ( ByVal pthis As IOBJECT Ptr,riid as REFIID ,rgszNames As LPOLESTR Ptr ,cNames as UINT ,lcid as LCID ,rgdispid As DISPID Ptr )As HRESULT
        Invoke  As Function ( Byval pthis As IOBJECT Ptr,dispid As DISPID ,riid As REFIID ,lcid As  LCID ,wFlags As WORD , params As DISPPARAMS Ptr ,result as VARIANT Ptr ,pexcepinfo as EXCEPINFO Ptr ,puArgErr As  UINT Ptr ) As HRESULT
 
   
        ' our functions
        SetString As Function(Byval pthis As IObject Ptr, Byval  lpstr As BSTR) As HRESULT
        GetString As Function(ByVal pthis As IObject Ptr, Byval buffer As BSTR Ptr) As HRESULT
       
End Type

Type LPOBJET As OBJ_OBJECT Ptr

Type OBJECT_ClassFactory
    icf As IclassFactory
    cRef As Integer
End Type

Type OBJ_OBJECT
   Ib As IObject
   count As Integer
   tex As BSTR
End Type

Type CLASS_OBJECT
   Ib As IObject
   count As Integer
   tex As bstr
End Type

Function IObject_AddRef   ( Byval pthis As IObject Ptr ) As HRESULT
    Cast(LPOBJET,pThis)->count+=1
     Function = Cast(LPOBJET,pThis)->count
End Function

Function IObject_QueryInterface( Byval pthis As IOBJECT Ptr, ByVal riid As GUID Ptr, _
                         Byval ppv As LPVOID Ptr ) As HRESULT
       
         
    If IsEqualIID(riid,@IID_IUnknown) Or IsEqualIID(riid,@IID_MyObject) Then ' Or IsEqualIID(riid,@IID_IDispatch) Then
        *ppv =@Cast(LPOBJET,pThis)->Ib
    Else
        *ppv = 0
        Function = E_NOINTERFACE: Exit Function
    End If
    pthis->lpVTbl->AddRef(pthis)
    Function = NOERROR
End Function

Function IObject_Release (ByVal pthis As IObject Ptr ) As HRESULT
    Cast(LPOBJET,pThis)->count-=1
   
    If Cast(LPOBJET,pThis)->tex Then SysFreeString(Cast(LPOBJET,pThis)->tex) 'win32api
       
    If Cast(LPOBJET,pThis)->count<=0 Then   
        InterlockedDecRement(@OutstandingObjects) 'win32api
        Free(pthis) 'win32api
        Function=0: Exit Function
    End If
    Function = Cast(LPOBJET,pThis)->count
End Function

' ================== The standard IDispatch functions

' This is just a helper function for the IDispatch functions below
Function loadMyTypeInfo()As HRESULT
 
   Dim As HRESULT   hr
   Dim As LPTYPELIB   pTypeLib

   ' Load our type library and get a ptr to its TYPELIB. Note: This does an
   ' implicit pTypeLib->lpVtbl->AddRef(pTypeLib)
   hr = LoadRegTypeLib(@CLSID_TypeLib, 1, 0, 0, @pTypeLib)
   if  hr=0 Then
   
      ' Get Microsoft's generic ITypeInfo, giving it our loaded type library. We only
      ' need one of these, and we'll store it in a global Tell Microsoft this is for
      ' our IExample2's VTable, by passing that VTable's GUID
      hr = pTypeLib->lpVtbl->GetTypeInfoOfGuid(pTypeLib, @IID_MyObject, @MyTypeInfo)
      if  hr=0 Then
      
         ' We no longer need the ptr to the TYPELIB now that we've given it
         ' to Microsoft's generic ITypeInfo. Note: The generic ITypeInfo has done
         ' a pTypeLib->lpVtbl->AddRef(pTypeLib), so this TYPELIB ain't going away
         ' until the generic ITypeInfo does a pTypeLib->lpVtbl->Release too
         pTypeLib->lpVtbl->Release(pTypeLib)

         ' Since caller wants us to return our ITypeInfo pointer,
         ' we need to increment its reference count. Caller is
         ' expected to Release() it when done
         MyTypeInfo->lpVtbl->AddRef(MyTypeInfo)
      End If
   End If

   return(hr)
End Function

 
Function IObject_GetTypeInfoCount( Byval pthis As IOBJECT Ptr,pCount As UINT Ptr )As HRESULT
 
   *pCount = 1
   return(S_OK)
End Function

 
Function IObject_GetTypeInfo( Byval pthis As IOBJECT Ptr,itinfo as UINT ,lcid As LCID ,pTypeInfo As ITypeInfo Ptr Ptr )As HRESULT
 
   Static As HRESULT   hr

   ' Assume an error
   *pTypeInfo = 0
   
   if (itinfo)Then
      hr = ResultFromScode(DISP_E_BADINDEX)

   ' If our ITypeInfo is already created, just increment its ref count. NOTE: We really should
   ' store the LCID of the currently created TYPEINFO and compare it to what the caller wants.
   ' If no match, unloaded the currently created TYPEINFO, and create the correct one. But since
   ' we support only one language in our IDL file anyway, we'll ignore this
   ElseIf (MyTypeInfo)Then
   
      MyTypeInfo->lpVtbl->AddRef(MyTypeInfo)
      hr = 0
   
   else
   
      ' Load our type library and get Microsoft's generic ITypeInfo object. NOTE: We really
      ' should pass the LCID to match, but since we support only one language in our IDL
      ' file anyway, we'll ignore this
      hr = loadMyTypeInfo()
   End If

   if (0=hr) Then *pTypeInfo = MyTypeInfo

   return(hr)
End Function

' IExample2's GetIDsOfNames()
Function IObject_GetIDsOfNames( Byval pthis As IOBJECT Ptr,riid as REFIID ,rgszNames As LPOLESTR Ptr ,cNames as UINT ,lcid as LCID ,rgdispid As DISPID Ptr )As HRESULT
 
   if (0=MyTypeInfo)Then
   
      dim as HRESULT   hr

      if ((hr = loadMyTypeInfo())) Then Return(hr)
   End if
   
   ' Let OLE32.DLL's DispGetIDsOfNames() do all the real work of using our type
   ' library to look up the DISPID of the requested function in our object
   return(DispGetIDsOfNames(MyTypeInfo, rgszNames, cNames, rgdispid))
End Function

 
Function IObject_Invoke( Byval pthis As IOBJECT Ptr,dispid As DISPID ,riid As REFIID ,lcid As  LCID ,wFlags As WORD , params As DISPPARAMS Ptr ,result as VARIANT Ptr ,pexcepinfo as EXCEPINFO Ptr ,puArgErr As  UINT Ptr ) As HRESULT
 
   ' We implement only a "default" interface
   if (0=IsEqualIID(riid, @IID_NULL))Then return(DISP_E_UNKNOWNINTERFACE)

   ' We need our type lib's TYPEINFO (to pass to DispInvoke)
   if (0=MyTypeInfo)then
   
      Dim As HRESULT   hr

      if ((hr = loadMyTypeInfo())) Then Return(hr)
   End If

   ' Let OLE32.DLL's DispInvoke() do all the real work of calling the appropriate
   ' function in our object, and massaging the passed args into the correct format
   return(DispInvoke(pthis, MyTypeInfo, dispid, wFlags, params, result, pexcepinfo, puArgErr))
End function


Function IObject_SetString(Byval pthis As IObject Ptr, Byval  lpstr As BSTR) As HRESULT
        If Cast(LPOBJET,pThis)->tex Then SysFreeString(Cast(LPOBJET,pThis)->tex)
        Cast(LPOBJET,pThis)->tex = SysAllocString(lpstr) ' store a copy of the string
        If Cast(LPOBJET,pThis)->tex = 0 Then Return E_OUTOFMEMORY Else Return NOERROR
End Function

Function IObject_GetString(Byval pthis As IObject Ptr, Byval buffer As BSTR Ptr) As HRESULT
        'If buffer=0 Then Return E_POINTER
        *buffer=SysAllocString(Cast(LPOBJET,pThis)->tex)
        If *buffer=0 Then Return E_OUTOFMEMORY Else Return NOERROR
End Function

 

Static Shared MyObjectVTbl As IObjectVTbl=(@IObject_QueryInterface, _
                                           @IObject_AddRef, _
                                           @IObject_Release, _
                                           @IObject_GetTypeInfoCount, _
                                           @IObject_GetTypeInfo, _
                                           @IObject_GetIDsOfNames, _
                                           @IObject_Invoke, _
                                           @IObject_SetString, _
                                           @IObject_GetString)

'===============================
' Class Factory Functions
'===============================
Static Shared MyClassFactory As IClassFactory
 
Function classAddRef (Byval pcF As IClassFactory Ptr) As ULong
        InterlockedIncRement(@OutstandingObjects)
        Function=1
End Function

Function classQueryInterface ( pcF  As IClassFactory Ptr,  riid As REFIID ,Byval ppv As PVOID Ptr) As Long
       
        If (IsEqualIID( riid,@IID_IUnknown) Or IsEqualIID( riid,@IID_IClassFactory)) Then
               *ppv = Cast(OBJECT_ClassFactory Ptr, pcF)
               Cast(OBJECT_ClassFactory Ptr, pcF)->icf.lpVTbl->AddRef(pcF)
               
                Return S_OK               
        End If
        *ppv = 0
        Return  E_NOINTERFACE
       
        'Cast(LPUNKNOWN,*ppv)->lpvtbl->AddRef(Cast(LPUNKNOWN,*ppv))
        'Return NOERROR
End Function

Function classRelease (pcF As IClassFactory Ptr) As ULong
   Dim pthis As OBJECT_ClassFactory Ptr =Cast(OBJECT_ClassFactory Ptr, pcF)
   Dim pcc As CLASS_OBJECT Ptr
   pthis->cRef -=1
   If pthis->cRef=0 Then
      free(pthis)
      Return 0
   EndIf
   Return pthis->cRef
        'Return  InterlockedDecRement(@OutstandingObjects)
End Function

Function classCreateInstance ( pcF As IClassFactory Ptr,punkOuter  As LPUNKNOWN ,Byval vTableGuid As REFIID ,Byval objHandle  As PVOID Ptr) As HRESULT
        Dim hr As HRESULT
        Dim pthis As OBJECT_ClassFactory Ptr =Cast(OBJECT_ClassFactory Ptr, pcF)
        Dim  thisobj As CLASS_OBJECT Ptr
        *objHandle = 0
        If punkOuter Then
                Return CLASS_E_NOAGGREGATION
        Else
                thisobj = Cast(CLASS_OBJECT ptr,malloc(SizeOf(CLASS_OBJECT)))
                If thisobj = 0 Then
                        Return E_OUTOFMEMORY
                Else
                        'intialise object properties
                        thisobj->ib.lpVTbl = @MyObjectVTbl
                        thisobj->count = 1
                        thisobj->tex =0
                        If S_OK<>thisobj->ib.lpVTbl->QueryInterface( @(thisobj->ib), vTableGuid, objHandle) Then
                           free(thisobj)
                           Return  E_NOINTERFACE
                        EndIf
                        thisobj->Ib.lpVTbl->Release(@(thisobj->ib))
                        OutstandingObjects +=1
                        'If hr = 0 Then InterlockedIncRement(@OutstandingObjects)
                End If
        End If
        Return  S_OK
End Function

Function classLockServer (pcF As IClassFactory Ptr, flock As BOOL) As HRESULT
    If flock Then
         OutstandingObjects +=1
        'InterlockedIncRement(@LockCount)
    Else
         OutstandingObjects -=1
        'InterlockedDecRement(@LockCount)
    End If
    Return  NOERROR
End Function

Static Shared  As IClassFactoryVTbl MyClassFactoryVTbl=(@classQueryInterface,@classAddRef,@classRelease,@classCreateInstance,@classLockServer)

'============================================
'dll function
'============================================
'Dim shared MyTypeInfo As ITypeInfo PTR

Extern "windows-ms"

#Undef DllGetClassObject
Function DllGetClassObject  Alias "DllGetClassObject"(objGuid As GUID Ptr, factoryGuid As GUID Ptr, Byval factoryHandle As LPVOID ptr)As HRESULT Export
         static pcF As OBJECT_ClassFactory Ptr =NULL
       
            *factoryHandle = 0
           If IsEqualCLSID(@CLSID_MyObject,objGuid) Then
                  If pCF=NULL Then
                     pcF=malloc(SizeOf(pcF))
                     If pCF=NULL Then
                        Return E_OUTOFMEMORY
                     EndIf
                  EndIf
                  pcF->icf.lpVtbl=@MyClassFactoryVTbl
                  pcF->cref=0
                Return classQueryInterface(Cast(IClassFactory Ptr,pcF), factoryGuid, factoryHandle)
               
           End If
             
                *factoryHandle = 0
                Return  CLASS_E_CLASSNOTAVAILABLE
       
End Function
 
     
#Undef DllCanUnloadNow
Function DllCanUnloadNow  Alias "DllCanUnloadNow" ()As HRESULT Export
   Return  IIF(OutstandingObjects Or LockCount, S_FALSE, S_OK)
End Function

 
Function DllRegisterServer() AS Long  EXPORT
Dim lv_temp_str As ZString*2048
Dim lv_varstr As ZString*2048


CREATEREGSTRING(HKEY_CLASSES_ROOT,ProgID,NULL,ProgID)
CREATEREGSTRING(HKEY_CLASSES_ROOT,ProgID & "\CLSID",NULL,CLSIDS_MyObject)
' prepare entery for HKEY_CLASSES_ROOT
lv_varstr = ProgID
lv_temp_str = "CLSID\" & CLSIDS_MyObject
CREATEREGSTRING(HKEY_CLASSES_ROOT,lv_temp_str,NULL,lv_varstr)
CREATEREGSTRING(HKEY_CLASSES_ROOT,lv_temp_str,"AppID",CLSIDS_MyObject) ' aa
' define localtion of dll in system32
lv_temp_str = "CLSID\" & CLSIDS_MyObject & "\InprocServer32"

lv_varstr = SPACE$(1024)
GetModuleFileName(GetModuleHandle("WellCOM.dll"),lv_varstr,LEN(lv_varstr))

lv_varstr = TRIM$(lv_varstr)
CREATEREGSTRING(HKEY_CLASSES_ROOT,lv_temp_str,NULL,lv_varstr)


lv_temp_str = TRIM$(REGSTRING(HKEY_CLASSES_ROOT,lv_temp_str,NULL))

IF lv_temp_str <> lv_varstr THEN ' VERIFY THAT CORRECT VALUE IS WRITTEN IN REGISTRY
    Return  S_FALSE
END IF

lv_temp_str = "CLSID\" & CLSIDS_MyObject & "\ProgID"
CREATEREGSTRING(HKEY_CLASSES_ROOT,lv_temp_str,NULL,ProgID)


 CREATEREGSTRING(HKEY_CLASSES_ROOT,"TypeLib\" ,NULL,CLSIDS_TypeLib)
 CREATEREGSTRING(HKEY_CLASSES_ROOT,"TypeLib\" & CLSIDS_TypeLib & "\2.0" ,NULL,"WellCOM 2.0 type library")
 CREATEREGSTRING(HKEY_CLASSES_ROOT,"TypeLib\" & CLSIDS_TypeLib & "\2.0\HELPDIR" ,NULL,lv_varstr)
 CREATEREGSTRING(HKEY_CLASSES_ROOT,"TypeLib\" & CLSIDS_TypeLib & "\2.0\409\win32" ,NULL,"wellcom.tlb")
 Return  S_OK
End FUNCTION

FUNCTION DllUnregisterServer() AS HRESULT  EXPORT
Dim lv_temp_str As ZString*2048

DeleteRegKey(HKEY_CLASSES_ROOT,ProgID & "\CLSID")
DeleteRegKey(HKEY_CLASSES_ROOT,"\" & ProgID)

  lv_temp_str  = "CLSID\" & CLSIDS_MyObject & "\InprocServer32"
  DELETEREGKEY (HKEY_CLASSES_ROOT,lv_temp_str)
   
  lv_temp_str = "CLSID\" & CLSIDS_MyObject & "\ProgID"
  DeleteRegKey (HKEY_CLASSES_ROOT,lv_temp_str) 
   
  lv_temp_str = "CLSID\" & CLSIDS_MyObject
  DeleteRegKey (HKEY_CLASSES_ROOT,lv_temp_str)
 
  lv_temp_str ="TypeLib\" & CLSIDS_TypeLib
  DeleteRegKey (HKEY_CLASSES_ROOT,lv_temp_str)
 
  FUNCTION =  S_OK
End Function

End Extern


wellcom.odl

Code: Select all

// The IDL file for wellCOM.DLL
//
// "{26A8002A-83D7-45eb-98E1-09CF47A40EE3}" = Type library's GUID
// "{F2E0AC34-64BA-4871-BBFC-B9DE5BD9C80B}" =CLSID_MyObject 
// "{2A2AF189-C5A1-4a4e-9277-B4FD871A5119}" = IID_MyObject

[
   uuid(26A8002A-83D7-45eb-98E1-09CF47A40EE3),
   version(1.0),
   helpstring("IObject COM server")
         
]
library IObject
{
   importlib("STDOLE2.TLB");

   [uuid(2A2AF189-C5A1-4a4e-9277-B4FD871A5119), dual, oleautomation, hidden, nonextensible]
   interface IObject : IDispatch
   {
      [propput,helpstring("Sets the test string."),id(1)]
       HRESULT string([in] BSTR val);
      [propget,helpstring("Gets the test string."),id(1)]
       HRESULT String([out, retval] BSTR * val);
   };

   [uuid(F2E0AC34-64BA-4871-BBFC-B9DE5BD9C80B), helpstring("IObject object."), appobject]
   coclass CoObject
   {
      [default] interface IObject;
   }
}


test_wellcom.bas

Code: Select all

#define INITGUID

#Include Once "windows.bi"
#Include Once "win/ocidl.bi"




'convert string to bstr
'please follow with sysfreestring(bstr) after use to avoid memory leak
Function StringToBSTR(cnv_string As String) As BSTR
    Dim sb As BSTR
    Dim As Integer n
    n = (MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, cnv_string, -1, NULL, 0))-1
    sb=SysAllocStringLen(sb,n)
    MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, cnv_string, -1, sb, n)
    Return sb
End Function

Function BstrToStr(ByVal szW As BSTR ) As String
   Static szA As ZString*256
   If szW=NULL Then Return ""
   WideCharToMultiByte(CP_ACP,0,SzW,-1,SzA,256,NULL,NULL)
   Return szA
End Function

#define W2Ansi(A,W)  WideCharToMultiByte(CP_ACP,0,W,-1,A,2047,0,0)
#define A2Wide(A,W,L)  MultiByteToWideChar(CP_ACP,0,A,-1,W,L)


Function UnicodeToAnsi(ByVal szW As OLECHAR Ptr ) As String
   Static szA As ZString*256
   If szW=NULL Then Return ""
   WideCharToMultiByte(CP_ACP,0,SzW,-1,SzA,256,NULL,NULL)
   Return szA
End Function

Function AnsiToUnicode(A As String) As OLECHAR Ptr
   Dim W As  OLECHAR Ptr
   Dim length As Integer
   length=(2 * Len(A)) + 1
   A2Wide(StrPtr(A),W,length)
   Return W
End Function

/' Convert a string to a GUID '/

function StringToGUID(S As const  string)as GUID
   Dim Result As GUID
  CLSIDFromString(WStr(S), @Result)
  Return Result
end function

/' Convert a GUID to a string '/

function GUIDToString( ClassID As GUID) As string
  dim P As Wstring Ptr
  StringFromCLSID(@ClassID, Cast(LPOLESTR Ptr,@P))
  GUIDToString = *P
  CoTaskMemFree(P)
end function

/' Convert a programmatic ID to a class ID '/

function ProgIDToClassID( ProgID As Const String)As GUID
   Dim Result As GUID
  CLSIDFromProgID(WStr(ProgID), @Result)
  Return Result
end function

/' Convert a class ID to a programmatic ID '/

function ClassIDToProgID(ClassID As GUID)As string
 
 dim P As Wstring Ptr
 
  ProgIDFromCLSID(@ClassID, Cast(LPOLESTR Ptr,@P))
  ClassIDToProgID = *P
  CoTaskMemFree(P)
end function



function CreateComObject(ClassID as GUID)as IUnknown Ptr
  Dim Result as IUnknown
  CoCreateInstance(@ClassID, NULL, CLSCTX_INPROC_SERVER or CLSCTX_LOCAL_SERVER, @IID_IUnknown, @Result)
  Return @Result
end function

function CreateOleObject(ClassName As const  string)As IDispatch Ptr
 Dim Result As IDispatch
 dim ClassID As CLSID
   ClassID = ProgIDToClassID(ClassName)
   CoCreateInstance(@ClassID, NULL, CLSCTX_INPROC_SERVER Or CLSCTX_LOCAL_SERVER, @IID_IDispatch, @Result)
  Return  @Result
end function



SUB CreateObject OverLoad(BYVAL strProgID AS String,byref ppv as lpvoid,ByVal clsctx As Integer=CLSCTX_INPROC_SERVER Or CLSCTX_LOCAL_SERVER OR CLSCTX_REMOTE_SERVER)
   Dim pDispatch As IDispatch Ptr
   Dim pUnknown As IUnknown Ptr
   Dim hr As HRESULT
 dim ClassID As CLSID
   ClassID = ProgIDToClassID(strProgID)
   
  hr = CoCreateInstance(@ClassID,null,clsctx, @IID_IUnknown, @pUnknown)
   IF hr<>0 OR pUnknown=0 THEN EXIT Sub
   
   ' Ask for the dispatch interface
   hr = IUnknown_QueryInterface(pUnknown, @IID_IDispatch, @pDispatch)
   ' If it fails, return the Iunknown interface
   IF hr<>0 OR pDispatch=0 Then      
      ppv = pUnknown
      Exit SUB
   End IF
   ' Release the IUnknown interface
   IUnknown_Release(pUnknown)
   ' Return a pointer to the dispatch interface
   ppv = pDispatch
   
END Sub

Function CreateObject (BYVAL strProgID AS String,ByVal clsctx As Integer=CLSCTX_INPROC_SERVER Or CLSCTX_LOCAL_SERVER OR CLSCTX_REMOTE_SERVER)as lpvoid
   Dim pDispatch As IDispatch Ptr
   Dim pUnknown As IUnknown Ptr
   Dim ppv As lpvoid
   Dim hr As HRESULT
 dim ClassID As CLSID
   ClassID = ProgIDToClassID(strProgID)
 
  hr = CoCreateInstance(@ClassID,null,clsctx, @IID_IUnknown, @pUnknown)
   IF hr<>0 OR pUnknown=0 THEN Return NULL
   
   ' Ask for the dispatch interface
   hr = IUnknown_QueryInterface(pUnknown, @IID_IDispatch, @pDispatch)
   ' If it fails, return the Iunknown interface
   IF hr<>0 OR pDispatch=0 Then      
      Return pUnknown
      
   End If
   ' Release the IUnknown interface
   IUnknown_Release(pUnknown)
   ' Return a pointer to the dispatch interface
   Return pDispatch
   
END Function

#Include Once "wellcom_Constant.bi"
#Include Once "wellcom2.0_vtable.bi"

Dim g As IObject


CoInitialize(NULL)
g = CreateObject("WellCOM.Object")

If(g<>NULL) Then


  Dim As LPOLESTR bstrset =StringToBSTR("AYELMA 2012")
  Dim As LPOLESTR bstrget=NULL

 
  g->lpvtbl->putString(g,bstrset)
  g->lpvtbl->GetString(g,@bstrget)
 
  Print "getting a string from COM: "; BstrToStr(bstrget) 
   
 
 
  SysFreeString(bstrset)
  SysFreeString(bstrget)
 
  g->lpvtbl->Release(g)
Else
    Print "UNABLE TO LAUNCH THE DLL OBJECT"
   
End If
 
 
 
  CoUninitialize()
 Sleep
 


code generated by axsuite2
wellcom2.0_vtble.bi

Code: Select all

'================================================================================
'vTable - WellCOM 2.0 type library
'GUID={26A8002A-83D7-45EB-98E1-09CF47A40EE3}
'================================================================================
'================================================================================
'CLSID - WellCOM 2.0 type library
'================================================================================
Const CLSID_CoObject="{F2E0AC34-64BA-4871-BBFC-B9DE5BD9C80B}"     'IObject object.
'================================================================================
'ProgID - WellCOM 2.0 type library
'================================================================================
Const ProgID_CoObject="WellCOM.Object"

'================================================================================
'Interface IObject     ?
Const IID_IObject="{2A2AF189-C5A1-4A4E-9277-B4FD871A5119}"
'================================================================================
Type IObjectvTbl
   QueryInterface As Function (Byval pThis As Any ptr,Byref riid As GUID,Byref ppvObj As Dword) As hResult
   AddRef As Function (Byval pThis As Any ptr) As hResult
   Release As Function (Byval pThis As Any ptr) As hResult
   GetTypeInfoCount As Function (Byval pThis As Any ptr,Byref pctinfo As Uinteger) As hResult
   GetTypeInfo As Function (Byval pThis As Any ptr,Byval itinfo As Uinteger,Byval lcid As Uinteger,Byref pptinfo As Any Ptr) As hResult
   GetIDsOfNames As Function (Byval pThis As Any ptr,Byval riid As GUID,Byval rgszNames As Byte,Byval cNames As Uinteger,Byval lcid As Uinteger,Byref rgdispid As Integer) As hResult
   Invoke As Function (Byval pThis As Any ptr,Byval dispidMember As Integer,Byval riid As GUID,Byval lcid As Uinteger,Byval wFlags As Ushort,Byval pdispparams As DISPPARAMS,Byref pvarResult As Variant,Byref pexcepinfo As EXCEPINFO,Byref puArgErr As Uinteger) As hResult
   putstring As Function(pThis As Any Ptr,val As BSTR) As HRESULT     'Sets the test string.
   getstring As Function(pThis As Any Ptr,val As BSTR Ptr) As HRESULT     'Sets the test string.
End Type

Type IObject_
   lpvtbl As IObjectvTbl Ptr
End Type

VANYA
Posts: 1465
Joined: Oct 24, 2010 15:16
Location: Ярославль
Contact:

Re: Building com objects with FB

Postby VANYA » Feb 04, 2012 12:51

After building the .tlb not forget to build again the dll and register it. If you have an error let me know.


Errors in the creation and registration was not.

Here is Version 2.0 of wellcom.dll


file not found: wellcom_Constant.bi
aloberoger
Posts: 495
Joined: Jan 13, 2009 19:23

Re: Building com objects with FB

Postby aloberoger » Feb 07, 2012 7:01

you can get it with axsuite2.exe
wellcom_constant.bi

Code: Select all

'================================================================================
'Constant - IObject COM server
'GUID={26A8002A-83D7-45EB-98E1-09CF47A40EE3}
'================================================================================
'================================================================================
'Alias - IObject COM server
'================================================================================
Type IObject As IObject_ Ptr     '
 

Return to “Windows”

Who is online

Users browsing this forum: No registered users and 3 guests