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

Windows specific questions.
OSchmidt
Posts: 49
Joined: Jan 01, 2016 12:27
Contact:

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

Postby OSchmidt » Jun 03, 2016 5:13

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
Posts: 1319
Joined: Oct 24, 2010 15:16
Location: Ярославль
Contact:

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

Postby VANYA » Jun 03, 2016 9:44

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
Posts: 476
Joined: Jan 13, 2009 19:23

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

Postby aloberoger » Jun 03, 2016 15:51

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
Posts: 476
Joined: Jan 13, 2009 19:23

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

Postby aloberoger » Jun 03, 2016 15:52

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
Posts: 476
Joined: Jan 13, 2009 19:23

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

Postby aloberoger » Jun 03, 2016 15:54

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
Posts: 476
Joined: Jan 13, 2009 19:23

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

Postby aloberoger » Jun 03, 2016 16:00

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
Posts: 49
Joined: Jan 01, 2016 12:27
Contact:

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

Postby OSchmidt » Jun 15, 2016 0:54

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

VANYA wrote: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
Posts: 49
Joined: Jan 01, 2016 12:27
Contact:

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

Postby OSchmidt » Jun 15, 2016 1:14

Thanks for the advice and the examples alober,
but...
aloberoger wrote:
...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
Posts: 476
Joined: Jan 13, 2009 19:23

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

Postby aloberoger » Jun 16, 2016 21:38

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
Posts: 49
Joined: Jan 01, 2016 12:27
Contact:

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

Postby OSchmidt » Jun 17, 2016 8:20

aloberoger wrote:...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
Posts: 476
Joined: Jan 13, 2009 19:23

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

Postby aloberoger » Jun 17, 2016 18:40

need

ExcWorkbook->lpvtbl->Release(ExcWorkbook)


all well be ok I think
OSchmidt
Posts: 49
Joined: Jan 01, 2016 12:27
Contact:

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

Postby OSchmidt » Jun 22, 2016 1:15

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: viewtopic.php?f=6&t=24777&p=221188#p221188 ...(with zipped Demos).

Olaf
kcvinu
Posts: 173
Joined: Oct 07, 2015 16:44
Location: Keralam, India

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

Postby kcvinu » Sep 06, 2018 18:00

@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
Posts: 441
Joined: Sep 27, 2016 18:20
Location: Valencia, Spain

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

Postby Josep Roca » Sep 06, 2018 18:14

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
Posts: 173
Joined: Oct 07, 2015 16:44
Location: Keralam, India

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

Postby kcvinu » Sep 07, 2018 13:09

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

Return to “Windows”

Who is online

Users browsing this forum: No registered users and 4 guests