Building com objects with FB

[VANYA]

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     '
 

So is running. Where can I take axsuite2?

[aloberoger]

answer to WANYA
serch on the forum with the keyword axsuite2

This example shows how to attach a .tlb file to a DLL, the .tlb file will not be posted more, but rather the DLL
add in the same folder " wellcom.rc". the file " wellcom.bas " must have the modifications of the following :
From Now this example not work with vb, but work with delphi
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 LIBID_Wellcom As GUID=Type(&h26a8002a, &h83d7, &h45eb,{ &h98, &he1, &h9, &hcf, &h47, &ha4, &he, &he3})
Dim Shared CLSID_WObject As GUID=Type(&hf2e0ac34, &h64ba, &h4871,{ &hbb, &hfc, &hb9, &hde, &h5b, &hd9, &hc8, &hb})
Dim Shared IID_WObject As GUID=Type(&h2a2af189, &hc5a1, &h4a4e,{ &h92, &h77, &hb4, &hfd, &h87, &h1a, &h51, &h19})

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


'==========================================================
'registry
'==========================================================
Dim Shared ProgID As Zstring*20=>"WellCOM.WObject"
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 disposition As DWORD


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

'==============================
'_WObject function
'==============================
Type _WObjectVTbl_ As _WObjectVTbl
Type _WObject
        lpVTbl As _WObjectVTbl_ Ptr
End Type

