Пример 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
