SimpleCom.bi (lean and mean LateBound COM-access)

[OSchmidt]

Hi *.*,

my first post @ FreeBasic-Forums... :-)
hopefully I can provide some help for the "Windows-guys" of this community (over the next weeks and months)...

I'm new to FreeBasic but not new to programming (usually develop on and for the Win-platform,
in VB6, C, C++, JavaScript - and have quite some experience with COM).

Trying to develop some simple COM-Demos for FreeBasic, I was stumbeling around at first -
(not getting variant.bi to work, since the needed lib was missing - same thing basically with
the dispatch-wrapper-dll for FreeBasic - though having written some LateBound-COM-stuff in
C some time ago, I've decided to save time - and simply port what I had there (it was quite similar to
some stuff in the FB-sources of aloberoger, which I've also looked into, to get up to speed with FB-syntax).

So, here's SimpleCOM.bi, which doesn't depend on any *.a-Files or libs...
http://vbRichClient.com/Downloads/SimpleCOM.zip
Please put it into your \inc\-Folder for the following simple examples to work...

Let's start with some Variant-Basics (we use the simple UDT-def which comes with the Win-headers)

Code: Select all

#define UNICODE
#Include Once "SimpleCOM.bi"

'MsgBox and simple Variant-Conversion-Tests
MsgBox V2S(D2V(1.1)) & " " & V2S(T2V(Now)) 

'second example, note that the Variant-temp-Result from S2V (which contains a BSTR), is 
'cleared up automatically by V2S ... V2S(V, False) will keep the content of V alive though...
MsgBox V2S(S2V("Hello FreeBasic")) 

That much to the Variants at the moment... here's how to deal with Simple COM-Objects LateBound:

Code: Select all

#define UNICODE
#Include Once "SimpleCOM.bi"

Dim oDict As Variant = CreateObject("Scripting.Dictionary") 'instantiate a Dictionary-Obj
 If oDict.VT = 0 Then MsgBox "Couldn't create a Scripting.Dictionary-instance"    
    
	CallByName oDict, "Add", , "sl", "Key1", 111 'add a Long-Value under a Key
	CallByName oDict, "Add", , "sl", "Key2", 222 '...and a second one...
	
    MsgBox "Count: " & V2S(CallByName(oDict, "Count")) 
    MsgBox "Item under Key1: " & V2S(CallByName(oDict, "Item", , "s", "Key1")) 
	
    CallByName oDict, "Remove", , "s", "Key1" 
    MsgBox "Count after Removing Key1: " & V2S(CallByName(oDict, "Count")) 
    MsgBox "Does Key2 still exist? " & V2S(CallByName(oDict, "Exists", , "s", "Key2"))
	
VClear oDict 'destroy the Dictionary-Object

That's it for the Opener-Posting - there's more to come - and comments are welcome
(as said, I'm new to FB - perhaps there's some stuff which could be done more efficiently).

Olaf

[VANYA]

Hi OSchmidt !

Code: Select all

#define UNICODE
#Include Once "SimpleCOM.bi"

Dim oDict As Variant = CreateObject("Scripting.Dictionary") 'instantiate a Dictionary-Obj
 If oDict.VT = 0 Then MsgBox "Couldn't create a Scripting.Dictionary-instance"   
   
   CallByName oDict, "Add", , "sl", "Key1", 111 'add a Long-Value under a Key
   CallByName oDict, "Add", , "sl", "Key2", 222 '...and a second one...
   
    MsgBox "Count: " & V2S(CallByName(oDict, "Count"))
    MsgBox "Item under Key1: " & V2S(CallByName(oDict, "Item", , "s", "Key1"))
   
    CallByName oDict, "Remove", , "s", "Key1"
    MsgBox "Count after Removing Key1: " & V2S(CallByName(oDict, "Count"))
    MsgBox "Does Key2 still exist? " & V2S(CallByName(oDict, "Exists", , "s", "Key2"))
   
VClear oDict 'destroy the Dictionary-Object

This code works not correctly: MsgBox "Count: " & V2S(CallByName(oDict, "Count")) the result of 1 , and should be 2

If you change the code as follows:

Code: Select all

#define UNICODE
#Include Once "SimpleCOM.bi"

Dim oDict As Variant = CreateObject("Scripting.Dictionary") 'instantiate a Dictionary-Obj
 If oDict.VT = 0 Then MsgBox "Couldn't create a Scripting.Dictionary-instance"   
   
   CallByName oDict, "Add", , "ss", "1", "AAA" 'add a Long-Value under a Key
   CallByName oDict, "Add", , "ss", "2", "BBB" '...and a second one...

    MsgBox "Count: " & V2S(CallByName(oDict, "Count"))
    MsgBox "Item under 1: " & V2S(CallByName(oDict, "Item", , "s", "1"))
    MsgBox "Item under 2: " & V2S(CallByName(oDict, "Item", , "s", "2"))

    CallByName oDict, "Remove", , "l", 2
    
    MsgBox "Count after Removing Key1: " & V2S(CallByName(oDict, "Count"))
    MsgBox "Does Key2 still exist? " & V2S(CallByName(oDict, "Exists", , "s", "Key2"))
   
VClear oDict 'destroy the Dictionary-Object

It returns "A" Instead of "AAA" and "B" Instead of "BBB".

In addition does not work with Unicode symbols (such as Russian). Correct the code not used WSTR , better (MultiByteToWideChar and WideCharToMultiByte)

[aloberoger]

your code functioned, but it is still in a primary state,
I have another approach % wants to say parameter passed by value and @ wants to say parameter passed by rférence.

here the code and an example of use
dispatchcall.bi

Code: Select all

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


#Define PropPut(pdisp,szName,pszFmt,args...)    Invoke(pdisp,DISPATCH_PROPERTYPUT,szName,pszFmt,args)  ' ok
#Define PropPutRef(pdisp,szName,pszFmt,args...) Invoke(pdisp,DISPATCH_PROPERTYPUTREF,szName,pszFmt,args) ' ok

#Define PropPut_id(pdisp,propid,pszFmt,args...)    Invoke(pdisp,DISPATCH_PROPERTYPUT,propid,pszFmt,args)  ' ok
#Define PropPutRef_id(pdisp,propid,pszFmt,args...) Invoke(pdisp,DISPATCH_PROPERTYPUTREF,propid,pszFmt,args) ' ok

Declare Function PropGet Cdecl (pdisp As LPDISPATCH ,PropName As String , pszFmt as String="" , ...)As VARIANT
Declare Function PropGet_id Cdecl (pdisp As LPDISPATCH ,dispid As DISPID , pszFmt as String="" , ...)As VARIANT
Declare Function Method Cdecl(pdisp As LPDISPATCH ,MethodName As String , pszFmt as String="" , ...)As VARIANT
Declare Function Method_id Cdecl(pdisp As LPDISPATCH ,dispid As DISPID, pszFmt as String="" , ...)As VARIANT

' implementé en function
'#Define PropGet(pdisp,szName,pszFmt,args...) Invoke(pdisp,DISPATCH_PROPERTYGET,szName,pszFmt,args) ' ok avec arguments
'#Define Method(pdisp,szName,pszFmt,args...)  Invoke(pdisp,DISPATCH_METHOD,szName,pszFmt,args)   ' ok avec arguments


Declare Function Invoke  Cdecl (pdisp As LPDISPATCH , wFlags As WORD ,szName As String , pszFmt as String="" , ...)As VARIANT
Declare Function Invoke_id Cdecl (pdisp As LPDISPATCH , wFlags As WORD ,dispidm As DISPID , pszFmt as String="" , ...)As VARIANT

Declare Function InvokeWrap OverLoad (pdisp As LPDISPATCH , wFlags As WORD ,dispidm As DISPID ,pParams as VARIANTARG Ptr ,count As Integer)As VARIANT
Declare Function InvokeWrap OverLoad (pdisp As LPDISPATCH , wFlags As WORD ,szName As String ,pParams as VARIANTARG Ptr ,count As Integer)As VARIANT

 ' LES PARAMETRES AVEC TABLEAU DES VARIANT 
Declare Function InvokePropPut OverLoad (pdisp As LPDISPATCH ,dispidm As DISPID ,pParams as VARIANTARG Ptr ,count As Integer=1)As VARIANT
Declare Function InvokePropPutRef OverLoad (pdisp As LPDISPATCH ,dispidm As DISPID ,pParams as VARIANTARG Ptr ,count As Integer=1)As VARIANT
Declare Function InvokePropGet OverLoad (pdisp As LPDISPATCH ,dispidm As DISPID ,pParams as VARIANTARG Ptr=NULL ,count As Integer=0)As VARIANT
Declare Function InvokeMethod OverLoad (pdisp As LPDISPATCH ,dispidm As DISPID ,pParams as VARIANTARG Ptr=NULL ,count As Integer=0)As VARIANT
Declare Function MethodDispid(pdisp As LPDISPATCH,szName As String)As DISPID
Declare Function InvokePropPut OverLoad (pdisp As LPDISPATCH ,szName As String ,pParams as VARIANTARG Ptr ,count As Integer=1)As VARIANT
Declare Function InvokePropPutRef OverLoad (pdisp As LPDISPATCH ,szName As String ,pParams as VARIANTARG Ptr ,count As Integer=1)As VARIANT
Declare Function InvokePropGet OverLoad (pdisp As LPDISPATCH ,szName As String ,pParams as VARIANTARG Ptr=NULL ,count As Integer=0)As VARIANT
Declare Function InvokeMethod OverLoad (pdisp As LPDISPATCH ,szName As String ,pParams as VARIANTARG Ptr=NULL ,count As Integer=0)As VARIANT

 ' LES PARAMETRES SONT UNIQUEMENT DES VARIANT PTR
Declare Function OleInvoke Cdecl(pdisp As LPDISPATCH, wFlags As WORD  ,szName As String,count As Integer=0, ...)As VARIANT
Declare Function OleInvoke_id Cdecl(pdisp As LPDISPATCH , wFlags As WORD,dispidm As DISPID,count As Integer=0, ...)As VARIANT

#Define OlePropPut(pdisp,szName,pszFmt,args...)    OleInvoke(pdisp,DISPATCH_PROPERTYPUT,szName,count,args)  ' ok
#Define OlePropPutRef(pdisp,szName,pszFmt,args...) OleInvoke(pdisp,DISPATCH_PROPERTYPUTREF,szName,count,args) ' ok

#Define OlePropPut_id(pdisp,propid,pszFmt,args...)    OleInvoke_id(pdisp,DISPATCH_PROPERTYPUT,propid,count,args)  ' ok
#Define OlePropPutRef_id(pdisp,propid,pszFmt,args...) OleInvoke_id(pdisp,DISPATCH_PROPERTYPUTREF,propid,count,args) ' ok


Declare Function CountArgsInFormat(pszFmt As String) As UINT  
Declare Function GetVarType(psmzFmt As  String ,pvt as VARTYPE Ptr ) As  String
Declare FUNCTION PARSE  (source as string, delimiter as String="|", index as integer)as String
Declare Function PARSECOUNT( source As String, delimiter As String=",")As Long

Declare Sub OleErrorShow ( hr As HRESULT, addit As String="")


Dim Shared ComWrapper_oleInitialized As BOOL

Function CreateObject OverLoad (ByVal ProgID as String,ByVal ppdisp As IDISPATCH Ptr Ptr) as HRESULT

 Dim As IDISPATCH Ptr pdisp = NULL
 Dim As IUNKNOWN Ptr  punk  = NULL 
 Dim as HRESULT hr
 
     If ComWrapper_oleInitialized=false Then 
   	  oleInitialize(NULL)
   	  ComWrapper_oleInitialized=1
     EndIf

      *ppdisp=NULL
          
      Dim As  CLSID clsid 
      hr=CLSIDFromProgID(WStr(ProgID), @clsid)
      If clsid=CLSID_NULL Then hr=CLSIDFromString(WStr(ProgID), @clsid)
      If clsid=CLSID_NULL Then goto errorn
  
      hr = CoCreateInstance(@clsid, NULL, CLSCTX_SERVER, @IID_IUNKNOWN, cast(LPVOID Ptr,@punk))
       
      If  FAILED(hr)  then	goto errorn 
   	 #If Not Defined( _FB_COM_VTBL_)
   	   hr = punk->QueryInterface(@IID_IDispatch, cast(LPVOID Ptr,@pdisp)) 
   	 #Else 
   	   hr = punk->lpvtbl->QueryInterface(punk,@IID_IDispatch, cast(LPVOID Ptr,@pdisp)) 
	    #EndIf
	   If  FAILED(hr)  Then goto errorn 
 
	   *ppdisp = pdisp  
	   #If Not Defined( _FB_COM_VTBL_)
	      punk->Release()
	   #Else 
   	   punk->lpvtbl->Release(punk) 
      #EndIf
      Return NOERROR 
	 
errorn: 
	      OleErrorShow(hr,"CreateObject(" & ProgID & ")" )
   #If Not Defined( _FB_COM_VTBL_)
	   If (punk)  Then punk->Release()  
	   If (pdisp) Then pdisp->Release()  
	#Else 
   	If (punk)  Then punk->lpvtbl->Release(punk) 
   	If (pdisp) Then pdisp->lpvtbl->Release(pdisp)
   #EndIf
	return hr  

end Function

 Function CreateObject OverLoad (szProgId As String ,riid As REFIID ,dwClsContext As DWORD , _
			               mpServerInfo As COSERVERINFO ptr ,ppv as lpvoid Ptr ) As HRESULT
 
	Dim As CLSID clsid 
	Dim As HRESULT hr 
	Dim As IClassFactory ptr pCf = NULL 

	 

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

	if  InStr(szProgId,"{") Then 
		hr = CLSIDFromString(WStr(szProgId), @clsid) 
	else
		hr = CLSIDFromProgID(WStr(szProgId), @clsid) 
	End If
	if (SUCCEEDED(hr)) Then hr = CoGetClassObject(@clsid, dwClsContext, mpServerInfo, @IID_IClassFactory, Cast(lpvoid Ptr, @pCf))
	#If Not Defined( _FB_COM_VTBL_) 
	   If (SUCCEEDED(hr)) Then hr = pCf->CreateInstance(NULL, riid, ppv) 
   	if (pCf) Then pCf->Release() 
   #Else
      If (SUCCEEDED(hr)) Then hr = pCf->lpVtbl->CreateInstance(pCf, NULL, riid, ppv) 
   	if (pCf) Then pCf->lpVtbl->Release(pCf) 
   #EndIf
	return  hr 
End Function

 Function GetObjectEx(szPathName As String ,szProgId As String ,riid As REFIID , _
		                dwClsContext As DWORD ,lpvReserved As LPVOID , ppv As LPVOID Ptr) As HRESULT
 
	Dim As HRESULT hr 

 

	if ((Len(szProgId)=0 and Len(szPathName)=0) Or  riid=NULL Or  ppv=NULL Or lpvReserved<>0) Then Return  E_INVALIDARG 

	if Len(szPathName) Then 
	 

		if len(szProgId)=0 Then 
		 
			hr = CoGetObject(WStr(szPathName), NULL, riid, ppv) 
		 
		else
		 
			Dim As IPersistFile ptr ppf = NULL 

			hr = CreateObject(szProgId, @IID_IPersistFile, dwClsContext, NULL, cast(lpvoid Ptr, @ppf)) 
         	#If Not Defined( _FB_COM_VTBL_)  
         	       If (SUCCEEDED(hr)) Then hr = ppf->Load(szPathName, 0) 
			          If (SUCCEEDED(hr)) Then hr = ppf->QueryInterface(riid, ppv) 
          			 If (ppf) Then ppf->Release() 
         	#Else
			          If (SUCCEEDED(hr)) Then hr = ppf->lpVtbl->Load(ppf, szPathName, 0) 
			          If (SUCCEEDED(hr)) Then hr = ppf->lpVtbl->QueryInterface(ppf, riid, ppv) 
          			 If (ppf) Then ppf->lpVtbl->Release(ppf) 
				#EndIf  
		EndIf
	 
	else
	 

		Dim As CLSID clsid 
		Dim As IUnknown Ptr pUnk = NULL 

		if  InStr(szProgId,"{" ) Then 
			hr = CLSIDFromString(WStr(szProgId), @clsid) 
		else
			hr = CLSIDFromProgID(WStr(szProgId), @clsid) 
      EndIf
		if (SUCCEEDED(hr)) Then hr = GetActiveObject(@clsid, NULL, @pUnk) 
		#If Not Defined( _FB_COM_VTBL_)  
		      If (SUCCEEDED(hr)) Then hr = pUnk->QueryInterface(riid, ppv) 
		      If (pUnk) Then pUnk->Release() 
		#Else
		     If (SUCCEEDED(hr)) Then hr = pUnk->lpVtbl->QueryInterface(pUnk, riid, ppv) 
		     If (pUnk) Then pUnk->lpVtbl->Release(pUnk) 
		#EndIf
	EndIf	

	return  hr  
End Function

 

Function _GetObject OverLoad (szPathName As String , szProgId As String ,ppDisp As IDispatch Ptr ptr ) As HRESULT
 	return  GetObjectEx(szPathName, szProgId, @IID_IDispatch,CLSCTX_LOCAL_SERVER Or CLSCTX_INPROC_SERVER, NULL, cast(lpvoid Ptr,ppDisp))
End Function
 
 Function _GetObject OverLoad (szPathName As String ="",szProgId As String) As VARIANT
 	Dim pDisp As IDispatch Ptr  
 	  GetObjectEx(szPathName, szProgId, @IID_IDispatch,CLSCTX_LOCAL_SERVER Or CLSCTX_INPROC_SERVER, NULL,@pDisp) ' curiosly bug with Cast(LPVOID Ptr,@pDisp))
 	Dim V As VARIANT
 	v.vt=VT_DISPATCH
 	v.pdispval=pDisp
 	Return V
 End Function


Function Invoke  Cdecl  (pdisp As LPDISPATCH , wFlags As WORD ,szName As String , pszFmt as String="" , ...)As VARIANT
    Dim vRet As  VARIANT
    Dim As Any Ptr argList 
    argList= va_first()  
    Dim As ..DISPID dispidm 
    Dim As HRESULT hr 
    Dim As VARIANTARG ptr pvarg = NULL 
    Dim As VARIANTARG ptr pParams = NULL 
    variantinit(@vRet)
   
   Dim wszName As WString*500 =szName
   Dim pszName As LPOLESTR =@wszName
   
     if (pdisp =  NULL)Then
    	  OleErrorShow(E_INVALIDARG)
        vRet.vt = VT_ERROR
		  vRet.scode = -1
		return vRet 
    End If
    ' Get DISPID of property/method
   #If Defined (_FB_COM_VTBL_) 
    hr = pdisp->lpvtbl->GetIDsOfNames(pdisp,@IID_NULL, @pszName, 1, LOCALE_USER_DEFAULT, @dispidm) 
   #Else
     hr = pdisp->GetIDsOfNames(@IID_NULL, @pszName, 1, LOCALE_USER_DEFAULT, @dispidm)
   #EndIf
    if(FAILED(hr))Then
        OleErrorShow(hr,*pszName)
        vRet.vt = VT_ERROR
		  vRet.scode = -1
		  Return vRet 
    End If           
   Dim As ..DISPPARAMS dispparams 
    memset(@dispparams, 0, SizeOf(..DISPPARAMS)) 

    ' determine number of arguments
    if (Len(pszFmt) <>  NULL)Then
        dispparams.cArgs=CountArgsInFormat(pszFmt) 
    End If
    ' Property puts have a named argument that represents the value that the property is
    ' being assigned.
    Dim As ..DISPID dispidNamed = DISPID_PROPERTYPUT 
    if (wFlags And(DISPATCH_PROPERTYPUT Or DISPATCH_PROPERTYPUTREF))Then
         If (dispparams.cArgs =  0)Then
            OleErrorShow(ResultFromScode(E_INVALIDARG),*pszName)
            vRet.vt = VT_ERROR
		      vRet.scode = -1
		      Return vRet 
         End If    
        dispparams.cNamedArgs = 1 
        dispparams.rgdispidNamedArgs = @dispidNamed 
    End If

    if (dispparams.cArgs <> 0)Then
        pParams= new VARIANTARG[dispparams.cArgs]  ' allocate memory for all VARIANTARG parameters
        pvarg = new VARIANTARG[dispparams.cArgs] 
        if(pvarg = NULL)Then
            OleErrorShow(ResultFromScode(E_OUTOFMEMORY),*pszName)
            vRet.vt = VT_ERROR
		      vRet.scode = -1
		      Return vRet  
        End If
        
      'memset(pvarg, 0, sizeof(VARIANTARG) * dispparams.cArgs) 
         
        Dim vt As VARTYPE
             
        For i As Integer=1 To dispparams.cArgs
 	         GetVarType(PARSE(pszFmt,",",i),@vt)
            pParams[i-1].vt=vt
             
         Select Case (pParams[i-1].vt)
            case VT_UI1:
               V_UI1(@pParams[i-1]) = va_arg(argList, UByte) 
               argList=va_next(argList,UByte)   
            case VT_I2:
               V_I2(@pParams[i-1]) = va_arg(argList, short) 
               argList=va_next(argList,short)  
            case VT_I4:
               V_I4(@pParams[i-1]) = va_arg(argList, long) 
               argList=va_next(argList,long)  
            case VT_R4:
               V_R4(@pParams[i-1]) = va_arg(argList, float) 
               argList=va_next(argList,float)  
            Case VT_DATE:
            	pParams[i-1].date = va_arg(argList,DATE_) 
               argList=va_next(argList, DATE_) 	
            case VT_R8:
               pParams[i-1].dblval = va_arg(argList, double) 
               argList=va_next(argList, double) 
                
            case VT_CY:
               V_CY(@pParams[i-1]) = va_arg(argList, CY) 
               argList=va_next(argList, CY)  
            case VT_BSTR:
               V_BSTR(@pParams[i-1]) = SysAllocString(va_arg(argList, OLECHAR Ptr)) 
               If (pParams[i-1].bstrVal =  NULL) Then
                  hr = ResultFromScode(E_OUTOFMEMORY)  
                  pParams[i-1].vt = VT_EMPTY 
                  GoTo cleanup  
               End If
                 argList=va_next(argList, OLECHAR Ptr) 
                  
            case VT_DISPATCH:
                'V_DISPATCH(@pvarg[i-1]) = va_arg(argList, LPDISPATCH)
               pParams[i-1].pdispval=va_arg(argList, LPDISPATCH)
               argList= va_next(argList,Any Ptr) 'LPDISPATCH)
                  
            case VT_ERROR:
               V_ERROR(@pParams[i-1]) = va_arg(argList, SCODE) 
               argList=va_next(argList,  SCODE) 
            case VT_BOOL:
               V_BOOL(@pParams[i-1]) = IIf(va_arg(argList,BOOL),-1,0)
               argList=va_next(argList,BOOL) 
            case VT_VARIANT:
               pParams[i-1] = *va_arg(argList, VARIANTARG Ptr) 
               argList=va_next(argList,VARIANTARG Ptr)  
            case VT_UNKNOWN:
               V_UNKNOWN(@pParams[i-1]) = va_arg(argList, LPUNKNOWN) 
               argList= va_next(argList,Any Ptr) 'LPUNKNOWN) 
            
            case VT_UI1 OR VT_BYREF:
               V_UI1REF(@pParams[i-1]) = va_arg(argList, UByte Ptr) 
               argList=va_next(argList,UByte Ptr)
            case VT_I2 OR VT_BYREF:
               V_I2REF(@pParams[i-1]) = va_arg(argList, short Ptr) 
               argList=va_next(argList,short Ptr) 
            case VT_I4 OR VT_BYREF:
               V_I4REF(@pParams[i-1]) = va_arg(argList, long Ptr) 
               argList=va_next(argList,long Ptr) 
            case VT_R4 OR VT_BYREF:
               V_R4REF(@pParams[i-1]) = va_arg(argList, float Ptr) 
               argList=va_next(argList,float Ptr)
                 
            case VT_R8 OR VT_BYREF:
               V_R8REF(@pParams[i-1]) = va_arg(argList, double Ptr) 
               argList=va_next(argList,double Ptr)
            case VT_DATE OR VT_BYREF:
               V_DATEREF(@pParams[i-1]) = va_arg(argList, DATE_ Ptr) 
               argList=va_next(argList,DATE_ Ptr) 
            case VT_CY OR VT_BYREF:
               V_CYREF(@pParams[i-1]) = va_arg(argList, CY Ptr) 
               argList=va_next(argList, CY Ptr) 
            case VT_BSTR OR VT_BYREF:
               V_BSTRREF(@pParams[i-1]) = va_arg(argList, BSTR Ptr) 
               argList=va_next(argList,BSTR Ptr) 
            case VT_DISPATCH OR VT_BYREF:
               ' V_DISPATCHREF(@pvarg[i-1]) = va_arg(argList, LPDISPATCH Ptr)  
               pParams[i-1].ppdispval = va_arg(argList, LPDISPATCH Ptr)  
               argList=va_next(argList,Any Ptr Ptr) 'LPDISPATCH Ptr) 
             
            case VT_ERROR OR VT_BYREF:
               V_ERRORREF(@pParams[i-1]) = va_arg(argList, SCODE Ptr) 
               argList=va_next(argList,SCODE Ptr) 
            case VT_BOOL OR VT_BYREF: 
               Dim As  BOOL Ptr pbool = va_arg(argList, BOOL Ptr) 
               '*pbool = 0 
               V_BOOLREF(@pParams[i-1]) = Cast(VARIANT_BOOL Ptr,pbool) 
               argList=va_next(argList,BOOL Ptr)
                 
            case VT_VARIANT OR VT_BYREF: 
               V_VARIANTREF(@pParams[i-1]) = va_arg(argList, VARIANTARG Ptr) 
               argList=va_next(argList,VARIANTARG Ptr)
            case VT_UNKNOWN OR VT_BYREF:
               V_UNKNOWNREF(@pParams[i-1]) = va_arg(argList, LPUNKNOWN Ptr) 
               argList=va_next(argList,Any Ptr Ptr) 'LPUNKNOWN Ptr)  
            
         	case VT_RECORD :
                pParams[i-1].pvRecord = va_arg(argList, Any Ptr) 
                argList=va_next(argList,Any Ptr Ptr)  
            Case Else:
                   If (pParams[i-1].vt And (VT_ARRAY Or VT_BYREF)) Then
                   	 pParams[i-1].pparray=va_arg(argList, SAFEARRAY Ptr Ptr ) 
                      argList=va_next(argList,SAFEARRAY Ptr Ptr) 
                      Exit Select   
                   EndIf
                    OleErrorShow(ResultFromScode(E_OUTOFMEMORY),*pszName) 
                  
            End Select

             
        Next i
        
    End if 'if
    
    ' Initialize return variant, in case caller forgot. Caller can pass NULL if return
    ' value is not expected.
    'if (@vRet)Then
    '    VariantInit(@vRet)  
    'End If
    ' inverser les parametres avant de les passer à dispparams
       For i As Integer= 0  to dispparams.cArgs-1   
			   pvarg[i] = pParams[dispparams.cArgs-i-1]
        Next
        
       dispparams.rgvarg = pvarg 
    ' make the call 
    #If Defined (_FB_COM_VTBL_) 
       hr = pdisp->lpvtbl->Invoke(pdisp,dispidm, @IID_NULL, LOCALE_USER_DEFAULT, wFlags,@dispparams, @vRet, NULL, NULL) 
    #Else
       hr = pdisp->Invoke(dispidm, @IID_NULL, LOCALE_USER_DEFAULT, wFlags,@dispparams, @vRet, NULL, NULL) 
    #EndIf
     OleErrorShow(hr,"pdisp->Invoke in " & *pszName)
cleanup:
    ' cleanup any arguments that need cleanup

   If(dispparams.cArgs > 0)Then
		for   i As Integer= 0  to dispparams.cArgs-1   
			pParams[dispparams.cArgs-i-1]=pvarg[i]  
		next	
	End If   


    if (dispparams.cArgs <> 0)Then
      For i As Integer= 0  to dispparams.cArgs-1   
			 If pvarg[i].vt=VT_BSTR  Then VariantClear(@pvarg[i])
	   Next	
    End If
    
   
    delete dispparams.rgvarg 
    delete pParams
    
    return vRet    
End function  


Function Invoke_id Cdecl(pdisp As LPDISPATCH , wFlags As WORD ,dispidm As DISPID , pszFmt as String="" , ...)As VARIANT
    Dim vRet As  VARIANT
    Dim As Any Ptr argList 
    argList= va_first()  
    Dim count As Integer
    Dim As HRESULT hr 
 
    Dim As VARIANTARG ptr pParams = NULL 
    variantinit(@vRet)
   
   if (pdisp =  NULL)Then
    	  OleErrorShow(E_INVALIDARG)
        vRet.vt = VT_ERROR
		  vRet.scode = -1
		return vRet 
    End If
   
   

    ' determine number of arguments
    if (Len(pszFmt) <>  NULL)Then
        count=CountArgsInFormat(pszFmt) 
    End If
     

    if (count <> 0)Then
        pParams= new VARIANTARG[count]  ' allocate memory for all VARIANTARG parameters
        
        if(pParams = NULL)Then
            OleErrorShow(ResultFromScode(E_OUTOFMEMORY))
            vRet.vt = VT_ERROR
		      vRet.scode = -1
		      Return vRet  
        End If
        
       
         
        Dim vt As VARTYPE
             
        For i As Integer=1 To count
 	         GetVarType(PARSE(pszFmt,",",i),@vt)
            pParams[i-1].vt=vt
             
         Select Case (pParams[i-1].vt)
            case VT_UI1:
               V_UI1(@pParams[i-1]) = va_arg(argList, UByte) 
               argList=va_next(argList,UByte)   
            case VT_I2:
               V_I2(@pParams[i-1]) = va_arg(argList, short) 
               argList=va_next(argList,short)  
            case VT_I4:
               V_I4(@pParams[i-1]) = va_arg(argList, long) 
               argList=va_next(argList,long)  
            case VT_R4:
               V_R4(@pParams[i-1]) = va_arg(argList, float) 
               argList=va_next(argList,float)  
            Case VT_DATE:
            	pParams[i-1].date = va_arg(argList,DATE_) 
               argList=va_next(argList, DATE_) 	
            case VT_R8:
               pParams[i-1].dblval = va_arg(argList, double) 
               argList=va_next(argList, double) 
                
            case VT_CY:
               V_CY(@pParams[i-1]) = va_arg(argList, CY) 
               argList=va_next(argList, CY)  
            case VT_BSTR:
               V_BSTR(@pParams[i-1]) = SysAllocString(va_arg(argList, OLECHAR Ptr)) 
               If (pParams[i-1].bstrVal =  NULL) Then
                  hr = ResultFromScode(E_OUTOFMEMORY)  
                  pParams[i-1].vt = VT_EMPTY 
                  'GoTo cleanup  
               End If
                 argList=va_next(argList, OLECHAR Ptr) 
                  
            case VT_DISPATCH:
                'V_DISPATCH(@pvarg[i-1]) = va_arg(argList, LPDISPATCH)
               pParams[i-1].pdispval=va_arg(argList, LPDISPATCH)
               argList= va_next(argList,Any Ptr) 'LPDISPATCH)
                  
            case VT_ERROR:
               V_ERROR(@pParams[i-1]) = va_arg(argList, SCODE) 
               argList=va_next(argList,  SCODE) 
            case VT_BOOL:
               V_BOOL(@pParams[i-1]) = IIf(va_arg(argList,BOOL),-1,0)
               argList=va_next(argList,BOOL) 
            case VT_VARIANT:
               pParams[i-1] = *va_arg(argList, VARIANTARG Ptr) 
               argList=va_next(argList,VARIANTARG Ptr)  
            case VT_UNKNOWN:
               V_UNKNOWN(@pParams[i-1]) = va_arg(argList, LPUNKNOWN) 
               argList= va_next(argList,Any Ptr) 'LPUNKNOWN) 
            
            case VT_UI1 OR VT_BYREF:
               V_UI1REF(@pParams[i-1]) = va_arg(argList, UByte Ptr) 
               argList=va_next(argList,UByte Ptr)
            case VT_I2 OR VT_BYREF:
               V_I2REF(@pParams[i-1]) = va_arg(argList, short Ptr) 
               argList=va_next(argList,short Ptr) 
            case VT_I4 OR VT_BYREF:
               V_I4REF(@pParams[i-1]) = va_arg(argList, long Ptr) 
               argList=va_next(argList,long Ptr) 
            case VT_R4 OR VT_BYREF:
               V_R4REF(@pParams[i-1]) = va_arg(argList, float Ptr) 
               argList=va_next(argList,float Ptr)
                 
            case VT_R8 OR VT_BYREF:
               V_R8REF(@pParams[i-1]) = va_arg(argList, double Ptr) 
               argList=va_next(argList,double Ptr)
            case VT_DATE OR VT_BYREF:
               V_DATEREF(@pParams[i-1]) = va_arg(argList, DATE_ Ptr) 
               argList=va_next(argList,DATE_ Ptr) 
            case VT_CY OR VT_BYREF:
               V_CYREF(@pParams[i-1]) = va_arg(argList, CY Ptr) 
               argList=va_next(argList, CY Ptr) 
            case VT_BSTR OR VT_BYREF:
               V_BSTRREF(@pParams[i-1]) = va_arg(argList, BSTR Ptr) 
               argList=va_next(argList,BSTR Ptr) 
            case VT_DISPATCH OR VT_BYREF:
               ' V_DISPATCHREF(@pvarg[i-1]) = va_arg(argList, LPDISPATCH Ptr)  
               pParams[i-1].ppdispval = va_arg(argList, LPDISPATCH Ptr)  
               argList=va_next(argList,Any Ptr Ptr) 'LPDISPATCH Ptr) 
             
            case VT_ERROR OR VT_BYREF:
               V_ERRORREF(@pParams[i-1]) = va_arg(argList, SCODE Ptr) 
               argList=va_next(argList,SCODE Ptr) 
            case VT_BOOL OR VT_BYREF: 
               Dim As  BOOL Ptr pbool = va_arg(argList, BOOL Ptr) 
               '*pbool = 0 
               V_BOOLREF(@pParams[i-1]) = Cast(VARIANT_BOOL Ptr,pbool) 
               argList=va_next(argList,BOOL Ptr)
                 
            case VT_VARIANT OR VT_BYREF: 
               V_VARIANTREF(@pParams[i-1]) = va_arg(argList, VARIANTARG Ptr) 
               argList=va_next(argList,VARIANTARG Ptr)
            case VT_UNKNOWN OR VT_BYREF:
               V_UNKNOWNREF(@pParams[i-1]) = va_arg(argList, LPUNKNOWN Ptr) 
               argList=va_next(argList,Any Ptr Ptr) 'LPUNKNOWN Ptr)  
            
         	case VT_RECORD :
                pParams[i-1].pvRecord = va_arg(argList, Any Ptr) 
                argList=va_next(argList,Any Ptr Ptr)  
            Case Else:
                   If (pParams[i-1].vt And (VT_ARRAY Or VT_BYREF)) Then
                   	 pParams[i-1].pparray=va_arg(argList, SAFEARRAY Ptr Ptr ) 
                      argList=va_next(argList,SAFEARRAY Ptr Ptr) 
                      Exit Select   
                   EndIf
                    OleErrorShow(ResultFromScode(E_OUTOFMEMORY)) 
                  
            End Select

             
        Next i
      Function= InvokeWrap (pdisp, wFlags,dispidm,pParams,count)  
      Delete pParams
      Exit Function
    End if  
    
    Function= InvokeWrap (pdisp, wFlags,dispidm,NULL,0) 
    Delete pParams
End function  


Function InvokeWrap (pdisp As LPDISPATCH , wFlags As WORD ,dispid  As DISPID ,pParams as VARIANTARG Ptr ,count As Integer)As VARIANT
    Dim vRet As  VARIANT
    Dim As HRESULT hr 
    Dim As VARIANTARG ptr pvarg = NULL 
   
  
    variantinit(@vRet)
   
   if (pdisp =  NULL)Then
    	  OleErrorShow(E_INVALIDARG)
        vRet.vt = VT_ERROR
		  vRet.scode = -1
		return vRet 
    End If
   
   Dim As ..DISPPARAMS dispparams 
    memset(@dispparams, 0, SizeOf(..DISPPARAMS)) 

 
    dispparams.cArgs=Count 
   
    ' Property puts have a named argument that represents the value that the property is
    ' being assigned.
    Dim As ..DISPID dispidNamed = DISPID_PROPERTYPUT  
    if (wFlags And (DISPATCH_PROPERTYPUT Or DISPATCH_PROPERTYPUTREF))Then
         If (dispparams.cArgs =  0)Then
            OleErrorShow(ResultFromScode(E_INVALIDARG),"property put must have at least one parameter")
            vRet.vt = VT_ERROR
		      vRet.scode = -1
		      Return vRet 
         End If    
        dispparams.cNamedArgs = 1 
        dispparams.rgdispidNamedArgs = @dispidNamed 
    End If

    if (dispparams.cArgs <> 0)Then
        pvarg = new VARIANTARG[dispparams.cArgs] 
        if(pvarg = NULL)Then
            OleErrorShow(ResultFromScode(E_OUTOFMEMORY))
            vRet.vt = VT_ERROR
		      vRet.scode = -1
		      Return vRet  
        End If
    End If    
  
         
    if (dispparams.cArgs <> 0)Then     
    ' inverser les parametres avant de les passer à dispparams
       For i As Integer= 0  to dispparams.cArgs-1   
			   pvarg[i] = pParams[dispparams.cArgs-i-1]
       Next
    End If   
    
       dispparams.rgvarg = pvarg 
    
      #If Defined (_FB_COM_VTBL_) 
         hr = pdisp->lpvtbl->Invoke(pdisp,dispid, @IID_NULL, LOCALE_USER_DEFAULT, wFlags,@dispparams, @vRet, NULL, NULL) 
      #Else
        hr = pdisp->Invoke(dispid, @IID_NULL, LOCALE_USER_DEFAULT, wFlags,@dispparams, @vRet, NULL, NULL) 
      #EndIf
    
    
      
   If(dispparams.cArgs > 0)Then
		for   i As Integer= 0  to dispparams.cArgs-1   
			pParams[dispparams.cArgs-i-1]=pvarg[i]  
		next	
	End If   


    if (dispparams.cArgs <> 0)Then
      For i As Integer= 0  to dispparams.cArgs-1   
			 If pvarg[i].vt=VT_BSTR  Then VariantClear(@pvarg[i])
	   Next	
    End If
    
   
    delete dispparams.rgvarg 
    
    return vRet    
End function  

Function PropGet_id Cdecl (pdisp As LPDISPATCH ,dispidm As DISPID , pszFmt as String="" , ...)As VARIANT
    Dim vRet As  VARIANT
    Dim As Any Ptr argList 
    argList= va_first()  
    Dim count As Integer
    Dim As HRESULT hr 
 
    Dim As VARIANTARG ptr pParams = NULL 
    variantinit(@vRet)
   
   if (pdisp =  NULL)Then
    	  OleErrorShow(E_INVALIDARG)
        vRet.vt = VT_ERROR
		  vRet.scode = -1
		return vRet 
    End If
   
   

    ' determine number of arguments
    if (Len(pszFmt) <>  NULL)Then
        count=CountArgsInFormat(pszFmt) 
    End If
     

    if (count <> 0)Then
        pParams= new VARIANTARG[count]  ' allocate memory for all VARIANTARG parameters
        
        if(pParams = NULL)Then
            OleErrorShow(ResultFromScode(E_OUTOFMEMORY))
            vRet.vt = VT_ERROR
		      vRet.scode = -1
		      Return vRet  
        End If
        
       
         
        Dim vt As VARTYPE
             
        For i As Integer=1 To count
 	         GetVarType(PARSE(pszFmt,",",i),@vt)
            pParams[i-1].vt=vt
             
         Select Case (pParams[i-1].vt)
            case VT_UI1:
               V_UI1(@pParams[i-1]) = va_arg(argList, UByte) 
               argList=va_next(argList,UByte)   
            case VT_I2:
               V_I2(@pParams[i-1]) = va_arg(argList, short) 
               argList=va_next(argList,short)  
            case VT_I4:
               V_I4(@pParams[i-1]) = va_arg(argList, long) 
               argList=va_next(argList,long)  
            case VT_R4:
               V_R4(@pParams[i-1]) = va_arg(argList, float) 
               argList=va_next(argList,float)  
            Case VT_DATE:
            	pParams[i-1].date = va_arg(argList,DATE_) 
               argList=va_next(argList, DATE_) 	
            case VT_R8:
               pParams[i-1].dblval = va_arg(argList, double) 
               argList=va_next(argList, double) 
                
            case VT_CY:
               V_CY(@pParams[i-1]) = va_arg(argList, CY) 
               argList=va_next(argList, CY)  
            case VT_BSTR:
               V_BSTR(@pParams[i-1]) = SysAllocString(va_arg(argList, OLECHAR Ptr)) 
               If (pParams[i-1].bstrVal =  NULL) Then
                  hr = ResultFromScode(E_OUTOFMEMORY)  
                  pParams[i-1].vt = VT_EMPTY 
                  'GoTo cleanup  
               End If
                 argList=va_next(argList, OLECHAR Ptr) 
                  
            case VT_DISPATCH:
                'V_DISPATCH(@pvarg[i-1]) = va_arg(argList, LPDISPATCH)
               pParams[i-1].pdispval=va_arg(argList, LPDISPATCH)
               argList= va_next(argList,Any Ptr) 'LPDISPATCH)
                  
            case VT_ERROR:
               V_ERROR(@pParams[i-1]) = va_arg(argList, SCODE) 
               argList=va_next(argList,  SCODE) 
            case VT_BOOL:
               V_BOOL(@pParams[i-1]) = IIf(va_arg(argList,BOOL),-1,0)
               argList=va_next(argList,BOOL) 
            case VT_VARIANT:
               pParams[i-1] = *va_arg(argList, VARIANTARG Ptr) 
               argList=va_next(argList,VARIANTARG Ptr)  
            case VT_UNKNOWN:
               V_UNKNOWN(@pParams[i-1]) = va_arg(argList, LPUNKNOWN) 
               argList= va_next(argList,Any Ptr) 'LPUNKNOWN) 
            
            case VT_UI1 OR VT_BYREF:
               V_UI1REF(@pParams[i-1]) = va_arg(argList, UByte Ptr) 
               argList=va_next(argList,UByte Ptr)
            case VT_I2 OR VT_BYREF:
               V_I2REF(@pParams[i-1]) = va_arg(argList, short Ptr) 
               argList=va_next(argList,short Ptr) 
            case VT_I4 OR VT_BYREF:
               V_I4REF(@pParams[i-1]) = va_arg(argList, long Ptr) 
               argList=va_next(argList,long Ptr) 
            case VT_R4 OR VT_BYREF:
               V_R4REF(@pParams[i-1]) = va_arg(argList, float Ptr) 
               argList=va_next(argList,float Ptr)
                 
            case VT_R8 OR VT_BYREF:
               V_R8REF(@pParams[i-1]) = va_arg(argList, double Ptr) 
               argList=va_next(argList,double Ptr)
            case VT_DATE OR VT_BYREF:
               V_DATEREF(@pParams[i-1]) = va_arg(argList, DATE_ Ptr) 
               argList=va_next(argList,DATE_ Ptr) 
            case VT_CY OR VT_BYREF:
               V_CYREF(@pParams[i-1]) = va_arg(argList, CY Ptr) 
               argList=va_next(argList, CY Ptr) 
            case VT_BSTR OR VT_BYREF:
               V_BSTRREF(@pParams[i-1]) = va_arg(argList, BSTR Ptr) 
               argList=va_next(argList,BSTR Ptr) 
            case VT_DISPATCH OR VT_BYREF:
               ' V_DISPATCHREF(@pvarg[i-1]) = va_arg(argList, LPDISPATCH Ptr)  
               pParams[i-1].ppdispval = va_arg(argList, LPDISPATCH Ptr)  
               argList=va_next(argList,Any Ptr Ptr) 'LPDISPATCH Ptr) 
             
            case VT_ERROR OR VT_BYREF:
               V_ERRORREF(@pParams[i-1]) = va_arg(argList, SCODE Ptr) 
               argList=va_next(argList,SCODE Ptr) 
            case VT_BOOL OR VT_BYREF: 
               Dim As  BOOL Ptr pbool = va_arg(argList, BOOL Ptr) 
               '*pbool = 0 
               V_BOOLREF(@pParams[i-1]) = Cast(VARIANT_BOOL Ptr,pbool) 
               argList=va_next(argList,BOOL Ptr)
                 
            case VT_VARIANT OR VT_BYREF: 
               V_VARIANTREF(@pParams[i-1]) = va_arg(argList, VARIANTARG Ptr) 
               argList=va_next(argList,VARIANTARG Ptr)
            case VT_UNKNOWN OR VT_BYREF:
               V_UNKNOWNREF(@pParams[i-1]) = va_arg(argList, LPUNKNOWN Ptr) 
               argList=va_next(argList,Any Ptr Ptr) 'LPUNKNOWN Ptr)  
            
         	case VT_RECORD :
                pParams[i-1].pvRecord = va_arg(argList, Any Ptr) 
                argList=va_next(argList,Any Ptr Ptr)  
            Case Else:
                   If (pParams[i-1].vt And (VT_ARRAY Or VT_BYREF)) Then
                   	 pParams[i-1].pparray=va_arg(argList, SAFEARRAY Ptr Ptr ) 
                      argList=va_next(argList,SAFEARRAY Ptr Ptr) 
                      Exit Select   
                   EndIf
                    OleErrorShow(ResultFromScode(E_OUTOFMEMORY)) 
                  
            End Select

             
        Next i
      Function= InvokePropGet(pdisp,dispidm,pParams,count)  
      Delete pParams
      Exit Function
    End if  
    
    Function= InvokePropGet (pdisp,dispidm,NULL,0) 
    Delete pParams
End function 


Function PropGet Cdecl (pdisp As LPDISPATCH ,PropName As String , pszFmt as String="" , ...)As VARIANT
    Dim vRet As  VARIANT
    Dim As Any Ptr argList 
    argList= va_first()  
    Dim count As Integer
    Dim As HRESULT hr 
    Dim dispidm As DISPID=MethodDispid(pdisp,PropName)
    Dim As VARIANTARG ptr pParams = NULL 
    variantinit(@vRet)
   
   if (pdisp =  NULL)Then
    	  OleErrorShow(E_INVALIDARG)
        vRet.vt = VT_ERROR
		  vRet.scode = -1
		return vRet 
    End If
   
   

    ' determine number of arguments
    if (Len(pszFmt) <>  NULL)Then
        count=CountArgsInFormat(pszFmt) 
    End If
     

    if (count <> 0)Then
        pParams= new VARIANTARG[count]  ' allocate memory for all VARIANTARG parameters
        
        if(pParams = NULL)Then
            OleErrorShow(ResultFromScode(E_OUTOFMEMORY))
            vRet.vt = VT_ERROR
		      vRet.scode = -1
		      Return vRet  
        End If
        
       
         
        Dim vt As VARTYPE
             
        For i As Integer=1 To count
 	         GetVarType(PARSE(pszFmt,",",i),@vt)
            pParams[i-1].vt=vt
             
         Select Case (pParams[i-1].vt)
            case VT_UI1:
               V_UI1(@pParams[i-1]) = va_arg(argList, UByte) 
               argList=va_next(argList,UByte)   
            case VT_I2:
               V_I2(@pParams[i-1]) = va_arg(argList, short) 
               argList=va_next(argList,short)  
            case VT_I4:
               V_I4(@pParams[i-1]) = va_arg(argList, long) 
               argList=va_next(argList,long)  
            case VT_R4:
               V_R4(@pParams[i-1]) = va_arg(argList, float) 
               argList=va_next(argList,float)  
            Case VT_DATE:
            	pParams[i-1].date = va_arg(argList,DATE_) 
               argList=va_next(argList, DATE_) 	
            case VT_R8:
               pParams[i-1].dblval = va_arg(argList, double) 
               argList=va_next(argList, double) 
                
            case VT_CY:
               V_CY(@pParams[i-1]) = va_arg(argList, CY) 
               argList=va_next(argList, CY)  
            case VT_BSTR:
               V_BSTR(@pParams[i-1]) = SysAllocString(va_arg(argList, OLECHAR Ptr)) 
               If (pParams[i-1].bstrVal =  NULL) Then
                  hr = ResultFromScode(E_OUTOFMEMORY)  
                  pParams[i-1].vt = VT_EMPTY 
                  'GoTo cleanup  
               End If
                 argList=va_next(argList, OLECHAR Ptr) 
                  
            case VT_DISPATCH:
                'V_DISPATCH(@pvarg[i-1]) = va_arg(argList, LPDISPATCH)
               pParams[i-1].pdispval=va_arg(argList, LPDISPATCH)
               argList= va_next(argList,Any Ptr) 'LPDISPATCH)
                  
            case VT_ERROR:
               V_ERROR(@pParams[i-1]) = va_arg(argList, SCODE) 
               argList=va_next(argList,  SCODE) 
            case VT_BOOL:
               V_BOOL(@pParams[i-1]) = IIf(va_arg(argList,BOOL),-1,0)
               argList=va_next(argList,BOOL) 
            case VT_VARIANT:
               pParams[i-1] = *va_arg(argList, VARIANTARG Ptr) 
               argList=va_next(argList,VARIANTARG Ptr)  
            case VT_UNKNOWN:
               V_UNKNOWN(@pParams[i-1]) = va_arg(argList, LPUNKNOWN) 
               argList= va_next(argList,Any Ptr) 'LPUNKNOWN) 
            
            case VT_UI1 OR VT_BYREF:
               V_UI1REF(@pParams[i-1]) = va_arg(argList, UByte Ptr) 
               argList=va_next(argList,UByte Ptr)
            case VT_I2 OR VT_BYREF:
               V_I2REF(@pParams[i-1]) = va_arg(argList, short Ptr) 
               argList=va_next(argList,short Ptr) 
            case VT_I4 OR VT_BYREF:
               V_I4REF(@pParams[i-1]) = va_arg(argList, long Ptr) 
               argList=va_next(argList,long Ptr) 
            case VT_R4 OR VT_BYREF:
               V_R4REF(@pParams[i-1]) = va_arg(argList, float Ptr) 
               argList=va_next(argList,float Ptr)
                 
            case VT_R8 OR VT_BYREF:
               V_R8REF(@pParams[i-1]) = va_arg(argList, double Ptr) 
               argList=va_next(argList,double Ptr)
            case VT_DATE OR VT_BYREF:
               V_DATEREF(@pParams[i-1]) = va_arg(argList, DATE_ Ptr) 
               argList=va_next(argList,DATE_ Ptr) 
            case VT_CY OR VT_BYREF:
               V_CYREF(@pParams[i-1]) = va_arg(argList, CY Ptr) 
               argList=va_next(argList, CY Ptr) 
            case VT_BSTR OR VT_BYREF:
               V_BSTRREF(@pParams[i-1]) = va_arg(argList, BSTR Ptr) 
               argList=va_next(argList,BSTR Ptr) 
            case VT_DISPATCH OR VT_BYREF:
               ' V_DISPATCHREF(@pvarg[i-1]) = va_arg(argList, LPDISPATCH Ptr)  
               pParams[i-1].ppdispval = va_arg(argList, LPDISPATCH Ptr)  
               argList=va_next(argList,Any Ptr Ptr) 'LPDISPATCH Ptr) 
             
            case VT_ERROR OR VT_BYREF:
               V_ERRORREF(@pParams[i-1]) = va_arg(argList, SCODE Ptr) 
               argList=va_next(argList,SCODE Ptr) 
            case VT_BOOL OR VT_BYREF: 
               Dim As  BOOL Ptr pbool = va_arg(argList, BOOL Ptr) 
               '*pbool = 0 
               V_BOOLREF(@pParams[i-1]) = Cast(VARIANT_BOOL Ptr,pbool) 
               argList=va_next(argList,BOOL Ptr)
                 
            case VT_VARIANT OR VT_BYREF: 
               V_VARIANTREF(@pParams[i-1]) = va_arg(argList, VARIANTARG Ptr) 
               argList=va_next(argList,VARIANTARG Ptr)
            case VT_UNKNOWN OR VT_BYREF:
               V_UNKNOWNREF(@pParams[i-1]) = va_arg(argList, LPUNKNOWN Ptr) 
               argList=va_next(argList,Any Ptr Ptr) 'LPUNKNOWN Ptr)  
            
         	case VT_RECORD :  ' je crois pas pris en charge à l'intérieur
                pParams[i-1].pvRecord = va_arg(argList, Any Ptr) 
                argList=va_next(argList,Any Ptr Ptr)  
            Case Else:
                   If (pParams[i-1].vt And (VT_ARRAY Or VT_BYREF)) Then
                   	 pParams[i-1].pparray=va_arg(argList, SAFEARRAY Ptr Ptr ) 
                      argList=va_next(argList,SAFEARRAY Ptr Ptr) 
                      Exit Select   
                   EndIf
                    OleErrorShow(ResultFromScode(E_OUTOFMEMORY)) 
                  
            End Select

             
        Next i
      Function= InvokePropGet(pdisp,dispidm,pParams,count)  
      Delete pParams
      Exit Function
    End if  
    
    Function= InvokePropGet (pdisp,dispidm,NULL,0) 
    Delete pParams
End function  
 
Function Method_id  Cdecl Alias "Method"(pdisp As LPDISPATCH ,dispidm As DISPID , pszFmt as String="" , ...)As VARIANT
    Dim vRet As  VARIANT
    Dim As Any Ptr argList 
    argList= va_first()  
    Dim count As Integer
    Dim As HRESULT hr 
 
    Dim As VARIANTARG ptr pParams = NULL 
    variantinit(@vRet)
   
   if (pdisp =  NULL)Then
    	  OleErrorShow(E_INVALIDARG)
        vRet.vt = VT_ERROR
		  vRet.scode = -1
		return vRet 
    End If
   
   

    ' determine number of arguments
    if (Len(pszFmt) <>  NULL)Then
        count=CountArgsInFormat(pszFmt) 
    End If
     

    if (count <> 0)Then
        pParams= new VARIANTARG[count]  ' allocate memory for all VARIANTARG parameters
        
        if(pParams = NULL)Then
            OleErrorShow(ResultFromScode(E_OUTOFMEMORY))
            vRet.vt = VT_ERROR
		      vRet.scode = -1
		      Return vRet  
        End If
        
       
         
        Dim vt As VARTYPE
             
        For i As Integer=1 To count
 	         GetVarType(PARSE(pszFmt,",",i),@vt)
            pParams[i-1].vt=vt
             
         Select Case (pParams[i-1].vt)
            case VT_UI1:
               V_UI1(@pParams[i-1]) = va_arg(argList, UByte) 
               argList=va_next(argList,UByte)   
            case VT_I2:
               V_I2(@pParams[i-1]) = va_arg(argList, short) 
               argList=va_next(argList,short)  
            case VT_I4:
               V_I4(@pParams[i-1]) = va_arg(argList, long) 
               argList=va_next(argList,long)  
            case VT_R4:
               V_R4(@pParams[i-1]) = va_arg(argList, float) 
               argList=va_next(argList,float)  
            Case VT_DATE:
            	pParams[i-1].date = va_arg(argList,DATE_) 
               argList=va_next(argList, DATE_) 	
            case VT_R8:
               pParams[i-1].dblval = va_arg(argList, double) 
               argList=va_next(argList, double) 
                
            case VT_CY:
               V_CY(@pParams[i-1]) = va_arg(argList, CY) 
               argList=va_next(argList, CY)  
            case VT_BSTR:
               V_BSTR(@pParams[i-1]) = SysAllocString(va_arg(argList, OLECHAR Ptr)) 
               If (pParams[i-1].bstrVal =  NULL) Then
                  hr = ResultFromScode(E_OUTOFMEMORY)  
                  pParams[i-1].vt = VT_EMPTY 
                  'GoTo cleanup  
               End If
                 argList=va_next(argList, OLECHAR Ptr) 
                  
            case VT_DISPATCH:
                'V_DISPATCH(@pvarg[i-1]) = va_arg(argList, LPDISPATCH)
               pParams[i-1].pdispval=va_arg(argList, LPDISPATCH)
               argList= va_next(argList,Any Ptr) 'LPDISPATCH)
                  
            case VT_ERROR:
               V_ERROR(@pParams[i-1]) = va_arg(argList, SCODE) 
               argList=va_next(argList,  SCODE) 
            case VT_BOOL:
               V_BOOL(@pParams[i-1]) = IIf(va_arg(argList,BOOL),-1,0)
               argList=va_next(argList,BOOL) 
            case VT_VARIANT:
               pParams[i-1] = *va_arg(argList, VARIANTARG Ptr) 
               argList=va_next(argList,VARIANTARG Ptr)  
            case VT_UNKNOWN:
               V_UNKNOWN(@pParams[i-1]) = va_arg(argList, LPUNKNOWN) 
               argList= va_next(argList,Any Ptr) 'LPUNKNOWN) 
            
            case VT_UI1 OR VT_BYREF:
               V_UI1REF(@pParams[i-1]) = va_arg(argList, UByte Ptr) 
               argList=va_next(argList,UByte Ptr)
            case VT_I2 OR VT_BYREF:
               V_I2REF(@pParams[i-1]) = va_arg(argList, short Ptr) 
               argList=va_next(argList,short Ptr) 
            case VT_I4 OR VT_BYREF:
               V_I4REF(@pParams[i-1]) = va_arg(argList, long Ptr) 
               argList=va_next(argList,long Ptr) 
            case VT_R4 OR VT_BYREF:
               V_R4REF(@pParams[i-1]) = va_arg(argList, float Ptr) 
               argList=va_next(argList,float Ptr)
                 
            case VT_R8 OR VT_BYREF:
               V_R8REF(@pParams[i-1]) = va_arg(argList, double Ptr) 
               argList=va_next(argList,double Ptr)
            case VT_DATE OR VT_BYREF:
               V_DATEREF(@pParams[i-1]) = va_arg(argList, DATE_ Ptr) 
               argList=va_next(argList,DATE_ Ptr) 
            case VT_CY OR VT_BYREF:
               V_CYREF(@pParams[i-1]) = va_arg(argList, CY Ptr) 
               argList=va_next(argList, CY Ptr) 
            case VT_BSTR OR VT_BYREF:
               V_BSTRREF(@pParams[i-1]) = va_arg(argList, BSTR Ptr) 
               argList=va_next(argList,BSTR Ptr) 
            case VT_DISPATCH OR VT_BYREF:
               ' V_DISPATCHREF(@pvarg[i-1]) = va_arg(argList, LPDISPATCH Ptr)  
               pParams[i-1].ppdispval = va_arg(argList, LPDISPATCH Ptr)  
               argList=va_next(argList,Any Ptr Ptr) 'LPDISPATCH Ptr) 
             
            case VT_ERROR OR VT_BYREF:
               V_ERRORREF(@pParams[i-1]) = va_arg(argList, SCODE Ptr) 
               argList=va_next(argList,SCODE Ptr) 
            case VT_BOOL OR VT_BYREF: 
               Dim As  BOOL Ptr pbool = va_arg(argList, BOOL Ptr) 
               '*pbool = 0 
               V_BOOLREF(@pParams[i-1]) = Cast(VARIANT_BOOL Ptr,pbool) 
               argList=va_next(argList,BOOL Ptr)
                 
            case VT_VARIANT OR VT_BYREF: 
               V_VARIANTREF(@pParams[i-1]) = va_arg(argList, VARIANTARG Ptr) 
               argList=va_next(argList,VARIANTARG Ptr)
            case VT_UNKNOWN OR VT_BYREF:
               V_UNKNOWNREF(@pParams[i-1]) = va_arg(argList, LPUNKNOWN Ptr) 
               argList=va_next(argList,Any Ptr Ptr) 'LPUNKNOWN Ptr)  
            
         	case VT_RECORD :
                pParams[i-1].pvRecord = va_arg(argList, Any Ptr) 
                argList=va_next(argList,Any Ptr Ptr)  
            Case Else:
                   If (pParams[i-1].vt And (VT_ARRAY Or VT_BYREF)) Then
                   	 pParams[i-1].pparray=va_arg(argList, SAFEARRAY Ptr Ptr ) 
                      argList=va_next(argList,SAFEARRAY Ptr Ptr) 
                      Exit Select   
                   EndIf
                    OleErrorShow(ResultFromScode(E_OUTOFMEMORY)) 
                  
            End Select

             
        Next i
      Function= InvokeMethod(pdisp,dispidm,pParams,count)  
      Delete pParams
      Exit Function
    End if  
    
    Function= InvokeMethod(pdisp,dispidm,NULL,0) 
    Delete pParams
End function  

 

[aloberoger]

dispathcall.bi (part2)

Code: Select all

Function Method Cdecl(pdisp As LPDISPATCH ,MethodName As String , pszFmt as String="" , ...)As VARIANT
    Dim vRet As  VARIANT
    Dim As Any Ptr argList 
    argList= va_first()  
    Dim count As Integer
    Dim As HRESULT hr 
    Dim dispidm As DISPID=MethodDispid(pdisp,MethodName)
    Dim As VARIANTARG ptr pParams = NULL 
    variantinit(@vRet)
   
   if (pdisp =  NULL)Then
    	  OleErrorShow(E_INVALIDARG)
        vRet.vt = VT_ERROR
		  vRet.scode = -1
		return vRet 
    End If
   
   

    ' determine number of arguments
    if (Len(pszFmt) <>  NULL)Then
        count=CountArgsInFormat(pszFmt) 
    End If
     

    if (count <> 0)Then
        pParams= new VARIANTARG[count]  ' allocate memory for all VARIANTARG parameters
        
        if(pParams = NULL)Then
            OleErrorShow(ResultFromScode(E_OUTOFMEMORY))
            vRet.vt = VT_ERROR
		      vRet.scode = -1
		      Return vRet  
        End If
        
       
         
        Dim vt As VARTYPE
             
        For i As Integer=1 To count
 	         GetVarType(PARSE(pszFmt,",",i),@vt)
            pParams[i-1].vt=vt
             
         Select Case (pParams[i-1].vt)
            case VT_UI1:
               V_UI1(@pParams[i-1]) = va_arg(argList, UByte) 
               argList=va_next(argList,UByte)   
            case VT_I2:
               V_I2(@pParams[i-1]) = va_arg(argList, short) 
               argList=va_next(argList,short)  
            case VT_I4:
               V_I4(@pParams[i-1]) = va_arg(argList, long) 
               argList=va_next(argList,long)  
            case VT_R4:
               V_R4(@pParams[i-1]) = va_arg(argList, float) 
               argList=va_next(argList,float)  
            Case VT_DATE:
            	pParams[i-1].date = va_arg(argList,DATE_) 
               argList=va_next(argList, DATE_) 	
            case VT_R8:
               pParams[i-1].dblval = va_arg(argList, double) 
               argList=va_next(argList, double) 
                
            case VT_CY:
               V_CY(@pParams[i-1]) = va_arg(argList, CY) 
               argList=va_next(argList, CY)  
            case VT_BSTR:
               V_BSTR(@pParams[i-1]) = SysAllocString(va_arg(argList, OLECHAR Ptr)) 
               If (pParams[i-1].bstrVal =  NULL) Then
                  hr = ResultFromScode(E_OUTOFMEMORY)  
                  pParams[i-1].vt = VT_EMPTY 
                  'GoTo cleanup  
               End If
                 argList=va_next(argList, OLECHAR Ptr) 
                  
            case VT_DISPATCH:
                'V_DISPATCH(@pvarg[i-1]) = va_arg(argList, LPDISPATCH)
               pParams[i-1].pdispval=va_arg(argList, LPDISPATCH)
               argList= va_next(argList,Any Ptr) 'LPDISPATCH)
                  
            case VT_ERROR:
               V_ERROR(@pParams[i-1]) = va_arg(argList, SCODE) 
               argList=va_next(argList,  SCODE) 
            case VT_BOOL:
               V_BOOL(@pParams[i-1]) = IIf(va_arg(argList,BOOL),-1,0)
               argList=va_next(argList,BOOL) 
            case VT_VARIANT:
               pParams[i-1] = *va_arg(argList, VARIANTARG Ptr) 
               argList=va_next(argList,VARIANTARG Ptr)  
            case VT_UNKNOWN:
               V_UNKNOWN(@pParams[i-1]) = va_arg(argList, LPUNKNOWN) 
               argList= va_next(argList,Any Ptr) 'LPUNKNOWN) 
            
            case VT_UI1 OR VT_BYREF:
               V_UI1REF(@pParams[i-1]) = va_arg(argList, UByte Ptr) 
               argList=va_next(argList,UByte Ptr)
            case VT_I2 OR VT_BYREF:
               V_I2REF(@pParams[i-1]) = va_arg(argList, short Ptr) 
               argList=va_next(argList,short Ptr) 
            case VT_I4 OR VT_BYREF:
               V_I4REF(@pParams[i-1]) = va_arg(argList, long Ptr) 
               argList=va_next(argList,long Ptr) 
            case VT_R4 OR VT_BYREF:
               V_R4REF(@pParams[i-1]) = va_arg(argList, float Ptr) 
               argList=va_next(argList,float Ptr)
                 
            case VT_R8 OR VT_BYREF:
               V_R8REF(@pParams[i-1]) = va_arg(argList, double Ptr) 
               argList=va_next(argList,double Ptr)
            case VT_DATE OR VT_BYREF:
               V_DATEREF(@pParams[i-1]) = va_arg(argList, DATE_ Ptr) 
               argList=va_next(argList,DATE_ Ptr) 
            case VT_CY OR VT_BYREF:
               V_CYREF(@pParams[i-1]) = va_arg(argList, CY Ptr) 
               argList=va_next(argList, CY Ptr) 
            case VT_BSTR OR VT_BYREF:
               V_BSTRREF(@pParams[i-1]) = va_arg(argList, BSTR Ptr) 
               argList=va_next(argList,BSTR Ptr) 
            case VT_DISPATCH OR VT_BYREF:
               ' V_DISPATCHREF(@pvarg[i-1]) = va_arg(argList, LPDISPATCH Ptr)  
               pParams[i-1].ppdispval = va_arg(argList, LPDISPATCH Ptr)  
               argList=va_next(argList,Any Ptr Ptr) 'LPDISPATCH Ptr) 
             
            case VT_ERROR OR VT_BYREF:
               V_ERRORREF(@pParams[i-1]) = va_arg(argList, SCODE Ptr) 
               argList=va_next(argList,SCODE Ptr) 
            case VT_BOOL OR VT_BYREF: 
               Dim As  BOOL Ptr pbool = va_arg(argList, BOOL Ptr) 
               '*pbool = 0 
               V_BOOLREF(@pParams[i-1]) = Cast(VARIANT_BOOL Ptr,pbool) 
               argList=va_next(argList,BOOL Ptr)
                 
            case VT_VARIANT OR VT_BYREF: 
               V_VARIANTREF(@pParams[i-1]) = va_arg(argList, VARIANTARG Ptr) 
               argList=va_next(argList,VARIANTARG Ptr)
            case VT_UNKNOWN OR VT_BYREF:
               V_UNKNOWNREF(@pParams[i-1]) = va_arg(argList, LPUNKNOWN Ptr) 
               argList=va_next(argList,Any Ptr Ptr) 'LPUNKNOWN Ptr)  
            
         	case VT_RECORD :
                pParams[i-1].pvRecord = va_arg(argList, Any Ptr) 
                argList=va_next(argList,Any Ptr Ptr)  
            Case Else:
                   If (pParams[i-1].vt And (VT_ARRAY Or VT_BYREF)) Then
                   	 pParams[i-1].pparray=va_arg(argList, SAFEARRAY Ptr Ptr ) 
                      argList=va_next(argList,SAFEARRAY Ptr Ptr) 
                      Exit Select   
                   EndIf
                    OleErrorShow(ResultFromScode(E_OUTOFMEMORY)) 
                  
            End Select

             
        Next i
      Function= InvokeMethod(pdisp,dispidm,pParams,count)  
      Delete pParams
      Exit Function
    End if  
    
    Function= InvokeMethod(pdisp,dispidm,NULL,0) 
    Delete pParams
End function  

Function InvokePropPut OverLoad (pdisp As LPDISPATCH ,dispidm As DISPID ,pParams as VARIANTARG Ptr ,count As Integer=1)As VARIANT
	return InvokeWrap(pdisp,DISPATCH_PROPERTYPUT,dispidm,pParams,count)
End Function

Function InvokePropPutRef OverLoad (pdisp As LPDISPATCH ,dispidm As DISPID ,pParams as VARIANTARG Ptr ,count As Integer=1)As VARIANT
	return InvokeWrap(pdisp,DISPATCH_PROPERTYPUTREF,dispidm,pParams,count)
End Function

Function InvokePropGet OverLoad (pdisp As LPDISPATCH ,dispidm As DISPID ,pParams as VARIANTARG Ptr=NULL ,count As Integer=0)As VARIANT
	return InvokeWrap(pdisp,DISPATCH_PROPERTYGET,dispidm,pParams,count)
End Function

Function InvokeMethod OverLoad (pdisp As LPDISPATCH ,dispidm As DISPID ,pParams as VARIANTARG Ptr=NULL ,count As Integer=0)As VARIANT
	return InvokeWrap(pdisp,DISPATCH_METHOD,dispidm,pParams,count)
End Function

  
Function MethodDispid(pdisp As LPDISPATCH,szName As String)As DISPID
   Dim wszName As WString*500 =szName
   Dim pszName As LPOLESTR =@wszName
   Dim dispidm As DISPID
   Dim As HRESULT hr
    
    if (pdisp =  NULL)Then
    	  OleErrorShow(E_INVALIDARG)
		  Return NULL 
    End If
    ' Get DISPID of property/method
   #If Defined (_FB_COM_VTBL_) 
    hr = pdisp->lpvtbl->GetIDsOfNames(pdisp,@IID_NULL, @pszName, 1, LOCALE_USER_DEFAULT, @dispidm) 
   #Else
     hr = pdisp->GetIDsOfNames(@IID_NULL, @pszName, 1, LOCALE_USER_DEFAULT, @dispidm)
   #EndIf
    if(FAILED(hr))Then
        OleErrorShow(hr,*pszName)
		  Return NULL 
    End If           
    Return dispidm
End Function


Function InvokePropPut OverLoad (pdisp As LPDISPATCH ,szName As String ,pParams as VARIANTARG Ptr ,count As Integer=1)As VARIANT
	return InvokeWrap(pdisp,DISPATCH_PROPERTYPUT,MethodDispid(pdisp,szName),pParams,count)
End Function

Function InvokePropPutRef OverLoad (pdisp As LPDISPATCH ,szName As String ,pParams as VARIANTARG Ptr ,count As Integer=1)As VARIANT
	return InvokeWrap(pdisp,DISPATCH_PROPERTYPUTREF,MethodDispid(pdisp,szName),pParams,count)
End Function

Function InvokePropGet OverLoad (pdisp As LPDISPATCH ,szName As String ,pParams as VARIANTARG Ptr=NULL ,count As Integer=0)As VARIANT
	return InvokeWrap(pdisp,DISPATCH_PROPERTYGET,MethodDispid(pdisp,szName),pParams,count)
End Function

Function InvokeMethod OverLoad (pdisp As LPDISPATCH ,szName As String ,pParams as VARIANTARG Ptr=NULL ,count As Integer=0)As VARIANT
	return InvokeWrap(pdisp,DISPATCH_METHOD,MethodDispid(pdisp,szName),pParams,count)
End Function


 Function InvokeWrap OverLoad (pdisp As LPDISPATCH , wFlags As WORD ,szName As String ,pParams as VARIANTARG Ptr ,count As Integer)As VARIANT
 	Return InvokeWrap(pdisp,wFlags,MethodDispid(pdisp,szName),pParams,count)
 End Function


Function OleInvoke Cdecl(pdisp As LPDISPATCH, wFlags As WORD  ,szName As String,count As Integer=0, ...)As VARIANT
    Dim vRet As  VARIANT
    Dim As Any Ptr argList = va_first()
    Dim As HRESULT hr 
 
    Dim As VARIANTARG ptr pParams = NULL 
    variantinit(@vRet)
   
   if (pdisp =  NULL)Then
    	  OleErrorShow(E_INVALIDARG)
        vRet.vt = VT_ERROR
		  vRet.scode = -1
		return vRet 
    End If
   
   Dim dispidm As DISPID=MethodDispid(pdisp,szName) 
    if (count <> 0)Then
        pParams= new VARIANTARG[count]  ' allocate memory for all VARIANTARG parameters
        
        if(pParams = NULL)Then
            OleErrorShow(ResultFromScode(E_OUTOFMEMORY))
            vRet.vt = VT_ERROR
		      vRet.scode = -1
		      Return vRet  
        End If
        
               
        Dim vt As VARTYPE
             
        For i As Integer=0 To count-1
 	      If (pParams[i].vt And VT_BYREF)Then
            V_VARIANTREF(@pParams[i]) = va_arg(argList, VARIANTARG Ptr) 
            argList=va_next(argList,VARIANTARG Ptr)
         Else
            pParams[i] = *va_arg(argList, VARIANTARG Ptr) 
            argList=va_next(argList,VARIANTARG Ptr)  
         End If                    
            
        Next i
      Function= InvokeWrap (pdisp, wFlags,dispidm,pParams,count)  
      Delete pParams
      Exit Function
    End if  
    
    Function= InvokeWrap (pdisp, wFlags,dispidm,NULL,0) 
    Delete pParams
End function  

Function OleInvoke_id Cdecl(pdisp As LPDISPATCH , wFlags As WORD,dispidm As DISPID,count As Integer=0, ...)As VARIANT
    Dim vRet As  VARIANT
    Dim As Any Ptr argList = va_first()
    Dim As HRESULT hr 
 
    Dim As VARIANTARG ptr pParams = NULL 
    variantinit(@vRet)
   
   if (pdisp =  NULL)Then
    	  OleErrorShow(E_INVALIDARG)
        vRet.vt = VT_ERROR
		  vRet.scode = -1
		return vRet 
    End If
   
   
    if (count <> 0)Then
        pParams= new VARIANTARG[count]  ' allocate memory for all VARIANTARG parameters
        
        if(pParams = NULL)Then
            OleErrorShow(ResultFromScode(E_OUTOFMEMORY))
            vRet.vt = VT_ERROR
		      vRet.scode = -1
		      Return vRet  
        End If
        
               
        Dim vt As VARTYPE
             
        For i As Integer=0 To count-1
 	      If (pParams[i].vt And VT_BYREF)Then
            V_VARIANTREF(@pParams[i]) = va_arg(argList, VARIANTARG Ptr) 
            argList=va_next(argList,VARIANTARG Ptr)
         Else
            pParams[i] = *va_arg(argList, VARIANTARG Ptr) 
            argList=va_next(argList,VARIANTARG Ptr)  
         End If                    
            
        Next i
      Function= InvokeWrap (pdisp, wFlags,dispidm,pParams,count)  
      Delete pParams
      Exit Function
    End if  
    
    Function= InvokeWrap (pdisp, wFlags,dispidm,NULL,0) 
    Delete pParams
End function  


Private Function CountArgsInFormat(pszFmt As String) As UINT  
    return PARSECOUNT(pszFmt,",") 
End Function


Private Function  GetVarType(psmzFmt As  String ,pvt as VARTYPE Ptr ) As  String  
  
    *pvt = 0 
    
    ' Cas Particulier des safearrays
    If InStr(psmzFmt,"%t") Then
         *pvt =VT_ARRAY Or VT_BYREF 
         psmzFmt=Right(psmzFmt,1)
        Select Case Trim(psmzFmt)
    	   Case "a" 
    		  *pvt  OR = VT_UI1				
        case  ("b"):
            *pvt  OR = VT_BOOL 
 
        case  ("i"): 
            *pvt  OR = VT_I2 
      
        case  ("I"): 
            *pvt  OR = VT_I4 
 
        case  ("r"): 
            *pvt  OR = VT_R4 
 

        case  ("R"): 
            *pvt  OR = VT_R8 
           
        case  ("c"):
            *pvt  OR = VT_CY 
 
        case  ("s"): 
            *pvt  OR = VT_BSTR 
 
        case  ("e"): 
            *pvt  OR = VT_ERROR 
 
        case  ("d"): 
            *pvt  OR = VT_DATE  
 
        case  ("v"): 
            *pvt  OR = VT_VARIANT 
            
    	  Case  ("U"): 
            *pvt  OR = VT_UNKNOWN  
 
    	case  ("D"): 
            *pvt  Or = VT_DISPATCH 
            
      case  ("p"): 
            *pvt= VT_RECORD 
       Case  (!"\0")
             return ""     ' End of Format string
        Case else:
            return "" 
      End Select 
    End If 
    
    
    ' Cas des parametres byref
    
    if InStr(psmzFmt,"@") Then
         *pvt = VT_BYREF 
         If (NULL=Len(psmzFmt))Then
             return "" 
         End If        
    End If 
    
    
    
    psmzFmt=Right(psmzFmt,1)
    
    Select Case Trim(psmzFmt)
    	   Case "a" 
    		  *pvt  OR = VT_UI1				
        case  ("b"):
            *pvt  OR = VT_BOOL 
 
        case  ("i"): 
            *pvt  OR = VT_I2 
      
        case  ("I"): 
            *pvt  OR = VT_I4 
 
        case  ("r"): 
            *pvt  OR = VT_R4 
 

        case  ("R"): 
            *pvt  OR = VT_R8 
           
        case  ("c"):
            *pvt  OR = VT_CY 
 
        case  ("s"): 
            *pvt  OR = VT_BSTR 
 
        case  ("e"): 
            *pvt  OR = VT_ERROR 
 
        case  ("d"): 
            *pvt  OR = VT_DATE  
 
        case  ("v"): 
            *pvt  OR = VT_VARIANT 
            
    	  Case  ("U"): 
            *pvt  OR = VT_UNKNOWN  
 
    	  Case  ("D"): 
            *pvt  Or = VT_DISPATCH 
 
        Case  ("p"): 
            *pvt = VT_RECORD 
        case  (!"\0")
             return ""     ' End of Format string
        Case else:
            return "" 
    End Select 
  
    return  psmzFmt  
End Function

Private Function PARSECOUNT( source As String, delimiter As String=",")As Long
	Dim As Long i,s,c,l
	s=1
	l=1
	Do
		i=Instr(s,source,Any delimiter)
		If i>0 Then
			c+=1
			s=i+l
		End If 
	Loop Until i=0
	Function=c+1
End Function

Private Function PARSE  (source as string, delimiter as String="|", index as integer)as String
	Dim As Long i,s,c,l
	s=1
	l=Len(delimiter)
	do
		If c=index-1 then
			function=mid(source,s,instr(s,source,delimiter)-s)
			exit function
		end if
		i=instr(s,source,delimiter)
		If i>0 then
			c+=1
			s=i+l
		end if 
	loop until i=0
End Function

 
Private Sub OleErrorShow ( hr As HRESULT, addit As String="")
 Dim serr As String
 If hr=s_ok Then Exit Sub
    
   Dim As Any Ptr pMsg 
	FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_FROM_SYSTEM,NULL,hr, _
		            MAKELANGID(LANG_NEUTRAL,SUBLANG_DEFAULT),Cast(LPTSTR,@pMsg),0,NULL) 
	Dim As String sCheckError= " : Error(&h" & Hex(hr) & "): "  & *Cast(ZString Ptr,pMsg) 
	LocalFree(pMsg) 
  
  	serr=addit & " " & sCheckError
	MessageBox (getactiveWindow(),serr,"OLE ERROR ",MB_ICONERROR Or MB_TASKMODAL)
