Пример Com DLL сервера

Для использования:

  • скомпилировать файл fbpoint.bas как DLL
  • зарегистрировать DLL: regsvr32 fbpoint.dll
  • запустить пример использования fb_point_Test.bas
  • Для удаления регистрации: regsvr32 /u fbpoint.dll

Платформа: Windows
Автор: aloberoger

Файл fbpoint.bas:

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

' 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)

Файл fb_point_Test.bas:

' 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