INSIDE ACTIVEX WITH FREEBASIC

Windows specific questions.
Post Reply
marpon
Posts: 342
Joined: Dec 28, 2012 13:31
Location: Paris - France

Re: INSIDE ACTIVEX WITH FREEBASIC

Post by marpon »

@aloberoger , thanks
Here is source code of FBTLBWTR.exe
the source for RegReadtlb.dll is not included
marpon
Posts: 342
Joined: Dec 28, 2012 13:31
Location: Paris - France

Re: INSIDE ACTIVEX WITH FREEBASIC

Post by marpon »

@aloberoger
comobject.dll
comobject in a dll, you can also build a static library
http://www.2shared.com/file/yF2nCKcg/po ... bject.html
the link is not working
aloberoger
Posts: 507
Joined: Jan 13, 2009 19:23

Re: INSIDE ACTIVEX WITH FREEBASIC

Post by aloberoger »

source for Regreadtlb.dll

Code: Select all

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

#Include Once "strwrap.bi"
#Include Once "lv.bi"



Function RegSearchWin32 (tszKey AS string) AS STRING
     Dim szKeyName AS zstring * max_PATH
     Dim szKey AS zstring * max_PATH
     Dim szClass AS zstring * max_PATH
     dim ft AS FILETIME
     Dim hKey AS HKEY
     Dim dwIdx AS uinteger
     Dim hr AS uinteger
     Dim dwname as uinteger=max_path
     Dim dwclass as uinteger=max_path
     szkey=tszkey
     DO
        hr = RegOpenKeyEx (hkey_CLASSES_ROOT, @szKey, 0, KEY_READ, @hKey)
        IF hr=ERROR_NO_MORE_ITEMS THEN EXIT FUNCTION
        IF hKey = 0 THEN EXIT FUNCTION
			dwname=max_path
    		dwclass=max_path

        hr = RegEnumKeyEx (hKey, dwIdx, @szKeyName, @dwname, 0, @szClass, @dwclass, @ft)
        IF hr<>0 THEN EXIT DO
        IF UCASE$(szKeyName) = "WIN32" THEN EXIT DO
        dwIdx+=1
     LOOP WHILE hr = 0
     RegCloseKey hKey
     IF hr <> 0 OR szKeyName = "" THEN EXIT FUNCTION
     FUNCTION = szKey
  END FUNCTION   