End Sub

[aloberoger]

test example with excell
testexcell.bas

Code: Select all

#Undef TRUE
#Include Once "DispatchCall.bi" 

 

 
Function Main() As Integer
	
   
     
    Dim As VARIANT rVal   ' Temporary result holder
    

    ' Initialize the OLE Library...
    OleInitialize(NULL)

    ' VB: Dim  Excapp As Object
    Dim As IDISPATCH Ptr Excapp 

    '' VB: Set wdApp = CreateObject "Excel.Application"
    
     CreateObject("Excel.Application",@Excapp)

    ' VB: Excapp.workbooks.add
    Dim As IDISPATCH Ptr ExcWorkbook 
    
    ExcWorkbook=PropGet(Excapp,"workbooks").pdispval 
    method(ExcWorkbook,"Add")
     
     
    
   'vb: Excapp.visible = true 
    propPut(Excapp,"Visible","%b", TRUE)
    
 
   

  ' vb:Excapp.ActiveSheet.Cells(3,1).Value = "Hello"
    
    Dim As IDISPATCH Ptr ExcSheet,ExcCell 
    ExcSheet=propGet(Excapp,"ActiveSheet").pdispval
    ExcCell=propGet(ExcSheet,"Cells","%I,%I",3,1).pdispval 
    
    propPut(ExcCell,"Value","%s",@WStr("Hello"))
     
    
    
  ' Excapp.ActiveSheet.Cells(4,1).Value= " COM "

    ExcCell=propGet(ExcSheet,"Cells","%I,%I",4,1).pdispval
     propPut(ExcCell,"Value","%s",@WStr("COM"))
    
   
    
   'Excapp.ActiveSheet.Cells (4,2).Value     = " With FB "
   
    ExcCell=propGet(ExcSheet,"Cells","%I,%I",4,2).pdispval
    propPut(ExcCell,"Value","%s",@WStr("With FB"))

   
    
  
  
    Dim temp_var as string

   ' ' temp_var  = Excapp.ActiveSheet.Cells(3,1).Value
   
       
    ExcSheet=propGet(ExcApp,"ActiveSheet").pdispval
    ExcCell=propGet(ExcSheet,"Cells","%I,%I",3,1).pdispval
    rVal=propGet(ExcCell,"Value")
  
    temp_var=*Cast(wstring Ptr,rVal.bstrval)
    messagebox NULL,temp_var , "value of cell(3,1)", 4096
    VariantClear(@rVal)
    
     
     
  ' Clearing variables
     ExcCell->Release()
     ExcSheet->Release()
     Excapp->Release()
    

    ' Terminate the OLE Library...
    OleUninitialize()

    return 0