Type _WObjectVTbl
        ' functions for Unknown Interface
        QueryInterface As Function(Byval pthis As _WObject Ptr,Byval vTableGuid As GUID Ptr,Byval ppv As lpvoid Ptr) As HRESULT
        AddRef As Function(Byval pthis As _WObject Ptr) As HRESULT
        Release As Function(Byval pthis As _WObject Ptr) As HRESULT
        ' IDispatch functions
        GetTypeInfoCount As Function ( Byval pthis As _WObject Ptr,pCount As UINT Ptr )As HRESULT
        GetTypeInfo  As Function ( Byval pthis As _WObject Ptr,itinfo as UINT ,lcid As LCID ,pTypeInfo As ITypeInfo Ptr Ptr )As HRESULT
        GetIDsOfNames  As Function ( ByVal pthis As _WObject 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 _WObject 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 _WObject Ptr, Byval  lpstr As BSTR) As HRESULT
        GetString As Function(ByVal pthis As _WObject 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 _WObject
   count As Integer
   tex As BSTR
End Type

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

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

Function IObject_QueryInterface( Byval pthis As _WObject Ptr, ByVal riid As GUID Ptr, _
                         Byval ppv As LPVOID Ptr ) As HRESULT
       
         
    If IsEqualIID(riid,@IID_IUnknown) Or IsEqualIID(riid,@IID_WObject) 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 _WObject 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(@LIBID_Wellcom, 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_WObject, @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 _WObject Ptr,pCount As UINT Ptr )As HRESULT
    *pCount = 1
   return(S_OK)
End Function

 
Function IObject_GetTypeInfo( Byval pthis As _WObject 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 _WObject 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 _WObject 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 _WObject 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 _WObject 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 _WObjectVTbl=(@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_WObject,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_WObject)
' prepare entery for HKEY_CLASSES_ROOT
lv_varstr = ProgID
lv_temp_str = "CLSID\" & CLSIDS_WObject
CREATEREGSTRING(HKEY_CLASSES_ROOT,lv_temp_str,NULL,lv_varstr)
CREATEREGSTRING(HKEY_CLASSES_ROOT,lv_temp_str,"AppID",CLSIDS_WObject) ' aa
' define localtion of dll in system32
lv_temp_str = "CLSID\" & CLSIDS_WObject & "\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)
CREATEREGSTRING(HKEY_CLASSES_ROOT,lv_temp_str,"ThreadingModel","Apartment")


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_WObject & "\ProgID"
CREATEREGSTRING(HKEY_CLASSES_ROOT,lv_temp_str,NULL,ProgID)
 
lv_temp_str = "CLSID\" & CLSIDS_WObject & "\TypeLib"
CREATEREGSTRING(HKEY_CLASSES_ROOT,lv_temp_str,NULL,LIBIDS_Wellcom)
 lv_temp_str = "CLSID\" & CLSIDS_WObject & "\VERSION"
 CreateRegString(HKEY_CLASSES_ROOT,lv_temp_str,NULL,"1.0")
 
 CreateRegString(HKEY_CLASSES_ROOT,"Interface\" & IIDS_WObject,NULL,IIDS_WObject)

CREATEREGSTRING(HKEY_CLASSES_ROOT,"Interface\" & IIDS_WObject & "\TypeLib" ,NULL,LIBIDS_Wellcom)
 
 Dim As ITypeLib ptr   pTypeLib
   lv_varstr = SPACE$(1024)
GetModuleFileName(GetModuleHandle("WellCOM.dll"),lv_varstr,LEN(lv_varstr))

 result = LoadTypeLib(StringToBSTR("Wellcom.dll"), @pTypeLib)
 if (result=0)Then
      result = RegisterTypeLib(pTypeLib, StringToBSTR(lv_varstr), NULL) 'RegisterTypeLib(ptlib, szFullPath, szHelpDir)
      pTypeLib->lpVtbl->Release(pTypeLib)
 EndIf
 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_WObject & "\InprocServer32"
  DELETEREGKEY (HKEY_CLASSES_ROOT,lv_temp_str)
   
  lv_temp_str = "CLSID\" & CLSIDS_WObject & "\ProgID"
  DeleteRegKey (HKEY_CLASSES_ROOT,lv_temp_str)
 
  lv_temp_str = "CLSID\" & CLSIDS_WObject & "\TypeLib"
  DeleteRegKey (HKEY_CLASSES_ROOT,lv_temp_str)
   
  lv_temp_str = "CLSID\" & CLSIDS_WObject & "\VERSION"
  DeleteRegKey (HKEY_CLASSES_ROOT,lv_temp_str)
   
  lv_temp_str = "CLSID\" & CLSIDS_WObject
  DeleteRegKey (HKEY_CLASSES_ROOT,lv_temp_str)
 
  lv_temp_str ="TypeLib\" & LIBIDS_Wellcom 
  DeleteRegKey (HKEY_CLASSES_ROOT,lv_temp_str)
 
 
  DeleteRegKey (HKEY_CLASSES_ROOT,"Interface\" & IIDS_WObject)
  DeleteRegKey (HKEY_CLASSES_ROOT,"Interface\" & IIDS_WObject & "\TypeLib")
  'DeleteRegKey (HKEY_CLASSES_ROOT,"Interface\" & IIDS_WObject & "\ProxyStubClsid32")
 
  '' Unregister type library
      UnRegisterTypeLib(@LIBID_Wellcom, 1, 0, LOCALE_NEUTRAL, SYS_WIN32)
  FUNCTION =  S_OK
End Function

End Extern


wellcom.odl

Code: Select all

// The IDL file for wellCOM.DLL
//
// "{26A8002A-83D7-45eb-98E1-09CF47A40EE3}" = LIBID_Wellcom
// "{F2E0AC34-64BA-4871-BBFC-B9DE5BD9C80B}" =CLSID_WObject 
// "{2A2AF189-C5A1-4a4e-9277-B4FD871A5119}" = IID_WObject

[
   uuid(26A8002A-83D7-45eb-98E1-09CF47A40EE3),  //Type library's GUID
   version(1.0),
   helpstring("WellCOM COM server")
         
]
library WellCOM
{
   importlib("stdole2.tlb");
         
         // declaration of all interfaces
        interface _WObject;
       
   [
         odl,
         uuid(2A2AF189-C5A1-4a4e-9277-B4FD871A5119), // IID_WObject
         version(1.0),
         hidden,
         dual,
         nonextensible,
         oleautomation
         
        ]

   interface _WObject : IDispatch
   {
      [propput,helpstring("Sets the test string."),id(0x00000001)]
       HRESULT strings([in] BSTR val);
      [propget,helpstring("Gets the test string."),id(0x00000001)]
       HRESULT Strings([out, retval] BSTR * val);
   };

   [
         uuid(F2E0AC34-64BA-4871-BBFC-B9DE5BD9C80B), // CLSID_WObject
         helpstring("WObject object."),
         version(1.0)
        ]
   coclass WObject
   {
      [default] interface _WObject;
   }
}


wellcom.rc

Code: Select all

1 typelib wellcom.tlb

Nota:
because wellcom.rc use wellcom.tlb, you must compile first wellcom.odl to make the wellcom.tlb


delphi test
unit1.pas

Code: Select all

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs,WellCOM_TLB, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
     w : WObject;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
   w:=CoWObject.create();
   w.strings:='ayelma';
   showMessage(w.strings);
end;

end.

In delphi: do menu Project/import type library and localize wellcom.dll and build wellcom_tlb unit

vb test

Code: Select all

 Dim iobj As WObject
  Set iobj = CreateObject("WellCOM.WObject")
  iobj.Strings = "AYELMA"
  MsgBox iobj.Strings
Set iobj = Nothing

but infortunatly with vb we have an error of memory leeks

[aloberoger]

without sharing there is no hope. vector.dll have an error because the order of functions was not the same both the declarations and the .odl. I have also fix something that Now it and work fine with vb and delphi or C++.

[Loe]

hi aloberoger,
great to see your efort to build com in fb.
i'll try your example.

[aloberoger]

I thing I have riched on one stage because both Olevariant.bi and comwrapper.bi have to be finilize.

comwrapper.bi

Code: Select all

 

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


#Include Once "olevariant.bi"
 
 Const CLSID_STRING_SIZE = 39


/' Convert a string to a GUID '/

function StringToGUID(S As 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

Sub CLSIDtoString( clsid As GUID , szCLSID As ZString Ptr,length As Integer )    ' Convert a CLSID to a char string.
 
 Dim As LPOLESTR wszCLSID=NULL
 Dim As size_t pRet
 Dim As HRESULT hr
 
 hr = StringFromCLSID(@clsid,@wszCLSID)       ' Get CLSID
 if(SUCCEEDED(hr))Then
    wcstombs(szCLSID,wszCLSID,length)  ' Covert from wide characters to non-wide.
    CoTaskMemFree(wszCLSID)               ' Free memory.
  End If
End Sub


Function CreateClassID() As string
 Dim ClassID As GUID
 Dim P  As Wstring Ptr
  CoCreateGuid(@ClassID)
  StringFromCLSID(@ClassID,Cast(LPOLESTR Ptr,@P))
  CreateClassID  = *P
  CoTaskMemFree(P)
end Function

 function GetActiveOleObject(ClassName As const string)As IDispatch Ptr
 dim ClassID As GUID
 Dim pUnknown As IUnknown Ptr
 Dim Result As IDispatch Ptr
  ClassID = ProgIDToClassID(ClassName)
  GetActiveObject(@ClassID, NULL, @pUnknown)
  IUnknown_QueryInterface(pUnknown, @IID_IDispatch, @Result)
  Return Result
 end function
 
 function CreateComObject OverLoad(strClassID As String)as IUnknown Ptr
  Dim Result as IUnknown Ptr
  Dim  As GUID ClassID=StringToGUID(strClassID)
  CoCreateInstance(@ClassID, NULL, CLSCTX_INPROC_SERVER or CLSCTX_LOCAL_SERVER, @IID_IUnknown, @Result)
  Return Result
end function

function CreateComObject(ClassID as GUID)as IUnknown Ptr
  Dim Result as IUnknown Ptr
  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 ptr
 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

 'NB: you must define    CLSIDS_##_object_##
#Define New_(_object_)  ##_object_## =Cast(##_object_##,CreateComObject(CLSIDS_##_object_##))

'NB: you must define    CLSID_##_object_##
#Define NewCOM(_object_)  ##_object_## =Cast(##_object_##,CreateComObject(CLSID_##_object_##))
 
 
 

' FUNCTIONS FOR REGISTRY

/' Create registry key '/

Sub CreateRegKey(Key As  String, ValueName As  String, Value As  String, RootKey As HKEY = HKEY_CLASSES_ROOT)
 
Dim As  HKEY  HKey
  Dim  As Integer   Status, Disposition
 
  Status = RegCreateKeyEx(RootKey, StrPtr(Key), 0, @"", _
    REG_OPTION_NON_VOLATILE, KEY_READ or KEY_WRITE, NULL, @HKey,@Disposition)
  if Status = 0 then
    Status = RegSetValueEx(HKey, StrPtr(ValueName), 0, REG_SZ,StrPtr(Value), Len(Value) + 1)
    RegCloseKey(HKey)
  end If
  if Status <> 0 then MessageBox(getactivewindow(),"Erreur ","CreateRegstring",MB_OK)
End Sub
 
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
/' Delete registry key '/

Sub DeleteRegKey OverLoad( Key As String, RootKey As HKEY = HKEY_CLASSES_ROOT)
  RegDeleteKey(RootKey, StrPtr(Key))
end Sub

/' Get registry value '/

function GetRegStringValue(  Key As String, ValueName As string, RootKey as HKEY = HKEY_CLASSES_ROOT)As string
 
Dim  Size as DWord
 Dim RegKey As HKEY
 
  Dim As String Result = ""
  if RegOpenKey(RootKey, STRPTR(Key), @RegKey) = ERROR_SUCCESS then
  'try
    Size = 256
     Result=Space(Size)
    if RegQueryValueEx(RegKey, STRPTR(ValueName), NULL, NULL, cast(LPBYTE,StrPtr(Result)), @Size) = ERROR_SUCCESS then
      Result=Space(Size - 1)
    Else
      Result = ""
    End If
  'finally
    RegCloseKey(RegKey)
  end If
  Return Result
end Function
 



 
Function SetKeyAndValue(ByVal szKey As ZString Ptr,szSubKey As ZString Ptr,  szValue As ZString Ptr ) As Long
  DIM   szKeyBuf As ZString*1024
  DIM   lResult As Long
  DIM   hKey As HKEY

  If *szKey<>"" Then
     szKeyBuf=*szKey
     If *szSubKey<>"" Then
        szKeyBuf=szKeyBuf+"\"+ *szSubKey
     End If
     lResult=RegCreateKeyEx(HKEY_CLASSES_ROOT,szKeyBuf,0,NULL,REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS,NULL,@hKey, NULL)
     If lResult<>ERROR_SUCCESS Then
        Function=FALSE
        Exit Function
     End If
     If *szValue<>"" Then
          RegSetValueEx(hKey,ByVal NULL, ByVal 0, REG_SZ, szValue, Len(*szValue)+1)
     End If
       RegCloseKey(hKey)
  Else
     Function=FALSE
     Exit Function
  End If

  Function=TRUE
End Function

Function RecursiveDeleteKey(ByVal hKeyParent As HKEY, ByRef lpszKeyChild As ZString Ptr) As Long
  Dim   As Dword dwSize
  Dim   hKeyChild As HKEY
  DIM   szBuffer As ZString*256
  Dim   F As PFILETIME   
  Dim   lRes As Long

  dwSize=256
  lRes=RegOpenKeyEx(hKeyParent,lpszKeyChild,0, KEY_ALL_ACCESS,@hKeyChild)
  If lRes<>ERROR_SUCCESS Then
     Function=lRes
     Exit Function
  End If
  While(RegEnumKeyEx(hKeyChild,0,szBuffer,@dwSize,0,0,0,F)=S_Ok)
    lRes=RecursiveDeleteKey(hKeyChild,szBuffer)  'Delete the decendents of pif child.
    If lRes<>ERROR_SUCCESS Then
         RegCloseKey(hKeyChild)
       Function=lRes
       Exit Function
    End If
    dwSize=256
  Wend
    RegCloseKey(hKeyChild)

  Function=RegDeleteKey(hKeyParent,lpszKeyChild)  'Delete pif child.
End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''' GROUPE 1 ''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 
Function RegisterServerdll OverLoad (szdllfullName As Const String, _
                                     szClsid As  Const String, _
                                     szLibid As  Const String, _
                                     szFriendlyName As  Const String, _
                                     szVerIndProgID As  Const String,_
                                     szProgID As  Const String, _
                                     description As  Const String) As Long
                      
  Dim szKey As ZString*64
  Dim iReturn As HRESULT

 
  If szClsid <> "" And szLibid <> "" Then
     szKey="CLSID\" & szClsid
     If S_OK <>SetKeyAndValue(szKey, ByVal NULL, szFriendlyName) Then
        Return E_FAIL
     End If
     If S_OK <>SetKeyAndValue(szKey, "InprocServer32", szdllfullName) Then
       Return E_FAIL
     End If
     If S_OK <>SetKeyAndValue(szKey, "ProgID", szProgID) Then
        Return E_FAIL
     End If
     If S_OK <>SetKeyAndValue(szKey, "VersionIndependentProgID", szVerIndProgID) Then
        Return E_FAIL
     End If
     If S_OK <>SetKeyAndValue(szKey, "TypeLib", szLibid) Then
        Return E_FAIL
     End If
     If S_OK <>SetKeyAndValue(szVerIndProgID,Byval NULL, szFriendlyName) Then
        Return E_FAIL 
     End If
     If S_OK <>SetKeyAndValue(szVerIndProgID, "CLSID", szClsid) Then
        Return E_FAIL
     End If
     If S_OK <>SetKeyAndValue(szVerIndProgID, "CurVer", szProgID) Then
        Return E_FAIL
     End If
     If S_OK <>SetKeyAndValue(szProgID, Byval NULL, description) Then
        Return E_FAIL
     End If
     If S_OK <>SetKeyAndValue(szProgID, "CLSID", szClsid) Then
        Return E_FAIL
     End If
     Return S_OK
     
  Else
     Return E_FAIL
     
  End If
 
End Function

Function RegisterServerExe OverLoad (szExeName As Const String, _
                                     szClsid As  Const String, _
                                     szLibid As  Const String, _
                                     szFriendlyName As  Const String, _
                                     szVerIndProgID As  Const String,_
                                     szProgID As  Const String, _
                                     description As  Const String) As Long
                      
  Dim szKey As ZString*64
  Dim iReturn As HRESULT

 
  If szClsid <> "" And szLibid <> "" Then
     szKey="CLSID\" & szClsid
     If S_OK <>SetKeyAndValue(szKey, ByVal NULL, szFriendlyName) Then
        Function=E_FAIL : Exit Function
     End If
     If S_OK <>SetKeyAndValue(szKey, "LocalServer32", szExeName) Then
        Function=E_FAIL : Exit Function
     End If
     If 0=(SetKeyAndValue(szKey, "ProgID", szProgID)) Then
        Function=E_FAIL : Exit Function
     End If
     If S_OK <>SetKeyAndValue(szKey, "VersionIndependentProgID", szVerIndProgID) Then
        Function=E_FAIL : Exit Function
     End If
     If S_OK <>SetKeyAndValue(szKey, "TypeLib", szLibid) Then
        Function=E_FAIL : Exit Function
     End If
     If S_OK <>SetKeyAndValue(szVerIndProgID,Byval NULL, szFriendlyName) Then
        Function=E_FAIL : Exit Function
     End If
     If S_OK <>SetKeyAndValue(szVerIndProgID, "CLSID", szClsid) Then
        Function=E_FAIL : Exit Function
     End If
     If S_OK <>SetKeyAndValue(szVerIndProgID, "CurVer", szProgID) Then
        Function=E_FAIL : Exit Function
     End If
     If S_OK <>SetKeyAndValue(szProgID, Byval NULL, description) Then
        Function=E_FAIL : Exit Function
     End If
     If S_OK <>SetKeyAndValue(szProgID, "CLSID", szClsid) Then
        Function=E_FAIL : Exit Function
     End If
     Function=S_OK
     Exit Function
  Else
     Function=E_FAIL
     Exit Function
  End If
 
End Function


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''GROUPE 2
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RegisterServerdll(hModule As HMODULE ,szCLSID As  ZString Ptr , szFriendlyName As ZString Ptr, szVerIndProgID As ZString Ptr,   szProgID As ZString ptr)As HRESULT
 
 'Dim  szCLSID As  ZString*CLSID_STRING_SIZE
 Dim  szModule As ZString*512
 Dim  szKey As ZString*64
 
 if(GetModuleFileName(hModule,szModule,sizeof(szModule)/sizeof(ZString Ptr)))Then
 
    strcpy(szKey, "CLSID\\")                          'Build the key CLSID\\{...}
    strcat(szKey,szCLSID)
    setKeyAndValue(szKey,NULL,szFriendlyName)          'Add the CLSID to the registry.
    setKeyAndValue(szKey, "InprocServer32", szModule)  'Add the server filename subkey under the CLSID key.
    setKeyAndValue(szKey, "ProgID", szProgID)          'Add the ProgID subkey under the CLSID key.
    setKeyAndValue(szKey,"VersionIndependentProgID",szVerIndProgID)  'Add the version-independent ProgID subkey under CLSID key.
    setKeyAndValue(szVerIndProgID, NULL, szFriendlyName)   'Add the version-independent ProgID subkey under HKEY_CLASSES_ROOT.
    setKeyAndValue(szVerIndProgID, "CLSID", szCLSID)
    setKeyAndValue(szVerIndProgID, "CurVer", szProgID)
    setKeyAndValue(szProgID, NULL, szFriendlyName)      'Add the versioned ProgID subkey under HKEY_CLASSES_ROOT.
    setKeyAndValue(szProgID, "CLSID", szCLSID) 
    Return S_OK
 else
    return E_FAIL
 End If
   
End Function


Function UnregisterServerdll( szCLSID As ZString Ptr  ,  szVerIndProgID As ZString Ptr, szProgID As ZString Ptr)As HRESULT
 
 Dim   szKey As ZString*64
 Dim As HRESULT lResult
 
 
 strcpy(szKey, "CLSID\\")                                'Build the key CLSID\\{...}
 strcat(szKey, szCLSID) 
 lResult=recursiveDeleteKey(HKEY_CLASSES_ROOT, szKey)    'Delete the CLSID Key - CLSID\{...}
 lResult=recursiveDeleteKey(HKEY_CLASSES_ROOT, szVerIndProgID)     'Delete the version-independent ProgID Key.
 lResult=recursiveDeleteKey(HKEY_CLASSES_ROOT, szProgID)      'Delete the ProgID key.
 
 return S_OK 
End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''' GROUPE3''''''''''''''''''''''''''''''''''''''''''''''''''
''''' .dll can be register if not .tlb then szLibid=""
''''' if szLibid<>"" there is a .tlb  call once TlbRegister(...) to register it
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


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, status
  status =RegCreateKeyEx(HK,Key,0,@Buff,REG_OPTION_NON_VOLATILE,KEY_ALL_ACCESS,0,@hKey,@Result)
  If status =0 Then
     Status = RegSetValueEx(hKey, VarName, 0, REG_SZ,Cast(LPBYTE,Value), Len(*Value) + 1)
    RegCloseKey(hKey)
  EndIf
   if Status <> 0 Then MessageBox(getactivewindow(),"Erreur ","CreateRegstring",MB_OK)
End Sub


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

Function DllRegister OverLoad (szfileName As String, _
                     szClsid As String, _
                     szLibid As String, _
                     szProgID As String, _
                     curver As String="1.0") As Long

CREATEREGSTRING(HKEY_CLASSES_ROOT,szProgID,NULL,szProgID)
CREATEREGSTRING(HKEY_CLASSES_ROOT,szProgID & "\CLSID",NULL,szClsid)
 
CreateRegString(HKEY_CLASSES_ROOT,"CLSID\" & szClsid,NULL,szProgID)
CREATEREGSTRING(HKEY_CLASSES_ROOT,"CLSID\" & szClsid,"AppID",szClsid)
' define localtion of dll in system32
Dim As ZString*1024 szfullfileName = SPACE$(1024)
GetModuleFileName(GetModuleHandle(szfileName),szfullfileName,LEN(szfullfileName))
CreateRegString(HKEY_CLASSES_ROOT,"CLSID\" & szClsid & "\InprocServer32",NULL,Trim(szfullfileName))
CreateRegString(HKEY_CLASSES_ROOT,"CLSID\" & szClsid & "\InprocServer32","ThreadingModel","Apartment")
CreateRegString(HKEY_CLASSES_ROOT,"CLSID\" & szClsid & "\ProgID",NULL,szProgID)
If szLibid<>"" Then
   CreateRegString(HKEY_CLASSES_ROOT,"CLSID\" & szClsid & "\TypeLib",NULL,szLibid)
End If
 CreateRegString(HKEY_CLASSES_ROOT,"CLSID\" & szClsid & "\VERSION",NULL,Trim(curver))
  Return  S_OK
End Function

Function TlbRegister(szfileName As String, szLibid As String) As Long
 If szLibid<>"" then
    Dim As ITypeLib ptr   pTypeLib
    Dim result As Long
    ' define localtion of dll in system32
Dim As ZString*1024 szfullfileName = SPACE$(1024)
GetModuleFileName(GetModuleHandle(szfileName),szfullfileName,LEN(szfullfileName))
    Dim bstrfullname As BSTR= StringToBSTR(szfullfileName)
    result = LoadTypeLib(StringToBSTR(szfileName), @pTypeLib)
    If (result=0)Then
      result = RegisterTypeLib(pTypeLib,bstrfullname , NULL) 'RegisterTypeLib(ptlib, szFullPath, szHelpDir)
      pTypeLib->lpVtbl->Release(pTypeLib)
    EndIf
    sysfreestring(bstrfullname)
 End if
 Return  S_OK
End FUNCTION

FUNCTION DllUnregister(ByVal szClsid As String, _
                       ByVal szLibid As String, _
                       ByVal szProgID As String) As HRESULT

  DeleteRegKey(HKEY_CLASSES_ROOT,szProgID & "\CLSID")
  DeleteRegKey(HKEY_CLASSES_ROOT,"\" & szProgID)
  DELETEREGKEY (HKEY_CLASSES_ROOT,"CLSID\" & szClsid & "\InprocServer32")
  DeleteRegKey (HKEY_CLASSES_ROOT,"CLSID\" & szClsid & "\ProgID")
  DeleteRegKey (HKEY_CLASSES_ROOT,"CLSID\" & szClsid & "\TypeLib")
  DeleteRegKey (HKEY_CLASSES_ROOT,"CLSID\" & szClsid & "\VERSION")
  DeleteRegKey (HKEY_CLASSES_ROOT,"CLSID\" & szClsid)
 
   FUNCTION =  S_OK
End Function

FUNCTION TlbUnregister(ByVal szLibid As String) As HRESULT

  Dim hr As HRESULT=S_OK
  If szLibid<>"" Then
  '' Unregister type library
  Dim g As GUID=StringToGUID(szLibid)
      DeleteRegKey (HKEY_CLASSES_ROOT,"TypeLib\" & szLibid)
      Return UnRegisterTypeLib(@g, 1, 0, LOCALE_NEUTRAL, SYS_WIN32)
  End If   
   
End Function


 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 ''''''''''GROUP 4'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 ' THE .TLB is in the .dll
 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 Sub cleanup(OurProgID As String,CLASSID  As GUID,LIBID As GUID,majversion As Integer=1,minversion As Integer=0 )
 
Dim As    HKEY      rootKey
Dim As   HKEY      hKey
Dim As   HKEY      hKey2
Dim As   ZString*39   buffer 

   buffer=GUIDToString(CLASSID)

   ' Open "HKEY_LOCAL_MACHINE\Software\Classes"
   if (0=RegOpenKeyEx(HKEY_LOCAL_MACHINE, @"Software\\Classes", 0, KEY_WRITE, @rootKey))Then
   
      ' Delete ProgID subkey and everything under it
      if (0=RegOpenKeyEx(rootKey, OurProgID, 0, KEY_ALL_ACCESS, @hKey))then
      
         RegDeleteKey(hKey, @"CLSID")
         RegCloseKey(hKey)
         RegDeleteKey(rootKey, OurProgID)

         ' Delete our CLSID key and everything under it
         if (0=RegOpenKeyEx(rootKey, "CLSID", 0, KEY_ALL_ACCESS, @hKey))Then
         
            if (0=RegOpenKeyEx(hKey, @buffer, 0, KEY_ALL_ACCESS, @hKey2))Then
            
               RegDeleteKey(hKey2, "InprocServer32")

               RegDeleteKey(hKey2, "ProgID")

               RegCloseKey(hKey2)
               RegDeleteKey(hKey, @buffer)
              End If

            RegCloseKey(hKey)
         End If
      End If

      RegCloseKey(rootKey)

      ' Unregister type library
      UnRegisterTypeLib(@LIBID,majversion,minversion, LOCALE_NEUTRAL, SYS_WIN32)
   End If
End Sub

 Function DllRegister (DllName As String, _
                        sProgID As String, _
                        CLASSID As GUID, _
                        LIBID As GUID, _
                        TypeLibName As String, _
                        ObjectDescription As String, _
                        majversion As Integer=1,minversion As Integer=0) As HRESULT
                           
   Dim As integer result
   Dim As ZString*512   filename

    

   'Pick out where our DLL is located. We need to know its location in
   'order to register it as a COM component
   
   
    result=1

   if (result > 0)Then
   
      Dim As HKEY      rootKey
      Dim As HKEY      hKey
      Dim As HKEY      hKey2
      Dim As HKEY      hkExtra
      Dim As ZString*39      buffer
      Dim As DWORD      disposition

' define localtion of dll in system32
GetModuleFileName(GetModuleHandle(Dllname),fileName,sizeof(fileName)/sizeof(ZString Ptr))

      

      'Open "HKEY_LOCAL_MACHINE\Software\Classes"
      if (0=RegOpenKeyEx(HKEY_LOCAL_MACHINE, @"Software\\Classes" , 0, KEY_WRITE, @rootKey))Then
      
         'For a script engine to call the OLE function CLSIDFromProgID() (passing
         'our registered ProgID in order to get our IExample3 object's GUID), then
         'we need to create a subkey named with our IExample3 ProgID string. We've
         'decided to use the ProgID "IExample3.object"
         buffer=sProgID
         if (0=RegCreateKeyEx(rootKey, Cast(LPCTSTR,@buffer) , 0, 0, REG_OPTION_NON_VOLATILE, KEY_WRITE, 0, @hKey, @disposition))Then
         
            'Set its default value to some "friendly" string that helps
            'a user identify what this COM DLL is for. Setting this value
            'is optional. You don't need to do it
            RegSetValueEx(hKey, 0, 0, REG_SZ, cast(Byte Ptr,@ObjectDescription) , Len(ObjectDescription))

            'Create a "CLSID" subkey whose default value is our IExample3 object's GUID (in ascii string format)
            disposition = RegCreateKeyEx(hKey, @"CLSID" , 0, 0, REG_OPTION_NON_VOLATILE, KEY_WRITE, 0, @hKey2,@disposition)
            if (disposition = 0)Then
            
                buffer =GUIDToString(CLASSID)
               disposition = RegSetValueEx(hKey2, 0, 0, REG_SZ, cast(Byte Ptr,@buffer ), lstrlen(@buffer ) + 1)
               RegCloseKey(hKey2)
            End If
            RegCloseKey(hKey)

            if (0=disposition)Then
            
               'Open "HKEY_LOCAL_MACHINE\Software\Classes\CLSID"
               if (0=RegOpenKeyEx(rootKey, @"CLSID" , 0, KEY_ALL_ACCESS, @hKey))then
               
                  'Create a subkey whose name is the ascii string that represents
                  'our IExample3 object's GUID
                  if (0=RegCreateKeyEx(hKey, @buffer , 0, 0, REG_OPTION_NON_VOLATILE, KEY_WRITE, 0, @hKey2, @disposition))then
                  
                     'Set its default value to some "friendly" string that helps
                     'a user identify what this COM DLL is for. Setting this value
                     'is optional. You don't need to do it
                     RegSetValueEx(hKey2, 0, 0, REG_SZ, cast(BYTE Ptr,@ObjectDescription) , Len(ObjectDescription))

                     'Create an "InprocServer32" key whose default value is the path of this DLL
                     if (0=RegCreateKeyEx(hKey2, @"InprocServer32" , 0, 0, REG_OPTION_NON_VOLATILE, KEY_WRITE, 0, @hkExtra, @disposition))then
                     
                        disposition = 1
                        if (0=RegSetValueEx(hkExtra, 0, 0, REG_SZ, Cast(BYTE Ptr,@filename) , lstrLen(@filename ) + 1))Then
                        
                           'Create a "ThreadingModel" value set to the string "both" (ie, we don't need to restrict an
                           'application to calling this DLL's functions only from a single thread. We don't use global
                           'data in our IExample3 functions, so we're thread-safe)
                           disposition = RegSetValueEx(hkExtra, @"ThreadingModel" , 0, REG_SZ, cast(BYTE Ptr,@"both" ), sizeof("both"))
                        End If
                         
   
 
                        RegCloseKey(hkExtra)

                        'Create a "ProgID" subkey whose default value is our ProgID. This allows the app to call ProgIDFromCLSID()
                        disposition = RegCreateKeyEx(hKey2, @"ProgID" , 0, 0, REG_OPTION_NON_VOLATILE, KEY_WRITE, 0, @hkExtra, @disposition)
                        if (0=disposition)Then
                            buffer=sProgID
                           disposition = RegSetValueEx(hkExtra, 0, 0, REG_SZ, cast(Byte Ptr,@buffer) , Len(buffer))
                           RegCloseKey(hkExtra)
                           if (0=disposition) Then result = 0
                        End If
                        
                        
                        RegCloseKey(hkExtra)

                        'Create a "TypeLib" subkey whose default value is our ProgID. This allows the app to call ProgIDFromCLSID()
                        disposition = RegCreateKeyEx(hKey2, @"TypeLib" , 0, 0, REG_OPTION_NON_VOLATILE, KEY_WRITE, 0, @hkExtra, @disposition)
                        if (0=disposition)Then
                            buffer= GUIDToString(LIBID)
                           disposition = RegSetValueEx(hkExtra, 0, 0, REG_SZ, cast(Byte Ptr,@buffer) , Len(buffer))
                           RegCloseKey(hkExtra)
                           if (0=disposition) Then result = 0
                        End If
                        
                     End If

                     RegCloseKey(hKey2)
                  End If

                  RegCloseKey(hKey)
               End If

               'Register the type lib (which is assumed to be a .TLB file in the same dir as this DLL)
               if (0=result)Then
                
                  Dim As ITypeLib Ptr pTypeLib
                  Dim As LPTSTR      strs

                  strs =  @filename  + lstrlen( @filename )
                  while (strs >  @filename  and *(strs - 1) <> "\\")
                     strs -=1
                  Wend
                  lstrcpy(strs,  TypeLibName )

               #ifdef UNICODE
                  if (0=(result = LoadTypeLib( @filename ,  @pTypeLib)))Then
                     result = RegisterTypeLib(pTypeLib,  @filename , 0)
                     pTypeLib->lpVtbl->Release(pTypeLib)
                  End If
               #else
                  
                  Dim As WString*MAX_PATH      wbuffer

                  MultiByteToWideChar(CP_ACP, 0,  @filename , -1,  @wbuffer , MAX_PATH)
                  result = LoadTypeLib( @wbuffer ,  @pTypeLib)
                  if (result =0)Then
                      result = RegisterTypeLib(pTypeLib,  @wbuffer , 0)
                     pTypeLib->lpVtbl->Release(pTypeLib)
                  End If
                  
               #endif
               End If

               'if (0=result)Then    MessageBox(0, "Successfully registered " & DllName & " as a COM component.",  ObjectDescription , MB_OK)
            End If
         End If

         RegCloseKey(rootKey)
      End If

      'If an error, make sure we clean everything up
      if (result)Then
          cleanup(sProgID ,CLASSID,LIBID,majversion,minversion)
         MessageBox(0,"Failed to register " & DllName & " as a COM component.",  ObjectDescription , MB_OK Or MB_ICONEXCLAMATION)
      End If
   End If

   return S_ok
 End Function

Function UnregisterDll(dllname As String, _
                       sProgID As String, _
                       CLASID As GUID,  _
                       LIBID As GUID, _
                       ObjectDescription As String, _
                       majversion As Integer=1,minversion As Integer=0 ) As HRESULT
                      
                      
   Dim As integer result
   Dim As ZString*MAX_PATH   filename

   
    result=1

   if (result > 0)Then
   
      Dim As HKEY      rootKey
      Dim As HKEY      hKey
      Dim As HKEY      hKey2
      Dim buffer As ZString*39

      buffer =GUIDToString(CLASID)

      ' Open "HKEY_LOCAL_MACHINE\Software\Classes"
      if ( 0=RegOpenKeyEx(HKEY_LOCAL_MACHINE, @"Software\\Classes" , 0, KEY_WRITE, @rootKey))Then
      
         ' Delete ProgID subkey and everything under it
         if ( 0=RegOpenKeyEx(rootKey, Cast(LPCTSTR,@sProgID)  , 0, KEY_ALL_ACCESS, @hKey))Then
         
            RegDeleteKey(hKey, @"CLSID" )
            RegCloseKey(hKey)
            RegDeleteKey(rootKey, @"ProgID")

            ' Delete our CLSID key and everything under it
            if ( 0=RegOpenKeyEx(rootKey, @"CLSID" , 0, KEY_ALL_ACCESS, @hKey))Then
            
               if ( 0=RegOpenKeyEx(hKey, @buffer , 0, KEY_ALL_ACCESS, @hKey2))Then
               
                  RegDeleteKey(hKey2, @"InprocServer32" )

                  RegDeleteKey(hKey2, @"ProgID"  )

                  RegCloseKey(hKey2)
                  RegDeleteKey(hKey, @buffer )
               End If

               RegCloseKey(hKey)
            End If
         End If

         RegCloseKey(rootKey)

         'Unregister type library
         UnRegisterTypeLib(@LIBID, majversion,minversion, LOCALE_NEUTRAL, SYS_WIN32)
      End If

      'MessageBox(0, "Unregistered " & dllname & " as a COM component.", ObjectDescription , MB_OK Or MB_ICONEXCLAMATION)
   End If

   return s_ok
End Function


[aloberoger]

Olevariant.bi

Code: Select all


#Include once"win/ocidl.bi"
#Include Once "crt/string.bi"
'#include Once "win/olectl.bi"  ' contient DllRegisterServer



#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)
#define CompareIID(A,B) memcmp (A,B,sizeof (GUID))
#define VBTRUE -1
#define GetInterface(A,B,C)    A->lpVtbl->QueryInterface(A, cast(REFIID,@IID_##B), Cast(LPVOID Ptr, @C))
#define IRelease(A)    A->lpVtbl->Release(A)
type As IFontDisp Font
type As IPictureDisp Picture


Declare Function ConvertAnsiStrToBStr(szAnsiIn As LPCSTR ,lpBstrOut As  BSTR Ptr )As HRESULT
Declare Function ConvertBStrToAnsiStr(bstrIn As BSTR ,lpszOut as LPSTR Ptr )As HRESULT
Declare Function StrToBSTR(ByVal cnv_string As String) As BSTR 'bon
Declare Function BSTRtoString(ByVal mbStr As BSTR)As String  ' bon
Declare Function BSTRtoStr(ByVal mbStr As BSTR)As zString Ptr
Declare Function strTOzstr ( Byval s1 As String ) As Zstring Ptr
Declare Function zstrTOstr ( s1 As Zstring Ptr ) As String
Declare Function BSTRtozString(ByVal mbStr As BSTR)As zString Ptr
Declare Function zStringToBSTR(ByVal sp As ZString Ptr) As BSTR
Declare Function UnicodeToAnsi (ByVal szW As OLECHAR Ptr ) As String  ' bon
Declare Function UnicodeToAnsi2(ByVal szW As BSTR ) As zString Ptr ' bon
Declare Function AnsiToUnicode(A As String) As OLECHAR Ptr



Declare Function ShowProperty (punkv As LPVOID , title As ZString Ptr)As HRESULT
Declare function RetIPict ( bm As LPVOID,imgtype As Integer)As IPictureDisp Ptr
Declare Function RetIFont (fnamme As ZString Ptr ,siz As Single ,wgt As Short ,Ital As BOOL ,Und As BOOL ,Strike As BOOL )As IFontDisp Ptr Ptr
Declare Function arrayDimCount OverLoad(array() As Integer) As Integer
Declare Function arrayDimCount (array() As Single) As Integer
Declare Function arrayDimCount (array() As Double) As Integer
Declare Function arrayDimCount (array() As String) As Integer
Declare Function arrayDimCount (array() As Short) As Integer
Declare Function arrayDimCount (array() As BSTR) As Integer
Declare Function arrayDimCount (array() As LONG) As Integer
Declare Function arrayDimCount (array() As Any Ptr) As Integer
Declare Function IsArray overload (A() As Double) As Integer
Declare Function IsArray (A() As Single) As Integer
Declare Function IsArray (A() As Integer) As Integer
Declare Function IsMatrix OverLoad(A() As Double) As Integer
Declare Function IsMatrix (A() As Single) As Integer
Declare Function IsMatrix (A() As Integer) As Integer
Declare Function getSafeArray OverLoad (vt As VARTYPE,n As LONG,m As Long, debutligne As ULong,debutcol As ULong=0) As SAFEARRAY Ptr
Declare Function getSafeArray (vt As VARTYPE,debut As ULong,n As Long) As SAFEARRAY Ptr
Declare Function getSafeArray_Ex OverLoad (vt As VARTYPE,n1 As LONG,m1 As Long, n2 As Long,m2 As Long) As SAFEARRAY Ptr
Declare Function getSafeArray_Ex (vt As VARTYPE,m1 As Long, m2 As Long,m3 As Long) As SAFEARRAY Ptr
Declare Function SafeArrayIsCreated(Mat As SAFEARRAY Ptr)As Integer
Declare Sub ArrayToSafeArray_Ex OverLoad (ByRef b As SAFEARRAY Ptr,A() As Double)
Declare Sub ArrayToSafeArray_Ex (ByRef b As SAFEARRAY Ptr,A() As Single)
Declare Sub ArrayToSafeArray_Ex (ByRef b As SAFEARRAY Ptr,A() As Integer)
Declare Sub ArrayToSafeArray_Ex (ByRef b As SAFEARRAY Ptr,A() As Short)
Declare Sub ArrayToSafeArray_Ex (ByRef b As SAFEARRAY Ptr,A() As Long)
Declare Sub ArrayToSafeArray_Ex (ByRef b As SAFEARRAY Ptr,A() As BSTR)
Declare Sub ArrayToSafeArray_Ex OverLoad (ByRef b As SAFEARRAY Ptr,A() As Any Ptr)

Declare Sub ArrayToSafeArray OverLoad (ByRef P As SAFEARRAY Ptr,A() As Double)
Declare Sub ArrayToSafeArray  (ByRef P As SAFEARRAY Ptr,A() As Single)
Declare Sub ArrayToSafeArray  (ByRef P As SAFEARRAY Ptr,A() As LONG)
Declare Sub ArrayToSafeArray  (ByRef P As SAFEARRAY Ptr,A() As BSTR)
Declare Sub ArrayToSafeArray  (ByRef P As SAFEARRAY Ptr,A() As Short)
Declare Function ArrayToSafeArray (A() As Double)As SAFEARRAY Ptr
   
Declare Sub VectorToSafeArray OverLoad ( P As SAFEARRAY Ptr,A() As BSTR)
Declare Sub VectorToSafeArray OverLoad ( P As SAFEARRAY Ptr,A() As Long)
Declare Sub VectorToSafeArray OverLoad (ByRef  b As SAFEARRAY Ptr,A() As Double)
Declare Sub VectorToSafeArray OverLoad (ByRef b As SAFEARRAY Ptr,A() As Single)
Declare Sub VectorToSafeArray OverLoad ( P As SAFEARRAY Ptr,A() As Short)
Declare Sub VectorToSafeArray (ByRef b As SAFEARRAY Ptr,A() As String)
Declare Sub VectorToSafeArray OverLoad ( P As SAFEARRAY Ptr,A() As Any Ptr)
Declare Sub SafeArrayToArray OverLoad ( A()As Double,P  As SAFEARRAY Ptr)
Declare Sub SafeArrayToArray  ( A()As Single,P  As SAFEARRAY Ptr)
Declare Sub SafeArrayTovector OverLoad ( A()As Double,ByRef P As SAFEARRAY Ptr)
Declare Sub SafeArrayTovector( mstr()As BSTR ,P As SAFEARRAY Ptr)
Declare Sub SafeArrayTovector  ( A()As Single,ByRef P  As SAFEARRAY Ptr)
Declare Sub SafeArrayToArray_Ex  ( A()As Double,ByRef P As SAFEARRAY Ptr)
Declare Sub ArrayToVariant OverLoad (ByRef hauteur  As VARIANT  Ptr ,M() As Double)
Declare Function ArrayToVariant(A() As Double)As VARIANT
Declare Function ArrayToVariant(A() As Single)As VARIANT
Declare Function ArrayToVariant(A() As BSTR)As VARIANT
Declare Function ArrayToVariant(A() As Long)As VARIANT
Declare Function ArrayToVariant(A() As Short)As VARIANT
Declare Function ArrayToVariant(A() As BOOL)As VARIANT
Declare Function ArrayToVariant(A() As Any Ptr)As VARIANT
Declare Function ArrayToVariant(arrySrc() As String)As VARIANT
Declare Sub ArrayToVariant (pVariant As VARIANT Ptr , arrySrc() As BSTR)
Declare Sub ArrayToVariant (pVariant As VARIANT Ptr , arrySrc As BSTR Ptr, n As Integer)
Declare Sub ArrayToVariant (pVariant As VARIANT Ptr , arrySrc() As Any Ptr)
Declare Sub ArrayToVariantd(ByRef V  As VARIANT  ,A() As double)
Declare Sub VariantToArray OverLoad(M() As Double, V As VARIANT)
Declare Sub VariantToArray(M() As Single, V As VARIANT)
Declare Sub VariantToArray OverLoad(arrySrc() As BSTR,v As VARIANT )
Declare Sub VariantToArray(arrySrc() As String,v As VARIANT )
Declare Sub VariantPutElement(value As Any Ptr,i As Integer,j As Integer=0)
Declare Sub VariantToArray OverLoad(arrySrc() As Any Ptr,v As VARIANT )
Declare Sub SafeArrayTovector( mstr()As String ,P As SAFEARRAY Ptr)
Declare Sub VariantToSafeArray OverLoad (ByVal V As VARIANT ,ByRef P As SAFEARRAY ptr)
Declare Function VariantToSafeArray(ByVal V As VARIANT Ptr)As SAFEARRAY Ptr
Declare Function SafeArrayToVariant(ByVal P As SAFEARRAY Ptr)As VARIANT
Declare function VarArrayCreate(Bounds()As Integer,AVarType As  VARTYPE)As VARIANT
Declare function VarArrayDimCount(A As Variant)As Integer
Declare Sub VarArrayRedim(ByRef A As Variant, HighBound As Integer)
Declare Function VarArrayLowBound( A as Variant, iDim as Integer)As Integer
Declare function VarArrayHighBound(A As Variant, iDim As  Integer)as Integer
Declare function VarArrayLock(A As Variant) As Any Ptr
Declare Sub VarArrayUnlock(A as Variant)
Declare function VarIsArray( A As  Variant)As Boolean
Declare SUB PrintMatrix OverLoad (ByVal Title AS STRING, A() AS DOUBLE)
Declare SUB PrintMatrix (ByVal Title AS STRING, A() AS Double, col1 As Integer,col2 As Integer)
Declare SUB PrintVector(ByVal Title AS STRING, B() AS DOUBLE)
Declare Function RoundFloat( Byval d As Double, Byval p As Integer ) As Double


'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 ConvertAnsiStrToBStr(szAnsiIn As LPCSTR ,lpBstrOut As  BSTR Ptr )As HRESULT

   Dim As DWORD dwSize

   if (lpBstrOut = NULL) Then Return E_INVALIDARG
   if (szAnsiIn = NULL) Then
       *lpBstrOut = NULL
        return NOERROR
   EndIf

   dwSize = MultiByteToWideChar(CP_ACP, 0, szAnsiIn, -1, NULL, 0)
   if (dwSize = 0) then return HRESULT_FROM_WIN32( GetLastError() )

   *lpBstrOut = SysAllocStringLen(NULL, dwSize - 1)
   if (*lpBstrOut = NULL) Then Return E_OUTOFMEMORY

   if ( 0=MultiByteToWideChar(CP_ACP, 0, szAnsiIn, -1, *lpBstrOut, dwSize) )Then
         SysFreeString(*lpBstrOut)
      return HRESULT_FROM_WIN32( GetLastError() )
   End If

   return NOERROR
End Function

Function ConvertBStrToAnsiStr(bstrIn As BSTR ,lpszOut as LPSTR Ptr )As HRESULT
 
Dim As    DWORD dwSize

   if (lpszOut = NULL) Then Return E_INVALIDARG
   if (bstrIn = NULL)Then
       *lpszOut = NULL
        return NOERROR
   EndIf

   dwSize = WideCharToMultiByte(CP_ACP, 0, bstrIn, -1, NULL, 0, NULL, NULL)
   if (dwSize = 0) Then Return HRESULT_FROM_WIN32( GetLastError() )

   *lpszOut = Cast(LPSTR,SysAllocStringByteLen(NULL, dwSize - 1))
   if (*lpszOut = NULL)then return E_OUTOFMEMORY

   if ( 0=WideCharToMultiByte(CP_ACP, 0, bstrIn, -1, *lpszOut, dwSize, NULL, NULL) )Then
   
      SysFreeString(Cast(BSTR,*lpszOut))
      return HRESULT_FROM_WIN32( GetLastError() )
   End If

   return NOERROR
End Function

Function StrToBSTR(ByVal 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 BSTRtoString(ByVal mbStr As BSTR)As String
    Return UnicodeToAnsi(mbstr)
End Function

Function BSTRtoStr(ByVal mbStr As BSTR)As zString Ptr
    Return UnicodeToAnsi2(mbstr)
End Function

Function strTOzstr ( Byval s1 As String ) As Zstring Ptr   
    Return StrPtr(s1 )
End Function
'-------------------------------------------------------------------------------
Function zstrTOstr ( s1 As Zstring Ptr ) As String
    Return s1[0]
End Function

Function BSTRtozString(ByVal mbStr As BSTR)As zString Ptr
   Dim s As String
   s=BSTRtoString(mbstr)
    Return Cast(ZString Ptr,@s)
End Function

Function zStringToBSTR(ByVal sp As ZString Ptr) As BSTR
    Return StrToBSTR(*sp)
End Function

Function UnicodeToAnsi (ByVal szW As OLECHAR Ptr ) As String  ' bon
   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 UnicodeToAnsi2(ByVal szW As BSTR ) As zString Ptr ' bon
   Static szA As  ZString ptr
   If szW=NULL Then Return NULL
   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


'******************************************************************************
' Helper Functions - General
'******************************************************************************
Function Cbstr (szIn As ZString Ptr,bfree As Integer=0)As BSTR Ptr
 
  static as BSTR  bStr(10)
  static As integer   index
  Dim As Integer   length
  if(bfree)Then
     
      for index=0 To 9   
         SysFreeString(bStr(index))
      Next
      return 0
  End If
  index+=1
  if(index=10)then index=0
  SysFreeString(bStr(index))
  length=(2 * len(*szIn)) + 1
  bStr(index)=SysAllocStringLen(NULL, length)
  A2Wide(szIn,bStr(index),length)
  return @bStr(index)
End Function

 
#Ifdef USECOM
   #include  "win/olectl.bi"  ' contient DllRegisterServer

 Function ShowProperty (punkv As LPVOID , title As ZString Ptr)As HRESULT

 Dim As ISpecifyPropertyPages Ptr  ptrproppages
 Dim As  CAUUID  ca
  memset(@ca,0,sizeof(CAUUID))
  Dim As HRESULT  hr
  Dim As IUnknown ptr  pUnk
  pUnk=Cast(IUnknown Ptr,punkv)
 ' hr=GetInterface(pUnk, ISpecifyPropertyPages, ptrproppages)
    pUnk->lpVtbl->QueryInterface(pUnk, cast(REFIID,@IID_ISpecifyPropertyPages), Cast(LPVOID Ptr, @ptrproppages))
  if(hr<>S_OK) Then Return hr

  hr=ptrproppages->lpVtbl->GetPages(ptrproppages,@ca)
  if(hr<>S_OK) Then Return hr
    hr=OleCreatePropertyFrame(GetActiveWindow(),30,30,*Cbstr(title),1,@pUnk,ca.cElems,ca.pElems,LOCALE_USER_DEFAULT,0,0)
  CoTaskMemFree(ca.pElems)
  IRelease(ptrproppages)
  return hr
 End Function





function RetIPict ( bm As LPVOID,imgtype As Integer)As IPictureDisp Ptr
 
  static as IPictureDisp Ptr  IPDisp
  if(IPDisp)Then IRelease(IPDisp)
 IPDisp=NULL
  if(bm=NULL)  Then return IPDisp

  Static As PICTDESC  pd
  memset(@pd,0,sizeof(pd))
  pd.cbSizeofstruct=sizeof(PICTDESC)
  pd.picType=imgtype
  if(imgtype=PICTYPE_BITMAP)Then
     
      pd.bmp.hbitmap=Cast(HBITMAP,bm )
   
  elseif(imgtype=PICTYPE_ICON)Then
     
      pd.icon.hicon=Cast(HICON,bm)
     
  else
      return NULL
   End If
  OleCreatePictureIndirect(@pd,cast(REFIID,@IID_IPictureDisp),TRUE,cast(LPVOID Ptr,@IPDisp))
  return IPDisp
End Function


 Function RetIFont (fnamme As ZString Ptr ,siz As Single ,wgt As Short ,Ital As BOOL ,Und As BOOL ,Strike As BOOL )As IFontDisp Ptr Ptr
  Dim As FONTDESC  fd  ' voir win/olectl.bi
  static As IFontDisp Ptr  IFDisp
  if(IFDisp)Then IRelease(IFDisp)

  if(fnamme=NULL)then
     
      IFDisp=NULL
      return NULL
   End If
  fd.cbSizeofstruct=sizeof(FONTDESC)
  fd.lpstrName =*Cbstr(fnamme)
'  ***PellesC users should change the next line to : fd.cySize.int64=siz*10000;
  'fd.cySize=Cast(CY,(siz*10000))
  fd.cySize.int64=siz*10000
  fd.sWeight=wgt
  fd.fItalic=Ital
  fd.fUnderline=Und
  fd.fStrikethrough=Strike
  OleCreateFontIndirect(@fd,Cast(REFIID,@IID_IFontDisp),Cast(LPVOID Ptr,@IFDisp))
  return @IFDisp
End Function

 #EndIf
 

Function arrayDimCount OverLoad(array() As Integer) As Integer
    Dim d As Integer
    Asm
        mov esi, [ebp+8]
        mov eax, [esi+16]
        mov [d], eax
    End Asm
    Return d
End Function

Function arrayDimCount (array() As Single) As Integer
    Dim d As Integer
    Asm
        mov esi, [ebp+8]
        mov eax, [esi+16]
        mov [d], eax
    End Asm
    Return d
End Function

Function arrayDimCount (array() As Double) As Integer
    Dim d As Integer
    Asm
        mov esi, [ebp+8]
        mov eax, [esi+16]
        mov [d], eax
    End Asm
    Return d
End Function

Function arrayDimCount (array() As String) As Integer
    Dim d As Integer
    Asm
         mov esi, [ebp+8]
        mov eax, [esi+16]
        mov [d], eax
    End Asm
    Return d
End Function

Function arrayDimCount (array() As Short) As Integer
    Dim d As Integer
    Asm
         mov esi, [ebp+8]
        mov eax, [esi+16]
        mov [d], eax
    End Asm
    Return d
End Function

Function arrayDimCount (array() As BSTR) As Integer
    Dim d As Integer
    Asm
         mov esi, [ebp+8]
        mov eax, [esi+16]
        mov [d], eax
    End Asm
    Return d
End Function

Function arrayDimCount (array() As LONG) As Integer
    Dim d As Integer
    Asm
         mov esi, [ebp+8]
        mov eax, [esi+16]
        mov [d], eax
    End Asm
    Return d
End Function

Function arrayDimCount (array() As Any Ptr) As Integer
   Dim d As Integer
    Asm
         mov esi, [ebp+8]
        mov eax, [esi+16]
        mov [d], eax
    End Asm
    Return d
End Function
 
Function IsArray overload (A() As Double) As Integer
   
   If arrayDimCount(A())=1 Then   
      Return 1
   Else
      Return 0
   End If   
End Function

Function IsArray (A() As Single) As Integer
   If arrayDimCount(A())=1 Then   
      Return 1
   Else
      Return 0
   End If   
End Function
Function IsArray (A() As Integer) As Integer
   If arrayDimCount(A())=1 Then   
      Return 1
   Else
      Return 0
   End If   
End Function

Function IsMatrix OverLoad(A() As Double) As Integer
   If arrayDimCount(A())=1 Then   
      Return 0
   Else
      Return arrayDimCount(A())
   End If   
   
End Function
Function IsMatrix (A() As Single) As Integer
   If arrayDimCount(A())=1 Then   
      Return 0
   Else
      Return arrayDimCount(A())
   End If   
End Function

Function IsMatrix (A() As Integer) As Integer
   If arrayDimCount(A())=1 Then   
      Return 0
   Else
      Return arrayDimCount(A())
   End If   
End Function


Function getSafeArray OverLoad (vt As VARTYPE,n As LONG,m As Long, debutligne As ULong,debutcol As ULong=0) As SAFEARRAY Ptr
   Dim a As SAFEARRAY Ptr
   Dim  aDims(0 To 1) As SAFEARRAYBOUND
      aDims(0).lLbound=debutligne
      aDims(0).cElements=n-debutligne+1
   If m<>0 Then
      aDims(1).lLbound=debutcol
      aDims(1).cElements=m-debutcol+1
      a=SafeArrayCreate(vt,2,@aDims(0))
   Else
      a=SafeArrayCreate(vt,1,@aDims(0))
   EndIf
   Return a
End Function
Function getSafeArray (vt As VARTYPE,debut As ULong,n As Long) As SAFEARRAY Ptr
   Dim a As SAFEARRAY Ptr
   Dim  aDims(0 To 1) As SAFEARRAYBOUND
      aDims(0).lLbound=debut
      aDims(0).cElements=n -debut+1
     
      a=SafeArrayCreate(vt,1,@aDims(0))
   
   Return a
End Function
Function getSafeArray_Ex OverLoad (vt As VARTYPE,n1 As LONG,m1 As Long, n2 As Long,m2 As Long) As SAFEARRAY Ptr
   Dim a As SAFEARRAY Ptr
   Dim  aDims(0 To 2) As SAFEARRAYBOUND 
    If (n1<>0 And m1<>0) Then
        If (n2=0 And m2=0) Then
              aDims(0).lLbound=n1
             aDims(0).cElements=m1-n1+1
             a=SafeArrayCreate(vt,1,@aDims(0))
             Return a
           
        End If
    End If   
    If( n1<>0 And m1<>0) Then
         If  (n2<>0 And m2<>0) Then
              aDims(0).lLbound=n1
            aDims(0).cElements=m1-n1+1
            aDims(1).lLbound=n2
            aDims(1).cElements=m2-n2+1
            a=SafeArrayCreate(vt,2,@aDims(0))
            Return a
         
         End If 
    End If
   
           
End Function
Function getSafeArray_Ex (vt As VARTYPE,m1 As Long, m2 As Long,m3 As Long) As SAFEARRAY Ptr
   Dim a As SAFEARRAY Ptr
   Dim  aDims(0 To 2) As SAFEARRAYBOUND 
               aDims(0).lLbound=1
                 aDims(0).cElements=m1
               aDims(1).lLbound=1
               aDims(1).cElements=m2
               aDims(2).lLbound=1
               aDims(2).cElements=m3
               a=SafeArrayCreate(vt,3,@aDims(0))
           Return a
             
End Function
Function getSafeArray_Ex1 (vt As VARTYPE,n1 As LONG,m1 As Long, n2 As Long=0,m2 As Long=0,n3 As Long=0,m3 As Long=0) As SAFEARRAY Ptr
   Dim a As SAFEARRAY Ptr
   Dim  aDims(0 To 2) As SAFEARRAYBOUND 
    If (n1<>0 And m1<>0) Then
        If (n2=0 And m2=0) Then
            If (n3=0 And m3=0) Then
              aDims(0).lLbound=n1
             aDims(0).cElements=m1
             a=SafeArrayCreate(vt,1,@aDims(0))
             Return a
           End If
        End If
    End If   
    If( n1<>0 And m1<>0) Then
         If  (n2<>0 And m2<>0) Then
          if (n3=0 And m3=0) Then
              aDims(0).lLbound=n1
            aDims(0).cElements=m1
            aDims(1).lLbound=n2
            aDims(1).cElements=m2
            a=SafeArrayCreate(vt,2,@aDims(0))
            Return a
          End If
        End If 
    End If
    If(n1<>0 And m1<>0)Then 
       if (n2<>0 And m2<>0) Then 
         If (n3<>0 And m3<>0) Then
                  aDims(0).lLbound=n1
                 aDims(0).cElements=m1
               aDims(1).lLbound=n2
               aDims(1).cElements=m2
               aDims(2).lLbound=n3
               aDims(2).cElements=m3
               a=SafeArrayCreate(vt,3,@aDims(0))
               Return a
         End If
       End If 
      'Else
         'MessageBox(GetActiveWindow(),"revoir les données","Erreur",MB_ICONERROR)
     End If
           
End Function

Function SafeArrayIsCreated(Mat As SAFEARRAY Ptr)As Integer
   Dim vt As VARTYPE
   If SafeArrayGetVartype(Mat,@vt)=s_ok Then
      Return 1
   Else
      Return 0
   EndIf
End Function

Sub ArrayToSafeArray_Ex OverLoad (ByRef b As SAFEARRAY Ptr,A() As Double)
   Dim As Integer i,j,k
   Dim  aDims(0 To 2) As SAFEARRAYBOUND
      aDims(0).lLbound=LBound(A,1)
      aDims(0).cElements=UBound(A,1)
      aDims(1).lLbound=LBound(A,2)
      aDims(1).cElements=UBound(A,2)
      aDims(2).lLbound=LBound(A,3)
      aDims(2).cElements=UBound(A,3)
    If SafeArrayIsCreated(b)=1 Then
        
   Else   
      b=SafeArrayCreate(VT_R8,3,@aDims(0))
    End If   
   Dim bi(0 To 2) As Integer
 
       For i=LBound(A,1) To UBound(A,1)
        bi(0)=i
        For j=LBound(A,2) To UBound(A,2)
           bi(1)=j
           For k=LBound(A,3) To UBound(A,3)
             bi(2)=k   
             SafeArrayPutElement(b,@bi(0),@A(i,j,k))
           Next
        Next
       Next
     
End Sub

Sub ArrayToSafeArray_Ex (ByRef b As SAFEARRAY Ptr,A() As Single)
   Dim As Integer i,j,k
   Dim R As Double
    Dim  aDims(0 To 2) As SAFEARRAYBOUND
      aDims(0).lLbound=LBound(A,1)
      aDims(0).cElements=UBound(A,1)
      aDims(1).lLbound=LBound(A,2)
      aDims(1).cElements=UBound(A,2)
      aDims(2).lLbound=LBound(A,3)
      aDims(2).cElements=UBound(A,3)
     If SafeArrayIsCreated(b)=1 Then
        
   Else
      b=SafeArrayCreate(VT_R8,3,@aDims(0))
     End If
   Dim bi(0 To 2) As Integer
 
       For i=LBound(A,1) To UBound(A,1)
        bi(0)=i
        For j=LBound(A,2) To UBound(A,2)
           bi(1)=j
           For k=LBound(A,3) To UBound(A,3)
             bi(2)=k   
             SafeArrayPutElement(b,@bi(0),@A(i,j,k))
           Next
        Next
       Next
     
End Sub

Sub ArrayToSafeArray_Ex (ByRef b As SAFEARRAY Ptr,A() As Integer)
   Dim As Integer i,j,k
   Dim  aDims(0 To 2) As SAFEARRAYBOUND
      aDims(0).lLbound=LBound(A,1)
      aDims(0).cElements=UBound(A,1)
      aDims(1).lLbound=LBound(A,2)
      aDims(1).cElements=UBound(A,2)
      aDims(2).lLbound=LBound(A,3)
      aDims(2).cElements=UBound(A,3)
     If SafeArrayIsCreated(b)=1 Then
        
      Else
           b=SafeArrayCreate(VT_I4,3,@aDims(0))
     End If   
   Dim bi(0 To 2) As Integer
 
       For i=LBound(A,1) To UBound(A,1)
        bi(0)=i
        For j=LBound(A,2) To UBound(A,2)
           bi(1)=j
           For k=LBound(A,3) To UBound(A,3)
             bi(2)=k   
             SafeArrayPutElement(b,@bi(0),@A(i,j,k))
           Next
        Next
       Next
     
End Sub
Sub ArrayToSafeArray_Ex (ByRef b As SAFEARRAY Ptr,A() As SHORT)
   Dim As Integer i,j,k
   Dim  aDims(0 To 2) As SAFEARRAYBOUND
      aDims(0).lLbound=LBound(A,1)
      aDims(0).cElements=UBound(A,1)
      aDims(1).lLbound=LBound(A,2)
      aDims(1).cElements=UBound(A,2)
      aDims(2).lLbound=LBound(A,3)
      aDims(2).cElements=UBound(A,3)
     If SafeArrayIsCreated(b)=1 Then
        
      Else
           b=SafeArrayCreate(VT_I2,3,@aDims(0))
     End If   
   Dim bi(0 To 2) As Integer
 
       For i=LBound(A,1) To UBound(A,1)
        bi(0)=i
        For j=LBound(A,2) To UBound(A,2)
           bi(1)=j
           For k=LBound(A,3) To UBound(A,3)
             bi(2)=k   
             SafeArrayPutElement(b,@bi(0),@A(i,j,k))
           Next
        Next
       Next
     
End Sub
Sub ArrayToSafeArray_Ex (ByRef b As SAFEARRAY Ptr,A() As Long)
   Dim As Integer i,j,k
   Dim  aDims(0 To 2) As SAFEARRAYBOUND
      aDims(0).lLbound=LBound(A,1)
      aDims(0).cElements=UBound(A,1)
      aDims(1).lLbound=LBound(A,2)
      aDims(1).cElements=UBound(A,2)
      aDims(2).lLbound=LBound(A,3)
      aDims(2).cElements=UBound(A,3)
     If SafeArrayIsCreated(b)=1 Then
        
      Else
           b=SafeArrayCreate(VT_I4,3,@aDims(0))
     End If   
   Dim bi(0 To 2) As Integer
 
       For i=LBound(A,1) To UBound(A,1)
        bi(0)=i
        For j=LBound(A,2) To UBound(A,2)
           bi(1)=j
           For k=LBound(A,3) To UBound(A,3)
             bi(2)=k   
             SafeArrayPutElement(b,@bi(0),@A(i,j,k))
           Next
        Next
       Next
     
End Sub

Sub ArrayToSafeArray_Ex (ByRef b As SAFEARRAY Ptr,A() As BSTR)
   Dim As Integer i,j,k
   Dim  aDims(0 To 2) As SAFEARRAYBOUND
      aDims(0).lLbound=LBound(A,1)
      aDims(0).cElements=UBound(A,1)
      aDims(1).lLbound=LBound(A,2)
      aDims(1).cElements=UBound(A,2)
      aDims(2).lLbound=LBound(A,3)
      aDims(2).cElements=UBound(A,3)
     If SafeArrayIsCreated(b)=1 Then
        
      Else
           b=SafeArrayCreate(VT_BSTR,3,@aDims(0))
     End If   
   Dim bi(0 To 2) As Integer
 
       For i=LBound(A,1) To UBound(A,1)
        bi(0)=i
        For j=LBound(A,2) To UBound(A,2)
           bi(1)=j
           For k=LBound(A,3) To UBound(A,3)
             bi(2)=k   
             SafeArrayPutElement(b,@bi(0),@A(i,j,k))
           Next k
        Next j
      Next i
     
End Sub

Sub ArrayToSafeArray_Ex OverLoad (ByRef b As SAFEARRAY Ptr,A() As Any Ptr)
   Dim As Integer i,j,k
   Dim  aDims(0 To 2) As SAFEARRAYBOUND
      aDims(0).lLbound=LBound(A,1)
      aDims(0).cElements=UBound(A,1)
      aDims(1).lLbound=LBound(A,2)
      aDims(1).cElements=UBound(A,2)
      aDims(2).lLbound=LBound(A,3)
      aDims(2).cElements=UBound(A,3)
     If SafeArrayIsCreated(b)=1 Then
        
      Else
           b=SafeArrayCreate(VT_VARIANT,3,@aDims(0))
     End If   
   Dim bi(0 To 2) As Integer
 
       For i=LBound(A,1) To UBound(A,1)
        bi(0)=i
        For j=LBound(A,2) To UBound(A,2)
           bi(1)=j
           For k=LBound(A,3) To UBound(A,3)
             bi(2)=k   
             SafeArrayPutElement(b,@bi(0),@A(i,j,k))
           Next k
        Next j
      Next i
     
End Sub

Sub ArrayToSafeArray OverLoad (ByRef P As SAFEARRAY Ptr,A() As Double)
   Dim As Integer i,j,mdim =arrayDimCount(A())
   Dim bi(0 To 1) As Integer
 
  If SafeArrayIsCreated(P)=1 Then
     
  Else
      If mdim=3 Then
          P=getSafeArray_Ex1 (VT_R8,LBound(A,1),UBound(A,1), LBound(A,2),UBound(A,2),LBound(A,3),UBound(A,3) ) 
      ElseIf  mdim=2 Then
      P=getSafeArray_Ex(VT_R8,LBound(A,1),UBound(A,1),LBound(A,2),UBound(A,2))
      ElseIf  mdim=1 Then
      P=getSafeArray(VT_R8,LBound(A,1),UBound(A,1)) 
    EndIf
  EndIf
 
   If SafeArrayGetDim(P)=1 Then
       'SafeArrayTovector(A(),P)
       VectorToSafeArray(P,A())   
   ElseIf SafeArrayGetDim(P)=2 Then
     For i=LBound(A,1) To UBound(A,1)
        bi(0)=i
        For j=LBound(A,2) To UBound(A,2)
           bi(1)=j
           SafeArrayPutElement(P,@bi(0),@A(i,j))
        Next
     Next
   ElseIf SafeArrayGetDim(P)=3 Then
       ArrayToSafeArray_Ex(P,A())
   End If   
     
   
End Sub
Sub ArrayToSafeArray  (ByRef P As SAFEARRAY Ptr,A() As Single)
    Dim As Integer i,j,mdim =arrayDimCount(A())
   Dim bi(0 To 1) As Integer
 
  If SafeArrayIsCreated(P)=1 Then
     
  Else
      If mdim=3 Then
            P=getSafeArray_Ex1 (VT_R4,LBound(A,1),UBound(A,1), LBound(A,2),UBound(A,2),LBound(A,3),UBound(A,3) ) 
      ElseIf  mdim=2 Then
      P=getSafeArray_Ex(VT_R4,LBound(A,1),UBound(A,1),LBound(A,2),UBound(A,2))
      ElseIf  mdim=1 Then
      P=getSafeArray(VT_R4,LBound(A,1),UBound(A,1)) 
    EndIf
  EndIf
 
   If SafeArrayGetDim(P)=1 Then
        VectorToSafeArray(P,A())   
   ElseIf SafeArrayGetDim(P)=2 Then
     For i=LBound(A,1) To UBound(A,1)
        bi(0)=i
        For j=LBound(A,2) To UBound(A,2)
           bi(1)=j
           SafeArrayPutElement(P,@bi(0),@A(i,j))
        Next
     Next
   ElseIf SafeArrayGetDim(P)=3 Then
       ArrayToSafeArray_Ex(P,A())
   End If   
End Sub
Sub ArrayToSafeArray  (ByRef P As SAFEARRAY Ptr,A() As LONG)
    Dim As Integer i,j,mdim =arrayDimCount(A())
   Dim bi(0 To 1) As Integer
 
  If SafeArrayIsCreated(P)=1 Then
     
  Else
      If mdim=3 Then
            P=getSafeArray_Ex1 (VT_I4,LBound(A,1),UBound(A,1), LBound(A,2),UBound(A,2),LBound(A,3),UBound(A,3) ) 
      ElseIf  mdim=2 Then
      P=getSafeArray_Ex(VT_I4,LBound(A,1),UBound(A,1),LBound(A,2),UBound(A,2))
      ElseIf  mdim=1 Then
      P=getSafeArray(VT_I4,LBound(A,1),UBound(A,1)) 
    EndIf
  EndIf
 
   If SafeArrayGetDim(P)=1 Then
        VectorToSafeArray(P,A())   
   ElseIf SafeArrayGetDim(P)=2 Then
     For i=LBound(A,1) To UBound(A,1)
        bi(0)=i
        For j=LBound(A,2) To UBound(A,2)
           bi(1)=j
           SafeArrayPutElement(P,@bi(0),@A(i,j))
        Next
     Next
   ElseIf SafeArrayGetDim(P)=3 Then
       ArrayToSafeArray_Ex(P,A())
   End If   
End Sub
Sub ArrayToSafeArray  (ByRef P As SAFEARRAY Ptr,A() As Short)
    Dim As Integer i,j,mdim =arrayDimCount(A())
   Dim bi(0 To 1) As Integer
 
  If SafeArrayIsCreated(P)=1 Then
     
  Else
      If mdim=3 Then
            P=getSafeArray_Ex1 (VT_I2,LBound(A,1),UBound(A,1), LBound(A,2),UBound(A,2),LBound(A,3),UBound(A,3) ) 
      ElseIf  mdim=2 Then
      P=getSafeArray_Ex(VT_I2,LBound(A,1),UBound(A,1),LBound(A,2),UBound(A,2))
      ElseIf  mdim=1 Then
      P=getSafeArray(VT_I2,LBound(A,1),UBound(A,1)) 
    EndIf
  EndIf
 
   If SafeArrayGetDim(P)=1 Then
        VectorToSafeArray(P,A())   
   ElseIf SafeArrayGetDim(P)=2 Then
     For i=LBound(A,1) To UBound(A,1)
        bi(0)=i
        For j=LBound(A,2) To UBound(A,2)
           bi(1)=j
           SafeArrayPutElement(P,@bi(0),@A(i,j))
        Next
     Next
   ElseIf SafeArrayGetDim(P)=3 Then
       ArrayToSafeArray_Ex(P,A())
   End If   
End Sub

Sub ArrayToSafeArray  (ByRef P As SAFEARRAY Ptr,A() As Any Ptr)
    Dim As Integer i,j,mdim =arrayDimCount(A())
   Dim bi(0 To 1) As Integer
  'NB:A() must Handle BSTR not string
  If SafeArrayIsCreated(P)=1 Then
     
  Else
      If mdim=3 Then
            P=getSafeArray_Ex1 (VT_VARIANT,LBound(A,1),UBound(A,1), LBound(A,2),UBound(A,2),LBound(A,3),UBound(A,3) ) 
      ElseIf  mdim=2 Then
      P=getSafeArray_Ex(VT_VARIANT,LBound(A,1),UBound(A,1),LBound(A,2),UBound(A,2))
      ElseIf  mdim=1 Then
      P=getSafeArray(VT_VARIANT,LBound(A,1),UBound(A,1)) 
    EndIf
  EndIf
 
   If SafeArrayGetDim(P)=1 Then
        VectorToSafeArray(P,A())   
   ElseIf SafeArrayGetDim(P)=2 Then
     For i=LBound(A,1) To UBound(A,1)
        bi(0)=i
        For j=LBound(A,2) To UBound(A,2)
           bi(1)=j
           SafeArrayPutElement(P,@bi(0),@A(i,j))
        Next
     Next
   ElseIf SafeArrayGetDim(P)=3 Then
       ArrayToSafeArray_Ex(P,A())
   End If   
End Sub

Sub ArrayToSafeArray  (ByRef P As SAFEARRAY Ptr,A() As BSTR)
    Dim As Integer i,j,mdim =arrayDimCount(A())
   Dim bi(0 To 1) As Integer
 
  If SafeArrayIsCreated(P)=1 Then
     
  Else
      If mdim=3 Then
            P=getSafeArray_Ex1 (VT_BSTR,LBound(A,1),UBound(A,1), LBound(A,2),UBound(A,2),LBound(A,3),UBound(A,3) ) 
      ElseIf  mdim=2 Then
      P=getSafeArray_Ex(VT_BSTR,LBound(A,1),UBound(A,1),LBound(A,2),UBound(A,2))
      ElseIf  mdim=1 Then
      P=getSafeArray(VT_BSTR,LBound(A,1),UBound(A,1)) 
    EndIf
  EndIf
 
   If SafeArrayGetDim(P)=1 Then
        VectorToSafeArray(P,A())   
   ElseIf SafeArrayGetDim(P)=2 Then
     For i=LBound(A,1) To UBound(A,1)
        bi(0)=i
        For j=LBound(A,2) To UBound(A,2)
           bi(1)=j
           SafeArrayPutElement(P,@bi(0),@A(i,j))
        Next
     Next
   ElseIf SafeArrayGetDim(P)=3 Then
       ArrayToSafeArray_Ex(P,A())
   End If   
End Sub

Function ArrayToSafeArray (A() As Double)As SAFEARRAY Ptr
    Dim As Integer i,j,mdim =arrayDimCount(A())
   Dim bi(0 To 1) As Integer
  Dim P As SAFEARRAY Ptr
 
      If mdim=3 Then
         
         P=getSafeArray_Ex1 (VT_R8,LBound(A,1),UBound(A,1), LBound(A,2),UBound(A,2),LBound(A,3),UBound(A,3) ) 
      ElseIf  mdim=2 Then
      P=getSafeArray_Ex(VT_R8,LBound(A,1),UBound(A,1),LBound(A,2),UBound(A,2))
      ElseIf  mdim=1 Then
      P=getSafeArray(VT_R8,LBound(A,1),UBound(A,1)) 
    EndIf
 
 
   If SafeArrayGetDim(P)=1 Then
        VectorToSafeArray(P,A())   
   ElseIf SafeArrayGetDim(P)=2 Then
     For i=LBound(A,1) To UBound(A,1)
        bi(0)=i
        For j=LBound(A,2) To UBound(A,2)
           bi(1)=j
           SafeArrayPutElement(P,@bi(0),@A(i,j))
        Next
     Next
   ElseIf SafeArrayGetDim(P)=3 Then
       ArrayToSafeArray_Ex(P,A())
   End If 
   Return P
End Function

Sub ArrayToSafeArray  (ByRef P As SAFEARRAY Ptr,A() As String)
    Dim B() As BSTR
   
    ArrayToSafeArray  (P,B())
End Sub
Sub VectorToSafeArray OverLoad ( P As SAFEARRAY Ptr,A() As BSTR)
   Dim As Integer i,j,k,mdim =arrayDimCount(A())
   Dim bi As Integer
 
  If SafeArrayIsCreated(P)=1 Then
          
  Else
       
    P=getSafeArray(VT_BSTR,LBound(A,1),UBound(A,1)) 
   
  EndIf
 
  Dim As BSTR Ptr dwArray = NULL
  SafeArrayAccessData(P, Cast(Any Ptr,@dwArray))
 

   For  i = LBound(A,1) To  UBound(A,1)
    dwArray[i] = A(i)
   Next
 
 SafeArrayUnaccessData(P)
 
   
End Sub

Sub VectorToSafeArray OverLoad ( P As SAFEARRAY Ptr,A() As Long)
   Dim As Integer i,j, mdim =arrayDimCount(A())
   Dim bi As Integer
 
  If SafeArrayIsCreated(P)=1 Then
             
  Else
    ' P=getSafeArray(VT_BSTR  ,LBound(A,1),UBound(A,1))
    '   If mdim=3 Then
      '    P=getSafeArray_Ex1 (VT_I4,LBound(A,1),UBound(A,1), LBound(A,2),UBound(A,2),LBound(A,3),UBound(A,3) ) 
      'ElseIf  mdim=2 Then
    '  P=getSafeArray_Ex(VT_I4,LBound(A,1),UBound(A,1),LBound(A,2),UBound(A,2))
      If  mdim=1 Then
      P=getSafeArray(VT_I4,LBound(A,1),UBound(A,1)) 
    EndIf   
  EndIf
 
  Dim As LONG Ptr dwArray = NULL
 SafeArrayAccessData(P, Cast(Any Ptr,@dwArray))

 for  nCount As Integer = LBound(A,1) To  UBound(A,1)
    dwArray[nCount] = A(nCount)
 Next
 SafeArrayUnaccessData(P)
 
   
End Sub

Sub VectorToSafeArray OverLoad (ByRef  b As SAFEARRAY Ptr,A() As Double)
   Dim As Integer i,j
   Dim R As Double
   Dim bi As Integer
   
   If SafeArrayIsCreated(b)=1 Then
     
  Else
       b=getSafeArray(VT_R8,LBound(A),UBound(A))
   EndIf
   
     For i=LBound(A,1) To UBound(A,1)
        bi=i
           SafeArrayPutElement(b,@bi,@A(i))
     Next
     
End Sub

Sub VectorToSafeArray OverLoad (ByRef b As SAFEARRAY Ptr,A() As Single)
   Dim As Integer i,j
   Dim R As Single
   Dim bi As Integer
   
   If SafeArrayIsCreated(b)=1 Then
     
   Else
       b=getSafeArray(VT_R4,LBound(A),UBound(A))
   EndIf
     
     For i=LBound(A,1) To UBound(A,1)
        bi=i
           SafeArrayPutElement(b,@bi,@A(i))
     Next
     
End Sub

Sub VectorToSafeArray (ByRef b As SAFEARRAY Ptr,A() As String)
 
 Dim As SAFEARRAYBOUND aDim(1)
 aDim(0).lLbound = LBound(A)
 aDim(0).cElements = UBound(A)

 If b<>NULL Then SafeArrayDestroy(b)
 b = SafeArrayCreate(VT_BSTR, 1, @aDim(0))

 Dim As BSTR PTR dwArray = NULL
 SafeArrayAccessData(b, Cast(Any Ptr,@dwArray))

 for  nCount As Integer = LBound(A) To  UBound(A)
    dwArray[nCount] = strToBstr(A(nCount))
Next
 SafeArrayUnaccessData(b)
 Exit sub
 fin:
    MessageBox(NULL,"Erreur","string",MB_OK)       
End Sub

Sub VectorToSafeArray OverLoad ( P As SAFEARRAY Ptr,A() As Short)
   Dim As Integer i,j,k,mdim =arrayDimCount(A())
   Dim bi As Integer
 
  If SafeArrayIsCreated(P)=1 Then
          
  Else
       
    P=getSafeArray(VT_I2,LBound(A,1),UBound(A,1)) 
   
  EndIf
 
  Dim As Short Ptr dwArray = NULL
  SafeArrayAccessData(P, Cast(Any Ptr,@dwArray))
 

   For  i = LBound(A,1) To  UBound(A,1)
    dwArray[i] = A(i)
   Next
 
 SafeArrayUnaccessData(P)
 
   
End Sub
Sub VectorToSafeArray OverLoad ( P As SAFEARRAY Ptr,A() As Any Ptr)
   Dim As Integer i,j,k,mdim =arrayDimCount(A())
   Dim bi As Integer
 
  If SafeArrayIsCreated(P)=1 Then
          
  Else
       
    P=getSafeArray(VT_VARIANT,LBound(A,1),UBound(A,1)) 
   
  EndIf
 
  Dim As Any Ptr Ptr dwArray = NULL
  SafeArrayAccessData(P, Cast(Any Ptr,@dwArray))
 

   For  i = LBound(A,1) To  UBound(A,1)
    dwArray[i] = A(i)
   Next
 
 SafeArrayUnaccessData(P)
 
   
End Sub

Sub SafeArrayToArray OverLoad ( A()As Double,P  As SAFEARRAY Ptr)
   Dim As Integer n1, n2, m1, m2
   Dim  As Integer i,J
   Dim bi(0 To 1) As Integer
    If SafeArrayGetDim(P)=1 Then
        SafeArrayTovector(A(),P)
    ElseIf SafeArrayGetDim(P)=2 Then
      SafeArrayGetLBound(P,1,@n1)
      SafeArrayGetLBound(P,2,@n2)
      SafeArrayGetUBound(P,1,@m1)
      SafeArrayGetUBound(P,2,@m2)
      ReDim A(n1 To m1, n2 To m2) As Double
        For i=n1 To m1
              bi(0)=i
              For j=n2 To m2
                 bi(1)=j
                 SafeArrayGetElement(P,@bi(0),@A(i,j))
              Next
        Next
    ElseIf SafeArrayGetDim(P)=3 Then
           SafeArrayToArray_Ex (A(),P)
    End If
End Sub

Sub SafeArrayToArray  ( A()As Single,P  As SAFEARRAY Ptr)
  Dim As Integer n1, n2, m1, m2
   Dim  As Integer i,J
   Dim bi(0 To 1) As Integer
    If SafeArrayGetDim(P)=1 Then
        SafeArrayTovector(A(),P)
    ElseIf SafeArrayGetDim(P)=2 Then
      SafeArrayGetLBound(P,1,@n1)
      SafeArrayGetLBound(P,2,@n2)
      SafeArrayGetUBound(P,1,@m1)
      SafeArrayGetUBound(P,2,@m2)
      ReDim A(n1 To m1, n2 To m2) As Double
        For i=n1 To m1
              bi(0)=i
              For j=n2 To m2
                 bi(1)=j
                 SafeArrayGetElement(P,@bi(0),@A(i,j))
              Next
        Next
    ElseIf SafeArrayGetDim(P)=3 Then
       '    SafeArrayToArray_Ex (A(),P)
    End If
 
End Sub

Sub SafeArrayTovector OverLoad ( A()As Double,ByRef P As SAFEARRAY Ptr)
   Dim As Integer n1, n2, m1, m2
   Dim  As Integer i,J
   Dim bi As Integer
   SafeArrayGetLBound(P,1,@n1)
   SafeArrayGetUBound(P,1,@m1)
   ReDim A(n1 To m1) As Double
   If SafeArrayGetDim (P) <>1 Then Exit Sub 
   For i=n1 To m1
     bi=i
       SafeArrayGetElement(P,@bi,@A(i))
   Next
 
End Sub



Sub SafeArrayTovector( mstr()As BSTR ,P As SAFEARRAY Ptr)
   Dim As Integer n1, m1
   Dim  As Integer i
   Dim bi As Integer
   SafeArrayGetLBound(P,1,@n1)
   SafeArrayGetUBound(P,1,@m1)
   ReDim mstr(n1 To m1) As BSTR
   
   
 Dim As BSTR Ptr arrayAccess = NULL
 SafeArrayAccessData(P, Cast(Any Ptr,@arrayAccess))
 
 for   iIndex As Integer = n1 To m1
   mstr(iIndex)=arrayAccess[iIndex]
   
 Next
 
 SafeArrayUnaccessData(P)
End Sub



Sub SafeArrayTovector  ( A()As Single,ByRef P  As SAFEARRAY Ptr)
   Dim As Integer n1, n2, m1, m2
   Dim  As Integer i,J
   Dim bi As Integer
   SafeArrayGetLBound(P,1,@n1)
   SafeArrayGetUBound(P,1,@m1)
   ReDim A(n1 To m1) As Single
   If SafeArrayGetDim (P) <>1 Then Exit Sub 
   For i=n1 To m1
     bi=i
       SafeArrayGetElement(P,@bi,@A(i))
   Next
 
End Sub
Sub SafeArrayToArray_Ex  ( A()As Double,ByRef P As SAFEARRAY Ptr)
   Dim As Integer n1, n2, m1, m2,n3,m3
   Dim  As Integer i,J,k
   Dim bi(0 To 2) As Integer
   SafeArrayGetLBound(P,1,@n1)
   SafeArrayGetLBound(P,2,@n2)
   SafeArrayGetLBound(P,2,@n3)
   
   SafeArrayGetUBound(P,1,@m1)
   SafeArrayGetUBound(P,2,@m2)
   SafeArrayGetUBound(P,2,@m3)
   ReDim A(n1 To m1, n2 To m2, n3 To m3) As Double
     
   For i=n1 To m1
     bi(0)=i
     For j=n2 To m2
        bi(1)=j
        For k=n3 To m3
          bi(2)=k
          SafeArrayGetElement(P,@bi(0),@A(i,j,k))
        Next
     Next
   Next
 
End Sub

Sub ArrayToVariant OverLoad (ByRef hauteur  As VARIANT  Ptr ,M() As Double)
   Dim  As Integer i,j
   Dim rgsabound(0 To 1)As SAFEARRAYBOUND
   Dim  position(0 To 1) As Integer
   for i=0 To 1
      rgsabound(i).lLbound = LBound(M,i+1)
      rgsabound(i).cElements = UBound(M,i+1)-LBound(M,i+1) +1
   Next i
   VariantInit(hauteur)
   
    hauteur->vt = VT_ARRAY Or VT_R8
    hauteur->parray = SafeArrayCreate(VT_R8,2,@rgsabound(0))
   
   for i=LBound(M,1) To UBound(M,1)
       position(0) = i
      for j=LBound(M,2) To UBound(M,2)
            position(1) = j
            SafeArrayPutElement(hauteur->parray,@position(0),@M(i,j))
      Next j
   Next i
 
End Sub

Function ArrayToVariant(A() As Double)As VARIANT 
   
   Dim V As VARIANT
    variantinit(@V)
   
   V.vt=VT_ARRAY Or VT_R8
   ArrayToSafeArray(V.parray,A())
   
   Return V
End Function

Function ArrayToVariant(A() As Single)As VARIANT 
   Dim V As VARIANT
   variantinit(@V)
   V.vt=VT_ARRAY Or VT_R4
   ArrayToSafeArray(V.parray,A())
    Return V
End Function

Function ArrayToVariant(A() As BSTR)As VARIANT 
   
   Dim V As VARIANT
   variantinit(@V)
   V.vt=VT_ARRAY Or VT_BSTR
   ArrayToSafeArray(V.parray,A())
   
    Return V
End Function

Function ArrayToVariant(A() As Long)As VARIANT 
   
   Dim V As VARIANT
   variantinit(@V)
   V.vt=VT_ARRAY Or VT_I4
   ArrayToSafeArray(V.parray,A())
   
    Return V
End Function

Function ArrayToVariant(A() As Short)As VARIANT 
   Dim Vvar As VARIANT 
   Dim V As VARIANT
   variantinit(@V)
   V.vt=VT_ARRAY Or VT_I2
   ArrayToSafeArray(V.parray,A())
   VariantCopy(@Vvar, @V)
   VariantClear(@V)
   Return Vvar
End Function

'Function ArrayToVariant(A() As BOOL)As VARIANT 
'   
'   Dim V As VARIANT
'   variantinit(@V)
'   V.vt=VT_ARRAY Or VT_BOOL
'   ArrayToSafeArray(V.parray,A())
'   
'    Return V
'End Function

Function ArrayToVariant(A() As Any Ptr)As VARIANT 
   
   Dim V As VARIANT
   variantinit(@V)
   V.vt=VT_ARRAY Or VT_VARIANT
   ArrayToSafeArray(V.parray,A())
   
    Return V
End Function

Function ArrayToVariant(arrySrc() As String)As VARIANT
    Dim V As VARIANT
   variantinit(@V)
   V.vt=VT_ARRAY Or VT_BSTR
   ArrayToSafeArray(V.parray,arrySrc())
   Return V
End Function
Sub ArrayToVariant (pVariant As VARIANT Ptr , arrySrc() As BSTR)
 
 ASSERT(NULL<>pVariant)
 VariantInit(pVariant)
 Dim As Integer iMax = UBound(arrySrc)

 Dim As SAFEARRAY Ptr pSafeArray
 Dim As SAFEARRAYBOUND aDim(1)
 aDim(0).lLbound = LBound(arrySrc)
 aDim(0).cElements = UBound(arrySrc)

 pVariant->vt = VT_ARRAY Or VT_BSTR

 pSafeArray = SafeArrayCreate(VT_BSTR, 1, @aDim(0))

 Dim As BSTR PTR dwArray = NULL
 SafeArrayAccessData(pSafeArray, Cast(Any Ptr,@dwArray))

 for  nCount As Integer = LBound(arrySrc) To  iMax*1
    dwArray[nCount] = arrySrc(nCount)
Next
 SafeArrayUnaccessData(pSafeArray)
 pVariant->parray = pSafeArray
End Sub

Sub ArrayToVariant (pVariant As VARIANT Ptr , arrySrc As BSTR Ptr, n As Integer)
 
 ASSERT(NULL<>pVariant)
 VariantInit(pVariant)
 Dim As Integer iMax = n

 Dim As SAFEARRAY Ptr pSafeArray
 Dim As SAFEARRAYBOUND aDim(1)
 aDim(0).lLbound = 0
 aDim(0).cElements = iMax

 pVariant->vt = VT_ARRAY Or VT_BSTR

 pSafeArray = SafeArrayCreate(VT_BSTR, 1, @aDim(0))

 Dim As BSTR PTR dwArray = NULL
 SafeArrayAccessData(pSafeArray, Cast(Any Ptr,@dwArray))

 for  nCount As Integer = 0 To  iMax*1
    dwArray[nCount] = arrySrc[nCount]
Next
 SafeArrayUnaccessData(pSafeArray)
 pVariant->parray = pSafeArray
End Sub

Sub ArrayToVariant (pVariant As VARIANT Ptr , arrySrc() As Any Ptr)
 
 ASSERT(NULL<>pVariant)
 VariantInit(pVariant)
 Dim As Integer iMax = UBound(arrySrc)

 Dim As SAFEARRAY Ptr pSafeArray
 Dim As SAFEARRAYBOUND aDim(1)
 aDim(0).lLbound = LBound(arrySrc)
 aDim(0).cElements = UBound(arrySrc)

 pVariant->vt = VT_ARRAY Or VT_VARIANT

 pSafeArray = SafeArrayCreate(VT_BSTR, 1, @aDim(0))

 Dim As Any Ptr PTR dwArray = NULL
 SafeArrayAccessData(pSafeArray, Cast(Any Ptr,@dwArray))

 for  nCount As Integer = LBound(arrySrc) To  iMax*1
    dwArray[nCount] = arrySrc(nCount)
Next
 SafeArrayUnaccessData(pSafeArray)
 pVariant->parray = pSafeArray
End Sub

 

Sub ArrayToVariantd(ByRef V  As VARIANT  ,A() As double)
   Dim P As SAFEARRAY Ptr
     ArrayToSafeArray(P,A() )
    V=SafeArrayToVariant(P)
   SafeArrayDestroy(P)
End Sub

 
Sub VariantToArray OverLoad(M() As Double, V As VARIANT)
   Dim P As SAFEARRAY Ptr
    SafeArrayCopy(V.parray,@P)
    SafeArrayToArray( M(),P)
    SafeArrayDestroy(P)
End Sub

 Sub VariantToArray(M() As Single, V As VARIANT)
   Dim P As SAFEARRAY Ptr
    SafeArrayCopy(V.parray,@P)
    SafeArrayToArray( M(),P)
 End Sub
 
 Sub VariantToArray OverLoad(arrySrc() As BSTR,v As VARIANT )
 
Dim As  long lStartBound = 0
Dim As  long lEndBound = 0
 
 Dim As SAFEARRAY Ptr pSafeArray  = v.parray
 ASSERT(NULL<>pSafeArray)
 SafeArrayGetLBound(pSafeArray, 1, @lStartBound)
 SafeArrayGetUBound(pSafeArray, 1, @lEndBound)
 ReDim arrySrc(lStartBound To lEndBound )
 
 Dim As BSTR Ptr arrayAccess = NULL
 SafeArrayAccessData(pSafeArray, Cast(Any Ptr,@arrayAccess))
 
 for   iIndex As Integer = lStartBound To lEndBound
   arrySrc(iIndex)=arrayAccess[iIndex]
   
 Next
 SafeArrayDestroy(pSafeArray)
 SafeArrayUnaccessData(pSafeArray)
End Sub

 Sub VariantToArray(arrySrc() As String,v As VARIANT )
     Dim B() As BSTR ' must be dynamic
     VariantToArray(B(),v)
     ReDim  arrySrc(LBound(B) To UBound(B)) As String
    For i As Integer=LBound(B) To UBound(B)
      arrySrc(i)= BstrToString(B(i))
    Next
 End Sub
 
 Sub VariantPutElement(value As Any Ptr,i As Integer,j As Integer=0)
    'todo
 End Sub
 
 Sub VariantToArray OverLoad(arrySrc() As Any Ptr,v As VARIANT )
 
Dim As  long lStartBound = 0
Dim As  long lEndBound = 0
 
 Dim As SAFEARRAY Ptr pSafeArray  = v.parray
 ASSERT(NULL<>pSafeArray)
 SafeArrayGetLBound(pSafeArray, 1, @lStartBound)
 SafeArrayGetUBound(pSafeArray, 1, @lEndBound)
 ReDim arrySrc(lStartBound To lEndBound )
 
 Dim As Any Ptr Ptr arrayAccess = NULL
 SafeArrayAccessData(pSafeArray, Cast(Any Ptr,@arrayAccess))
 
 for   iIndex As Integer = lStartBound To lEndBound
   arrySrc(iIndex)=arrayAccess[iIndex]
   
 Next
 SafeArrayDestroy(pSafeArray)
 SafeArrayUnaccessData(pSafeArray)
End Sub

 Sub SafeArrayTovector( mstr()As String ,P As SAFEARRAY Ptr)
    ' must be dynamic
   Dim As Integer n1, m1
   SafeArrayGetLBound(P,1,@n1)
   SafeArrayGetUBound(P,1,@m1)
   ReDim mstr(n1 To m1)
   
   ReDim B(n1 To m1) As BSTR 
   
 Dim As BSTR Ptr arrayAccess = NULL
 SafeArrayAccessData(P, Cast(Any Ptr,@arrayAccess))
 
 for   i As Integer = n1 To m1
     mstr(i)=BstrToString(arrayAccess[i])
 Next i 
 
 SafeArrayUnaccessData(P)
 
 
 
 End Sub
 
 Sub VariantToSafeArray OverLoad (ByVal V As VARIANT ,ByRef P As SAFEARRAY ptr)
    If SafeArrayCopy(V.parray,@P)=S_OK Then
         
    Else
         Messagebox(getactiveWindow(),"Une erreur est survenue","Convertion variant à SafeArray ",MB_ICONERROR)
         P=NULL
    End If
 End Sub
 
 Function VariantToSafeArray(ByVal V As VARIANT Ptr)As SAFEARRAY Ptr
     Dim P As SAFEARRAY Ptr
    If SafeArrayCopy(V->parray,@P)=S_OK Then
        Return P
    Else
       Messagebox(getactiveWindow(),"Une erreur est survenue","Convertion variant à SafeArray ",MB_ICONERROR)
       Return NULL
    End If
 End Function
 
 Function SafeArrayToVariant(ByVal P As SAFEARRAY Ptr)As VARIANT
  Dim   V As VARIANT
    If SafeArrayCopy(P,@(V.parray))=S_OK Then
        V.vt=P->cbElements
        Return V
    Else
       Messagebox(getactiveWindow(),"Une erreur est survenue","Convertion SafeArray à Variant",MB_ICONERROR)
       'Return 0
    End If
 End Function
 
 
 function VarArrayCreate(Bounds()As Integer,AVarType As  VARTYPE)As VARIANT
 Dim V As VARIANT
 Dim as Integer I, LDimCount 
 Dim P As  SAFEARRAY Ptr
 Dim  LVarBounds(0 To 63)As SAFEARRAYBOUND
   LDimCount = (UBound(Bounds) + 1) \ 2
  for I = 0 to LDimCount - 1 
    with LVarBounds(I) 
      .lLbound = Bounds(I * 2)
      .cElements = Bounds(I * 2 + 1) - .lLbound + 1
    end With
  Next
  P = SafeArrayCreate(AVarType, LDimCount, @LVarBounds(0))
 
    VariantClear(@V)

  V.VT = VT_ARRAY Or AVarType
  V.pArray = P
  Return V
end function

'function VarArrayDimCount(A As Any Ptr)As Integer
' dim P As SafeArray Ptr
'   P=VariantToSafeArray(@A)
'    Return P->cDims
'End Function

function VarArrayDimCount(A As Variant)As Integer
 dim P As SafeArray Ptr
   P=VariantToSafeArray(@A)
    Return P->cDims
End Function

Sub VarArrayRedim(ByRef A As Variant, HighBound As Integer)

  Dim VarBound As SAFEARRAYBOUND
  dim P As SafeArray Ptr
   SafearrayCopy(P,@A.parray)
  Dim As Integer DimCount =VarArrayDimCount(A)
  with *P 
    VarBound.lLbound = .rgsabound(DimCount - 1).lLbound
    VarBound.cElements  = HighBound - VarBound.lLbound + 1
  End With
   SafeArrayRedim(P, @VarBound)
   SafearrayCopy(A.parray,@P)
End Sub

Function VarArrayLowBound( A as Variant, iDim as Integer)As Integer
  Dim Res As Integer
  SafeArrayGetLBound(VariantToSafeArray(@A), iDim, @Res)
  Return Res
End Function

function VarArrayHighBound(A As Variant, iDim As  Integer)as Integer
Dim Res As Integer
  SafeArrayGetUBound(VariantToSafeArray(@A), iDim, @Res)
  Return Res
End Function

function VarArrayLock(A As Variant) As Any Ptr
Dim P As Any Ptr
  SafeArrayAccessData(VariantToSafeArray(@A), @P)
  Return P
End Function

Sub VarArrayUnlock(A as Variant)
  SafeArrayUnaccessData(VariantToSafeArray(@A))
end Sub


function VarIsArray( A As  Variant)As Boolean
    Return (A.VT and vt_Array) = vt_Array
end Function











SUB PrintMatrix OverLoad (ByVal Title AS STRING, A() AS DOUBLE)
  DIM AS INTEGER I, J,K

  PRINT : PRINT Title : PRINT
         FOR I = 1 TO UBOUND(A, 1)
          FOR J = 1 TO UBOUND(A, 2)
            PRINT USING "#####.##"; A(I, J);
          NEXT J
          PRINT
        NEXT I
 
END SUB

SUB PrintMatrix (ByVal Title AS STRING, A() AS Double, col1 As Integer,col2 As Integer)
  DIM AS INTEGER I, J,K

  PRINT : PRINT Title : PRINT
         FOR I = LBound(A, 1) TO col1
          For J = LBound(A, 2) TO col2
            PRINT USING "#####.##"; A(I, J);
          NEXT J
          PRINT
        NEXT I
 
END Sub

SUB PrintVector(ByVal Title AS STRING, B() AS DOUBLE)
  DIM AS INTEGER I

  PRINT : PRINT Title : PRINT
 
  FOR I = LBound(B,1) TO UBOUND(B,1)
    PRINT USING "#####.##"; B(I)
  NEXT I
END SUB

Function RoundFloat( Byval d As Double, Byval p As Integer ) As Double
        Dim As Integer t = 10 ^ p
        Function = Cint(d * t) / t
End Function

Function FloatToStr(Byval d As Double,byval precision As Integer=2) As String
        Dim As String f=""
        While d>0
                d\=10
                f+="#"
        Wend
        If f="" Then f="#"
        f = f & "." & String(precision,"#")
        Return f
End Function




[aloberoger]

Here is the vector.dll again, this example show how to call vtable functions,call Idispatch method via Invoke
Note: The VARIANT work well internally byval or byref, but can be exported only byref. This is the only one case in with there is problem with com in fb.therefore I removed Properties using VARIANT and put variant in parameters of Determinant to make dll to be portable.
vector.bas

Code: Select all

#include Once "windows.bi"
#include Once "crt.bi"
#Include Once "win/ocidl.bi"
 
#include Once "comwrapper.bi"
#include Once "Vector.bi"   'GUIDs and INTERFACES definitions

 'GLOBAL OBJECT COUNTER
static Shared As integer  vcObjects = 0
Static Shared As integer  cfLock    = 0

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

Dim Shared MyClassfactory As IClassFactory

'Iobjet instance data''''''''''/
Type VECTOR_OBJ
        lpvtbl As ICalculatorvtbl 
        cRef As Integer
        m_x As Double
        m_y As Double
       
End Type

Type LPVECTOR As VECTOR_OBJ Ptr

'IOBJECT INTERFACE1 METHODS'''''''''''

'IUNKNOWN IMPLEMENTATION

 Function Calc_QueryInterface(pif As ICalculator ptr,riid As REFIID , ppv As LPVOID Ptr) As HRESULT 
 

        if(IsEqualIID(riid,@IID_IUnknown) Or  IsEqualIID(riid,@IID_ICalculator) Or IsEqualIID(riid,@IID_IDispatch) ) Then ' ok
                *ppv=pif
                pif->lpVtbl->AddRef(pif)
             
                  Return NOERROR
        End If
           *ppv=0
             Return E_NOINTERFACE
       
 End Function

 Function Calc_AddRef(pif As ICalculator ptr) As HRESULT 
 
               Cast(LPVECTOR,pif)->cRef =Cast(LPVECTOR,pif)->cRef+1
        Return  Cast(LPVECTOR,pif)->cRef
End Function

Function Calc_Release(pif As ICalculator Ptr ) As HRESULT 
 
   Cast(LPVECTOR,pif)->cRef -=1
 
   
    if Cast(LPVECTOR,pif)->cRef = 0 Then
          GlobalFree (pif)
          vcObjects -=1
          return 0
    End If
        return Cast(LPVECTOR,pif)->cRef
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

   hr = LoadRegTypeLib(@LIBID_VECTOR, 1, 0, 0, @pTypeLib)
   if  hr=0 Then
      hr = pTypeLib->lpVtbl->GetTypeInfoOfGuid(pTypeLib, @IID_ICalculator, @MyTypeInfo)
      if  hr=0 Then
          pTypeLib->lpVtbl->Release(pTypeLib)
         MyTypeInfo->lpVtbl->AddRef(MyTypeInfo)
      End If
   End If

   return(hr)
End Function

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

 
Function CALC_GetTypeInfo( Byval pthis As ICalculator Ptr,itinfo as UINT ,lcid As LCID ,pTypeInfo As ITypeInfo Ptr Ptr )As HRESULT
 
   Dim As HRESULT   hr

   *pTypeInfo = 0
   
   if (itinfo)Then
      hr = ResultFromScode(DISP_E_BADINDEX)

   ElseIf (MyTypeInfo)Then
   
      MyTypeInfo->lpVtbl->AddRef(MyTypeInfo)
      hr = 0
   
   else
   
      hr = loadMyTypeInfo()
   End If

   if (0=hr) Then *pTypeInfo = MyTypeInfo

   return(hr)
End Function

Function CALC_GetIDsOfNames( Byval pthis As ICalculator 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
      hr = loadMyTypeInfo()
      if hr<>0 Then Return(hr)
   End if
   
   return(DispGetIDsOfNames(MyTypeInfo, rgszNames, cNames, rgdispid))
End Function
 
Function CALC_Invoke( Byval pthis As ICalculator 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
       hr = loadMyTypeInfo()
      if (hr<>0) Then Return(hr)
   End If

   Return(DispInvoke(pthis, MyTypeInfo, dispid, wFlags, params, result, pexcepinfo, puArgErr))
End Function
'OBJECT SPECIFIC METHODS
 
 Function Calc_ToString(pif As ICalculator ptr, pValue As BSTR Ptr)As HRESULT 
        If pvalue=0 Then Return E_POINTER
        Dim As ZString*25 s="x= "+ Str(Cast(LPVECTOR,pif)->m_x) + "  y = "+Str(Cast(LPVECTOR,pif)->m_y)
        Dim m_bs As BSTR=strToBstr(s)
        *pValue=SysAllocString(m_bs)
        sysfreestring(m_bs)
    Return NOERROR
End Function
 

Function Calc_Produit(pif As ICalculator ptr,  pValue As Double Ptr)As HRESULT 
         *pValue=(Cast(LPVECTOR,pif)->m_x)  * (Cast(LPVECTOR,pif)->m_y)
        Return NOERROR
End Function

 Function Calc_Set_x(pif As ICalculator Ptr, value As double)As HRESULT 
            Cast(LPVECTOR,pif)->m_x=value
         return NOERROR
End Function

 Function Calc_Get_x(pif As ICalculator Ptr , pValue As Double Ptr)As HRESULT 
          *pValue=cast(LPVECTOR,pif)->m_x
        return NOERROR
End Function

 Function Calc_Set_y(pif As ICalculator Ptr, value As double)As HRESULT 
         
          Cast(LPVECTOR,pif)->m_y=value

         return NOERROR
End Function

 Function Calc_Get_y(pif As ICalculator Ptr , pValue As Double Ptr)As HRESULT 
             *pValue=cast(LPVECTOR,pif)->m_y

         return NOERROR
End Function
 
 
 Function Calc_Determinant(pif As ICalculator ptr,v As VARIANT Ptr,  pValue As Double Ptr)As HRESULT 
        Dim value As Double
         
        Dim A() As Double
        VariantToArray(A() , *v)
        GaussJordan(A(),value)
        *v=ArrayToVariant(A())
         *pValue=value
         Return NOERROR
End Function

static Shared As ICalculatorVtbl vtblI1 = (@Calc_QueryInterface, _
                                           @Calc_AddRef, _
                                           @Calc_Release, _
                                           @CALC_GetTypeInfoCount, _
                                           @CALC_GetTypeInfo, _
                                           @CALC_GetIDsOfNames, _
                                           @CALC_Invoke, _
                                           @Calc_ToString, _
                                           @Calc_Get_x, _
                                           @Calc_Set_x, _
                                           @Calc_Get_y,_
                                           @Calc_Set_y, _
                                           @Calc_Produit, _
                                           @Calc_Determinant)


'CLASS FACTORY''''''''''''''''''''''''''''''''

'OBJECT CLASS FACTORY DEFINITION
 

'static Shared As IClassFactory Ptr vpcfOutside = NULL

'OBJECT CLASS FACTORY METHODS
 Function CF_QueryInterface(pcf As IClassFactory Ptr ,riid As  REFIID , ppv As PVOID Ptr)As Long
   if(IsEqualIID(riid, @IID_IUnknown) and  IsEqualIID(riid, @IID_IClassFactory)) Then 'ok
        *ppv=pcf
        pcf->lpVtbl->AddRef(pcF)
       Return S_OK   
   End If
    *ppv = 0
    return E_NOINTERFACE
 End Function

 Function CF_AddRef(pcf As IClassFactory Ptr ) As ULong
    InterLocKedIncrement(@vcObjects)
     Return 1
End Function

 Function CF_Release(pcf As IClassFactory Ptr ) As ULong
      return  InterLocKedDecrement(@vcObjects )
 End Function

'THE OBJECT CREATOR (class factory CREATEINSTANCE member)

 Function CF_CreateInstance(pcf As IClassFactory ptr,punkOuter As LPUNKNOWN ,riid as REFIID ,  ppv As PVOID Ptr)As HRESULT
 
Dim As HRESULT hr
Dim As Icalculator Ptr thisobj
           
       *ppv=0
        If (punkOuter) Then
               Return CLASS_E_NOAGGREGATION
       Else
          thisobj=Cast(Icalculator Ptr,GlobalAlloc(GMEM_FIXED,SizeOf(VECTOR_OBJ)))
           If Thisobj=NULL Then
              hr=E_OUTOFMEMORY
           
           Else
                            'Set up object's vTables
             thisobj->lpVtbl=@vtblI1
                    'Initialize object's internal attributs
             Cast(LPVECTOR,thisobj)->m_x =3.0
             Cast(LPVECTOR,thisobj)->m_y=4.0
           
                      'Set up count ref to allow self destruction if QueryInterface goes wrong
             Cast(LPVECTOR,thisobj)->cRef = 1
                               
                     'Ask for the required interface
                      hr=vtblI1.QueryInterface(Thisobj,riid,ppv)
                             vtblI1.release(Thisobj)
                       If hr=0 Then InterLockedIncrement(@vcObjects)
     
        End If
   End If     
       
   return hr
 End Function

 Function CF_LockServer(pcf As IClassFactory Ptr ,flock As BOOL ) As HRESULT
 
    If (flock) Then
         cfLock = cfLock + 1
    Else
         cfLock = cfLock - 1
    End If
 
     return NOERROR
End Function

static Shared As IClassFactoryVtbl vtblClassFactory = (@CF_QueryInterface, _
                                                       @CF_AddRef, _
                                                       @CF_Release, _
                                                       @CF_CreateInstance, _
                                                       @CF_LockServer)

 
 
Extern "windows-ms"
'DLL REQUIRED EXPORTS
#Undef DllGetClassObject
Function DllGetClassObject(rclsid As REFCLSID ,riid As REFIID , ppv As LPVOID Ptr)  As HRESULT Export
   
    if(IsEqualCLSID(rclsid, @CLSID_CALCULATOR)) Then
           Return CF_QueryInterface(@MyClassfactory, riid, ppv)
 
    else
        *ppv = 0
        Return CLASS_E_CLASSNOTAVAILABLE     
     End If
   Return S_FALSE
End Function

#Undef DllCanUnloadNow
Function DllCanUnloadNow()As  HRESULT Export
    return IIf(vcObjects=0 and  (cfLock=0) , S_OK , S_FALSE)
End Function

'Called by regsvr32 to set up registry
 
Function DllRegisterServer()As  HRESULT Export
   Dim hr As HRESULT
    hr=DllRegister("vector.dll", CLSIDS_CALCULATOR,LIBIDS_VECTOR,PROGID_CALCULATOR)
    hr=TlbRegister("vector.dll",LIBIDS_VECTOR)
   Return hr
End Function

'Called by regsvr32 to clear registry
 
Function DllUnregisterServer() As Long Export
   Dim hr As HRESULT
   hr= DllUnregister(CLSIDS_CALCULATOR,LIBIDS_VECTOR,PROGID_CALCULATOR)
   hr= TlbUnregister(LIBIDS_VECTOR)
    Return hr
End Function

End Extern


Sub Initialize Constructor
    vcObjects=0
    cfLock=0
    MyClassfactory.lpVtbl = Cast(Iclassfactoryvtbl Ptr,@vtblClassFactory)
           
End Sub

Sub finalize Destructor
 End Sub



vector.bi

Code: Select all

#ifndef _Vector_bi_
#Define _Vector_bi_

#Include Once "win/ocidl.bi"

 
Dim Shared As ZString*18 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
    ' IDispatch functions
   STDMETHOD  (GetTypeInfoCount) (As THIS_ As UINT Ptr )As HRESULT PURE
   STDMETHOD  (GetTypeInfo) (As THIS_ as UINT ,  As LCID , As ITypeInfo Ptr Ptr )As HRESULT PURE
   STDMETHOD  (GetIDsOfNames) (As THIS_ as REFIID ,  As LPOLESTR Ptr , As UINT , As LCID , As DISPID Ptr )As HRESULT PURE
   STDMETHOD  (Invoke ) (As THIS_ As DISPID , As REFIID , As  LCID , As WORD , As DISPPARAMS Ptr , As VARIANT Ptr , As EXCEPINFO Ptr , As  UINT Ptr ) As HRESULT PURE

   'ICalculator Interface Methods
   STDMETHOD  (ToString)     (As THIS_ As BSTR Ptr)As HRESULT PURE
   STDMETHOD  (Get_X)       (As THIS_  As Double Ptr)As HRESULT  PURE 
   STDMETHOD  (Set_X)       (As THIS_ As Double) As HRESULT  PURE
   STDMETHOD  (Get_Y)       (As THIS_  As Double Ptr)As HRESULT  PURE
   STDMETHOD  (Set_Y)       (As THIS_ As Double) As HRESULT  PURE
   STDMETHOD  (Produit)       (As THIS_  As Double Ptr)As HRESULT  PURE
   'STDMETHOD  (GetArray)   (As THIS_ As VARIANT Ptr )As HRESULT PURE  ' work only internally in fb
   'STDMETHOD  (SetArray)   (As THIS_ As VARIANT ) As HRESULT PURE
   STDMETHOD  (Determinant)(As THIS_  As VARIANT Ptr ,As Double Ptr)As HRESULT  PURE
End Type

 
Dim Shared As ZString*39 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})


Dim Shared As ZString*39 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})
 
Dim Shared As ZString*39  LIBIDS_VECTOR ="{440776EB-369D-4ED6-978F-46A3F6DD62FF}"
 Dim Shared As GUID LIBID_VECTOR: LIBID_VECTOR =StringToGUID(LIBIDS_VECTOR)
   
   #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

#EndIf  /'_Vector_bi_'/


test.bas

Code: Select all

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

 
 #Include Once "comwrapper.bi"
 
' extern "Windows-MS"
'    Declare Function Register   Lib "vector.dll" Alias "DllRegisterServer" () As HRESULT
'    Declare Function UnRegister Lib "vector.dll" Alias "DllUnregisterServer" () As Long
'end Extern

'Register()

 '#Include Once "Vector_constant.bi"
#Include Once "Vector_vTable.bi"

Function CreateRemoteObject(szProgId As LPCOLESTR ,riid As REFIID , dwClsContext As DWORD , _
                                                pServerInfo as COSERVERINFO Ptr ) As pvoid 
 
   Dim ppv As pvoid Ptr
   Dim As CLSID clsid
   Dim As HRESULT hr
   Dim As IClassFactory Ptr pCf = NULL

    if (0=szProgId or  0=riid or  0=ppv) Then Return NULL

   if "{" =Left(Bstrtostring(szProgId),1) then
      hr = CLSIDFromString(cast(LPOLESTR,szProgId), @clsid)
   else
      hr = CLSIDFromProgID(szProgId, @clsid)
   End If
   if (SUCCEEDED(hr))Then hr = CoGetClassObject(@clsid, dwClsContext, pServerInfo, @IID_IClassFactory, Cast(pvoid Ptr, @pCf))
   if (SUCCEEDED(hr)) Then hr = pCf->lpVtbl->CreateInstance(pCf, NULL, riid, ppv)

   if (pCf) Then pCf->lpVtbl->Release(pCf)

   return *ppv
End Function

Function  CreateObject(szProgId As LPCOLESTR ,szMachine As LPCWSTR=NULL ) As  IDispatch  Ptr
   Dim ppDisp  As  IDispatch  Ptr Ptr
   Dim As COSERVERINFO si = Any

   si.pwszName = cast(LPWSTR,szMachine)

   return Cast(IDispatch  Ptr,CreateRemoteObject(szProgId,@IID_IDispatch, _
           IIf(szMachine , CLSCTX_REMOTE_SERVER , CLSCTX_LOCAL_SERVER Or CLSCTX_INPROC_SERVER), _
           IIf(szMachine , @si , NULL)))
End Function

 
Dim  As ICalculator Ptr pCalc
Dim Shared As Double result

 
 'DON'T FORGET
  CoInitialize(NULL)

   Dim As HRESULT         hr
      
 'SIMPLE WAY using  progID
    'pCalc=CreateObject(PROGID_CALCULATOR)
     pCalc=CreateObject(PROGID_CALCULATOR)
   If  pCalc <>NULL Then       
          Dim s As BSTR
           Print "initialized values in the dll"
           pCalc->lpVtbl->ToString(pCalc,@s)
           Print "called pCalc.Tostring:  "; bstrtostring(s)
          
           pCalc->lpVtbl->putX(pCalc,250.0)
           pCalc->lpVtbl->putY(pCalc,30.0)
                     
           pCalc->lpVtbl->Produit(pCalc,@result)
           pCalc->lpVtbl->ToString(pCalc,@s)
              
          Print
          Print 
          Print "Called pCalc.Produit, value:";result ; " (should be 7500.00) " 
          Print
          Print "called pCalc.Tostring:  "; bstrtostring(s)
          sysfreestring(s)
         
         Dim V As VARIANT
         Dim A(1 To 2,1 To 2) As Double={{10,5},{4,1}}
         Dim RA() As Double
         V=ArrayToVariant(A())
       
         pCalc->lpVtbl->Determinant(pCalc,@V,@result)
         Print
         PrintMatrix("vararray V: ",A())
         Print "Called pCalc.Determinant:of V =  ";result ; " (should be -10.00) "
         Print
         Print " Look at GauuJordan in the dll implementation to understand the following"
         Print " the variant transformed by Determinant is:"
         Print " in this example square maxtrix variant transformed by Determinant is the inverse of the matrix:"
         
        variantToArray(RA(),V)
         PrintMatrix("vararray transformed V: ",RA())
       
              
            ' We have to call those extra functions indirectly via the Invoke function, as we'll
            ' see below
            
               Dim As VARIANT         ret
               Dim As ULong         count, i
               Dim As DISPID         dispid
               Dim As OLECHAR   ptr   funcName

               funcName = Strtobstr("Produit")
               Print "function name: ";bstrtostring(funcName)
               
               hr = pCalc->lpVtbl->GetIDsOfNames(pCalc,  @IID_NULL,  @funcName, 1, LOCALE_USER_DEFAULT,  @dispid)
               
               If hr<>0 Then
                  MessageBox(0, "Can't get Produit()'s DISPID", "GetIDsOfNames error", MB_OK Or MB_ICONEXCLAMATION)
               else
                   Print "Produit()'s DISPID: ",dispid
                  
                  Dim As DISPPARAMS   dspp
                  Dim As VARIANT      args(0)
                                                        VariantInit( @args(0))
                     ZeroMemory( @dspp, sizeof(DISPPARAMS))
                     dspp.cArgs = 0
                     dspp.rgvarg =  @args(0)
                     args(0).vt = VT_R8

                        hr = pCalc->lpVtbl->Invoke(pCalc, dispid,  @IID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD ,  @dspp,  @ret, 0, 0)
                        If hr<>0 Then
                           MessageBox(0, "Can't get produit name", "Invoke/produit error", MB_OK Or MB_ICONEXCLAMATION)
                                                   
                        Else
                        
                           Print "Produit via dispatch call: ";  ret.dblVal 
                     
                           VariantClear( @ret)
                         End If
                     
                  End If
       
        ' Free Interface
         pCalc->lpVtbl->Release(pCalc)   
 
 Else
   Print "unable to get valid PCalc"
 
 End If
 
 'UnRegister()
  CoUninitialize()
  Sleep


[aloberoger]

test with vb
ModOle32.bas

Code: Select all

Option Explicit

'----------------------------------------------------------------
'- Public type used in Ole32 api calls...
'----------------------------------------------------------------
Public Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type

'----------------------------------------------------------------
'- Public API Declares...
'----------------------------------------------------------------
Public Declare Function CLSIDFromString Lib "ole32.dll" (strCLS As Long, clsid As GUID) As Long
Public Declare Function CoCreateInstance Lib "ole32.dll" (rclsid As GUID, pUnkOuter As Any, ByVal dwClsContext As Long, riid As GUID, ppvObj As IUnknown) As Long

Public Declare Function ProgIDFromCLSID Lib "ole32.dll" (strCLS As Long, clsid As GUID) As Long
Public Declare Function CLSIDFromProgID Lib "ole32.dll" (strCLS As Long, clsid As GUID) As Long
Public Declare Function StringFromCLSID Lib "ole32.dll" (clsid As GUID, strCLS As Long) As Long


'----------------------------------------------------------------
'- Public Constants...
'----------------------------------------------------------------
Public Const CLSCTX_INPROC_SERVER = 1
Public Const CLSCTX_INPROC_HANDLER = 2
Public Const CLSCTX_LOCAL_SERVER = 4



' Convert a programmatic ID to a class ID '

Function ProgIDToClassID(ProgID As String) As GUID
    Dim Result As GUID
 Call CLSIDFromProgID(ByVal StrPtr(ProgID), Result)
  ProgIDToClassID = Result
End Function





'----------------------------------------------------------------
Public Function CreateObjectLocal(strCLS As String) As IUnknown
'----------------------------------------------------------------
    Dim rclsid As GUID                              ' Class identifier (CLSID) of object
    Dim IID_IUnknown As GUID                        ' Reference to identifier of IUnknown interface
    Dim pvObj As IUnknown                           ' Indirect pointer to requested interface
    Dim hr As Long                                  ' HRESULT
'----------------------------------------------------------------
    hr = CLSIDFromString(ByVal StrPtr(strCLS), rclsid) ' Convert classid to guid
   
    If (hr = 0) Then                                ' If Success
        With IID_IUnknown                           ' Build IUnknown Guid
           .Data4(0) = &HC0
           .Data4(7) = &H46
        End With
       
        hr = CoCreateInstance(rclsid, ByVal 0&, CLSCTX_INPROC_SERVER, IID_IUnknown, pvObj) ' Get instance of object from classid
       
        If (hr = 0) Then                            ' If Success
            Set CreateObjectLocal = pvObj           ' Return Created object
            Exit Function
        End If
    End If
   
    If hr Then Err.Raise hr                         ' Validate HRESULT
'----------------------------------------------------------------
End Function
'----------------------------------------------------------------


 
Public Function Ole_CreateObject(ProgID As String) As IUnknown
     Dim rclsid As GUID
      Dim IID_IUnknown As GUID                        ' Reference to identifier of IUnknown interface
    Dim pvObj As IUnknown                           ' Indirect pointer to requested interface
    Dim hr As Long
     rclsid = ProgIDToClassID(ProgID)
     If (hr = 0) Then                                ' If Success
        With IID_IUnknown                           ' Build IUnknown Guid
           .Data4(0) = &HC0
           .Data4(7) = &H46
        End With
       
        hr = CoCreateInstance(rclsid, ByVal 0&, CLSCTX_INPROC_SERVER, IID_IUnknown, pvObj) ' Get instance of object from classid
       
        If (hr = 0) Then                            ' If Success
            Set Ole_CreateObject = pvObj           ' Return Created object
             
            Exit Function
        End If
    End If
   
    If hr Then Err.Raise hr                         ' Validate HRESULT
     
End Function


Code: Select all

Private Sub Command1_Click()
Dim v As Vector.Calculator
' Set v = New Calculator ' still have memory lack
  Set v = Ole_CreateObject("VECTOR.Calculator")
 MsgBox v.ToString
 
v.x = 10
v.y = 20
MsgBox "produit de 10 par 20= " & v.Produit

Dim A(1 To 2, 1 To 2) As Double
A(1, 1) = 10: A(1, 2) = 5
A(2, 1) = 4:   A(2, 2) = 1
Dim v1 As Variant
 v1 = A
 MsgBox "Determinant= " & v.Determinant(v1)
Set v = Nothing
End Sub

'NB: Createobject de vb et New ne doivent pas fonctionner en creant un Iunknown
' Il faut savoir comment ils ont été implementés pour fixer ce ennui dans fb.Une ligne de code
' dans fb est peut etre fautive. et si vb travaille avec Idispatch cree ?



[aloberoger]

This example show how to implement collection. Only Iunknown is implemented, you can only use vtbl method.
Fbgraphics.bas

Code: Select all

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

CONST MY_DLL_NAME = "fbgraphics.dll"

 
'{02371D4E-058F-437f-98FD-A564CE683354}
DEFINE_GUID(LIBID_FBGRAPHICS, &h2371d4e, &h58f, &h437f, &h98, &hfd, &ha5, &h64, &hce, &h68, &h33, &h54)



#Include Once "pointd.bi"
#Include Once "pointds.bi"


#Include Once "pointds.bas"
#Include Once "pointd.bas"



Extern "windows-ms"
' *************************************************************************************************************
' called by REGSVR32.exe when registering com inproc server;  Example: REGSVR32 fbpoint.dll
' *************************************************************************************************************

Function DllRegisterServer() AS Long  EXPORT
 Dim hr As HRESULT
 hr= DllRegister(MY_DLL_NAME,CLSIDS_POINTD,"",ProgID_POINTD)
 hr= DllRegister(MY_DLL_NAME,CLSIDS_POINTDS,"",ProgID_POINTDS)
   
  Return hr
End FUNCTION

' *************************************************************************************************************
' called by REGSVR32.exe when /U parameter is specified (uninstall);  Example: REGSVR32 /U fbpoint.dll
' *************************************************************************************************************


FUNCTION DllUnregisterServer() AS HRESULT  EXPORT
    Dim hr As HRESULT
    hr= DllUnregister(CLSIDS_POINTD,"",ProgID_POINTD)
    hr=DllUnregister(CLSIDS_POINTDS,"",ProgID_POINTDS)
   
    Return hr
End Function


' *************************************************************************************************************
'             DllCanUnloadNow function tests if all copies of object are released, before unloading dll
' *************************************************************************************************************
#Undef DllCanUnloadNow
FUNCTION DllCanUnloadNow() AS HRESULT  EXPORT
    IF POINTD_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
 Dim pcF As IClassFactory Ptr

IF IsEqualCLSID(@CLSID_POINTD, rclsid )  Then
     Return  POINTD_CFQueryInterface(@POINTDClassFactory, riid, ppv )
     
End If
     Return  CLASS_E_CLASSNOTAVAILABLE
End Function

End Extern


Sub Initialize Constructor
   POINTD_COUNTER = 0
   POINTD_LOCKED = 0
   
   POINTDClassFactory.lpvtbl=@POINTDCFVT
   'EnablePOINTDS
       
End Sub

Sub finilize Destructor
   
End Sub


pointd.bi

Code: Select all

Dim Shared As ZString*18 ProgID_POINTD = "fbgraphics.pointd"

 '{6AC542D7-7277-4054-8505-4017F1EE17CB}
DEFINE_GUID(IID_IPOINTD,&h6ac542d7, &h7277, &h4054, &h85, &h5, &h40, &h17, &hf1, &hee, &h17, &hcb)

 

' {46354AD3-6817-4dc6-AD82-EC5F7BA30213}
DEFINE_GUID(CLSID_POINTD, &h46354ad3, &h6817, &h4dc6, &had, &h82, &hec, &h5f, &h7b, &ha3, &h2, &h13)
Static Shared CLSIDS_POINTD As ZString*39 = "{46354AD3-6817-4dc6-AD82-EC5F7BA30213}"

 
 

Type IPOINTDVtbl_ As IPOINTDVtbl

type  IPOINTD
     lpVtbl  As  IPOINTDVtbl_ Ptr
End Type

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

/'POINTD functions'/
  Get_x  As Function(As IPOINTD Ptr, Byval As Double Ptr )  As HRESULT
  put_x  As Function (As IPOINTD Ptr, As Double )  As HRESULT
  Get_y  As Function(As IPOINTD Ptr, Byval As Double Ptr )  As HRESULT
  put_y  As Function (As IPOINTD Ptr, As Double )  As HRESULT
  Norme As Function(As IPOINTD Ptr, Byval As Double Ptr  )  As HRESULT
  Angle As Function(As IPOINTD Ptr, Byval As Double Ptr  )  As HRESULT
  getPOINTDS As Function(pthis As IPOINTD Ptr,ppu As IUNKNOWN Ptr Ptr)As HRESULT
End Type


pointds.bi

Code: Select all

Dim Shared As ZString*19  ProgID_POINTDS = "fbgraphics.pointds"
 ' {503DF11E-9274-4e1e-AF10-C85466A0F3AB}
DEFINE_GUID(IID_IPointds,&h503df11e, &h9274, &h4e1e, &haf, &h10, &hc8, &h54, &h66, &ha0, &hf3, &hab)


Const CLSIDS_Pointds= "{74C159B6-CF30-448d-8805-1823DF0AD1C9}"
DEFINE_GUID(CLSID_Pointds,&h74c159b6, &hcf30, &h448d, &h88, &h5, &h18, &h23, &hdf, &ha, &hd1, &hc9)

#Undef INTERFACE
#Define INTERFACE IPOINTDS
/' Definition of interface: ILines '/
DECLARE_INTERFACE_(INTERFACE, IUnknown)
 
/'implements IUnknown interface'/
  STDMETHOD(QueryInterface)(AS THIS_  As REFIID ,  As LPVOID Ptr)  As HRESULT PURE
  STDMETHOD_(ULONG, AddRef)(As This) As ULong  PURE
  STDMETHOD_(ULONG, Release)(As This) As ULong  PURE
 
    /' ILines methods '/
    STDMETHOD(Add) (AS THIS_ As Double,As Double,As IPOINTD Ptr Ptr) AS HRESULT PURE
    STDMETHOD(get_Count) (AS THIS_ As Long Ptr  ) AS HRESULT PURE
    STDMETHOD(get_Item) (AS THIS_ As Long , As IPOINTD ptr Ptr  ) AS HRESULT PURE

    STDMETHOD(get__NewEnum) (AS THIS_ As IUnknown Ptr Ptr  ) AS HRESULT PURE
    STDMETHOD(Remove) (AS THIS_ As Long ) AS HRESULT PURE
end Type

pointd.bas

Code: Select all

TYPE OBJ_POINTD 
       lpvtbl  As IPOINTDVtbl ptr
       cRef AS INTEGER
       m_x AS Double
       m_y AS Double
       
End Type

 
Dim Shared POINTDClassFactory As IclassFactory

DIM SHARED POINTD_COUNTER AS UINT
Dim Shared POINTD_LOCKED As UINT

' INTERFACE AND FUNCTIONS
Function POINTD_QueryInterface (pthis as IPOINTD PTR, iid AS REFIID, ppv AS LPVOID Ptr) AS HRESULT

IF IsEqualIID( iid, @IID_IUnknown) Or IsEqualIID( iid, @IID_IPOINTD) Then 'Or IsEqualIID( iid, @IID_IPOINTDS) Then
   *ppv = pThis
  pthis->lpVtbl->AddRef(pthis)
 Return  S_OK

End IF

ppv = NULL
FUNCTION =  E_NOINTERFACE
End Function


Function POINTD_AddRef(pthis AS IPOINTD PTR) AS ULONG
  Cast(OBJ_POINTD  Ptr,pthis)->cRef +=1
 Function = Cast(OBJ_POINTD  Ptr,pthis)->cRef
End Function


Function POINTD_Release(pthis AS IPOINTD PTR) AS ULONG
Cast(OBJ_POINTD  Ptr,pthis)->cRef -=1
 
IF Cast(OBJ_POINTD  Ptr,pthis)->cRef = 0 THEN
  POINTD_COUNTER -=1
  Globalfree(pThis)
  Return 0
END IF

FUNCTION = Cast(OBJ_POINTD  Ptr,pthis)->cRef
End Function





FUNCTION POINTD_Get_x(pthis as IPOINTD PTR, BYVAL invalue AS DOUBLE Ptr) AS HRESULT
   *invalue =  Cast(OBJ_POINTD  Ptr,pthis)->m_x
    FUNCTION = S_OK
END FUNCTION


Function POINTD_put_x(pthis as IPOINTD PTR,  NewValue AS DOUBLE) AS HRESULT
  Cast(OBJ_POINTD  Ptr,pthis)->m_x = NewValue
  Function = S_OK
End Function

FUNCTION POINTD_Get_y(pthis as IPOINTD PTR, BYVAL invalue AS DOUBLE Ptr) AS HRESULT
   *invalue =  Cast(OBJ_POINTD  Ptr,pthis)->m_y
    FUNCTION = S_OK
END FUNCTION


Function POINTD_put_y(pthis as IPOINTD PTR,  NewValue AS DOUBLE) AS HRESULT
   Cast(OBJ_POINTD  Ptr,pthis)->m_y = NewValue
   Function = S_OK
End Function

Function POINTD_Norme(pthis As IPOINTD Ptr, ByVal retvalue As DOUBLE Ptr  )  As HRESULT
  *retValue = (Cast(OBJ_POINTD  Ptr,pthis)->m_x) * (Cast(OBJ_POINTD  Ptr,pthis)->m_y)
Function = S_OK
End Function
 
 Function POINTD_Angle(pthis As IPOINTD Ptr, ByVal retvalue As DOUBLE Ptr  )  As HRESULT
  *retValue = ATan2(Cast(OBJ_POINTD  Ptr,pthis)->m_y,Cast(OBJ_POINTD  Ptr,pthis)->m_x)
Function = S_OK
 End Function

Function getPOINTDS(pthis As IPOINTD Ptr,ppu As IUNKNOWN Ptr Ptr)As HRESULT
   *ppu=EnablePOINTDS()
   Return S_OK
End Function


 
Dim Shared As IPOINTDVtbl POINTDVT = Type(@POINTD_QueryInterface, _
                                          @POINTD_AddRef, _
                                          @POINTD_Release, _
                                           @POINTD_Get_x, _
                                          @POINTD_put_x , _
                                          @POINTD_Get_y,_
                                          @POINTD_put_y,_
                                          @POINTD_Norme, _
                                          @POINTD_Angle, _
                                          @getPOINTDS)
                                   
 

' ------------------------------------------------------------------------------------------------------------------
' *********************************************   CLASS FACTORY    *************************************************
' ------------------------------------------------------------------------------------------------------------------
FUNCTION POINTD_CFQueryInterface(pCF AS IClassFactory PTR, iid AS REFIID, ppvObject AS LPVOID PTR) AS HRESULT
If IsEqualIID( iid, @IID_IUnknown) Or IsEqualIID( iid, @IID_IClassFactory) THEN
 *ppvObject = pcF
  pCF->lpVtbl->AddRef(pCF)
 Return  S_OK
End IF

*ppvObject = NULL
FUNCTION =  E_NOINTERFACE
END FUNCTION

FUNCTION POINTD_CFAddRef(pCF AS IClassFactory PTR) AS ULONG
  POINTD_COUNTER +=1
Function = 1
END Function

FUNCTION  POINTD_CFRelease( pCF AS IClassFactory PTR) AS ULONG
Function = InterLockedDecrement(@POINTD_COUNTER)
END Function


FUNCTION POINTD_CFCreateInstance( pICF AS IClassFactory PTR, pUnkOuter AS IUnknown PTR, riid AS REFIID, ppvObject As LPVOID PTR) AS HRESULT
 
DIM  thisobj AS IPOINTD  Ptr


Dim hr As HRESULT
IF pUnkOuter <> NULL then
   Return  CLASS_E_NOAGGREGATION
END IF
 
   thisobj = Cast(IPOINTD  Ptr,Globalalloc(GMEM_FIXED,SizeOf(OBJ_POINTD)))
   If NULL = thisobj THEN
       Return  E_OUTOFMEMORY
   End IF

    thisobj->lpVtbl = @POINTDVT
    Cast(OBJ_POINTD Ptr ,thisobj)->cRef = 1
   ' Initialisations
   Cast(OBJ_POINTD Ptr ,thisobj)->m_x=0.0
   Cast(OBJ_POINTD Ptr ,thisobj)->m_y=0.0
       hr=POINTDVT.QueryInterface(thisobj, riid, ppvObject)
       POINTDVT.Release(thisobj)
      If hr=S_ok Then    InterLockedincrement(@POINTD_COUNTER)
       
Function =  S_OK
End FUNCTION

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


 

Static Shared As IClassFactoryVtbl POINTDCFVT = Type(@POINTD_CFQueryInterface, _
                                                @POINTD_CFAddRef, _
                                                @POINTD_CFRelease, _
                                                @POINTD_CFCreateInstance,  _
                                                @POINTD_CFLockServer)
 


pointds.bas

Code: Select all

TYPE OBJ_POINTDS 
       lpvtbl  As IPOINTDSVtbl ptr
       cRef AS INTEGER
             
End Type

 Dim Shared POINTDSClassFactory As IclassFactory

 
Extern POINTD_COUNTER As DWORD
Extern POINTD_LOCKED As DWORD

#Include Once "tlist.bi"

Dim Shared plistPoints As TList
' INTERFACE AND FUNCTIONS
Function POINTDS_QueryInterface (pthis as IPOINTDS PTR, iid AS REFIID, ppv AS LPVOID Ptr) AS HRESULT
 
IF IsEqualIID( iid, @IID_IUnknown)Or IsEqualIID( iid, @IID_IPOINTDS) Then
   *ppv = pThis
  pthis->lpVtbl->AddRef(pthis)
 Return  S_OK
End IF

ppv = NULL
FUNCTION =  E_NOINTERFACE
End Function


Function POINTDS_AddRef(pthis AS IPOINTDS PTR) AS ULONG
  Cast(OBJ_POINTDS  Ptr,pthis)->cRef +=1
Function =  Cast(OBJ_POINTDS  Ptr,pthis)->cRef
End Function


Function POINTDS_Release(pthis AS IPOINTDS PTR) AS ULONG
 
  Cast(OBJ_POINTDS  Ptr,pthis)->cRef -=1
 
IF Cast(OBJ_POINTDS  Ptr,pthis)->cRef <= 0 THEN
  POINTD_COUNTER -=1
   globalfree(pThis)
  Return 0
END IF

FUNCTION = Cast(OBJ_POINTDS  Ptr,pthis)->cRef
End Function


Function POINTDS_Add (pthis AS IPOINTDS Ptr,Newx As Double,Newy As Double,pP As IPOINTD Ptr Ptr ) AS HRESULT PURE
   Dim As  HRESULT hr 
  Dim As   IPointd Ptr pPoint =createobject("fbgraphics.pointd")

               if (s_ok = pPoint->lpvtbl->put_x(pPoint,Newx) And  s_ok = pPoint->lpvtbl->put_y(pPoint,Newy))Then
                         
                  plistPoints.Add(Cast(Any Ptr,pPoint))
                  *pP=createobject("fbgraphics.pointd")
                  *pP=pPoint
                  
               'pPoint->lpvtbl->Release(pPoint)  ' si present ici et non en bas bug assuré à l'exécution
                             
                  Return s_ok
               EndIf
       
       
       
       pPoint->lpvtbl->Release(pPoint)  ' si present bug assuré à l'exécution
   
   
    return S_FALSE   
End Function

Function POINTDS_get_Count (pthis AS IPOINTDS Ptr,retval As Long Ptr ) AS HRESULT PURE
   *retval=plistPoints.Count
   Return NOERROR
End Function

Function POINTDS_get_Item (pthis AS IPOINTDS Ptr,Index As long ,ppl As IPOINTD ptr Ptr ) AS HRESULT PURE
   *ppl=createobject("fbgraphics.pointd")
   *ppl=Cast(IPOINTD Ptr,plistPoints.Items[Index])
   Return NOERROR
End Function

Function POINTDS_get__NewEnum (pthis AS IPOINTDS Ptr,ppi As IUnknown Ptr Ptr ) AS HRESULT PURE
   Return E_NOTIMPL
End Function

Function POINTDS_Remove (pthis AS IPOINTDS Ptr,Index As Long ) AS HRESULT PURE
    Dim As  HRESULT hr
   Dim As  long l, lIndex
   Dim As  VARIANT Ptr pvar
   Dim As  ULONG cRef
   Dim As  Double nX, nY
   Dim As  IPointd ptr pPoint = NULL ,pPointRemove
   Dim As  BOOL bFound = FALSE   
   Dim As   BOOL bRet = FALSE
   
    pPointRemove=Cast(IPOINTD Ptr,plistPoints.Items[Index])
   
    ' Get coordinates of point to be removed from collection
     pPointRemove->lpvtbl->get_x(pPointRemove,@nX)
     pPointRemove->lpvtbl->get_y(pPointRemove,@nY )
         
   

             
    ' Check if point to be removed is in the collection.       

    for  l=0 To plistPoints.Count-1
             
        hr = Cast(IPOINTD Ptr,plistPoints.Item(l))->lpvtbl->QueryInterface(Cast(IPOINTD Ptr,plistPoints.Item(l)),@IID_IPointd, cast(pvoid Ptr,@pPoint))
        if (FAILED(hr))Then   continue For
                 
        if (s_ok=pPoint->lpvtbl->get_x(pPoint,@nX )) and   (s_ok= pPoint->lpvtbl->get_y(pPoint,@nY ) )Then
         
            ' Release point. Note that this collection does not have duplicates. Duplicate
            ' points are handled by increasing the ref count.
            Cast(IPOINTD Ptr,plistPoints.Item(l))->lpvtbl->Release(Cast(IPOINTD Ptr,plistPoints.Item(l)))     

             
            bFound = TRUE
            lIndex = l
            pPoint->lpvtbl->Release(pPoint) 
            Exit For   
        End If             
        pPoint->lpvtbl->Release(pPoint)       
    next   
   
    ' If the internal ref count of point to be removed has dropped to 0, move up the array elements
    ' after the element to be removed.     
    if (bFound )Then
         plistPoints.Remove(lIndex)
     End If
           
         
    return hr 
       
errorn:
    return FALSE
End Function


 
Dim Shared As IPOINTDSVtbl POINTDSVT = Type(@POINTDS_QueryInterface, _
                                            @POINTDS_AddRef, _
                                            @POINTDS_Release, _
                                            @POINTDS_Add, _
                                            @POINTDS_get_Count , _
                                            @POINTDS_get_Item,_
                                            @POINTDS_get__NewEnum,_
                                            @POINTDS_Remove)



Function EnablePOINTDS() As IUNKNOWN Ptr
   Dim hr As HRESULT
Static As OBJ_POINTDS Ptr collection
Dim  thisobjs AS IPOINTDS  Ptr   
collection = Cast(OBJ_POINTDS Ptr,Globalalloc(GMEM_FIXED,SizeOf(OBJ_POINTDS)))   
If collection Then
 POINTD_COUNTER=0
 collection->lpVtbl = @POINTDSVT
 collection->cRef = 1
  InterLockedincrement(@POINTD_COUNTER)
End If
 Return Cast(IUNKNOWN Ptr,collection)
End Function

test.bas

Code: Select all

#Include Once "comwrapper.bi"
 

 #Include Once "win/objbase.bi"
 #include Once "pointd.bi"
 #Include Once "pointds.bi"

DIM  As IPOINTD Ptr pd ,pd1,pd2
DIM  pds as IPOINTDS Ptr
Dim  x As Double,y As Double 
       
 
    DIM dResult AS Double
 
  coinitialize(0)
 
    pd = CreateObject(ProgID_POINTD)
    'pds= CreateObjectEx(ProgID_POINTDS)
    Print "pd" ,pd
    pd->lpVtbl->getPOINTDS(pd,Cast(Iunknown Ptr,@pds))   
   
    Print "pds" ,pds
     
    ' Ajoute un premier point dans la collection pds
    pds->lpVtbl->Add(pds,5.0,4.0,@pd1)
   
    ' vérification si pd1 a bien été créé
    pd1->lpVtbl->get_x(pd1,@x)
    pd1->lpVtbl->get_x(pd1,@y)   
    Print "pd1.x= " ;x ; "  pd1.y= " ;y   
   
    ' Ajoute un 2e point dans la collection pds
    pds->lpVtbl->Add(pds,15,10,@pd2)
   
   
    Dim count As Long
    ' Compte le nombre de points ajouté
    pds->lpVtbl->get_Count(pds,@count)
    Print
    Print "there is ";count ; " points added in the collection"
   
   Dim pdd As IPOINTD Ptr
   
   Print
   Print "Recupere  les valeurs de l'index 0"
   pds->lpVtbl->get_Item(pds,0,@pdd)
   pdd->lpVtbl->get_x(pdd,@x)
   pdd->lpVtbl->get_y(pdd,@y)
   
   Print "P(0).x = ";x; "  P(0).y = ";y
   
   Print
   Print "Recuperer les valeurs de l'index 1"
   pds->lpVtbl->get_Item(pds,1,@pdd)
   pdd->lpVtbl->get_x(pdd,@x)
   pdd->lpVtbl->get_y(pdd,@y)
   
    Print "P(1).x = ";x; "  P(1).y = ";y
   
   
    'pd->lpVtbl->put_x(pd, 15.0)
    'pd->lpVtbl->put_y(pd,10.0)
 
    'pd->lpVtbl->put_x(pd, 6.0)
    'pd->lpVtbl->put_y(pd,4.0)
    'pd->lpVtbl->Norme(pd,@dResult)
    'Print "Norme: " ;dResult
    'pd->lpVtbl->Angle(pd,@dResult)
    'Print "POINT Angle: " ;dResult
   
   
   
  pds->lpVtbl->Release(pds)
  pd->lpVtbl->Release(pd)
  coUninitialize()

Sleep


TList.bi

Code: Select all

Type TList
    Private:
    Public:
    Count As Integer
    Items As Any Ptr Ptr
    Declare Property Item(Index As Integer) As Any Ptr
    Declare Property Item(Index As Integer,FItem As Any Ptr)
    Declare Sub Add(FItem As Any Ptr)
    Declare Sub Insert(Index As Integer,FItem As Any Ptr)
    Declare Sub Exchange(Index1 As Integer,Index2 As Integer)
    Declare Sub Remove(Index As Integer)
    Declare Sub Clear
    Declare Function IndexOf(FItem As Any Ptr) As Integer
    Declare Operator Cast As Any Ptr
    Declare Constructor
    Declare Destructor
End Type

Operator TList.Cast As Any Ptr
    Return @This
End Operator

Property TList.Item(Index As Integer) As Any Ptr
    If Index >= 0 And Index <= Count -1 Then
       Return Items[Index]
    Else
       Return 0
    End If
End Property

Property TList.Item(Index As Integer,FItem As Any Ptr)
    If Index >= 0 And Index <= Count -1 Then
       Items[Index] = FItem
    End If   
End Property

Sub TList.Add(FItem As Any Ptr)
    Count += 1
    Items = ReAllocate(Items,Count*SizeOf(Any Ptr))
    Items[Count -1] = FItem
End Sub

Sub TList.Insert(Index As Integer,FItem As Any Ptr)
    Dim As Any Ptr Ptr Temp
    Dim As Integer i
    If Index >= 0 And Index <= Count -1 Then
       Temp = cAllocate((Count+1)*SizeOf(Any Ptr))
       For i = 0 to Index
           Temp[i] = Items[i]
       Next i
       Temp[Index] = FItem
       For i = Index to Count -1
           Temp[i +1] = Items[i]
       Next i
       Count += 1
       Items = cAllocate(Count*SizeOf(Any Ptr))
       For i = 0 to Count -1
           Items[i] = Temp[i]
       Next i
       DeAllocate Temp
    End If   
End Sub

Sub TList.Exchange(Index1 As Integer,Index2 As Integer)
    Dim As Any Ptr P
    If ((Index1 >= 0 And Index1 <= Count -1) And (Index2 >= 0 And Index2 <= Count -1)) Then
       P = Items[Index1]
       Items[Index1] = Items[Index2]
       Items[Index2] = P
    End If
End Sub

Sub TList.Remove(Index As Integer)
    Dim As Integer i,x
    Dim As Any Ptr Ptr Temp
    If Index >= 0 And Index <= Count -1 Then
       Temp = cAllocate((Count-1)*SizeOf(Any Ptr))
       x = 0
       For i = 0 To Count -1
           If i <> Index Then
              x += 1
              Temp[x -1] = Items[i]
           End If
       Next i
       Count -= 1
       Items = cAllocate(Count*SizeOf(Any Ptr))
       For i = 0 to Count -1
           Items[i] = Temp[i]
       Next i
       DeAllocate Temp
    End If
End Sub

Sub TList.Clear
    Count = 0
    Items = cAllocate(Count)
End Sub

Function TList.IndexOf(FItem As Any Ptr) As Integer
    Dim i As Integer
    For i = 0 To Count -1
        If Items[i] = FItem Then Return i
    Next i
    Return -1
End Function

Constructor TList
    Items = cAllocate(0)
End Constructor

Destructor TList
    Items = cAllocate(0)
    DeAllocate Items
End Destructor


[nobozoz]

[WIN XP PRO SP3]
Trying to compile test.bas (which I renamed: "test_fbgraphics.bas"), I get serious errors...
---
C:\FreeBASIC\fbc -s gui -v -mt -exx -arch 386 -w pedantic "test_fbgraphics.bas"
FreeBASIC Compiler - Version 0.23.0 (08-14-2011) for win32 (target:win32)
Copyright (C) 2004-2011 The FreeBASIC development team.
Configured as standalone
objinfo enabled using FB BFD header version 217

compiling: test_fbgraphics.bas -o test_fbgraphics.asm
---

C:\FreeBASIC\fb_com_object\comwrapper.bi(92) error 41: Variable not declared, wcstombs in 'wcstombs(szCLSID,wszCLSID,length) ' Covert from wide characters to non-wide.'

C:\FreeBASIC\fb_com_object\pointds.bi(16) error 11: Expected constant, found 'ULONG' in 'STDMETHOD_(ULONG, AddRef)(As This) As ULong PURE'
C:\FreeBASIC\fb_com_object\pointds.bi(17) error 11: Expected constant, found 'ULONG' in 'STDMETHOD_(ULONG, Release)(As This) As ULong PURE'

test_fbgraphics.bas(73) error 10: Expected '=' in 'pds->lpVtbl->Release(pds)'

[aloberoger]

Hi nobozor taks you for your interest
Put this macro in "win/basetyps.bi" or in a file of your project
#Ifndef STDMETHOD_
#define STDMETHOD_(type_not_eused,func_name) func_name As Function
#EndIf

test is not a gui application, remove gui to console
or simply use this command: "C:\FreeBASIC\fbc.exe" -s console "test_fbgraphics.bas"

yes i have improved "comwrapper.bi"
I not remember again where was wcstombs im my code
you can use szCLSID=BSTrtostring(szCLSID)
instead of wcstombs(szCLSID,wszCLSID,length) ' Covert from wide characters to non-wide.'

in test_graphics.bas use this
pd->lpVtbl->getPOINTDS(pd,Cast(IUNKNOWN Ptr Ptr,@pds))
instead of pd->lpVtbl->getPOINTDS(pd,Cast(IPOINTD Ptr,@pds))

[aloberoger]

this example show how to implement com with inheritance.
http://www.2shared.com/file/052GF2UN/fbpoint_forum.html

[YogiYang]

The download link is invalid. Please update it or reupload.

[aloberoger]

The download link is invalid. Please update it or reupload.

I thing the new link is good

[aloberoger]

My goal is to create a tool able to read a .bas file containing one or more classes
and automatically to convert them into DLL Com.
By supposing that the implementation of the class is carried out.
to help me has to read one or of the classes and to store them in the following Arrays:

for only one classe:
Dim Shared colClassFunctions(1 To 50) As TFunctions
Dim Shared colClassProperties(1 To 50) As TProperty
Dim Shared colClassSubs(1 To 50) As TSubprocedure


fore more classes :
NMAXCLASSES=10
NMAXFUNCTIONS=50
NMAXSUBS=50
NMAXPROPERTIES=50
Dim Shared colClassFunctions(1 to NMAXCLASSES,1 To NMAXFUNCTIONS) As TFunctions
Dim Shared colClassProperties(1 to NMAXCLASSES,1 To NMAXPROPERTIES) As TProperty
Dim Shared colClassSubs(1 to NMAXCLASSES,1 To NMAXSUBS) As TSubprocedure


example of class to read:

type POINTD
private:
m_x as double
m_y as double
public:
visible as long
declare constructor
declare destructor
declare property x as double
declare property x( as double)
decxlare function Somme as double) as double
decxlare function Produit(as double,as double) as double
decxlare sub Add(as double,as double,as integer)
end type





an exapmple to get


colClassSubs(1,1).SubName = "Add"
colClassSubs(1,1).AccessSpecifier = "public"
colClassSubs(1,1).Parameters = "as double,as double,as integer"


















Type TProperty
Private:
Dim mvarPropertyName As String
Dim mvarAccessSpecifier As String
Dim mvarPropertyType As String
Dim mvarPropertyPurpose As Integer

Public:

Declare Function Header() As String
Declare Function ToString() As String
Declare Property PropertyName(vdata As String)
Declare Property PropertyName() As String
Declare Property AccessSpecifier(vdata As String)
Declare Property AccessSpecifier() As String
Declare Property PropertyType(vdata As String)
Declare Property PropertyType() As String
Declare Property PropertyPurpose(vdata As Integer)
Declare Property PropertyPurpose() As Integer

End Type




Type TFunctions
Private:
Dim mvarFunctionName As String
Dim mvarReturnType As String
Dim mvarAccessSpecifier As String
Dim mvarParameters As String
Dim mvarClassType As String="Normal"
Public:
Declare Property ClassType(vdata As String)
Declare Property ClassType As String
Declare Function ToString() As String
Declare Property FunctionName(vdata As String)
Declare Property FunctionName() As String
Declare Property ReturnType(vdata As String)
Declare Property ReturnType() As String
Declare Property AccessSpecifier(vdata As String)
Declare Property AccessSpecifier() As String
Declare Property Parameters(vdata As String)
Declare Property Parameters() As String
End Type


Type TSubprocedure
Private:
Dim mvarSubName As String
Dim mvarAccessSpecifier As String
Dim mvarParameters As String
Dim mvarClassType As String="Normal"
Public:
Declare Property ClassType(vdata As String)
Declare Property ClassType As String
Declare Function ToString() As String
Declare Property SubName(vdata As String)
Declare Property SubName() As String
Declare Property AccessSpecifier(vdata As String)
Declare Property AccessSpecifier() As String
Declare Property Parameters(vdata As String)
Declare Property Parameters() As String
End Type





NOTA: For the creation of the DLL COM starting from the tables obtained the code is already perfectly carried out.