FUNCTION RegEnumDirectory (sKey AS STRING) AS STRING
     Dim szKey AS zstring * max_PATH
     Dim szKeyName AS zstring * max_PATH
     Dim szClass AS zstring * max_PATH
     Dim ft AS FILETIME
     Dim hKey AS HKEY
     Dim dwIdx AS uinteger
     Dim hr AS uinteger
     dim sSubkey AS STRING
     Dim dwname as uinteger
     Dim dwclass as uinteger

     ' Searches the HKEY_CLASSES_ROOT\TypeLib\<LIBID> node.
     szKey = sKey
     hr = RegOpenKeyEx (hkey_CLASSES_ROOT, @szKey, 0, KEY_READ, @hKey)
     IF hr <> ERROR_SUCCESS THEN EXIT FUNCTION
     IF hKey = 0 THEN EXIT FUNCTION
     dwIdx = 0
     DO
     	  dwname=max_path
     	  dwclass=max_path
        hr = RegEnumKeyEx (hKey, dwIdx, @szKeyName, @dwname, 0, @szClass, @dwclass, @ft)
        IF hr=ERROR_NO_MORE_ITEMS THEN EXIT DO
        sSubkey = RegSearchWin32(szKey & "\" & szKeyName)
        IF LEN(sSubkey) THEN EXIT DO
        dwIdx+=1
     LOOP
     RegCloseKey hKey
     IF hr <> 0 OR sSubkey = "" THEN EXIT FUNCTION
     
     dim szValueName AS zstring * max_PATH
     Dim KeyType AS DWORD
     Dim szKeyValue AS zstring * max_PATH
     Dim cValueName AS DWORD
     Dim cbData AS DWORD

     ' win32 node
     dwIdx = 0
     cValueName = max_PATH
     cbData = max_PATH
     szKey = sSubkey & "\" & "win32"
     hr = RegOpenKeyEx (hkey_CLASSES_ROOT, @szKey, 0, KEY_READ, @hKey)
     IF hr <> ERROR_SUCCESS THEN EXIT FUNCTION
     hr = RegEnumValue (hKey, dwIdx, @szValueName, @cValueName, BYVAL NULL, @KeyType, @szKeyValue, @cbData)
     RegCloseKey hKey
     FUNCTION = szKeyValue
  END FUNCTION 
  
Function CheckEnvVar(BYVAL sTextIn AS STRING) AS STRING
     Dim iPos     AS LONG
     dim iSafety  AS LONG
     Dim sTemp    AS STRING
     Dim sNew     AS String
     Dim ttxt As String
	  
	  ttxt=stextin
     DO UNTIL str_TALLY(ttxt,"%") < 2
        iPos = INSTR(1,ttxt,"%")   'get first position
        sTemp = MID$(ttxt,iPos + 1,(INSTR(iPos +1,ttxt,"%")- (iPos + 1)))
        sNew = ENVIRON$(sTemp)
        ttxt=str_replace( "%" + sTemp + "%",sNew,ttxt)
        iSafety+=1 : IF iSafety > 5 THEN EXIT do 'if we find more than 5 vars...  something is wrong
     LOOP
     FUNCTION = ttxt
End FUNCTION

Function RegEnumVersions (hlist As HWND,sCLSID AS STRING) AS LONG 
	Dim szKey AS zstring * max_PATH
	dim szKeyName AS zstring * max_PATH
	dim szClass AS zstring * max_PATH
	dim ft AS FILETIME
	dim hKey AS HKEY
	Dim dwIdx AS DWORD
	dim hr AS DWORD
	dim idx AS LONG
	dim sPath AS STRING
	dim PathPos AS LONG
	dim sFile AS STRING
	dim i AS LONG
	dim lvi as lv_item
	
	dim szValueName AS zstring * max_PATH
	dim KeyType AS DWORD
	dim szKeyValue AS zstring * max_PATH
	dim tsz AS zstring * max_PATH
	dim cValueName AS DWORD
	dim cbData AS DWORD
	dim hVerKey AS HKEY
	dim verIdx AS DWORD
	dim vmax_path as uinteger
	dim dwname as uinteger
	dim dwclass as uinteger
	
	cValueName = max_PATH
	cbData = max_PATH
	' // Searches the HKEY_CLASSES_ROOT\TypeLib\<LIBID> node.
	szKey = "TypeLib\" & sCLSID
	
	hr = RegOpenKeyEx (hkey_CLASSES_ROOT, @szKey, 0, KEY_READ, @hKey)
	IF hr <> ERROR_SUCCESS THEN EXIT Function
	IF hKey = 0 THEN EXIT FUNCTION
	dwIdx = 0
	' // Open the subtrees of the different versions of the TypeLib library
	' // and store the filenames, descriptions, paths and CLSIDs in a 4D array.
	DO
		dwname=max_path
		dwclass=max_path
		hr = RegEnumKeyEx (hKey, dwIdx, @szKeyName, @dwname, 0, @szClass, @dwclass, @ft)
		IF hr=ERROR_NO_MORE_ITEMS THEN EXIT DO  
		lvi.iItem = 0
		lvi.mask = LVIF_TEXT
		lvi.iSubItem = 0
		tsz=UCASE$(sCLSID)
		lvi.pszText = StrPtr(tsz)
		SendMessage hlist,LVM_INSERTITEM,0,Cast(LPARAM,@lvi)
		
		' -- Get default value -------------------------------------------
		verIdx = 0
		cvaluename=max_path
		cbdata=max_path        
		tsz=szKey & "\" & szKeyName
		hr = RegOpenKeyEx (hkey_CLASSES_ROOT,@tsz,0,KEY_READ, @hVerKey)
		hr = RegEnumValue(hVerKey, verIdx, @szValueName, @cValueName, NULL, @KeyType, @szKeyValue, @cbData)   'Default value
		RegCloseKey hVerKey
		IF szValueName = "" THEN
			lvi.iSubItem =1
			lvi.pszText = @szKeyvalue
			SendMessage hlist,LVM_SETITEM,0,Cast(LPARAM,@lvi)         
		Else
			lvi.iSubItem = 1
			lvi.pszText = @szValueName
			SendMessage hlist,LVM_SETITEM,0,Cast(LPARAM,@lvi)         
		End IF
		'-----------------------------------------------------------------
		sPath = RegEnumDirectory(szKey & "\" & szKeyName)         
		' Check for environment variables
		IF INSTR(sPath, "%") THEN 
		sPath = CheckEnvVar(sPath)'-- added in July 25th, 2003
		EndIf
		lvi.iSubItem = 3
		lvi.pszText = strptr(spath)
		SendMessage hlist,LVM_SETITEM,0,Cast(LPARAM,@lvi)
		sfile=str_parse(spath,"\",str_numparse(spath,"\"))
		If InStr(sfile,".")=0 Then sfile=str_parse(spath,"\",str_numparse(spath,"\")-1)
		lvi.iSubItem = 2
		lvi.pszText = strptr(sfile)
		SendMessage hlist,LVM_SETITEM,0,Cast(LPARAM,@lvi)
		dwIdx+=1
	Loop
	' // Close the registry
	RegCloseKey hKey
	Return 0
END FUNCTION 



' *********************************************************************************************
' Enumerates all the typelibs.
' *********************************************************************************************
SUB RegEnumTypeLibs(hlist As HWND)
	Dim szKey AS zstring*max_path
	dim szKeyName AS zstring*max_path
	dim szClass AS zstring*max_path
	dim ft AS FILETIME
	dim hKey AS hkey
	dim dwIdx AS uinteger
	dim hr AS uinteger
	dim ttxt as string
	dim dwname as dword
	dim dwclass as dword
	
	
	' // Open the HKEY_CLASSES_ROOT\TypeLib subtree.
	szKey = "TypeLib"
	hr = RegOpenKeyEx (HKEY_CLASSES_ROOT, @szKey,0,key_read,@hKey)
	IF hr <> ERROR_SUCCESS THEN EXIT SUB
	IF hKey = 0 THEN EXIT SUB     
	' // Parse all the TypeLib subtree and get the CLSIDs of all the TypeLibs.
	dwIdx = 0
	Do
		dwname=MAX_PATH:dwclass=max_path
		hr = RegEnumKeyEx (hKey, dwIdx, @szKeyName, @dwname, 0, @szClass, @dwclass, @ft)
		IF hr=ERROR_NO_MORE_ITEMS THEN EXIT DO
		dwIdx +=1
		RegEnumVersions(hlist,Left(szKeyName,dwname))
	LOOP
	' // Close the registry
	RegCloseKey(hKey)
End SUB
  
#define ListView_SetItemCountEx(l,c,f) SendMessage(L, LVM_SETITEMCOUNT, c, F)

Extern "windows-ms"
FUNCTION SearchTypeLibs (hlist As HWND) AS Long Export
	SendMessage hlist,LVM_DELETEALLITEMS,0,0
	RegEnumTypeLibs(hlist) 
	Return 0  
End Function

End Extern

aloberoger
Posts: 507
Joined: Jan 13, 2009 19:23

Re: INSIDE ACTIVEX WITH FREEBASIC

Post by aloberoger »

marpon said
the link is not working
try the new link in the previous post.
marpon
Posts: 342
Joined: Dec 28, 2012 13:31
Location: Paris - France

Re: INSIDE ACTIVEX WITH FREEBASIC

Post by marpon »

@aloberoger thanks again
on the fbtlbreader.bas (extract)

Code: Select all

Else
 	ss &="#Include Once " & DQ & "Comobjects.bi" & DQ  & CRLF
   ss &= CRLF
 End If
 If icode=ABSTRACTCLASS_CODE Or INVOKE_INVOKE Then
    If  UseIfont=TRUE Or UseIFontDisp=TRUE Then
        If UseOleFontWrapper=TRUE Then ss &="#Include Once " & DQ & "olefont.bi" & DQ  & CRLF
    End If
    If UseIPicture=TRUE Or UseIPictureDisp=TRUE Then
       If UseOleFontWrapper=TRUE Then ss &="#Include Once " & DQ & "olepictureex.bi" & DQ  & CRLF
    End If
 End If

 If icode=INVOKE_INVOKE Then
 	    ss &="#include once " & DQ & "Invoke.bi" & DQ  & CRLF
 EndIf
you are genereting code referring to :
Comobjects.bi
olefont.bi
olepictureex.bi
Invoke.bi

but i did not find these files...
aloberoger
Posts: 507
Joined: Jan 13, 2009 19:23

Re: INSIDE ACTIVEX WITH FREEBASIC

Post by aloberoger »

oleFont.bi

Code: Select all

Type OleFont     ' peut s'utiliser ou on attend un IFONTDISP ptr
	Private:
       vDispatch AS VARIANT 
   Public:
   Declare Constructor
   Declare Constructor(ByRef value  As IDISPATCH Ptr)
   Declare Constructor(ByRef value  As OleFont ) 
   Declare Operator cast() As IDISPATCH Ptr 
   Declare Operator Let(ByRef value  As IDISPATCH Ptr)   
   Declare Property Name () AS string 
   Declare Property Name ( BYVAL pname AS string)
   Declare Property Size () AS float 
   Declare Property Size (ByVal psize AS float )
   Declare Property Bold () AS VARIANT_BOOL 
   Declare Property Bold (ByVal pbold AS VARIANT_BOOL )
   Declare Property Italic () AS VARIANT_BOOL
   Declare Property Italic (ByVal pitalic AS VARIANT_BOOL ) 
   Declare Property Underline () AS VARIANT_BOOL 
   Declare Property Underline (ByVal punderline AS VARIANT_BOOL)
   Declare Property Strikethrough ( ) AS VARIANT_BOOL 
   Declare Property Strikethrough (ByVal pstrikethrough AS VARIANT_BOOL )

  Declare Property Weight () AS integer 
  Declare Property Weight (ByVal pweight AS integer)
  Declare Property Charset () AS integer 
  Declare Property Charset (ByVal pcharset AS integer)
  End Type

 
     Constructor OleFont
       Dim hr As HRESULT
      hr = CoCreateInstance(@CLSID_StdFont, NULL, CLSCTX_SERVER, @IID_IDISPATCH,cast(LPVOID PTr,@vDispatch))
     End Constructor
     Constructor OleFont(ByRef value As IDISPATCH Ptr)
         vDispatch.pdispval=value
     End Constructor
     Constructor OleFont(ByRef value  As OleFont )
        This=value
        vDispatch.pdispval=value
     End Constructor
     Operator OleFont.cast() As IDISPATCH Ptr 
     	  Return vDispatch.pdispval
     End Operator
     Operator OleFont.Let(ByRef value  As IDISPATCH Ptr)
     	  vDispatch.pdispval=value
     End Operator
  

  Property OleFont.Name (BYVAL pname AS string )
     DIM oDispatch AS IDISPATCH PTR
     DIM uDispParams AS DISPPARAMS
    
    
     DIM hr AS HRESULT
     DIM DISPIDPROPERTYPUT AS LONG
     DIM vArgs(0) AS VARIANT

      vArgs(0).vt =VT_BSTR
     vArgs(0).bstrval =strtobstr(pname)

      oDispatch = vDispatch.pdispval
     IF oDispatch=NULL THEN EXIT Property
     uDispParams.CNamedArgs = 1
     DISPIDPROPERTYPUT = -3
     uDispParams.rgdispidNamedArgs = VARPTR(DISPIDPROPERTYPUT)
     uDispParams.CArgs = 1
     uDispParams.rgvarg = @vArgs(0)
     
   #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
     hr = oDispatch->Invoke(0, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
   #Else    
     hr = oDispatch->lpvtbl->Invoke(oDispatch,0, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
    #EndIf
     
     
     oDispatch = NULL

  END Property
  
  Property OleFont.Name ()  AS string 

     DIM oDispatch AS IDISPATCH PTR
     DIM uDispParams AS DISPPARAMS
    
    
     DIM hr AS HRESULT
     DIM vResult AS VARIANT

      oDispatch = vDispatch.pdispval
     IF oDispatch=NULL THEN EXIT Property
     
   #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
     hr = oDispatch->Invoke(0, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
   #Else  
     hr = oDispatch->lpvtbl->Invoke(oDispatch,0, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
   #EndIf 
     
     
     oDispatch = NULL
     Property = *cast(WSTRING PTR,vResult.bstrval)

  END Property


Property OleFont.Size (BYVAL psize AS float )

     DIM oDispatch AS IDISPATCH PTR
     DIM uDispParams AS DISPPARAMS
    
    
     DIM hr AS HRESULT
     DIM DISPIDPROPERTYPUT AS LONG
     DIM vArgs(0) AS VARIANT

     vArgs(0).Vt=VT_CY
     vArgs(0).cyval.int64=psize *10000

      oDispatch = vDispatch.pdispval
     IF oDispatch=NULL THEN EXIT Property
     uDispParams.CNamedArgs = 1
     DISPIDPROPERTYPUT = -3
     uDispParams.rgdispidNamedArgs = VARPTR(DISPIDPROPERTYPUT)
     uDispParams.CArgs = 1
     uDispParams.rgvarg = @vArgs(0)
     #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
      hr = oDispatch->Invoke(2, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
     #Else
     hr = oDispatch->lpvtbl->Invoke(oDispatch,2, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
     #EndIf
     
     
     oDispatch = NULL

  END Property

  Property OleFont.Size ()  AS float 

     DIM oDispatch AS IDISPATCH PTR
     DIM uDispParams AS DISPPARAMS
    
    
     DIM hr AS HRESULT
     DIM vResult AS VARIANT

      oDispatch = vDispatch.pdispval
     IF oDispatch=NULL THEN EXIT Property
     
     #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
       hr = oDispatch->Invoke(2, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
     #Else
     hr = oDispatch->lpvtbl->Invoke(oDispatch,2, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
     #EndIf
     
     
     oDispatch = NULL
     RETURN   vResult.Cyval.int64/10000

  END Property


  Property OleFont.Bold ()  AS VARIANT_BOOL 

     DIM oDispatch AS IDISPATCH PTR
     DIM uDispParams AS DISPPARAMS
    
    
     DIM hr AS HRESULT
     DIM vResult AS VARIANT

      oDispatch = vDispatch.pdispval
     IF oDispatch=NULL THEN EXIT Property
     
     #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
       hr = oDispatch->Invoke(3, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
     #Else
       hr = oDispatch->lpvtbl->Invoke(oDispatch,3, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
     #EndIf
     
     
     oDispatch = NULL
     Property = vResult.boolval

  END Property

   Property OleFont.Bold (BYVAL pbold AS VARIANT_BOOL )

     DIM oDispatch AS IDISPATCH PTR
     DIM uDispParams AS DISPPARAMS
    
    
     DIM hr AS HRESULT
     DIM DISPIDPROPERTYPUT AS LONG
     DIM vArgs(0) AS VARIANT

      vArgs(0).vt =VT_BOOL
     vArgs(0).boolval =pbold

      oDispatch = vDispatch.pdispval
     IF oDispatch=NULL THEN EXIT Property
     uDispParams.CNamedArgs = 1
     DISPIDPROPERTYPUT = -3
     uDispParams.rgdispidNamedArgs = VARPTR(DISPIDPROPERTYPUT)
     uDispParams.CArgs = 1
     uDispParams.rgvarg = @vArgs(0)
     
     #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
        hr = oDispatch->Invoke(3, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
     #Else
       hr = oDispatch->lpvtbl->Invoke(oDispatch,3, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
     #EndIf
     
     
     oDispatch = NULL

  END Property
  
  Property OleFont.Italic ()  AS VARIANT_BOOL 

     DIM oDispatch AS IDISPATCH PTR
     DIM uDispParams AS DISPPARAMS
    
    
     DIM hr AS HRESULT
     DIM vResult AS VARIANT

      oDispatch = vDispatch.pdispval
     IF oDispatch=NULL THEN EXIT Property
     
     #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
        hr = oDispatch->Invoke(4, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
     #Else
     hr = oDispatch->lpvtbl->Invoke(oDispatch,4, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
     #EndIf
     
     
     oDispatch = NULL
     Property = vResult.boolval

  END Property

  Property OleFont.Italic (BYVAL pitalic AS VARIANT_BOOL)

     DIM oDispatch AS IDISPATCH PTR
     DIM uDispParams AS DISPPARAMS
    
    
     DIM hr AS HRESULT
     DIM DISPIDPROPERTYPUT AS LONG
     DIM vArgs(0) AS VARIANT

     vArgs(0).vt =VT_BOOL
     vArgs(0).boolval =pitalic

      oDispatch = vDispatch.pdispval
     IF oDispatch=NULL THEN EXIT Property
     uDispParams.CNamedArgs = 1
     DISPIDPROPERTYPUT = -3
     uDispParams.rgdispidNamedArgs = VARPTR(DISPIDPROPERTYPUT)
     uDispParams.CArgs = 1
     uDispParams.rgvarg = @vArgs(0)
     
     #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
        hr = oDispatch->Invoke(4, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
     #Else
        hr = oDispatch->lpvtbl->Invoke(oDispatch,4, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
     #EndIf
     
     
     oDispatch = NULL

  END Property
  
  Property OleFont.Underline ()  AS VARIANT_BOOL 

     DIM oDispatch AS IDISPATCH PTR
     DIM uDispParams AS DISPPARAMS
    
    
     DIM hr AS HRESULT
     DIM vResult AS VARIANT

      oDispatch = vDispatch.pdispval
     IF oDispatch=NULL THEN EXIT Property
     
   #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
     hr = oDispatch->Invoke(5, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
   #Else  
     hr = oDispatch->lpvtbl->Invoke(oDispatch,5, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
    #EndIf
     
     
     oDispatch = NULL
     Property = vResult.boolval

  END Property

   Property OleFont.Underline ( BYVAL punderline AS VARIANT_BOOL )

     DIM oDispatch AS IDISPATCH PTR
     DIM uDispParams AS DISPPARAMS
    
    
     DIM hr AS HRESULT
     DIM DISPIDPROPERTYPUT AS LONG
     DIM vArgs(0) AS VARIANT

     vArgs(0).vt =VT_BOOL
     vArgs(0).boolval =punderline

      oDispatch = vDispatch.pdispval
     IF oDispatch=NULL THEN EXIT Property
     uDispParams.CNamedArgs = 1
     DISPIDPROPERTYPUT = -3
     uDispParams.rgdispidNamedArgs = VARPTR(DISPIDPROPERTYPUT)
     uDispParams.CArgs = 1
     uDispParams.rgvarg = @vArgs(0)
     
     #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
       hr = oDispatch->Invoke(5, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
     #Else
     hr = oDispatch->lpvtbl->Invoke(oDispatch,5, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
     #EndIf
     
     
     oDispatch = NULL

  END Property
  
  Property OleFont.Strikethrough ()  AS VARIANT_BOOL 

     DIM oDispatch AS IDISPATCH PTR
     DIM uDispParams AS DISPPARAMS
    
    
     DIM hr AS HRESULT
     DIM vResult AS VARIANT

      oDispatch = vDispatch.pdispval
     IF oDispatch=NULL THEN EXIT Property
     
     #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
       hr = oDispatch->Invoke(6, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
     #Else
     hr = oDispatch->lpvtbl->Invoke(oDispatch,6, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
     #EndIf
     
     
     oDispatch = NULL
     Property = vResult.boolval

  END Property

   Property OleFont.Strikethrough (BYVAL pstrikethrough AS VARIANT_BOOL)

     DIM oDispatch AS IDISPATCH PTR
     DIM uDispParams AS DISPPARAMS
    
    
     DIM hr AS HRESULT
     DIM DISPIDPROPERTYPUT AS LONG
     DIM vArgs(0) AS VARIANT

     vArgs(0).vt =VT_BOOL
     vArgs(0).boolval =pstrikethrough

      oDispatch = vDispatch.pdispval
     IF oDispatch=NULL THEN EXIT Property
     uDispParams.CNamedArgs = 1
     DISPIDPROPERTYPUT = -3
     uDispParams.rgdispidNamedArgs = VARPTR(DISPIDPROPERTYPUT)
     uDispParams.CArgs = 1
     uDispParams.rgvarg = @vArgs(0)
     
     #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
         hr = oDispatch->Invoke(6, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
     #Else
        hr = oDispatch->lpvtbl->Invoke(oDispatch,6, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
      #EndIf
     
     
     oDispatch = NULL

  END Property

  Property OleFont.Weight ()  AS integer 

     DIM oDispatch AS IDISPATCH PTR
     DIM uDispParams AS DISPPARAMS
    
    
     DIM hr AS HRESULT
     DIM vResult AS VARIANT

      oDispatch = vDispatch.pdispval
     IF oDispatch=NULL THEN EXIT Property
     
     #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
        hr = oDispatch->Invoke(7, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
     #Else
        hr = oDispatch->lpvtbl->Invoke(oDispatch,7, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
     #EndIf
     
     
     oDispatch = NULL
     RETURN  vResult.intval

  END Property

  Property OleFont.Weight ( BYVAL pweight AS integer )
     DIM oDispatch AS IDISPATCH PTR
     DIM uDispParams AS DISPPARAMS
    
    
     DIM hr AS HRESULT
     DIM DISPIDPROPERTYPUT AS LONG
     DIM vArgs(0) AS VARIANT

     vArgs(0).vt =VT_INT
     vArgs(0).intval =pweight

      oDispatch = vDispatch.pdispval
     IF oDispatch=NULL THEN EXIT Property
     uDispParams.CNamedArgs = 1
     DISPIDPROPERTYPUT = -3
     uDispParams.rgdispidNamedArgs = VARPTR(DISPIDPROPERTYPUT)
     uDispParams.CArgs = 1
     uDispParams.rgvarg = @vArgs(0)
     
     #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
        hr = oDispatch->Invoke(7, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
     #Else
        hr = oDispatch->lpvtbl->Invoke(oDispatch,7, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
     #EndIf
     
     
     oDispatch = NULL

  END Property
  
  Property OleFont.Charset ()  AS integer 

     DIM oDispatch AS IDISPATCH PTR
     DIM uDispParams AS DISPPARAMS
     DIM hr AS HRESULT
     DIM vResult AS VARIANT

      oDispatch = vDispatch.pdispval
     IF oDispatch=NULL THEN EXIT Property
     
     #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
       hr = oDispatch->Invoke(8, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
     #Else
     hr = oDispatch->lpvtbl->Invoke(oDispatch,8, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
     #EndIf    
     
     oDispatch = NULL
     RETURN vResult.intval

  END Property


  Property OleFont.Charset (BYVAL pcharset AS integer )

     DIM oDispatch AS IDISPATCH PTR
     DIM uDispParams AS DISPPARAMS
    
    
     DIM hr AS HRESULT
     DIM DISPIDPROPERTYPUT AS LONG
     DIM vArgs(0) AS VARIANT

     vArgs(0).vt =VT_INT
     vArgs(0).intval =pcharset

      oDispatch = vDispatch.pdispval
     IF oDispatch=NULL THEN EXIT Property
     uDispParams.CNamedArgs = 1
     DISPIDPROPERTYPUT = -3
     uDispParams.rgdispidNamedArgs = VARPTR(DISPIDPROPERTYPUT)
     uDispParams.CArgs = 1
     uDispParams.rgvarg = @vArgs(0)
     
     #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
         hr = oDispatch->Invoke(8, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
     #Else
         hr = oDispatch->lpvtbl->Invoke(oDispatch,8, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
     #EndIf
     
     
     oDispatch = NULL

  End Property
olepictureex.bi

Code: Select all

Type OlePicture       ' can be used where IPICTUREDISP PTR is needed
	Private:
       oPicture AS IPICTUREDISP Ptr 
       m_handle As ..HANDLE
       m_typ As Short
       m_Own As VARIANT_BOOL
   Public:
   Declare Constructor
   Declare Constructor(ByRef value  As IDISPATCH Ptr)
   Declare Constructor(ByRef value  As OlePicture ) 
   Declare Operator cast() As IDISPATCH Ptr 
   Declare Operator Let(ByRef value  As iDispatCH Ptr)
   Declare Operator cast() As IPICTUREDISP Ptr 
   Declare Operator Let(ByRef value  As IPICTUREDISP Ptr)
   Declare SUB Release()  
  
   Declare Property Handle (value As HANDLE) 
   Declare Property Handle ()  AS ..HANDLE  
   Declare Property Typ (AS Short)     ' PICTYPE_BITMAP,PICTYPE_METAFILE,PICTYPE_ICON,PICTYPE_ENHMETAFILE
   Declare Property Own(value As BOOL)
   Declare Sub Create()                ' create if  handle is set (hbitmaP,hicon,HMETAFILE), and typ
   
   Declare Property Width () AS OLE_XSIZE_HIMETRIC
   Declare Property Height ()As OLE_XSIZE_HIMETRIC

	Declare Sub	LoadPictureFile(szFile As String)                  ' create from a file
	Declare Sub LoadPicRes(hInst As HINSTANCE , resID As Integer)  ' create  from rc    RCDATA value for bitmap icon etc
	Declare Function IsNULL() As BOOL
End Type

 
 
 Constructor OlePicture
       ' Dim hr As HRESULT
       '  coinitialize(NULL)
       'hr = CoCreateInstance(@CLSID_StdPicture, NULL, CLSCTX_ALL, @IID_IPICTURE,cast(LPVOID PTr,@oPicture))
        'Not need This at all because vDispatch will be created but With no image
 End Constructor
     
     Constructor OlePicture(ByRef value As iDispatCH Ptr)
         oPicture=Cast(IPICTUREDISP Ptr,value)
     End Constructor
     
     Constructor OlePicture(ByRef value  As OlePicture )
        This=value
        oPicture=value.oPicture
     End Constructor
     
     Operator OlePicture.cast() As iDispatCH Ptr 
     	  Return Cast(iDispatCH Ptr,oPicture)
     End Operator
     
     Operator OlePicture.Let(ByRef value  As iDispatCH Ptr)
     	  oPicture=Cast(IPICTUREDISP Ptr,value)
     End Operator

     Operator OlePicture.cast() As IPICTUREDISP Ptr 
     	   Return oPicture
     End Operator
     
    Operator OlePicture.Let(ByRef value  As IPICTUREDISP Ptr) 
    	    oPicture= value 
    End Operator
    
    SUB OlePicture.Release() 
    	#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
    	    oPicture->Release()
    	#Else
    	    oPicture->lpvtbl->Release(oPicture)
    	#EndIf
    End Sub
    
  Property OlePicture.Handle (value As ..HANDLE)  
      m_Handle=value
  End Property  

   Property OlePicture.Handle ()  AS ..HANDLE 
     Dim uDispParams AS DISPPARAMS
     DIM hr AS HRESULT
     DIM vResult AS VARIANT
 
     IF oPicture=NULL THEN EXIT Property 
     
     #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
         hr = oPicture->Invoke(0, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL,NULL)
     #Else 
         hr = oPicture->lpvtbl->Invoke(oPicture,0, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL,NULL)
     #EndIf
    
    m_Handle=Cast(..HANDLE,vResult.lval)
     
     RETURN m_Handle

  END Property  
  Property OlePicture.Typ(value  AS Short )
        m_typ=value
  END Property  

  Property OlePicture.Own(value As BOOL)
       m_Own=value
  End Property
  
  
  Property OlePicture.Width () AS OLE_XSIZE_HIMETRIC
    Dim res As OLE_XSIZE_HIMETRIC  
     DIM uDispParams AS DISPPARAMS
     DIM hr AS HRESULT
     DIM vResult AS VARIANT
     If oPicture=NULL THEN EXIT Property 
     #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
        hr = oPicture->Invoke(4, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL,NULL)
     #Else 
         hr = oPicture->lpvtbl->Invoke(opicture,4, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL,NULL)
     #EndIf
          
     res=  Cast(OLE_XSIZE_HIMETRIC,vResult.lval)
    Return res
  END Property  


  Property OlePicture.Height () As OLE_XSIZE_HIMETRIC
  Dim res As OLE_XSIZE_HIMETRIC   
      DIM uDispParams AS DISPPARAMS
     DIM hr AS HRESULT
     DIM vResult AS VARIANT
     If oPicture=NULL THEN EXIT Property 
     #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
        hr = oPicture->Invoke(5, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL,NULL)
     #Else 
         hr = oPicture->lpvtbl->Invoke(opicture,5, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL,NULL)
     #EndIf
          
     res=  Cast(OLE_XSIZE_HIMETRIC,vResult.lval)
    Return res
  END Property  
  
		
Sub OlePicture.Create()
	  Dim tpd AS PICTDESC 
  IF m_Handle = 0 THEN return   
   SELECT CASE m_Typ
  	CASE  PICTYPE_BITMAP        ' Bitmap
        tpd.bmp.hbitmap = m_Handle
  	CASE  PICTYPE_ICON          ' Icon
        tpd.icon.hicon = m_Handle
   Case PICTYPE_METAFILE
   		tpd.wmf.hmeta=m_Handle
   		'tpd.wmf.xExt= 
   		'tpd.wmf.yExt=
   Case PICTYPE_ENHMETAFILE
   		tpd.emf.hemf=m_Handle 
  	CASE ELSE
        Return
  END SELECT
  tpd.cbSizeOfStruct = SIZEOF(PICTDESC)
  tpd.picType = m_Typ
  IF m_Own THEN m_Own = -1
   OleCreatePictureIndirect(@tpd, @IID_IDispatch, m_Own, @oPicture)
End Sub
           
Sub	OlePicture.LoadPictureFile(szFile As String)
  STATIC  hFile        AS ..HANDLE
  STATIC  dwFileSize   AS DWORD
  STATIC  pvData       AS LPVOID
  STATIC  hGlobal      AS HGLOBAL
  STATIC  dwBytesRead  AS DWORD
  STATIC  bRead        AS BOOL
  STATIC  pstm         AS LPSTREAM
  STATIC  hr           AS HRESULT

  hFile = CreateFile(szFile, GENERIC_READ, 0, NULL, OPEN_EXISTING, 0, NULL)
  dwFileSize  =   GetFileSize(hFile, NULL)
  pvData      =   NULL
  hGlobal     =   GlobalAlloc(GMEM_MOVEABLE, dwFileSize)
  pvData      =   GlobalLock(hGlobal)
  dwBytesRead =   0
  bRead       =   ReadFile(hFile, pvData, dwFileSize, @dwBytesRead, NULL)
  GlobalUnlock(hGlobal)
  CloseHandle(hFile)
  pstm        =   NULL
  hr          =   CreateStreamOnHGlobal(hGlobal, TRUE, @pstm)
  if  oPicture THEN 
  	   #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
    	    oPicture->Release()
    	#Else
    	    oPicture->lpvtbl->Release(oPicture)
    	#EndIf
  EndIf
  
  hr=OleLoadPicture(pstm,dwFileSize,FALSE,@IID_IPictureDisp,Cast(LPVOID Ptr, @oPicture))
  
   #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
    	    pstm->Release()
   #Else
    	    pstm->lpvtbl->Release(pstm)
   #EndIf
End Sub
	
	' This function loads a file into an IStream.
Sub OlePicture.LoadPicRes(hInst As HINSTANCE , resID As Integer) 
 
	Dim  mname As ZString*100 
	 mname="#" & resID  

	   
	' Make resource ident string e.g. "#307"

	' Load resource
	Dim As HRSRC hRes 			= FindResource(hInst, mname, RT_RCDATA) 
	Dim As DWORD dwResSize		= SizeofResource(hInst, hRes) 
	Dim As HGLOBAL hResGlobal 	= LoadResource(hInst, hRes) 
	Dim As LPVOID lpResMem 	= LockResource(hResGlobal) 

	' The
	' Make a new global memory block with GMEM_MOVEABLE
	Dim As HGLOBAL hNewMem = GlobalAlloc(GMEM_MOVEABLE, dwResSize) 
	Dim As LPVOID lpNewMem = GlobalLock(hNewMem) 

	' Copy old to new
	memcpy(lpNewMem, lpResMem, dwResSize) 

	' Unlock both memory's
	GlobalUnlock(hNewMem) 
	GlobalUnlock(hResGlobal) 

	' Pass new memory to CreateStreamOnHGlobal and create IStream* from global memory
	' The memory must be MOVEABLE for this to work. I tried making the return
	' from LoadResource() MOVEABLE with GlobalReAlloc() but it would not work.
	Dim As LPSTREAM pstm = NULL 
	Dim As HRESULT hr = CreateStreamOnHGlobal(hNewMem, TRUE, @pstm) 

	' Destroy last picture if exists
	if ( oPicture) Then  
		#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
    	    oPicture->Release()
    	#Else
    	    oPicture->lpvtbl->Release(oPicture)
    	#EndIf
	EndIf

	' Create IPicture from image file
	hr = OleLoadPicture(pstm, dwResSize, FALSE, @IID_IPictureDisp, cast(LPVOID PTR, @oPicture)) 
	  
   #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
    	    pstm->Release()
   #Else
    	    pstm->lpvtbl->Release(pstm)
   #EndIf
	  
End Sub

	
	Function OlePicture.IsNULL() As BOOL
		If (oPicture=NULL) Then Return TRUE
		Return FALSE
	End Function
aloberoger
Posts: 507
Joined: Jan 13, 2009 19:23

Re: INSIDE ACTIVEX WITH FREEBASIC

Post by aloberoger »

Invoke.bi

Code: Select all

#Ifndef _INVOKE_BI_
#Define _INVOKE_BI_

#Include Once "windows.bi"
#Include Once "win/ocidl.bi"
 
 
 Dim Shared ComWrapper_oleInitialized As bool
 
 
 
 ''=======================================================================================
'' Fonctions globales.
''=======================================================================================
 
 
 
 Declare Function  CheckError(hr As HRESULT) As String
 Declare Sub ShowOleError ( hr As HRESULT, addit As String="")
 Declare Function  CreateObject OverLoad (ByVal ProgID as String,ByVal ppdisp As IDISPATCH Ptr Ptr) as HRESULT
 Declare  Function   CreateObject(ByVal ProgID as String,ByVal ppunk As IUNKNOWN Ptr Ptr) as HRESULT
 Declare  Function   CreateObject(ByVal ProgID as string) as VARIANT    ' ProgID is progid or clsid string result is variant(iunknown or idispatch)
 Declare  Function   CreateObject  (ByVal szProgId As String ,ByVal riid As REFIID ,ByVal dwClsContext As DWORD , _
			                                 ByVal mpServerInfo As COSERVERINFO ptr ,ByVal ppv as lpvoid Ptr ) As HRESULT
 
 Declare  Function  GetObjectEx(ByVal szPathName As String ,ByVal szProgId As String ,ByVal riid As REFIID , _
		                                ByVal  dwClsContext As DWORD ,ByVal lpvReserved As LPVOID ,ByVal  ppv As LPVOID Ptr) As HRESULT
 
 Declare  Function   _GetObject OverLoad (ByVal szPathName As String ,ByVal  szProgId As String ,ByVal ppDisp As IDispatch Ptr ptr ) As HRESULT
 Declare  Function   _GetObject  (ByVal szPathName As String="" ,ByVal  szProgId As String ) As IDispatch Ptr
 Declare  Function   GetObjectV   (ByVal szPathName As String ="",ByVal szProgId As String) As VARIANT



 
''***************************************************************************************
'' InvokeGetDISPID :
''***************************************************************************************
 Declare  Function   InvokeGetDISPID(pDispatch  as IDispatch Ptr,lpszName As LPCWSTR , pdispid as DISPID ptr) As HRESULT 

' IDispatch Ptr + ID DES  FunctionS  

Declare  Function   InvokePropGet OverLoad (pDispatch as IDispatch Ptr,propid As DISPID ,pVarRes As VARIANT Ptr,nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT 
Declare  Function   InvokePropPut OverLoad (pDispatch  as IDispatch Ptr,propid As DISPID , nParamCount As Integer =0,pVarNew As VARIANT Ptr=NULL )As HRESULT 
Declare  Function   InvokeMethod OverLoad (pDispatch as IDispatch Ptr,pVarRes As VARIANT Ptr,methodid As DISPID, nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT 
Declare  Function   InvokePropGet OverLoad (pDispatch as IDispatch Ptr,pVarRes As VARIANT Ptr,lpszPropName As LPCWSTR , nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT 
Declare  Function   InvokePropPut OverLoad (pDispatch  as IDispatch Ptr,lpszPropName As LPCWSTR , nParamCount As Integer =0,pVarNew As VARIANT Ptr=NULL )As HRESULT 
Declare  Function   InvokeMethod OverLoad (pDispatch as IDispatch Ptr,pVarRes As VARIANT Ptr,lpszMethodName As LPCWSTR, nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT 

 
 
 ' VARIANT + NOM DES  FunctionS EN LPCWSTR
 
Declare  Function   InvokePropPut (ByVal pDispV as VARIANT,sName As LPCWSTR, nParamCount As Integer =1,pParams As VARIANT Ptr=NULL )As HRESULT 
Declare  Function   InvokePropGet (ByVal pDispV as VARIANT,pVarRes As VARIANT Ptr,sName As LPCWSTR , nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT 
Declare  Function   InvokeMethod (ByVal pDispV as VARIANT,pVarRes As VARIANT Ptr,sName As LPCWSTR, nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT 

 
 ' VARIANT + NOM DES  FunctionS EN STRING
 
Declare  Function   InvokePropPut (ByVal pDispV as VARIANT,sName As String,pParams As VARIANT Ptr=NULL,nParamCount As Integer =1 )As HRESULT 
Declare  Function   InvokePropGet (ByVal pDispV as VARIANT,pVarRes As VARIANT Ptr,sName As String,pParams As VARIANT Ptr=NULL  , nParamCount As Integer =0)As HRESULT 
 Declare  Function   InvokePropGet (ByVal pDispV as VARIANT,sName As String,pParams As VARIANT Ptr=NULL  , nParamCount As Integer =0)As VARIANT 
Declare  Function   InvokeMethod (ByVal pDispV as VARIANT,pVarRes As VARIANT Ptr,sName As String,pParams As VARIANT Ptr=NULL, nParamCount As Integer =0 )As HRESULT 
Declare  Function   InvokeMethod (ByVal pDispV as VARIANT,sName As String,pParams As VARIANT Ptr=NULL, nParamCount As Integer =0 )As VARIANT  

 ' IDispatch Ptr + NOM DES FunctionS EN STRING
 
 Declare  Function   InvokePropPut (pDisp as IDispatch Ptr,sName As String,pParams As VARIANT Ptr=NULL , nParamCount As Integer =1 )As HRESULT 
 Declare  Function   InvokePropGet (pDisp as IDispatch Ptr,pVarRes As VARIANT Ptr,sName As String ,pParams As VARIANT Ptr=NULL, nParamCount As Integer =0 )As HRESULT 
 Declare  Function   InvokePropGet (ByVal pDispV as IDispatch Ptr,sName As String,pParams As VARIANT Ptr=NULL  , nParamCount As Integer =0)As VARIANT 
 Declare  Function   InvokeMethod (pDisp as IDispatch Ptr,pVarRes As VARIANT Ptr,sName As String,pParams As VARIANT Ptr=NULL, nParamCount As Integer =0 )As HRESULT 
 Declare  Function   InvokeMethod (ByVal pDispV as IDispatch Ptr,sName As String,pParams As VARIANT Ptr=NULL, nParamCount As Integer =0 )As VARIANT  
 
 
 
 
 
 Function CheckError(hr As HRESULT) As String
	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) 

	CheckError= " : Error(&h" & Hex(hr) & "): "  & *Cast(ZString Ptr,pMsg) 

	LocalFree(pMsg) 
End Function

Sub ShowOleError ( hr As HRESULT, addit As String="")
 Dim serr As String
 If hr=s_ok Then Exit Sub
 	serr=addit & " " & CheckError(hr)
	MessageBox (getactiveWindow(),serr,"OLE ERROR ",MB_ICONERROR Or MB_TASKMODAL)
End Sub


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=TRUE
     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: 
	      ShowOleError(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(ByVal ProgID as String,ByVal ppunk As IUNKNOWN Ptr Ptr) as HRESULT
 
 Dim As IUNKNOWN Ptr  punk  = NULL 
 Dim as HRESULT hr
 
     
      If ComWrapper_oleInitialized=false Then 
   	  oleInitialize(NULL)
   	  ComWrapper_oleInitialized=TRUE
      EndIf

      *ppunk=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 
   	
	   *ppunk = punk  

      Return NOERROR 
	 
errorn: 
	        ShowOleError(hr,"CreateObject(" & ProgID & ")" ) 
	If (punk)  Then 
	  #If Not Defined( _FB_COM_VTBL_)
	       punk->Release()  
	  #Else 
   	    punk->lpvtbl->Release(punk) 
     #EndIf
	EndIf
	
	return hr  

end Function

 Function CreateObject(ByVal ProgID as string) as VARIANT    ' ProgID is progid or clsid string result is variant(iunknown or idispatch)
 Dim As  HRESULT hr   
 Dim As IUNKNOWN Ptr  punk  = NULL 
 
     If ComWrapper_oleInitialized=false Then 
   	  oleInitialize(NULL)
   	  ComWrapper_oleInitialized=TRUE
      EndIf

    
   Dim as VARIANT Vvar 
   VariantInit(@Vvar) 
         
       Dim As  CLSID clsid 
        hr=CLSIDFromProgID(WStr(ProgID), @clsid) 
        If clsid=CLSID_NULL Then hr=CLSIDFromString(WStr(ProgID), @clsid)
        If clsid=CLSID_NULL Then 
        	  	Vvar .vt = VT_ERROR
		      Vvar .scode = -1
		      ShowOleError(hr,"CreateObject(" & ProgID & ")" )
		      Return Vvar 
        EndIf
        hr = CoCreateInstance(@clsid, NULL,CLSCTX_SERVER,@IID_IUNKNOWN, cast(LPVOID Ptr,@punk))
        if(FAILED(hr))then
            ShowOleError(hr,"CreateObject(" & ProgID & ")" )
            Exit Function 
        end if
        #If Not Defined( _FB_COM_VTBL_)
           hr = punk->QueryInterface(@IID_IDispatch, cast(LPVOID Ptr,@Vvar.pdispval))
        #Else 
   	     hr=punk->lpvtbl->QueryInterface(punk,@IID_IDispatch, cast(LPVOID Ptr,@Vvar.pdispval))
        #EndIf 
	     If (FAILED(hr)) Then 
	     	  	Vvar.vt = VT_UNKNOWN
		      Vvar.punkval = punk
		      Return Vvar
	     EndIf
 	     #If Not Defined( _FB_COM_VTBL_)
	         punk->Release() 
	     #Else 
   	      If (punk)  Then punk->lpvtbl->Release(punk) 
        #EndIf
	     
        Vvar.vt = VT_DISPATCH
      return Vvar
end Function
 
 


 Function CreateObject  (ByVal szProgId As String ,ByVal riid As REFIID ,ByVal dwClsContext As DWORD , _
			               ByVal mpServerInfo As COSERVERINFO ptr ,ByVal 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(ByVal szPathName As String ,ByVal szProgId As String ,ByVal riid As REFIID , _
		               ByVal  dwClsContext As DWORD ,ByVal lpvReserved As LPVOID ,ByVal  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 (ByVal szPathName As String ,ByVal  szProgId As String ,ByVal 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  (ByVal szPathName As String="" ,ByVal  szProgId As String ) As IDispatch Ptr
 	Dim pDisp As IDispatch Ptr
 	 GetObjectEx(szPathName, szProgId, @IID_IDispatch,CLSCTX_LOCAL_SERVER Or CLSCTX_INPROC_SERVER, NULL, cast(lpvoid Ptr,@pDisp))
 	 return pDisp
End Function
 
 Function GetObjectV   (ByVal szPathName As String ="",ByVal 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



 
''=======================================================================================
'' Fonctions globales.
''=======================================================================================

 
''***************************************************************************************
'' InvokeGetDISPID :
''***************************************************************************************
 Function InvokeGetDISPID(pDispatch  as IDispatch Ptr,lpszName As LPCWSTR , pdispid as DISPID ptr) As HRESULT 
 
   if (pDispatch=NULL)Then
        MessageBox(NULL, "NULL IDispatch passed", "InvokeGetDISPID()", MB_SETFOREGROUND or MB_ICONHAND)
        return E_UNEXPECTED
    End If
	'' Id associé au nom
	 Dim As HRESULT hr
	 #If Not Defined( _FB_COM_VTBL_)
	    hr = pDispatch->GetIDsOfNames(@IID_NULL,Cast(LPOLESTR PTR,@lpszName), 1,LOCALE_USER_DEFAULT, pdispid) 
	 #Else
	    hr = pDispatch->lpvtbl->GetIDsOfNames(pDispatch,@IID_NULL,Cast(LPOLESTR PTR,@lpszName), 1,LOCALE_USER_DEFAULT, pdispid) 
	 #EndIf
	Dim Buf As ZString*250
	if(FAILED(hr))Then
        ShowOleError(hr,"   in InvokeGetDISPID: " & *lpszName)
        return hr
    End If		                                       
	return hr 
End Function

''***************************************************************************************
'' InvokePropGet :
''***************************************************************************************
 Function InvokePropGet OverLoad (pDispatch as IDispatch Ptr,propid As DISPID ,pVarRes As VARIANT Ptr,nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT 
    Dim buf As ZString*250
   '' paramètres de l'appel à Invoke (ordre des paramètres inversé)
	Dim As VARIANTARG Ptr rgvarg = NULL 
	if(nParamCount > 0)Then
	 
		rgvarg = new VARIANTARG[nParamCount] 
		for   i As Integer= 0  to nParamCount-1   
			rgvarg[i] = pParams[nParamCount-i-1]
		next	
	End If

	'' initialisation structure DISPPARAMS 
	Dim As DISPPARAMS dispparams = (rgvarg, NULL, nParamCount, 0) 

	'' appel de Invoke
	Dim As HRESULT hr = pDispatch->Invoke(propid, @IID_NULL, LOCALE_USER_DEFAULT, _
			DISPATCH_PROPERTYGET, @dispparams, pVarRes, NULL, NULL) 

   if(nParamCount > 0)Then
		for   i As Integer= 0  to nParamCount-1   
			pParams[nParamCount-i-1]=rgvarg[i]  
		next	
	End If   
   '' libération mémoire
	if(nParamCount > 0)Then
		delete[] rgvarg 
	End If	

	'' retour
	return hr 
End Function

''***************************************************************************************
'' InvokePropPut :
''***************************************************************************************
Function InvokePropPut OverLoad (pDispatch  as IDispatch Ptr,propid As DISPID , nParamCount As Integer =0,pVarNew As VARIANT Ptr=NULL )As HRESULT 
  Dim buf As ZString*250
Dim As VARIANTARG Ptr rgvarg = NULL 
	if(nParamCount > 0)Then
	 
		rgvarg = new VARIANTARG[nParamCount] 
		for   i As Integer= 0  to nParamCount-1   
			rgvarg[i] = pVarNew[nParamCount-i-1]
		next	
	End If
	
	
	Dim As DISPID rgdispidNamedArgs(1) 
	rgdispidNamedArgs(0) = DISPID_PROPERTYPUT 

	'' initialisation structure DISPPARAMS 
	Dim As DISPPARAMS dispparams = (rgvarg, @rgdispidNamedArgs(0),nParamCount, 1)

	'' appel de Invoke
	Dim As HRESULT hr
	#If Not Defined( _FB_COM_VTBL_)
	   hr = pDispatch->Invoke(propid, @IID_NULL, LOCALE_USER_DEFAULT, _
			                                DISPATCH_PROPERTYPUT, @dispparams, NULL, NULL, NULL) 
   #Else
      hr= pDispatch->lpvtbl->Invoke(pDispatch,propid, @IID_NULL, LOCALE_USER_DEFAULT, _
			                                DISPATCH_PROPERTYPUT, @dispparams, NULL, NULL, NULL)
   #EndIf
   if(nParamCount > 0)Then
		for   i As Integer= 0  to nParamCount-1   
			pVarNew[nParamCount-i-1]=rgvarg[i]  
		next	
	End If
 '' libération mémoire
	if(nParamCount > 0)Then
		delete[] rgvarg 
	End If	

	'' retour
	return hr 
End Function

''***************************************************************************************
'' InvokeMethod :
''***************************************************************************************
Function InvokeMethod OverLoad (pDispatch as IDispatch Ptr,pVarRes As VARIANT Ptr,methodid As DISPID, nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT 
   
	'' paramètres de l'appel à Invoke (ordre des paramètres inversé)
	Dim As VARIANTARG Ptr rgvarg = NULL 
	if(nParamCount > 0)Then
	 	rgvarg = new VARIANTARG[nParamCount] 
		for   i As Integer= 0  to nParamCount-1   
			rgvarg[i] = pParams[nParamCount-i-1]
		next	
	End If

	'' initialisation structure DISPPARAMS 
	Dim As DISPPARAMS dispparams = (rgvarg, NULL, nParamCount, 0) 

	'' appel de Invoke
	Dim As HRESULT hr
	#If Not Defined( _FB_COM_VTBL_)
	   hr = pDispatch->Invoke(methodid, @IID_NULL, LOCALE_USER_DEFAULT, _
			                    DISPATCH_METHOD, @dispparams, pVarRes, NULL, NULL) 
   #Else
      hr = pDispatch->lpvtbl->Invoke(pDispatch,methodid, @IID_NULL, LOCALE_USER_DEFAULT, _
			                            DISPATCH_METHOD, @dispparams, pVarRes, NULL, NULL)
   #EndIf
	
	if(nParamCount > 0)Then
		for   i As Integer= 0  to nParamCount-1   
			pParams[nParamCount-i-1]=rgvarg[i]  
		next	
	End If
	'' libération mémoire
	if(nParamCount > 0)Then
		delete[] rgvarg 
	End If	
	'' retour
	return hr 
 End FUNCTION


''***************************************************************************************
'' InvokePropGet :
''***************************************************************************************
Function InvokePropGet OverLoad (pDispatch as IDispatch Ptr,pVarRes As VARIANT Ptr,lpszPropName As LPCWSTR , nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT 
	Dim buf As ZString*250
	'' Id de la propriété
	Dim As DISPID propid 
	Dim As HRESULT hr
	#If Not Defined( _FB_COM_VTBL_) 
	    hr = pDispatch->GetIDsOfNames(@IID_NULL, cast(LPOLESTR PTR,@lpszPropName), 1,LOCALE_USER_DEFAULT, @propid) 
   #Else
      hr = pDispatch->lpvtbl->GetIDsOfNames(pDispatch,@IID_NULL, cast(LPOLESTR PTR,@lpszPropName), 1,LOCALE_USER_DEFAULT, @propid) 
   #EndIf
 
	'' récupération en cas de réussite
	if(SUCCEEDED(hr))Then hr = InvokePropGet(pDispatch,propid,pVarRes,nParamCount,pParams) 
	
	if (FAILED(hr))Then
        ShowOleError(hr,"   in InvokePropGet: " & *lpszPropName)
	End If 
	
	return hr 
End Function

''***************************************************************************************
'' InvokePropPut :
''***************************************************************************************
Function InvokePropPut OverLoad (pDispatch  as IDispatch Ptr,lpszPropName As LPCWSTR , nParamCount As Integer =0,pVarNew As VARIANT Ptr=NULL )As HRESULT 
  Dim buf As ZString*250
 
	'' Id de la propriété
	Dim As DISPID propid 
	Dim As HRESULT hr
	#If Not Defined( _FB_COM_VTBL_) 
	   hr = pDispatch->GetIDsOfNames(@IID_NULL, cast(LPOLESTR PTR,@lpszPropName), 1, LOCALE_USER_DEFAULT, @propid) 
   #Else
      hr = pDispatch->lpvtbl->GetIDsOfNames(pDispatch,@IID_NULL, cast(LPOLESTR PTR,@lpszPropName), 1, LOCALE_USER_DEFAULT, @propid) 
   #EndIf
	'' affectation en cas de réussite
	if(SUCCEEDED(hr))Then hr = InvokePropPut(pDispatch ,propid , nParamCount ,pVarNew )
	
	if (FAILED(hr))Then
       ShowOleError(hr,"   in InvokePropPut: " & *lpszPropName)
	End If 
	
	return hr 
End Function

''***************************************************************************************
'' InvokeMethod :
''***************************************************************************************
Function InvokeMethod OverLoad (pDispatch as IDispatch Ptr,pVarRes As VARIANT Ptr,lpszMethodName As LPCWSTR, nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT 
  Dim buf As ZString*250
 
	'' Id de la méthode
	Dim As DISPID methodid 
	Dim As HRESULT hr
	#If Not Defined( _FB_COM_VTBL_) 
	    hr = pDispatch->GetIDsOfNames(@IID_NULL, cast(LPOLESTR PTR,@lpszMethodName), 1,LOCALE_USER_DEFAULT, @methodid) 
   #Else
       hr = pDispatch->lpvtbl->GetIDsOfNames(pDispatch,@IID_NULL, cast(LPOLESTR PTR,@lpszMethodName), 1,LOCALE_USER_DEFAULT, @methodid) 
   #EndIf
   
	'' appel en cas de réussite
	if(SUCCEEDED(hr)) Then	hr = InvokeMethod (pDispatch ,pVarRes ,methodid, nParamCount ,pParams ) 
	
	if (FAILED(hr))Then
        		ShowOleError(hr,"   in InvokeMethod: " & *lpszMethodName)
    End If 
	return hr 
End Function


 
 
 ' VARIANT + NOM DES FUNCTIONS EN LPCWSTR
 
Function InvokePropPut (ByVal pDispV as VARIANT,sName As LPCWSTR, nParamCount As Integer =1,pParams As VARIANT Ptr=NULL )As HRESULT 
	Return InvokePropPut (pDispV.pdispval,sName,nParamCount, pParams)
End Function

Function InvokePropGet (ByVal pDispV as VARIANT,pVarRes As VARIANT Ptr,sName As LPCWSTR , nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT 
	Return InvokePropGet (pDispV.pdispval,pVarRes,sName,nParamCount, pParams)
End Function
 
Function InvokeMethod (ByVal pDispV as VARIANT,pVarRes As VARIANT Ptr,sName As LPCWSTR, nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT 
	Return InvokeMethod(pDispV.pdispval,pVarRes,sName,nParamCount, pParams)
End Function
 
 
 ' VARIANT + NOM DES FUNCTIONS EN STRING
 
Function InvokePropPut (ByVal pDispV as VARIANT,sName As String,pParams As VARIANT Ptr=NULL,nParamCount As Integer =1 )As HRESULT 
	Return InvokePropPut (pDispV.pdispval,OLESTR(sName),nParamCount, pParams)
End Function

Function InvokePropGet (ByVal pDispV as VARIANT,pVarRes As VARIANT Ptr,sName As String,pParams As VARIANT Ptr=NULL  , nParamCount As Integer =0)As HRESULT 
	Return InvokePropGet (pDispV.pdispval,pVarRes,OLESTR(sName),nParamCount, pParams)
End Function
 
 Function InvokePropGet (ByVal pDispV as VARIANT,sName As String,pParams As VARIANT Ptr=NULL  , nParamCount As Integer =0)As VARIANT 
	dim  VarRes As VARIANT 
	variantInit(@VarRes) 
	Dim As HRESULT hr=InvokePropGet(pDispV,@VarRes, sName, pParams,nParamCount)
	If hr=s_ok Then
		Return VarRes
	Else
		VarRes.vt = VT_ERROR
		VarRes.scode = -1
		return VarRes
	EndIf
End Function
 	
Function InvokeMethod (ByVal pDispV as VARIANT,pVarRes As VARIANT Ptr,sName As String,pParams As VARIANT Ptr=NULL, nParamCount As Integer =0 )As HRESULT 
	Return InvokeMethod(pDispV.pdispval,pVarRes,OLESTR(sName),nParamCount, pParams)
End Function
 
Function InvokeMethod (ByVal pDispV as VARIANT,sName As String,pParams As VARIANT Ptr=NULL, nParamCount As Integer =0 )As VARIANT  
	dim  VarRes As VARIANT 
	variantInit(@VarRes) 
	Dim As HRESULT hr=InvokeMethod(pDispV,@VarRes,sName, pParams,nParamCount)
	If hr=s_ok Then
		Return VarRes
	Else
		VarRes.vt = VT_ERROR
		VarRes.scode = -1
		return VarRes
	EndIf
End Function

 ' IDispatch Ptr + NOM DES FUNCTIONS EN STRING
 
 Function InvokePropPut (pDisp as IDispatch Ptr,sName As String,pParams As VARIANT Ptr=NULL , nParamCount As Integer =1 )As HRESULT 
	Return InvokePropPut( pDisp,OLESTR(sName),nParamCount, pParams)
End Function


Function InvokePropGet (pDisp as IDispatch Ptr,pVarRes As VARIANT Ptr,sName As String ,pParams As VARIANT Ptr=NULL, nParamCount As Integer =0 )As HRESULT 
	Return InvokePropGet( pDisp,pVarRes, OLESTR(sName), nParamCount, pParams)
End Function
 
 Function InvokePropGet (ByVal pDispV as IDispatch Ptr,sName As String,pParams As VARIANT Ptr=NULL  , nParamCount As Integer =0)As VARIANT 
	dim  VarRes As VARIANT 
	Dim As HRESULT hr=InvokePropGet (pDispV,@VarRes,sName,pParams,nParamCount)
	If hr=s_ok Then
		Return VarRes
	Else
		VarRes.vt = VT_ERROR
		VarRes.scode = -1
		return VarRes
	EndIf
 End Function
 
Function InvokeMethod (pDisp as IDispatch Ptr,pVarRes As VARIANT Ptr,sName As String,pParams As VARIANT Ptr=NULL, nParamCount As Integer =0 )As HRESULT 
	Return InvokeMethod (pDisp, pVarRes, OLESTR(sName),nParamCount,pParams )
End Function

Function InvokeMethod (ByVal pDispV as IDispatch Ptr,sName As String,pParams As VARIANT Ptr=NULL, nParamCount As Integer =0 )As VARIANT  
	dim  VarRes As VARIANT 
	variantInit(@VarRes) 
	Dim As HRESULT hr=InvokeMethod(pDispV,@VarRes,sName, pParams,nParamCount)
	If hr=s_ok Then
		Return VarRes
	Else
		VarRes.vt = VT_ERROR
		VarRes.scode = -1
		return VarRes
	EndIf
End Function


#EndIf
aloberoger
Posts: 507
Joined: Jan 13, 2009 19:23

Re: INSIDE ACTIVEX WITH FREEBASIC

Post by aloberoger »

Comobjects.bi

Code: Select all

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

Common Shared ComWrapper_oleInitialized As BOOL

#Inclib "comObjects"


 

'Declare(s) for  "variants.bi"
DECLARE Function StrToBSTR(ByVal cnv_string As String) AS BSTR
DECLARE Function Variantvt(ByRef v As variant) AS VARTYPE
DECLARE Function SafeArrayIsCreated(Mat As SAFEARRAY Ptr) AS INTEGER
DECLARE Function SafearrayVartype(ByVal P As SAFEARRAY Ptr) AS VARTYPE
Declare Sub safearrayofRecord(tlbfileName As String,iidRec As REFIID,rgbounds As SAFEARRAYBOUND) 


Declare Function Variantv(ByRef v As variant)As Double   'return numeric value from variant
Declare Function Variants(ByRef v As variant)As String   'return string value from variant
Declare Function Variantb(ByRef v As variant)As bstr     'return bstr value from variant


Declare Sub ArrayToSafeArray OverLoad (ByRef P As SAFEARRAY Ptr,A() As Double)
Declare Sub ArrayToSafeArray  (ByRef P As SAFEARRAY Ptr,A() As Single)
Declare Sub ArrayToSafeArray  (ByRef P As SAFEARRAY Ptr,A() As LONG)
Declare Sub ArrayToSafeArray  (ByRef P As SAFEARRAY Ptr,A() As Short)
Declare Sub ArrayToSafeArray  (ByRef P As SAFEARRAY Ptr,A() As Integer)
Declare Sub ArrayToSafeArray  (ByRef P As SAFEARRAY Ptr,A() As String)
Declare Sub ArrayToSafeArray  (ByRef P As SAFEARRAY Ptr,A() As BSTR)
Declare Sub ArrayToSafeArray  (ByRef P As SAFEARRAY Ptr,A() As VARIANT)
Declare Sub ArrayToSafeArray  (ByRef P As SAFEARRAY Ptr,A() As IDISPATCH Ptr)
Declare Sub ArrayToSafeArray  (ByRef P As SAFEARRAY Ptr,A() As IUNKNOWN Ptr)
Declare Sub ArrayToSafeArray  (ByRef P As SAFEARRAY Ptr,A() As Any Ptr)


Declare Function ArrayToSafeArray (A() As Double)As SAFEARRAY Ptr
Declare Function ArrayToSafeArray (A() As Single)As SAFEARRAY Ptr
Declare Function ArrayToSafeArray (A() As Short)As SAFEARRAY Ptr
Declare Function ArrayToSafeArray (A() As Integer)As SAFEARRAY Ptr
Declare Function ArrayToSafeArray (A() As Long)As SAFEARRAY Ptr
Declare Function ArrayToSafeArray (A() As BSTR)As SAFEARRAY Ptr
Declare Function ArrayToSafeArray (A() As String)As SAFEARRAY Ptr
Declare Function ArrayToSafeArray (A() As VARIANT)As SAFEARRAY Ptr
Declare Function ArrayToSafeArray (A() As IDISPATCH Ptr)As SAFEARRAY Ptr
Declare Function ArrayToSafeArray (A() As IUNKNOWN Ptr)As SAFEARRAY Ptr
Declare Function ArrayToSafeArray (A() As Any Ptr)As SAFEARRAY Ptr	 




Declare Sub SafeArrayToArray OverLoad ( A()As Double,P  As SAFEARRAY Ptr)
Declare Sub SafeArrayToArray  ( A() As Single,P  As SAFEARRAY Ptr)
Declare Sub SafeArrayToArray  ( A() As BSTR,P  As SAFEARRAY Ptr)
Declare Sub SafeArrayToArray  ( A() As STRING,P  As SAFEARRAY Ptr)
Declare Sub SafeArrayToArray  ( A() As Long,P  As SAFEARRAY Ptr)
Declare Sub SafeArrayToArray  ( A() As Integer,P  As SAFEARRAY Ptr)
Declare Sub SafeArrayToArray  ( A() As Short,P  As SAFEARRAY Ptr)
Declare Sub SafeArrayToArray  ( A() As VARIANT,P  As SAFEARRAY Ptr)
Declare Sub SafeArrayToArray  ( A() As IDISPATCH Ptr,P  As SAFEARRAY Ptr)
Declare Sub SafeArrayToArray  ( A() As IUNKNOWN Ptr,P  As SAFEARRAY Ptr)
Declare Sub SafeArrayToArray  ( A() As Any Ptr,P  As SAFEARRAY Ptr)

 

Declare Function ArrayToVariant OverLoad (A() As Double)As VARIANT
Declare Function ArrayToVariant(A() As Single)As VARIANT
Declare Function ArrayToVariant(A() As BSTR)As VARIANT
Declare Function ArrayToVariant(A() As Long)As VARIANT
Declare Function ArrayToVariant(A() As Integer)As VARIANT
Declare Function ArrayToVariant(A() As Short)As VARIANT
Declare Function ArrayToVariantB(A() As BOOL)As VARIANT
Declare Function ArrayToVariant(A() As Any Ptr)As VARIANT
Declare Function ArrayToVariant(A() As String)As VARIANT
Declare Function ArrayToVariant(A() As IDISPATCH Ptr)As VARIANT
Declare Function ArrayToVariant(A() As IUNKNOWN Ptr)As VARIANT


Declare Sub ArrayToVariant OverLoad (ByVal pVariant  As VARIANT  Ptr ,M() As Double)
Declare Sub      ArrayToVariant (ByVal pVariant As VARIANT Ptr , A() As Single)
Declare Sub      ArrayToVariant (ByVal pVariant As VARIANT Ptr , A() As Long)
Declare Sub      ArrayToVariant (ByVal pVariant As VARIANT Ptr , A() As Integer)
Declare Sub      ArrayToVariant (ByVal pVariant As VARIANT Ptr , A() As short)
Declare Sub      ArrayToVariant (ByVal pVariant As VARIANT Ptr , A() As String)
Declare Sub      ArrayToVariant (ByVal pVariant As VARIANT Ptr , A() As Any Ptr)
Declare Sub      ArrayToVariant (ByVal pVariant As VARIANT Ptr , A() As IDISPATCH Ptr)
Declare Sub      ArrayToVariant (ByVal pVariant As VARIANT Ptr , A() As IUNKNOWN Ptr)

Declare Sub VariantToArray OverLoad(M() As Double,ByVal V As VARIANT)
Declare Sub      VariantToArray(M() As Single,ByVal V As VARIANT)
Declare Sub      VariantToArray(M() As Long,ByVal V As VARIANT)
Declare Sub      VariantToArray(M() As Integer,ByVal V As VARIANT)
Declare Sub      VariantToArray(M() As Short,ByVal V As VARIANT)
Declare Sub      VariantToArray (M() As BSTR,ByVal v As VARIANT )
Declare Sub      VariantToArray(M() As String,ByVal v As VARIANT )
Declare Sub      VariantToArray(M() As Any Ptr,ByVal v As VARIANT )
Declare Sub      VariantToArray(M() As IDISPATCH Ptr,ByVal v As VARIANT )
Declare Sub      VariantToArray(M() As IUNKNOWN Ptr,ByVal v As VARIANT )
 
 
Declare Sub       VariantToSafeArray OverLoad (ByVal V As VARIANT ,ByRef P As SAFEARRAY ptr)
Declare Function  VariantToSafeArray          (ByVal V As VARIANT) As SAFEARRAY ptr 
Declare Function  SafeArrayToVariant OverLoad (ByVal P As SAFEARRAY Ptr)As VARIANT
Declare Sub       SafeArrayToVariant  (ByVal V As VARIANT Ptr,ByVal P As SAFEARRAY Ptr)


Declare function VarArrayCreate(Bounds()As Integer,AVarType As  VARTYPE)As VARIANT
Declare function VarArrayDimCount(ByVal A As Variant)As Integer
Declare Sub      VarArrayRedim(ByRef A As Variant, HighBound As Integer)
Declare Function VarArrayLowBound(ByVal  A as Variant, iDim as Integer)As Integer
Declare function VarArrayHighBound(ByVal A As Variant, iDim As  Integer)as Integer
Declare function VarArrayLock(ByVal A As Variant) As Any Ptr
Declare Sub      VarArrayUnlock(ByVal A as Variant)
 


DECLARE Function StrToVariant(s As String) AS VARIANT

DECLARE Function ToVariant OverLoad (s As String)As VARIANT
DECLARE Function  ToVariant  (BYVAL value AS Short) AS VARIANT
DECLARE Function  ToVariant   (BYVAL value AS Integer) AS VARIANT
DECLARE Function  ToVariant   (BYVAL value AS Long) AS VARIANT
DECLARE Function  ToVariant (BYVAL value AS Single) AS VARIANT
DECLARE Function  ToVariant (BYVAL value AS Double) AS VARIANT
DECLARE Function  ToVariant (BYVAL value AS BSTR) AS VARIANT
DECLARE Function  ToVariant   (BYVAL value AS SAFEARRAY Ptr) AS VARIANT
DECLARE Function  ToVariant(BYVAL value AS LPDISPATCH) AS VARIANT
DECLARE Function  ToVariant(BYVAL value AS IUnknown Ptr) AS VARIANT
DECLARE Function  ToVariant(BYVAL value AS  CY) AS VARIANT

  
 
DECLARE Function VariantToShort OverLoad (BYVAL value AS VARIANT) AS SHORT
DECLARE Function VariantToInteger OverLoad (BYVAL value AS VARIANT) AS INTEGER
DECLARE Function VariantToLong (BYVAL value AS VARIANT) AS LONG
DECLARE Function VariantToSingle(BYVAL value AS VARIANT) AS SINGLE
DECLARE Function VariantToDouble(BYVAL value AS VARIANT) AS DOUBLE
DECLARE Function VariantToBstr(BYVAL value AS VARIANT) AS BSTR
DECLARE Function VariantToarray (BYVAL value AS VARIANT) AS SAFEARRAY PTR
DECLARE Function VariantToDispatch (BYVAL value AS VARIANT) AS LPDISPATCH
DECLARE Function VariantToUnknown (BYVAL value AS VARIANT) AS LPUNKNOWN
DECLARE Function VariantTodate (BYVAL value AS VARIANT) AS DATE_
DECLARE Function VariantTocy (BYVAL value AS VARIANT) AS CY
DECLARE Function VariantToBool (BYVAL value AS VARIANT) AS VARIANT_BOOL

Declare Function PrintMatrix OverLoad (ByVal Title AS STRING, A() AS DOUBLE) As String
Declare Function PrintMatrix (ByVal Title AS STRING, A() AS Double, col1 As Integer,col2 As Integer)As String
Declare Function PrintVector(ByVal Title AS STRING, B() AS Double,outlineorcol As Integer=0) As String

Declare Function RoundFloat( Byval d As Double, Byval p As Integer ) As Double
 
Declare Function Matrix_ToStr OverLoad (ByVal Title AS STRING, A() AS DOUBLE)As String
Declare Function Matrix_ToStr (ByVal Title AS STRING, A() AS Double, col1 As Integer,col2 As Integer)As String
Declare Function Vector_ToStr(ByVal Title AS STRING, B() AS Double,outlineorCol As Integer)As String

 


'Declare(s) for  "InvokeEx.bas"

 DECLARE Function InvokeGetDISPID(pDispatch As IDispatch Ptr,lpszName As LPCWSTR , pdispid as DISPID ptr) As HRESULT 
 DECLARE Function InvokePropGet OverLoad (pDispatch as IDispatch Ptr,propid As DISPID ,pVarRes As VARIANT Ptr,nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT 
 DECLARE Function InvokePropPut OverLoad (pDispatch As IDispatch Ptr,propid As DISPID , nParamCount As Integer =1,pVarNew As VARIANT Ptr=NULL )As HRESULT 
 DECLARE Function InvokeMethod OverLoad (pDispatch  As IDispatch Ptr,pVarRes As VARIANT Ptr,methodid As DISPID, nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT 
 
 ' IDispatch Ptr + NOM DES FUNCTIONS EN LPCWSTR
 Declare Function InvokePropPut OverLoad (pDispatch As IDispatch Ptr,lpszPropName As LPCWSTR , nParamCount As Integer =1,pVarNew As VARIANT Ptr=NULL )As HRESULT 
 DECLARE Function InvokePropGet OverLoad (pDispatch as IDispatch Ptr,pVarRes As VARIANT Ptr,lpszPropName As LPCWSTR , nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT 
 DECLARE Function InvokeMethod OverLoad (pDispatch as IDispatch Ptr,pVarRes As VARIANT Ptr,lpszMethodName As LPCWSTR, nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT 

 
 ' VARIANT + NOM DES FUNCTIONS EN LPCWSTR
 
DECLARE Function InvokePropPut (ByVal pDispV as VARIANT,sName As LPCWSTR, nParamCount As Integer =1,pParams As VARIANT Ptr=NULL )As HRESULT 
DECLARE Function InvokePropGet (ByVal pDispV as VARIANT,pVarRes As VARIANT Ptr,sName As LPCWSTR , nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT 
DECLARE Function InvokeMethod (ByVal pDispV as VARIANT,pVarRes As VARIANT Ptr,sName As LPCWSTR, nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT 
 
 ' VARIANT + NOM DES FUNCTIONS EN STRING
 
DECLARE Function InvokePropPut (ByVal pDispV as VARIANT,sName As String,pParams As VARIANT Ptr=NULL,nParamCount As Integer =1 )As HRESULT 
DECLARE Function InvokePropGet (ByVal pDispV as VARIANT,pVarRes As VARIANT Ptr,sName As String,pParams As VARIANT Ptr=NULL  , nParamCount As Integer =0)As HRESULT 
DECLARE Function InvokePropGet (ByVal pDispV as VARIANT,sName As String,pParams As VARIANT Ptr=NULL  , nParamCount As Integer =0)As VARIANT 
DECLARE Function InvokeMethod (ByVal pDispV as VARIANT,pVarRes As VARIANT Ptr,sName As String,pParams As VARIANT Ptr=NULL, nParamCount As Integer =0 )As HRESULT 
DECLARE Function InvokeMethod (ByVal pDispV as VARIANT,sName As String,pParams As VARIANT Ptr=NULL, nParamCount As Integer =0 )As VARIANT  

 ' IDispatch Ptr + NOM DES FUNCTIONS EN STRING
 
 Declare  Function InvokePropPut (pDisp as IDispatch Ptr,sName As String,pParams As VARIANT Ptr=NULL , nParamCount As Integer =1 )As HRESULT 
 DECLARE Function InvokePropGet (pDisp as IDispatch Ptr,pVarRes As VARIANT Ptr,sName As String ,pParams As VARIANT Ptr=NULL, nParamCount As Integer =0 )As HRESULT 
 DECLARE Function InvokePropGet (ByVal pDispV as IDispatch Ptr,sName As String,pParams As VARIANT Ptr=NULL  , nParamCount As Integer =0)As VARIANT 
 DECLARE Function InvokeMethod (pDisp as IDispatch Ptr,pVarRes As VARIANT Ptr,sName As String,pParams As VARIANT Ptr=NULL, nParamCount As Integer =0 )As HRESULT 
 DECLARE Function InvokeMethod (ByVal pDispV as IDispatch Ptr,sName As String,pParams As VARIANT Ptr=NULL, nParamCount As Integer =0 )As VARIANT  




'Declare(s) for  "ComWrapper.bas"

DECLARE Function CheckError(hr As HRESULT) As String
DECLARE Sub      ShowOleError OverLoad  ( hr As HRESULT, addit As String="")
DECLARE Function BstrToStr(ByVal mbStr As BSTR)As String 
DECLARE Function GUIDTXT(uuid AS UUID PTR) AS String
DECLARE Function BGUIDTXT (uuid AS UUID PTR) AS String
DECLARE Function StringToGUID(S As String)as GUID               ' Convert a string to a GUID 
DECLARE Function GUIDToString( ClassID As GUID) As string       ' Convert a GUID to a string 
DECLARE Function ProgIDToClassID( ProgID As Const String)As GUID     ' Convert a programmatic ID to a class ID 
DECLARE Function ClassIDToProgID OverLoad (ClassID As GUID)As string ' Convert a class ID to a programmatic ID '
DECLARE Function ClassIDToProgID (sClassID As String)As string 
DECLARE Sub      CLSIDtoString( clsid As GUID , szCLSID As ZString Ptr,length As Integer )    ' Convert a CLSID to a char string.
DECLARE Function CreateClassID() As string 
DECLARE Function GetActiveOleObject(ClassName As const string)As IDispatch Ptr
DECLARE Function CreateComObject OverLoad(strClassID As String)as IUnknown Ptr
DECLARE Function CreateComObject(ClassID as GUID)as IUnknown Ptr
DECLARE Function CreateOleObject (progIDName As const String)As IDispatch Ptr 
DECLARE Function CreateObject OverLoad (ByVal ProgID as String,ByVal ppdisp As IDISPATCH Ptr Ptr) as HRESULT   ' ProgID is progid or clsid string
DECLARE Function CreateObject(ByVal ProgID as String,ByVal ppunk As IUNKNOWN Ptr Ptr) as HRESULT               ' ProgID is progid or clsid string
DECLARE Function CreateObject(ByVal ProgID as string) as VARIANT                                    ' ProgID is progid or clsid string result is variant(iunknown or idispatch)
DECLARE Function CreateRemoteObject(szProgId As LPCOLESTR ,riid As REFIID , dwClsContext As DWORD , _
			                                       pServerInfo as COSERVERINFO Ptr ) As pvoid Ptr
 
DECLARE Function  CreateObject(szProgId As LPCOLESTR ,szMachine As LPCWSTR=NULL ) As IDispatch  Ptr 
DECLARE Function  CreateObjectEx(szProgId As String ,szMachine As string="" ) As IDispatch  Ptr 

'dans InvokeEx

Declare Function CreateObject  (ByVal szProgId As String ,ByVal riid As REFIID ,ByVal dwClsContext As DWORD , _
			                       ByVal mpServerInfo As COSERVERINFO ptr ,ByVal ppv as lpvoid Ptr ) As HRESULT
Declare  Function GetObjectEx(ByVal szPathName As String ,ByVal szProgId As String ,ByVal riid As REFIID , _
		                        ByVal  dwClsContext As DWORD ,ByVal lpvReserved As LPVOID ,ByVal  ppv As LPVOID Ptr) As HRESULT

Declare Function _GetObject OverLoad (ByVal szPathName As String ,ByVal  szProgId As String ,ByVal ppDisp As IDispatch Ptr ptr ) As HRESULT
Declare Function _GetObject  (ByVal szPathName As String="" ,ByVal  szProgId As String ) As IDispatch Ptr
Declare Function  GetObjectv (ByVal szPathName As String ="",ByVal szProgId As String) As VARIANT
 
Declare Function ComDllGetClassObject OverLoad (Byval hdll As HINSTANCE,Byval CLSIDS As String,Byval IIDS As String,ByVal pObj As PVOID Ptr) As HRESULT
Declare Function ComDllGetClassObject OverLoad (Byval hdll As HINSTANCE,Byval rclsid As REFCLSID,Byval riid As REFIID,ByVal pObj As PVOID Ptr) As HRESULT




Declare Function ShowProperty (ByVal punk as LPVOID , ByVal title as ZSTRING PTR) As HRESULT

' ========================================================================================
' Creates a standard IFont object
' ========================================================================================
Declare Function OleCreateFont OverLoad ( ByVal szFontName AS STRING , _           
                         ByVal cySize AS float,ByVal fWeight AS INTEGER, _     
                         ByVal fCharset AS INTEGER, BYVAL fItalic AS LONG, _      
                         ByVal fUnderline AS LONG,BYVAL fStrikethrough AS LONG, ByVal pFont AS IFont Ptr PTR) AS HRESULT  
 
' ========================================================================================
' Creates a standard IFontDisp object
' ========================================================================================
Declare Function OleCreateFontDisp OverLoad(BYVAL szFontName AS STRING,ByVal cySize AS float=10, _      
                            ByVal fWeight AS Short=FW_NORMAL,BYVAL fCharset AS Short=FALSE,BYVAL fItalic AS LONG=FALSE, BYVAL fUnderline AS Long=FALSE, _    
                            ByVal fStrikethrough AS LONG=FALSE,ByVal pFont AS IFontDisp Ptr Ptr ) AS HRESULT   
 

Declare Function OleCreateFontDisp (BYVAL szFontName AS STRING,ByVal cySize AS float=10, _    
                            ByVal fWeight AS Short=FW_NORMAL,BYVAL fCharset AS Short=FALSE,BYVAL fItalic AS LONG=FALSE, BYVAL fUnderline AS Long=FALSE, _    
                            ByVal fStrikethrough AS LONG=FALSE) AS IFontDisp Ptr 
 
 
Declare Function OleCreatePicture (ByVal hPicHandle AS HANDLE, _     
                           ByVal picType AS UINT, _          
                           ByVal fOwn AS INTEGER, _          
                           ByVAL pPicture AS IPicture Ptr Ptr _   
                           ) AS HRESULT                            ' Creates a standard IPicture object.

Declare Function LoadPictureFile(ByVal szFile As String)AS LPPICTURE
Declare Function LoadPictureRes(ByVal hInst As HINSTANCE ,ByVal resID As Integer)AS LPPICTURE ' This function loads rc into an IStream.

Declare Function OleCreatePictureDisp overload (ByVal hPicHandle AS HANDLE, _        
                               ByVal picType AS UINT, _             
                               ByVal fOwn AS INTEGER, _              
                               ByVAL pPicture AS IPictureDisp Ptr PTR  _ 
                               ) AS HRESULT                                    ' Creates a standard IPictureDisp object.

Declare Function OleCreatePictureDisp (ByVal hPicHandle AS HANDLE, _ 
                               ByVal picType AS UINT, _    
                               ByVal fOwn AS INTEGER) As IPictureDisp Ptr 

' ****************************************************************************************
' Creates an  instance of a visual control (OCX), and a window and attaches the instance to the window.
' StrProgID can be the ProgID or the ClsID.
' return the handle of the window created.
' ****************************************************************************************
Declare Function  CreateOcxControl  (BYVAL strProgID AS STRING,hWndparent AS HWND,ByVal id As Integer,  _
	              ByVal ileft As Integer=0,ByVal itop As Integer=0,ByVal iwidth As Integer=0,ByVal iheight As Integer=0, _
	              ByVal istyle As Integer=WS_VISIBLE And WS_CHILD,ByVal istyleex As Integer=WS_EX_CLIENTEDGE)  AS HWND

Declare Function CreateControlLic (BYVAL strProgID AS STRING, BYVAL bstrLicKey AS BSTR) AS IDispatch ptr

' ****************************************************************************************
' Creates a licensed instance of a visual control (OCX) and attaches it to a window.
' StrProgID can be the ProgID or the ClsID. If you pass a version dependent ProgID or a ClsID,
' it will work only with this particular version.
' hWndControl is the handle of the window and strLicKey the license key.
' ****************************************************************************************
Declare Function AtlCreateControlLic (BYVAL strProgID AS STRING, BYVAL hWndControl AS HWND, BYVAL strLicKey AS STRING) AS HRESULT
 

' ****************************************************************************************
' Retrieves the interface of the ActiveX control given the handle of its ATL container
' ****************************************************************************************
Declare Function AtlAxGetDispatch OverLoad (BYVAL hWndControl AS HWND, ByVal ppdisp AS IDispatch Ptr Ptr) AS HRESULT
Declare Function AtlAxGetDispatch OverLoad (BYVAL hWndControl AS HWND, ByVal ppunk AS IUNKNOWN Ptr Ptr) AS HRESULT
Declare Function AtlAxGetDispatch OverLoad (BYVAL hWndControl AS HWND) AS IDISPATCH Ptr
 


#Macro CREATE_INTERFACE(C,I)
FUNCTION Create_##I () As I Ptr
dim hr As HRESULT
       If ComWrapper_oleInitialized=false Then 
   	  oleInitialize(NULL)
   	  ComWrapper_oleInitialized=TRUE
      EndIf
Dim pobj As IDISPATCH Ptr
Dim As IUNKNOWN Ptr  punk  = NULL 
  hr=CoCreateInstance(@CLSID_##C, NULL,CLSCTX_ALL, @IID_IUNKNOWN, cast(LPVOID Ptr,@punk))
if hr=S_OK then 
   hr = punk->QueryInterface(@IID_IDISPATCH, cast(LPVOID Ptr,@pobj))
   if hr=S_OK then 
     punk->Release()
     Return Cast(I Ptr,pobj)
   Else
     Return Cast(I Ptr,punk)	
   EndIf	
else
   MessageBox NULL,"Error number hr=" & hr,"Can't create " & ##I ,0
   Return NULL
END IF
END Function
#EndMacro
 
#Define INTERFACE_NEW(C,I) Create_##I

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

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

source code of the library
http://www.2shared.com/file/wrQXkGRb/Co ... s_lib.html
aloberoger
Posts: 507
Joined: Jan 13, 2009 19:23

Re: INSIDE ACTIVEX WITH FREEBASIC

Post by aloberoger »

marpon
the list of files already modified is:

Code: Select all

1-amaudio.bi
  amvideo.bi
  comcat.bi
  control.bi
  ddraw.bi
  dimm.bi
  dinput.bi
  disphelper.bi
  dmplugin.bi
  dmusicc.bi
  dmusici.bi
  dmusics.bi
  docobj.bi
  dpaddr.bi
  dplay.bi
  dplay8.bi
  dsound.bi
  exdisp.bi
  guiddef.bi
  intchcut.bi
  mshtmhst.bi
  oaidl.bi
  objidl.bi
  objidlbase.bi
  objsafe.bi
  ocidl.bi
  ole.bi
  ole2.bi
  oleacc.bi
  oledlg.bi
  oleidl.bi
  portabledeviceconnectapi.bi
  propidl.bi
  richole.bi
  rpcde.bi     with #inclib "rpcrt4"
  servprov.bi
  shlwapi.bi
  strmif.bi
 structuredquerycondition
  unknwnbase.bi
  vfw.bi
I mislaid the list which I had on file, on the manual list I have 52 already modified files
izero
Posts: 8
Joined: Feb 26, 2008 16:03

Re: INSIDE ACTIVEX WITH FREEBASIC

Post by izero »

aloberoger wrote:Comobjects.bi
source code of the library
http://www.2shared.com/file/wrQXkGRb/Co ... s_lib.html
Hi ... link not working anymore, can you upload it again? Thanks.
aloberoger
Posts: 507
Joined: Jan 13, 2009 19:23

Re: INSIDE ACTIVEX WITH FREEBASIC

Post by aloberoger »

Code: Select all

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

 
#Ifndef __COMVARIANT_INC__
#Define __COMVARIANT_INC__


   'NOTE: VARIANT_BOLL must be contruct normally like variant  example: dim v as COMVARIANT:v.vt=VT_BOOL: v.boolval=-1



#Ifndef __WIDESTRING_INC__

Function BstrWriteToStream(m_bstr As BSTR,pStream As IStream Ptr ) As HRESULT
		Assert(pStream <> NULL)
		Dim As ULong cb
		Dim As ULong cbStrLen =IIf( m_bstr , SysStringByteLen(m_bstr)+sizeof(OLECHAR) , 0)
		#If Not Defined( _FB_COM_VTBL_) 
		  Dim As HRESULT hr = pStream->Write(cast(void ptr, @cbStrLen), sizeof(cbStrLen), @cb)
		#Else
		  Dim As HRESULT hr = pStream->lpvtbl->Write(pStream,Cast(void ptr, @cbStrLen), sizeof(cbStrLen), @cb)
		#EndIf
		if (FAILED(hr)) Then
			return hr
		EndIf	
		If cbStrLen Then
			#If Not Defined( _FB_COM_VTBL_) 
		      Return   pStream->Write(cast(void ptr, m_bstr), cbStrLen, @cb)
		   #Else
		       Return  pStream->lpvtbl->Write(pStream,Cast(void ptr, m_bstr), cbStrLen, @cb)
		   #EndIf
		Else
			Return S_OK
		EndIf

End Function

#EndIf


Extern "windows" Lib "atl"
      Declare Function AtlAxAttachControl(As IUnknown Ptr,As HWND,As IUnknown Ptr Ptr) As HRESULT  ' Attaches a previously created control to the specified window.
End Extern



' COMVARIANT

Type COMVARIANT extends VARIANTARG

Private:
  	Declare Function  InternalClear() As HRESULT
	Declare Sub InternalCopy(ByVal pSrc as VARIANT Ptr )
	'private functions
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="")

public:
   Declare Constructor ()
	Declare Destructor ()
	Declare Constructor (ByRef varSrc As Const VARIANT  )
	Declare Constructor (ByRef varSrc As VARIANT  )
	Declare Constructor (ByRef varSrc As  COMVARIANT)
	Declare Constructor (byval bstrSrc AS BSTR)
	Declare Constructor (byval value as String )
	Declare Constructor (byval lpszSrc AS LPCOLESTR)
	'Declare Constructor (byval bSrc as BOOLEAN)
 	Declare Constructor (byval nSrc AS Integer)
	Declare Constructor (byval nSrc AS Byte)
	Declare Constructor (byval nSrc AS Short)
	Declare Constructor (byval nSrc AS Long,vtSrc As  VARTYPE  = VT_I4)
	Declare Constructor (byval fltSrc AS float)
	Declare Constructor (byval dblSrc AS Double)
	Declare Constructor (byval cySrc AS CY)
	Declare Constructor (byval pSrc AS IDispatch Ptr,fAddRef As bool  = CTRUE)
	Declare Constructor (byval pSrc AS IUnknown Ptr,fAddRef As bool  = CTRUE)
   Declare Constructor (byval  as SAFEARRAY Ptr)
	Declare Constructor (ByRef decSrc As Const DECIMAL )    
      
	Declare operator Let(ByRef lvarSrc AS COMVARIANT)
	Declare operator Let(ByVal varSrc as VARIANT)
	Declare operator Let(byval bstrSrc AS BSTR)
	Declare operator Let(byval bstrSrc AS String)
   Declare operator Let(byval lpszSrc AS LPCOLESTR)
  ' Declare  operator Let(byval bSrc as BOOLEAN)
   Declare  Operator Let(byval nSrc AS Integer)
   Declare  operator Let(byval nSrc AS BYTE)
   Declare  operator Let(byval nSrc AS Short)
   Declare  Operator  Let(byval nSrc AS Long)
   Declare  operator Let(byval fltSrc AS float)
   Declare  operator Let(byval dblSrc AS double)
   Declare  operator Let(byval cySrc AS CY)
   Declare  operator Let(byval pSrc AS IDispatch ptr)
   Declare  operator Let(byval pSrc AS IUnknown ptr)
   Declare  Operator Let(byval  as SAFEARRAY Ptr)
   Declare Operator Let(ByRef decSrc As Const DECIMAL )
	
	
	'Declare operator Let(ByVal varSrc as VARIANT) 
   
	 
	Declare Function  Clear() As HRESULT
	Declare Function  Copy(pSrc As  VARIANT ptr ) As HRESULT
	Declare Function  Attach(pSrc As  VARIANT ptr) As HRESULT   
	Declare Function  Detach(pDest As VARIANT Ptr )As HRESULT
	Declare Function  Detach() As VARIANT Ptr  
	Declare Function  ChangeType(vtNew As VARTYPE ,ByVal pSrc As  VARIANT ptr = NULL) As HRESULT

   Declare Function WriteToStream(pStream As IStream Ptr) As HRESULT
   Declare Function ReadFromStream(pStream As IStream Ptr ) As  HRESULT 


    Declare Operator cast() as Integer
    Declare Operator cast() As Byte
    Declare Operator cast() AS Short
    Declare operator cast() AS Long
    Declare operator cast() AS float
    Declare operator cast() AS Double
    Declare operator cast() AS CY
    Declare Operator Cast() AS DECIMAL 
 	 Declare Operator cast() as String
 	 Declare Operator cast() as BSTR
    Declare operator cast() AS IDispatch Ptr
    Declare operator cast() AS IUnknown Ptr
    Declare Operator Cast() as SAFEARRAY Ptr
 
		 
	 Declare Operator += ( byval rhs as string )
	 
	 
	 Declare Sub CreateObject (ByVal ProgID as LPCOLESTR) 
	 Declare Sub CreateObject(szProgId As LPCOLESTR ,szMachine As LPCWSTR)
	 Declare Function CreateObject (szProgId As LPCOLESTR ,riid As REFIID ,dwClsContext As DWORD , _
			               mpServerInfo As COSERVERINFO ptr ,ppv as lpvoid Ptr ) As HRESULT
    Declare Function GetObjectEx(szPathName As LPCOLESTR ,szProgId As LPCOLESTR ,riid As REFIID , _
		                dwClsContext As DWORD ,lpvReserved As LPVOID , ppv As LPVOID Ptr) As HRESULT
    Declare sub  GetObject (szPathName As LPCOLESTR =NULL,szProgId As LPCOLESTR)  
    Declare Sub AttachControl(hwnd As HWND)           ' if .ocx attach a prébuild control Handle
    Declare Function Invoke  Cdecl  (wFlags As WORD ,szName As LPCOLESTR , pszFmt as String="" ,argList As Any Ptr)As COMVARIANT
    Declare Function Method Cdecl(MethodName As LPCOLESTR , pszFmt as String="" ,...)As COMVARIANT
    Declare Function PropGet Cdecl (PropName As LPCOLESTR , pszFmt as String="" , ...)As COMVARIANT
    Declare Sub  PropPut  Cdecl (szName As LPCOLESTR,pszFmt as String,...)    
    Declare Sub  PropPutRef  Cdecl (szName As LPCOLESTR,pszFmt as String,...) 
End Type




	Constructor COMVARIANT()
		vt = VT_EMPTY
	End Constructor 
	
	Destructor COMVARIANT()
		Clear()
	End Destructor 

	Constructor COMVARIANT(ByRef varSrc As Const VARIANT  )
		vt = VT_EMPTY
		InternalCopy(@Cast(VARIANT,varSrc))
	End Constructor
   Constructor COMVARIANT(ByRef varSrc As VARIANT  )
		vt = VT_EMPTY
		InternalCopy(@varSrc)
	End Constructor
	Constructor COMVARIANT(ByRef varSrc As  COMVARIANT  )
		vt = VT_EMPTY
		InternalCopy(@varSrc)
	End Constructor

	Constructor COMVARIANT(byval bstrSrc AS BSTR)
		vt = VT_BSTR
		bstrval = bstrSrc
	End Constructor
	
 
	
	constructor COMVARIANT (byval value as String )
	  Var wlen = MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, StrPtr(value), -1, 0, 0)-1
	  vt = VT_BSTR
	  bstrval = SysAllocStringLen(NULL, wlen)	
	  MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED,StrPtr(value), -1, V_BSTR(@This), wlen)
	
   End constructor

 
	Constructor COMVARIANT(byval lpszSrc AS LPCOLESTR)
		vt = VT_EMPTY
		bstrval = Cast(BSTR,lpszSrc)
	End Constructor


	'Constructor COMVARIANT(byval bSrc as BOOLEAN)
	'	vt = VT_BOOL
	'	boolVal = bSrc  
	'End Constructor

	Constructor COMVARIANT(byval nSrc AS Integer)
		vt = VT_I4
		lVal = nSrc
	End Constructor
	
	
	Constructor COMVARIANT(byval nSrc AS Byte)
		vt = VT_UI1
		bVal = nSrc
	End Constructor
	
	Constructor COMVARIANT(byval nSrc AS Short)
		vt = VT_I2
		iVal = nSrc
	End Constructor
	
 	
	Constructor COMVARIANT(byval nSrc AS Long,  vtSrc As VARTYPE = VT_I4)
		 Assert(vtSrc = VT_I4 OR  vtSrc = VT_ERROR)
		vt = vtSrc
		lVal = nSrc
	End Constructor
	
	Constructor COMVARIANT(byval fltSrc AS float)
		vt = VT_R4
		fltVal = fltSrc
	End Constructor
	
 
	
	Constructor COMVARIANT(byval dblSrc AS Double)
		V_VT(@this) = VT_R8 
		V_R8(@this) = dblSrc 
	End Constructor
	
 
	
	Constructor COMVARIANT(byval cySrc AS CY)
		'vt = VT_CY
		'cyVal.Hi = cySrc.Hi
		'cyVal.Lo = cySrc.Lo
		
		V_VT(@this) = VT_CY 
	   V_CY(@this) = cySrc 
	End Constructor
	
	Constructor COMVARIANT(byval pSrc AS IDispatch Ptr,fAddRef As BOOL)
		vt = VT_DISPATCH
		pdispVal = pSrc
		If (pdispVal <> NULL)  Then     ' Need to AddRef as VariantClear will Release
		 if (fAddRef) Then
	 	  #If Not Defined( _FB_COM_VTBL_)
			  pdispVal->AddRef()
		  #Else 
   	     pdispVal->lpvtbl->Release(pdispVal) 
        #EndIf
       EndIf 
		EndIf
	End Constructor
	
 
	
	Constructor COMVARIANT(byval pSrc AS IUnknown Ptr,fAddRef As BOOL)
		vt = VT_UNKNOWN
		punkVal = pSrc
		If (punkVal <>	 NULL)  Then
		 if (fAddRef) Then	
			#If Not Defined( _FB_COM_VTBL_) 
			  punkVal->AddRef()                 ' Need to AddRef as VariantClear will Release
			#Else 
   	     punkVal->lpvtbl->AddRef(punkVal) 
        #EndIf
       EndIf 
		endif	
	End Constructor
   
 
	
   Constructor COMVARIANT(ByVal value As SAFEARRAY Ptr)
   Dim vvt As VARTYPE
   SafeArrayGetVartype(value,@vvt)
	 vt=vvt Or VT_ARRAY
	 parray=value
End Constructor

   Constructor COMVARIANT(ByRef decSrc As Const DECIMAL )  
 	' Order is important here! Setting V_DECIMAL wipes out the entire VARIANT
		V_DECIMAL(@this) = decSrc 
	   V_VT(@this) = VT_DECIMAL 
End Constructor


   
  ' Assignment Operators
 
	 operator COMVARIANT.let(ByRef lvarSrc AS COMVARIANT)
		InternalCopy(Cast(VARIANT Ptr,@lvarSrc))
	 End Operator
	 
	 operator COMVARIANT.let(ByVal varSrc as VARIANT)
		InternalCopy(@varSrc)
	End Operator

	 operator COMVARIANT.let(byval bstrSrc AS BSTR)
		InternalClear()
		vt = VT_BSTR
		bstrVal = ..SysAllocString(bstrSrc)
		if (bstrVal = NULL And bstrSrc <>	 NULL)  Then
			vt = VT_ERROR
			scode = E_OUTOFMEMORY
		EndIf
	 End Operator

 operator COMVARIANT.let(byval lpszSrc AS LPCOLESTR)
		InternalClear()
		vt = VT_BSTR
		bstrVal = SysAllocString(lpszSrc)
		if (bstrVal = NULL And lpszSrc <>	 NULL)  Then
			vt = VT_ERROR
			scode = E_OUTOFMEMORY
		EndIf
 End Operator

 operator COMVARIANT.let(byval value as STRING)
	 if (vt <> VT_BSTR)  Then
	    InternalClear()
	    vt = VT_BSTR
	 EndIf   
	Var wlen = MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, StrPtr(value) , -1, 0, 0)-1
	bstrval = SysAllocStringLen(NULL, wlen)	
	MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED,  StrPtr(value) , -1,V_BSTR(@This), wlen)
End Operator


 /'operator COMVARIANT.let(byval bSrc as BOOLEAN)
		if (vt <> VT_BOOL)  Then
			InternalClear()
			vt = VT_BOOL
		EndIf
		boolVal =  bSrc  
 End Operator
'/
operator COMVARIANT.let(byval nSrc AS Integer)
 		if (vt <>	 VT_I4)  Then
			InternalClear()
			vt = VT_I4
		EndIf
		lVal = nSrc
End Operator

 operator COMVARIANT.let(byval nSrc AS BYTE)
 	if (vt <>VT_UI1)  Then
			InternalClear()
			vt = VT_UI1
		EndIf
		bVal = nSrc
 End Operator

 operator COMVARIANT.let(byval nSrc AS Short)
		if (vt <>VT_I2)  Then
			InternalClear()
			vt = VT_I2
		EndIf
		iVal = nSrc
 End Operator

operator COMVARIANT.let(byval nSrc AS Long)
		if (vt <> VT_I4) Then
			InternalClear()
			vt = VT_I4
		EndIf
		lVal = nSrc
	End Operator

 operator COMVARIANT.let(byval fltSrc AS float)
		if (vt <>	 VT_R4)  Then
			InternalClear()
			vt = VT_R4
		End If
		fltVal = fltSrc
 End Operator

 operator COMVARIANT.let(byval dblSrc As double)
		if (vt <>VT_R8) Then
			InternalClear()
			vt = VT_R8
		End If
		dblVal = dblSrc
 End Operator

 operator COMVARIANT.let(byval cySrc AS CY)
		if (vt <> VT_CY)Then
			InternalClear()
			vt = VT_CY
		EndIf
		cyVal.Hi = cySrc.Hi
		cyVal.Lo = cySrc.Lo
 End Operator

 operator COMVARIANT.let(byval pSrc AS IDispatch ptr)
		InternalClear()
		vt = VT_DISPATCH
		pdispVal = pSrc
		If (pdispVal <> NULL) Then
			#If Not Defined( _FB_COM_VTBL_) 
			  pdispVal->AddRef()                ' Need to AddRef as VariantClear will Release
			#Else 
   	     pdispVal->lpvtbl->AddRef(pdispVal) 
        #EndIf
		End If	
 End Operator


 operator COMVARIANT.let(byval pSrc AS IUnknown ptr)
		InternalClear()
		vt = VT_UNKNOWN
		punkVal = pSrc
		if (punkVal <>	NULL) Then
			#If Not Defined( _FB_COM_VTBL_) 
			   punkVal->AddRef()                ' Need to AddRef as VariantClear will Release
			#Else 
   	      punkVal->lpvtbl->AddRef(punkVal) 
        #EndIf
		EndIf
		Return	
 End Operator

   Operator COMVARIANT.Let(byval p as SAFEARRAY Ptr)
   	InternalClear()
	   Dim vvt As VARTYPE
      SafeArrayGetVartype(p,@vvt)
	   vt= vvt Or VT_ARRAY
	   parray=p
   End Operator
   
   Operator COMVARIANT.Let(ByRef decSrc As Const DECIMAL )
   	if (V_VT(@this) <> VT_DECIMAL) Then
		  this.Clear()
      End If
	 	' Order is important here! Setting V_DECIMAL wipes out the entire VARIANT
	   V_DECIMAL(@this) = decSrc 
	   V_VT(@this) = VT_DECIMAL 

   End Operator
 
	Function COMVARIANT.Clear() As HRESULT
	   return VariantClear(@this)
	End Function 
	
	Function COMVARIANT.Copy(pSrc As  VARIANT ptr ) As HRESULT
	  Return VariantCopy(@this, pSrc)
	End Function  
	
	Function COMVARIANT.Attach(pSrc As  VARIANT ptr) As HRESULT
		Dim As HRESULT hr = Clear()                ' Clear out the variant
		if (0=FAILED(hr))  Then
			memcpy(@this, pSrc, sizeof(VARIANT))     ' Copy the contents and give control to COMVARIANT
			pSrc->vt = VT_EMPTY
			hr = S_OK
		endif
		return hr
	End Function

	Function COMVARIANT.Detach(pDest As VARIANT Ptr )As HRESULT
		Dim As HRESULT hr = VariantClear(pDest) ' Clear out the variant
		if (0=FAILED(hr)) Then
			memcpy(pDest, @this, sizeof(VARIANT))  ' Copy the contents and remove control from COMVARIANT
			vt = VT_EMPTY 
			hr = S_OK 
		EndIf
		return hr 
	End Function
   
   Function COMVARIANT.Detach() As VARIANT Ptr  
		Dim pDest As VARIANT Ptr
		Dim As HRESULT hr   
		 memcpy(pDest, @this, sizeof(VARIANT))  ' Copy the contents and remove control from COMVARIANT
		Return pDest 
   End Function
   
	Function COMVARIANT.ChangeType(vtNew As VARTYPE ,ByVal pSrc As  VARIANT ptr = NULL) As HRESULT
		Dim As VARIANT Ptr pVar = cast(VARIANT Ptr,pSrc)
		If (pVar = NULL) Then
			pVar = @This                     ' Convert in place if pSrc is NULL
		EndIf	
		' Do nothing if doing in place convert and vts not different
		return ..VariantChangeType(@this, pVar, 0, vtNew)
	End Function
	
 	Function COMVARIANT.InternalClear() As HRESULT
 		Dim As HRESULT hr = Clear()
		 Assert(SUCCEEDED(hr)) 
		if (FAILED(hr)) Then
			vt = VT_ERROR
			scode = hr
		EndIf
		return hr
	End Function

	Sub COMVARIANT.InternalCopy(ByVal pSrc as VARIANT Ptr )
	Dim As	HRESULT hr = Copy(pSrc) 
		if (FAILED(hr)) Then
			vt = VT_ERROR 
			scode = hr 
		EndIf
	End Sub

 'Operator COMVARIANT.cast() as BOOLEAN
 '	Return this.boolval
 'End Operator
 
 Operator COMVARIANT.cast() as Integer
 	If (V_VT(@this) = VT_INT) Then
		return V_INT(@this) 
	End If
	Dim vvar As variant
 	VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_INT)
	return V_INT(@vvar) 
 End Operator
 
   Operator COMVARIANT.cast()As Byte
   	If (V_VT(@this) = VT_UI1) Then
		return V_UI1(@this) 
	End If
	Dim vvar As variant
 	VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_UI1)
	return V_UI1(@vvar)
   End Operator

   
  Operator COMVARIANT.cast() AS Short
  	If (V_VT(@this) = VT_I2) Then
		return V_I2(@this) 
	End If
	Dim vvar As variant
 	VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_I2)
	return V_I2(@vvar) 
  End Operator
  
   
  operator COMVARIANT.cast() AS Long
  	If (V_VT(@this) = VT_I4) Then
		return V_I4(@this) 
	End If
	Dim vvar As variant
 	VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_I4)
	return V_I4(@vvar) 
  End Operator
  
 
  
  operator COMVARIANT.cast() AS float
  	If (V_VT(@this) = VT_R4) Then
		return V_R4(@this) 
	End If
	Dim vvar As variant
 	VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_R4)
	return V_R4(@vvar) 
  End Operator
  
    
  operator COMVARIANT.cast() AS Double
  	If (V_VT(@this) = VT_R8) Then
		return V_R8(@this) 
	End If
	Dim vvar As variant
 	VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_R8)
	return V_R8(@vvar) 
  End Operator
  
   
  operator COMVARIANT.cast() AS CY
  	 if (V_VT(@this) = VT_CY) Then
		return V_CY(@this) 
	End If
	Dim vvar As variant
 	VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_CY)
	return V_CY(@vvar) 
  End Operator
  
 operator COMVARIANT.cast() AS DECIMAL 
 	if (V_VT(@this) = VT_DECIMAL) Then
		return V_DECIMAL(@this) 
	End If
	Dim vvar As variant
 	VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_DECIMAL)
	return V_DECIMAL(@vvar) 
 End Operator

 
  
  Operator COMVARIANT.cast() as String
 	Dim vvar As variant
 	VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_BSTR)
	return *Cast(wString Ptr,vvar.bstrval)
 End Operator

 
  
Operator COMVARIANT.cast() as BSTR
 	Dim vvar As variant
 	VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_BSTR)
	return  vvar.bstrval 
End Operator

 
 
  operator COMVARIANT.cast() AS IDispatch Ptr
  	If (V_VT(@this) = VT_DISPATCH) then
		V_DISPATCH(@this)->AddRef() 
		return V_DISPATCH(@this) 
	End If

	Dim vvar As variant
 	VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_DISPATCH)
 	V_DISPATCH(@vvar)->AddRef() 
	return V_DISPATCH(@vvar) 
  End Operator
 
  
  operator COMVARIANT.cast() AS IUnknown Ptr
  	if (V_VT(@this) = VT_UNKNOWN) then
		V_UNKNOWN(@this)->AddRef() 
		return V_UNKNOWN(@this) 
	End If

	Dim vvar As variant
 	VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_UNKNOWN)
	V_UNKNOWN(@vvar)->AddRef() 
	return V_UNKNOWN(@vvar) 
  End Operator
  
   
 
 operator COMVARIANT.cast() as SAFEARRAY Ptr
	if (vt And VT_ARRAY)=VT_ARRAY Then  
	   Return this.parray
	Else
	  	Dim vvar As variant
	   VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_ARRAY Or (vt Xor VT_ARRAY) )
	   Return vvar.parray
   EndIf    
End Operator


Function COMVARIANT.WriteToStream(pStream As IStream Ptr) As HRESULT
 
	Dim As HRESULT hr = pStream->Write(@vt, sizeof(VARTYPE), NULL)
	if (FAILED(hr)) Then
		return hr
   EndIf
	Dim As Integer cbWrite = 0
	Select Case (vt)
	 
		case VT_UNKNOWN,VT_DISPATCH:
		 
			Dim spStream As IPersistStream Ptr
			if (punkVal <>	 NULL) Then
			   #If Not Defined( _FB_COM_VTBL_) 
				    hr = punkVal->QueryInterface(@IID_IPersistStream, cast(lpvoid Ptr,@spStream))
				#Else 
   	         hr=punkVal->lpvtbl->QueryInterface(punkVal,@IID_IPersistStream, cast(lpvoid Ptr,@spStream))
            #EndIf
				if (FAILED(hr)) Then
					return hr
				EndIf	
			EndIf
			if (spStream <> NULL) Then
				return OleSaveToStream(spStream, pStream)
			else
				return WriteClassStm(pStream,@CLSID_NULL)
		   EndIf
	case VT_UI1,VT_I1:
		cbWrite = sizeof(BYTE)
		 
	case VT_I2,VT_UI2,VT_BOOL:
		cbWrite = sizeof(short)
		 
	case VT_I4,VT_UI4,VT_R4,VT_INT,VT_UINT, VT_ERROR:
		cbWrite = sizeof(long)
	 
	case VT_R8,VT_CY,VT_DATE:
		cbWrite = sizeof(double)
		 
	Case Else
		 
	End Select
	if (cbWrite <>	 0) Then
		#If Not Defined( _FB_COM_VTBL_) 
		    Return pStream->Write(cast(lpvoid Ptr, @bVal), cbWrite, NULL)
		#Else 
   	    Return pStream->lpvtbl->Write(pStream,Cast(lpvoid Ptr, @bVal), cbWrite, NULL)
      #EndIf
	EndIf
	'bon pour finaliser
	#Ifndef __WIDESTRING_INC__
	  Dim As BSTR bstrWrite
	#Else
	  Dim As WideString bstrWrite
	#EndIf
	Dim As COMVARIANT varBSTR
	if (vt <> VT_BSTR)Then
 
		hr = VariantChangeType(@varBSTR, @this, VARIANT_NOVALUEPROP, VT_BSTR)
		if (FAILED(hr)) Then
			return hr
		EndIf	
		bstrWrite = varBSTR.bstrVal
	 
	else
		bstrWrite = bstrVal
	EndIf
	
	#Ifndef __WIDESTRING_INC__
      Return  BstrWriteToStream(bstrWrite,pStream)
	#Else
	   Return bstrWrite.WriteToStream(pStream)
	#EndIf
	
	Return S_OK
End Function

Function COMVARIANT.ReadFromStream(pStream As IStream Ptr ) As  HRESULT
 
	Assert(pStream <>	 NULL)
	Dim As HRESULT hr
	hr = VariantClear(@this)
	if (FAILED(hr)) Then
		return hr
	EndIf
	Dim As VARTYPE vtRead
	   #If Not Defined( _FB_COM_VTBL_) 
	      hr = pStream->Read(@vtRead, sizeof(VARTYPE), NULL)
	   #Else 
   	   hr= pStream->lpvtbl->Read(pStream,@vtRead, sizeof(VARTYPE), NULL)
      #EndIf
	if (hr = S_FALSE) Then
		hr = E_FAIL
	EndIf
	if (FAILED(hr)) Then
		return hr
   EndIf
	vt = vtRead
	Dim As Integer cbRead = 0
	Select Case (vtRead)
	
	 
	case VT_UNKNOWN,VT_DISPATCH:
		 
			punkVal = NULL
			hr = OleLoadFromStream(pStream, _
				iif(vtRead = VT_UNKNOWN, @IID_IUnknown , @IID_IDispatch), _
				cast(LPVOID Ptr,@punkVal))
			if (hr = REGDB_E_CLASSNOTREG) Then
				hr = S_OK
			EndIf
			return S_OK
		 
	case VT_UI1,VT_I1:
		cbRead = sizeof(BYTE)
		 
	Case VT_I2,VT_UI2,VT_BOOL:
		cbRead = sizeof(short)
		 
	case VT_I4,VT_UI4,VT_R4,VT_INT,VT_UINT,VT_ERROR:
		cbRead = sizeof(long)
		 
	case VT_R8,VT_CY,VT_DATE:
		cbRead = sizeof(double)
		 
	Case Else
		 
	End Select
	if (cbRead <> 0)Then
	 	#If Not Defined( _FB_COM_VTBL_) 
	 	    hr = pStream->Read(cast(lpvoid,@bVal), cbRead, NULL)
	 	#Else 
   	    hr= pStream->lpvtbl->Read(pStream,Cast(lpvoid,@bVal), cbRead, NULL)
      #EndIf
		if (hr = S_FALSE) Then
			hr = E_FAIL
		EndIf
		return hr
	EndIf
	Dim As COMVARIANT bstrRead
   Dim tempv As VARIANT
	hr = bstrRead.ReadFromStream(pStream)
	if (FAILED(hr)) Then
		return hr
	EndIf
	vt = VT_BSTR
	  bstrRead.Detach(@tempv)
	bstrVal= tempv.bstrVal  
	if (vtRead <> VT_BSTR) Then
		hr = ChangeType(vtRead)
	EndIf
	return hr
End Function

Operator COMVARIANT.+= ( byval rhs as string ) 
	Dim as VARIANT tmp = any, res = any
	VariantInit( @tmp )
	Var wlen = MultiByteToWideChar(CP_ACP, NULL, StrPtr(rhs), &HFFFFFFFF, 0, 0)-1
	V_VT(@tmp) = VT_BSTR
	V_BSTR(@tmp) = SysAllocStringLen(NULL, wlen)	
	MultiByteToWideChar(CP_ACP, NULL, StrPtr(rhs), &HFFFFFFFF, V_BSTR(@tmp), wlen)
	VarAdd( @This, @tmp, @res )
	VariantClear( @This )
	This = res
	VariantClear( @tmp )
End Operator


Sub COMVARIANT.CreateObject (ByVal ProgID as LPCOLESTR) 

 Dim As IDISPATCH Ptr pdisp = NULL
 Dim As IUNKNOWN Ptr  punk  = NULL 
 Dim as HRESULT hr
 
      
   	  oleInitialize(NULL)
   
          
      Dim As  CLSID clsid 
      hr=CLSIDFromProgID(ProgID, @clsid)
      If clsid=CLSID_NULL Then hr=CLSIDFromString(ProgID, @clsid)
      If clsid=CLSID_NULL Then goto errorn
  
      hr = CoCreateInstance(@clsid, NULL,CLSCTX_LOCAL_SERVER Or CLSCTX_INPROC_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 
 
	     
	   #If Not Defined( _FB_COM_VTBL_)
	      punk->Release()
	   #Else 
   	   punk->lpvtbl->Release(punk) 
      #EndIf
      This.vt=VT_DISPATCH
      this.pdispval= pdisp 
	   Return
errorn: 
	      OleErrorShow(hr,"CreateObject(" & Chr(34) & *Cast(WString Ptr,ProgID) & Chr(34) & ")" )
   #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
	 
End Sub

Sub COMVARIANT.CreateObject(szProgId As LPCOLESTR ,szMachine As LPCWSTR)
 	Dim As COSERVERINFO si 
	si.pwszName = Cast(LPWSTR,szMachine)

	 CreateObject(szProgId, @IID_IDispatch, _
			 IIf( szMachine , CLSCTX_REMOTE_SERVER , CLSCTX_LOCAL_SERVER Or CLSCTX_INPROC_SERVER), _
			 IIf( szMachine , @si , NULL), cast(LPVOID Ptr, @pdispval)) 
End Sub
Function COMVARIANT.CreateObject (szProgId As LPCOLESTR ,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 
   hr = CLSIDFromProgID(szProgId, @clsid)
   If clsid=IID_NULL Then
   	hr = CLSIDFromString(szProgId, @clsid)
   EndIf
	If clsid=IID_NULL Then  
		OleErrorShow(hr,"CreateObject(" & Chr(34) & *Cast(WString Ptr,szProgId) & Chr(34) & ")" )
		Return hr
	EndIf
	
	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 COMVARIANT.GetObjectEx(szPathName As LPCOLESTR ,szProgId As LPCOLESTR ,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(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 

		hr = CLSIDFromProgID(szProgId, @clsid)
      If clsid=IID_NULL Then
   	     hr = CLSIDFromString(szProgId, @clsid)
      EndIf
	   If clsid=IID_NULL Then  
		    OleErrorShow(hr,"CreateObject(" & Chr(34) & *szProgId & Chr(34) & ")" )
		    Return hr
	    EndIf
		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

 

Sub COMVARIANT.GetObject(szPathName As LPCOLESTR =NULL,szProgId As LPCOLESTR)
 	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))
 	 
 	this.vt=VT_DISPATCH
 	this.pdispval=pDisp
End Sub

Sub COMVARIANT.AttachControl(hwnd As HWND)
	 AtlAxAttachControl(Cast(IUnknown Ptr,this.pdispval),hwnd,NULL)
End Sub
Function COMVARIANT.Invoke  Cdecl  (wFlags As WORD ,szName As LPCOLESTR , pszFmt as String="" ,argList As Any Ptr)As COMVARIANT
    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)
   
    
   
     if (this.pdispval =  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 = this.pdispval->lpvtbl->GetIDsOfNames(this.pdispval,@IID_NULL, Cast(LPOLESTR Ptr,@szName), 1, LOCALE_USER_DEFAULT, @dispidm) 
   #Else
     hr = this.pdispval->GetIDsOfNames(@IID_NULL,Cast(LPOLESTR Ptr,@szName), 1, LOCALE_USER_DEFAULT, @dispidm)
   #EndIf
    if(FAILED(hr))Then
        OleErrorShow(hr,*Cast(WString Ptr,szName))
        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),*Cast(WString Ptr,szName))
            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),*Cast(WString Ptr,szName))
            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,VARIANT_BOOL),-1,0)
               argList=va_next(argList,VARIANT_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  VARIANT_BOOL Ptr pbool = va_arg(argList, VARIANT_BOOL Ptr) 
               '*pbool = 0 
               V_BOOLREF(@pParams[i-1]) = Cast(VARIANT_BOOL Ptr,pbool) 
               argList=va_next(argList,VARIANT_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),*Cast(WString Ptr,szName)) 
                  
            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 = this.pdispval->lpvtbl->Invoke(this.pdispval,dispidm, @IID_NULL, LOCALE_USER_DEFAULT, wFlags,@dispparams, @vRet, NULL, NULL) 
    #Else
       hr = this.pdispval->Invoke(dispidm, @IID_NULL, LOCALE_USER_DEFAULT, wFlags,@dispparams, @vRet, NULL, NULL) 
    #EndIf
     OleErrorShow(hr,"pdisp->Invoke in " & *szName)
     
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 COMVARIANT.Method Cdecl( MethodName As LPCOLESTR , pszFmt as String="" ,...)As COMVARIANT
    Return Invoke(DISPATCH_METHOD,MethodName,pszFmt,va_first()) 
End function  

Function COMVARIANT.PropGet Cdecl ( PropName As LPCOLESTR , pszFmt as String="" , ...)As COMVARIANT
   Return Invoke(DISPATCH_PROPERTYGET,PropName,pszFmt,va_first()) 
End function  
 
Sub  COMVARIANT.PropPut  Cdecl ( szName As LPCOLESTR,pszFmt as String,...)    
	Invoke(DISPATCH_PROPERTYPUT,szName,pszFmt,va_first())   
End Sub
Sub  COMVARIANT.PropPutRef  Cdecl ( szName As LPCOLESTR,pszFmt as String,...) 
	Invoke(DISPATCH_PROPERTYPUTREF,szName,pszFmt,va_first()) 
End Sub


'''''''''''''''''    PRIVATE FUNCTIONS '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


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


Private Function  COMVARIANT.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 COMVARIANT.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 COMVARIANT.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 COMVARIANT.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





 Operator <>(ByVal V As COMVARIANT,ByVal varSrc as VARIANT) As BOOL
	 Return (@v=@varSrc)
	End Operator
	
  Operator  <(ByVal V As COMVARIANT,ByVal varSrc as VARIANT)  As BOOL 
	 Return VarCmp(@V,@varSrc, LOCALE_USER_DEFAULT, 0)=VARCMP_LT 
  End Operator

Operator >(ByVal V As COMVARIANT,ByVal varSrc as VARIANT)  As BOOL 
	     Return VarCmp(@V,@varSrc, LOCALE_USER_DEFAULT, 0)=VARCMP_GT
End Operator
	  
Operator =(ByVal V As COMVARIANT,ByVal varSrc as VARIANT) As BOOL
		if (@V = @varSrc)  Then
			return TRUE
      EndIf
		' Variants not equal if types don't match
		if (V.vt <>varSrc.vt)  Then
			return FALSE
      EndIf
		' Check type specific values
		Select Case (V.vt)
		 
			case VT_EMPTY,VT_NULL:
				return TRUE

			case VT_BOOL:
				return (V.boolVal = varSrc.boolVal)

			case VT_UI1:
				return (V.bVal = varSrc.bVal)

			case VT_I2:
				return V.iVal = varSrc.iVal

			case VT_I4:
				return V.lVal = varSrc.lVal

			case VT_R4:
				return V.fltVal = varSrc.fltVal

			case VT_R8:
				return V.dblVal = varSrc.dblVal

			case VT_BSTR:
				return (SysStringByteLen(V.bstrVal) = SysStringByteLen(varSrc.bstrVal)) And _
						 (memcmp(V.bstrVal, varSrc.bstrVal, SysStringByteLen(V.bstrVal)) = 0)

			case VT_ERROR:
				return V.scode = varSrc.scode

			case VT_DISPATCH:
				return V.pdispVal = varSrc.pdispVal

			case VT_UNKNOWN:
				return V.punkVal = varSrc.punkVal

			Case Else
				 Assert(false)
				' fall through
		End Select

		return FALSE
	End Operator
	
#EndIf	  
erosolmi
Posts: 16
Joined: May 12, 2007 15:03
Location: Milan - Italy
Contact:

Re: INSIDE ACTIVEX WITH FREEBASIC

Post by erosolmi »

None of the links to 2shared are anymore working.
That's the problem when using general sharing sites :(
Tolo68
Posts: 105
Joined: Mar 30, 2020 18:18
Location: Spain

Re: INSIDE ACTIVEX WITH FREEBASIC

Post by Tolo68 »

Errors in Variants.bi and InvokeHelper.bi

IDE FbIde

FreeBasic V 1.0.8

C:\Archivos de programa\FreeBASIC\inc\variants.bi(976) error 18: Element not defined, AddRef in 'If v.punkVal THEN pUnk->AddRef(pUnk)'
C:\Archivos de programa\FreeBASIC\inc\variants.bi(987) error 3: Expected End-of-Line, found '(' in 'If v.ppunkVal THEN (*pUnk)->AddRef()'
C:\Archivos de programa\FreeBASIC\inc\variants.bi(1346) error 9: Expected expression, found ')' in 'v.punkVal->AddRef()'
C:\Archivos de programa\FreeBASIC\inc\variants.bi(1355) error 9: Expected expression, found ')' in 'vvar.punkVal->AddRef()'
C:\Archivos de programa\FreeBASIC\inc\variants.bi(1366) error 3: Expected End-of-Line, found '(' in 'Cast(IUnknown Ptr,*(v.ppunkVal))->AddRef()'
C:\Archivos de programa\FreeBASIC\inc\variants.bi(1375) error 3: Expected End-of-Line, found '(' in 'Cast(IUnknown Ptr,*(vvar.ppunkVal))->AddRef()'
C:\Archivos de programa\FreeBASIC\inc\InvokeHelper.bi(17) warning 44(1): Suffix ignored in 'FORMAT$'
C:\Archivos de programa\FreeBASIC\inc\InvokeHelper.bi(109) error 18: Element not defined, QueryInterface in 'hr = rVal.punkval->QueryInterface(@IID_IDispatch, cast(lpvoid Ptr,@rVal.pdispval))'
C:\Archivos de programa\FreeBASIC\inc\InvokeHelper.bi(125) error 18: Element not defined, Release in 'rVal.punkval->Release()'
C:\Archivos de programa\FreeBASIC\inc\InvokeHelper.bi(137) error 9: Expected expression, found ')' in 'If (rVal.punkval) Then rVal.punkval->Release()'
C:\Archivos de programa\FreeBASIC\inc\InvokeHelper.bi(138) error 9: Expected expression, found ')' in 'If (rVal.pdispval) Then rVal.pdispval->Release()'
C:\Archivos de programa\FreeBASIC\inc\InvokeHelper.bi(138) error 133: Too many errors, exiting
aloberoger
Posts: 507
Joined: Jan 13, 2009 19:23

Re: INSIDE ACTIVEX WITH FREEBASIC

Post by aloberoger »

you don't have modified .bi so use lptvbl->
Post Reply