End Function
End Main

/'
Dim Excapp as Object
set Excapp = CreateObject("Excel.Application")

Excapp.workbooks.add
Excapp.visible = true
Excapp.ActiveSheet.Cells (3,1).Value = "Hello"
Excapp.ActiveSheet.Cells (4,1).Value= " COM"
Excapp.ActiveSheet.Cells (4,2).Value     = " With FB "

Dim temp_var as string

temp_var  = Excapp.ActiveSheet.Cells(3,1).Value
msgbox temp_var , "value of cell(3,1)", 4096

Sleep(1000)
Excapp.activeworkbook.saved = true
Excapp.quit
Set Excapp = Nothing
'/

[aloberoger]

starting help
% man byval "@" mean byref


' Cas Particular case of safearrays always "%t" = "%tI" safearray of long "%tR" safearray of Double

"%a" byval as ubyte "@a" byval as ubyte ptr
"%b" byval as bool, boolean
"%i" byval as short ...
"%I" byval as long, intreger ...
"%r" byval as float,single ...
"%R" byval as double "@R" byval as double ptr
"%c" byval as CY ...
"%s" byval as string "@s" byval as string ptr
"%e" byval as error vt_error ...
"%d" byval as DATE_ ...
"%v" byval as variant (but you pass @v where v is a VARAINT)
"%U" byval as byval as IUNKNOWN ptr ...
"%D" byval as IDISPATCH ptr ...

exemple:
calling dothat(x as double, y as long ptr,pdis as IDIDPATCH PTR)

you must use in the format parameter "%R,@I,%D",x,@y,pdisp)

don't worry if you don't have my libraries
simply put at the top level before the headers file #define _FB_COM_VTBL_
or in the code remove the unwanted part: for exemple
#If Defined (_FB_COM_VTBL_)
hr = pdisp->lpvtbl->GetIDsOfNames(pdisp,@IID_NULL, @pszName, 1, LOCALE_USER_DEFAULT, @dispidm)
#Else
hr = pdisp->GetIDsOfNames(@IID_NULL, @pszName, 1, LOCALE_USER_DEFAULT, @dispidm)
#EndIf
you can remain with
hr = pdisp->lpvtbl->GetIDsOfNames(pdisp,@IID_NULL, @pszName, 1, LOCALE_USER_DEFAULT, @dispidm)

[OSchmidt]

Thanks for the hints - and for checking things out...

If you change the code as follows:

Code: Select all

    ...
    CallByName oDict, "Add", , "ss", "1", "AAA" 'add a Long-Value under a Key
    ...
    MsgBox "Item under 1: " & V2S(CallByName(oDict, "Item", , "s", "1"))

It returns "A" Instead of "AAA"[/color].

In addition does not work with Unicode symbols (such as Russian). Correct the code not used WSTR , better (MultiByteToWideChar and WideCharToMultiByte)

Yep, but that behaviour is not really based on faulty code in SimpleCOM.bi -
instead it's related to the fact, that (with Win32-FB 1.05 at least):
- with normal (ANSI) CodeModules, FB is storing (and passing) String-Literals as 8Bit-Chars
- with UTF8-BOM prefixed CodeModules FB will store (and pass) String-Literals as 16Bit-WChars

So, in your case (since you're obviously working with Unicode-tagged FB-CodeModules),
it would be enough, to replace the little "s" with a little "w" in all places, where a String-Literal is passed
(although String-*Variables* are not affected - these will always need to be passed with an "s")

Took me a while to fiddle that out (it's nowhere explicitely documented IMO - and I was searching quite intensively...)

Would be nice of you, when you could check-out the enhanced version of it, which is now called 'SimpleVariant.bi'
(it's basically the same Dispatch-Call-codebase, but now containing also a Variant-Class, to get rid of all the little conversion-functions)

Will open a new thread for that (with adapted and new examples, also showing RegFree loading of COM-Classes).

Olaf

[OSchmidt]

Thanks for the advice and the examples alober,
but...

...don't worry if you don't have my libraries
simply put at the top level before the headers file
#define _FB_COM_VTBL_
or in the code remove the unwanted part: for exemple
#If Defined (_FB_COM_VTBL_)
hr = pdisp->lpvtbl->GetIDsOfNames(pdisp,@IID_NULL, @pszName, 1, LOCALE_USER_DEFAULT, @dispidm)
#Else
hr = pdisp->GetIDsOfNames(@IID_NULL, @pszName, 1, LOCALE_USER_DEFAULT, @dispidm)
#EndIf
you can remain with
hr = pdisp->lpvtbl->GetIDsOfNames(pdisp,@IID_NULL, @pszName, 1, LOCALE_USER_DEFAULT, @dispidm)

I've tried exactly that - and didn't get it to work (I guess, there was still a dependency remainig to your Dlls,
but it could also well be, that my "FB-proficiencies" were not yet sufficient to make it function, some weeks ago)...

Don't get me wrong - I'm not trying to "shun your code for petty reasons" -
instead I'm really trying to share a bit of knowledge about COM, especially
how to deal with the Dispatch-Calls in a more efficient way - and how to get
RegFree-COM-instancing to work from within FB-Code...

Hopefully my new version (called 'SimpleVariant.bi') will help you to improve your own COM-stuff
(in the same way as your code-examples helped me, to climb over the first hurdles with regards to
"expressing myself properly with FB-syntax").

Olaf

[aloberoger]

it is interessant what you proposes, I simply wanted, to propose improvements to that you made.
you said that my code did not work, exact, that is due to the operators on the CLSID, which appear normally in win/guiddef.bi in my headers.
for this example, place them before # include once " win/ole2.bi " in " DispatchCall.bi "
and test with this example below:

Private Operator = OverLoad (ByVal guidOne As REFGUID ,ByRef guidOther As Const GUID)As BOOL
return IsEqualGUID (guidOne, @guidOther)
End Operator

Private Operator = OverLoad( ByRef guid1 As Const GUID , ByRef guid2 As Const GUID) As BOOL
return IsEqualGUID(@guid1,@guid2)
End Operator

Private Operator = OverLoad( ByRef guid1 As Const GUID , ByVal guid2 As REFIID) As BOOL
return IsEqualGUID(@guid1,guid2)
End Operator

testdispatchCall.bas

Code: Select all

 #Define  _FB_COM_VTBL_ 


#Undef TRUE
#Include Once "DispatchCall.bi" 

 ' put theses operators in DispatchCall.bi after #include once "Win/ole2.bi"
 ' Normaly I have put them in win/guiddef.bi
/'
Private Operator  = OverLoad (ByVal guidOne As REFGUID ,ByRef guidOther As  Const GUID)As BOOL 
 return   IsEqualGUID (guidOne, @guidOther)
End Operator  

Private Operator  = OverLoad( ByRef guid1 As  Const GUID  , ByRef guid2 As  Const GUID) As BOOL
     return IsEqualGUID(@guid1,@guid2) 
End Operator 

Private Operator  = OverLoad( ByRef guid1 As Const GUID  , ByVal guid2 As REFIID) As BOOL
     return IsEqualGUID(@guid1,guid2) 
End Operator 

 
Private  Operator  <> OverLoad(ByVal guidOne As REFGUID ,ByRef guidOther As  Const GUID) As BOOL
 return  Not(guidOne = guidOther) 
End Operator  

Private  Operator  <> OverLoad( ByRef guid1 As  Const GUID  , ByRef guid2 As  Const GUID) As BOOL
     return Not(IsEqualGUID(@guid1,@guid2)) 
End Operator 

Private Operator  <> OverLoad( Byref guid1 As Const GUID , ByVal guid2 As REFIID) As BOOL
     return Not(IsEqualGUID(@guid1,guid2)) 
End Operator 
'/

 
Function Main() As Integer
	
   
     
    Dim As VARIANT rVal   ' Temporary result holder
    

    ' Initialize the OLE Library...
    OleInitialize(NULL)

    ' VB: Dim  Excapp As Object
    Dim As IDISPATCH Ptr Excapp 

    '' VB: Set wdApp = CreateObject "Excel.Application"
    
     CreateObject("Excel.Application",@Excapp)

    ' VB: Excapp.workbooks.add
    Dim As IDISPATCH Ptr ExcWorkbook 
    
    ExcWorkbook=PropGet(Excapp,"workbooks").pdispval 
    method(ExcWorkbook,"Add")
     
     
    
   'vb: Excapp.visible = true 
    propPut(Excapp,"Visible","%b", TRUE)
    
 
   

  ' vb:Excapp.ActiveSheet.Cells(3,1).Value = "Hello"
    
    Dim As IDISPATCH Ptr ExcSheet,ExcCell 
    ExcSheet=propGet(Excapp,"ActiveSheet").pdispval
    ExcCell=propGet(ExcSheet,"Cells","%I,%I",3,1).pdispval 
    
    propPut(ExcCell,"Value","%s",@WStr("Hello"))
     
    
    
  ' Excapp.ActiveSheet.Cells(4,1).Value= " COM "

    ExcCell=propGet(ExcSheet,"Cells","%I,%I",4,1).pdispval
     propPut(ExcCell,"Value","%s",@WStr("COM"))
    
   
    
   'Excapp.ActiveSheet.Cells (4,2).Value     = " With FB "
   
    ExcCell=propGet(ExcSheet,"Cells","%I,%I",4,2).pdispval
    propPut(ExcCell,"Value","%s",@WStr("With FB"))

   
    
  
  
    Dim temp_var as string

   ' ' temp_var  = Excapp.ActiveSheet.Cells(3,1).Value
   
       
    ExcSheet=propGet(ExcApp,"ActiveSheet").pdispval
    ExcCell=propGet(ExcSheet,"Cells","%I,%I",3,1).pdispval
    rVal=propGet(ExcCell,"Value")
  
    temp_var=*Cast(wstring Ptr,rVal.bstrval)
    messagebox NULL,temp_var , "value of cell(3,1)", 4096
    VariantClear(@rVal)
    
     
     
  ' Clearing variables
   #If Not Defined( _FB_COM_VTBL_)
     ExcCell->Release()
     ExcSheet->Release()
     Excapp->Release()
   #Else
     ExcCell->lpvtbl->Release(ExcCell)
     ExcSheet->lpvtbl->Release(ExcSheet)
     Excapp->lpvtbl->Release(Excapp)
   #EndIf 

    ' Terminate the OLE Library...
    OleUninitialize()

    return 0
End Function
End Main

[OSchmidt]

...my code did not work, exact, that is due to the operators on the CLSID, which appear normally in win/guiddef.bi in my headers.
for this example, place them before # include once " win/ole2.bi " in " DispatchCall.bi "
and test with this example below:

Thanks, just tested it with these changes(additions) - and it does indeed work now (without referencing your libs)...

Though not easy to take care about proper RefCounting with such a "pure procedural approach" to LateBound-COM.

E.g. in your Excel-example, the Excel-ProcessInstance is not properly cleared (at least on my machine, Win8/Office13)...
When you look into the Task-Manager, there's an "Excel-Zombie-instance" left over, after each FBApp-Run.

That was one of the reasons, why I discarded the "pure procedural LateBound-COM"-approach (SimpleCOM.bi)
pretty fast in favour of SimpleVariant.bi (which takes much better care of RefCounting, due to the Destructor-
methods of the vbVariant-TypeDef).

Olaf

[aloberoger]

need

ExcWorkbook->lpvtbl->Release(ExcWorkbook)


all well be ok I think

[OSchmidt]

Since this thread is getting quite some clicks...

Please note, that SimpleCOM.bi has - in the meantime - a (better written, and faster) successor in SimpleVariant.bi,
which I've introduced here: http://www.freebasic.net/forum/viewtopi ... 88#p221188 ...(with zipped Demos).

Olaf

[kcvinu]

@OSchmidt ,
Could you please guide me to get the COM object of a running excel instance ?. I mean something like GetActiveObject() in VB.Net.

[Josep Roca]

Try this:

Code: Select all

' ========================================================================================
' WARNING: Untested because I fon't have Office installed.
' If the requested object is in an EXE (out-of-process server), such Office applications,
' and it is running and registered in the Running Object Table (ROT), AfxGetCom will
' return a pointer to its interface. AfxAnyCom will first try to use an existing, running
' application if available, or it will create a new instance if not.
' Be aware that AfxGetCom can fail under if Office is running but not registered in the ROT.
' When an Office application starts, it does not immediately register its running objects.
' This optimizes the application's startup process. Instead of registering at startup, an
' Office application registers its running objects in the ROT once it loses focus. Therefore,
' if you attempt to use GetObject or GetActiveObject to attach to a running instance of an
' Office application before the application has lost focus, you might receive an error.
' See: https://support.microsoft.com/en-us/help/238610/getobject-or-getactiveobject-cannot-find-a-running-office-application
' ========================================================================================
' ========================================================================================
PRIVATE FUNCTION AfxGetCom OVERLOAD (BYREF wszProgID AS CONST WSTRING) AS ANY PTR
   DIM classID AS CLSID, pUnk AS ANY PTR
   CLSIDFromProgID(wszProgID, @classID)
   IF IsEqualGuid(@classID, @IID_NULL) THEN RETURN NULL
   GetActiveObject(@classID, NULL, @pUnk)
   RETURN pUnk
END FUNCTION
' ========================================================================================
' ========================================================================================
PRIVATE FUNCTION AfxGetCom OVERLOAD (BYREF classID AS CONST CLSID) AS ANY PTR
   DIM pUnk AS ANY PTR
   GetActiveObject(@classID, NULL, @pUnk)
   RETURN pUnk
END FUNCTION
' ========================================================================================

[kcvinu]

@Josep Roca

Thanks a lot for the code. Infact, I was frustrated using disphelper and SimpleCom, since these libs dont have a function for getting active com object. So far so good. Your code is running and it gives me an any ptr. But using this gave an error message ;

Code: Select all

Var xlApp  = AfxGetCom("Excel.Application")
? xlApp.ActiveWindow.Caption

I think that i am missing something. this is only an any ptr. Please guide me.

Edit note:
We need to add this inside the AfxGetCom function.

Code: Select all

CoInitialize(Null)