INSIDE ACTIVEX WITH FREEBASIC

Windows specific questions.
Post Reply
aloberoger
Posts: 507
Joined: Jan 13, 2009 19:23

INSIDE ACTIVEX WITH FREEBASIC

Post by aloberoger »

This is the first post of a sery of my works on activex with FB, you can download at:
http://www.2shared.com/file/-XG27yjo/Post1.html
Imortis
Moderator
Posts: 1923
Joined: Jun 02, 2005 15:10
Location: USA
Contact:

Re: INSIDE ACTIVEX WITH FREEBASIC

Post by Imortis »

This looks very promising, though your English is not the best. It is not too hard to understand what you mean in most places, but in some, it is rather difficult for me.

I may do some cleanup on the text to make it a bit more friendly to native English speakers.

Well done. I am looking forward to more.
aloberoger
Posts: 507
Joined: Jan 13, 2009 19:23

Re: INSIDE ACTIVEX WITH FREEBASIC

Post by aloberoger »

there will be an improvement be sure
aloberoger
Posts: 507
Joined: Jan 13, 2009 19:23

Re: INSIDE ACTIVEX WITH FREEBASIC

Post by aloberoger »

In a first post we saw how to use VTBL method and the method abstract with Classes, but we forgot the simple method abstract: here its test which you will place in the folder " abstract example " .

Code: Select all

#Define _FBV2013_       ‘  Nécessaire pour la méthode des fonctions virtuelles pures

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

#Include Once "TEMPIPOINT_abstract.bi"

' NOT FORGET TO INITIALIZE OLE   WITH REGISTERED DLL
OleInitialize(NULL)

Dim C1 As ICLASS1 Ptr
Dim C2 As ICLASS2 Ptr
Dim ClassID As GUID, hr As HRESULT
CLSIDFromProgID(WStr(ProgID_CLASS1), @ClassID)
   hr=CoCreateInstance(@ClassID, NULL, CLSCTX_INPROC_SERVER Or CLSCTX_LOCAL_SERVER, @IID_IDispatch,Cast(LPVOID Ptr, @C1))
If hr<>s_ok Then MessageBox(getactivewindow(),!"can t create IDispatch\n " & "hr= " & hr ,"Error in Constructor",MB_ICONERROR)

Dim As Double C1x,C1y,Result 
      C1->get_x(@C1x) 
      C1->get_y(@C1y)
Print "C1.x: ";C1x
Print "C1.y ";C1y
 C1->Produit (@Result)
Print "Produit: ";Result
C1->Somme(@Result)
Print "Somme: ";Result
CLSIDFromProgID(WStr(ProgID_CLASS2), @ClassID)
   hr=CoCreateInstance(@ClassID, NULL, CLSCTX_INPROC_SERVER Or CLSCTX_LOCAL_SERVER, @IID_IDispatch,Cast(LPVOID Ptr, @C2))
If hr<>s_ok Then MessageBox(getactivewindow(),!"can t create IDispatch\n " & "hr= " & hr ,"Error in Constructor",MB_ICONERROR)
C1->Add(C2,50,150,@Result)
Print "C1.Add(C2,50,150): ";Result
Print
Print

'C1.x=1250
'C1.y=350
      C1->put_x (1250) 
      C1->put_y(350)
        
      C1->get_x (@C1x) 
      C1->get_y(@C1y)
Print "C1.x: ";C1x
Print "C1.y ";C1y
C1->Produit (@Result)
Print "Produit: ";Result
C1->Produit (@Result)
Print "Produit: ";Result
C1->Somme(@Result)
Print "Somme: ";Result
C1->Add(C2,50,150,@Result)
Print "C1.Add(C2,50,150): ";Result
'  we need to clear the memory
C2->Release ()
C1->Release () 
 
' NOT FORGET TO UNINITIALIZE OLE   WITH REGISTERED DLL
 OleUninitialize()
Sleep

For the moment after the VTBL and ABSTRACT methods it is the moment to pass to the invoke method. It should be said gilds and already it is longest, slowest and most flexible (the flexibility is an asset). It is thus necessary to pass the name of the function to recover the DISPID of the function, then to pass the parameters in a structure DISPPARAMS in opposite order, and finally to call the Invoke method. See the file testinv1.bas to complete in " Invoke example / testinv1.bas "
testinv1.bas

Code: Select all

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

Function StrToBSTR(ByVal cnv_string As String) As BSTR
    Dim sb As BSTR
    Dim As Integer n
    n = (MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, cnv_string, -1, NULL, 0))-1
    sb=SysAllocStringLen(sb,n)
    MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, cnv_string, -1, sb, n)
    Return sb
End Function

Function CreateObject  (BYVAL strProgID AS String,ByVal clsctx As Integer=CLSCTX_INPROC_SERVER Or CLSCTX_LOCAL_SERVER OR CLSCTX_REMOTE_SERVER) As IDISPATCH Ptr
	Dim pDispatch As IDispatch Ptr
	Dim pUnknown As IUnknown Ptr
	Dim hr As HRESULT
 dim ClassID As CLSID 
 CLSIDFromProgID(WStr(strProgID), @ClassID)
   hr = CoCreateInstance(@ClassID,null,clsctx, @IID_IUnknown, @pUnknown)
  IF hr<>0 OR pUnknown=0 THEN Return NULL
' Ask for the dispatch interface
#Ifdef _FBV2013_
      hr=pUnknown->QueryInterface(@IID_IDispatch, @pDispatch)
   #Else
     hr = IUnknown_QueryInterface(pUnknown, @IID_IDispatch, @pDispatch)
#EndIf
' If it fails, return the Iunknown interface
IF hr<>0 OR pDispatch=0 Then		
	Return Cast(IDISPATCH Ptr, pUnknown)   'not recommended
End IF
	' Release the IUnknown interface
	#Ifdef _FBV2013_
	    pUnknown->Release()
	#Else
	    IUnknown_Release(pUnknown)
	#EndIf
	' Return a pointer to the dispatch interface
	Return pDispatch 
   
END function
 

Dim pC1 As IDISPATCH Ptr

' show how to call produit  function

' We have to call those extra functions indirectly via the Invoke function, as we'll  see below
	 CoInitialize(NULL) 			 
	  Dim hr As HRESULT
	Dim As VARIANT ret 
	Dim As ULong	count, i 
	Dim As DISPID	dispid 
	Dim As OLECHAR	ptr	funcName 

	funcName = Strtobstr("Produit")
               'Print "function name: ";*Cast(WString Ptr,funcName)
	pC1=CreateObject("TEMPIPOINT.CLASS1")  ' you must create an object after CoInitialize(NULL)
					 
	hr = pC1->lpVtbl->GetIDsOfNames(pC1,  @IID_NULL,  @funcName, 1, LOCALE_USER_DEFAULT,  @dispid)
					
	If hr<>0 Then
	MessageBox(0, "Can't get Produit()'s DISPID", "GetIDsOfNames error", MB_OK Or MB_ICONEXCLAMATION) 
	else
	      ' Print "Produit()'s DISPID: ",dispid
	Dim As DISPPARAMS	dspp 
	Dim As VARIANT		args(0)
	VariantInit( @args(0)) 
	ZeroMemory( @dspp, sizeof(DISPPARAMS)) 
	dspp.cArgs = 0              ' Produit don't have any parameters
	dspp.rgvarg =  @args(0) 
	args(0).vt = VT_R8 
hr = pC1->lpVtbl->Invoke(pC1, dispid,  @IID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD ,  @dspp,  @ret, 0, 0)
	If hr<>0 Then 
	MessageBox(0, "Can't get produit name", "Invoke/produit error", MB_OK Or MB_ICONEXCLAMATION) 
	Else
		Print "Produit via dispatch call: ";  ret.dblVal  
		VariantClear( @ret) 
	 End If
End If
'  DISPATCH_METHOD             is a flag for sub or function
  ' DISPATCH_PROPERTYGET 2      is a flag for property get
       ' DISPATCH_PROPERTYPUT 4      is a flag for property put
       ' DISPATCH_PROPERTYPUTREF 8	 
	  ' Free Interface
	   pC1->lpVtbl->Release(pC1)   
   CoUninitialize()
  Sleep
 
As much the statement it is better to use wrappers to do it. Fortunately I have created
" Invoke.bi " and " InvokeEx bi " in the folder " Utils ". One will quite simply need to pass the name of the function and the parameters (by respecting the normal order in the procedure) in a pointer of a VARIANT. See the file to complete in " Invoke example / testinv2.bas "
testinv2.bas

Code: Select all


#Include Once "windows.bi"
#Include Once "win/ole2.bi"
#Include Once "invokeex.bi"
 
Const ProgID_CLASS2="TEMPIPOINT.Class2"
Const ProgID_CLASS1="TEMPIPOINT.CLASS1"
 
	 CoInitialize(NULL) 			 
Dim C1 As VARIANT   'CLASS1
Dim C2 As  VARIANT  'CLASS2
Dim pVarRes As VARIANT,C1x As Double,C1y As Double

C1=CreateObject(ProgID_CLASS1)  ' see in InvokeEx this one return a VARIANT
'InvokePropGet (ByVal pDispV as VARIANT,pVarRes As VARIANT Ptr,sName As String , nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT 
 InvokePropGet(C1,@pVarRes,"x"): C1x=pVarRes.dblval
 InvokePropGet(C1,@pVarRes,"y"): C1y=pVarRes.dblval
Print "C1.x: ";C1x
Print "C1.y ";C1y


  ' InvokeMethod (ByVal pDispV as VARIANT,pVarRes As VARIANT Ptr,sName As String, nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT  
		 
  InvokeMethod(C1,@pVarRes,"Produit")
Print "Produit: ";pVarRes.dblval

InvokeMethod(C1,@pVarRes,"Somme")
Print "Somme: ";pVarRes.dblval

ReDim pParams(0 To 2) As VARIANT
C2=CreateObject(ProgID_CLASS2)
pParams(0)=C2

pParams(1).vt=VT_R8
pParams(1).dblval=50

pParams(2).vt=VT_R8
pParams(2).dblval=150
InvokeMethod(C1,@pVarRes,"Add",3,@pParams(0))
Print "C1.Add(C2,50,150): ";pVarRes.dblval
Print
Print
 
'C1.x=1250
'C1.y=350
'InvokePropPut (ByVal pDispV as VARIANT,sName As string, nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT 
 ReDim pParams(1) AS VARIANT
       pParams(0).vt=VT_R8
       pParams(0).dblval=1250
    InvokePropPut(C1,"x",1,@pParams(0))
    
  ReDim pParams(1) AS VARIANT
       pParams(0).vt=VT_R8
       pParams(0).dblval=350
   InvokePropPut(C1,"y",1,@pParams(0))
       
InvokePropGet(C1,@pVarRes,"x"): C1x=pVarRes.dblval
 InvokePropGet(C1,@pVarRes,"y"): C1y=pVarRes.dblval
Print "C1.x: ";C1x
Print "C1.y ";C1y

  InvokeMethod(C1,@pVarRes,"Produit")
Print "Produit: ";pVarRes.dblval

InvokeMethod(C1,@pVarRes,"Somme")
Print "Somme: ";pVarRes.dblval
'Print "C1.Add(C2,50,150): ";C1.Add(C2,50,150)    this one is the same as above
   ' Free Interface
	  variantClear(@C1)   
               variantClear(@C2) 

 
  CoUninitialize()
  Sleep
 
These wrappers for invoke easily makes it possible to write personalized classes of use even simpler: to see the folder " InvokeClass example "
The next chapter will allow us more for an example complicates to apply all that we saw until and especially outward journey one can further with INVOKE method.
aloberoger
Posts: 507
Joined: Jan 13, 2009 19:23

Re: INSIDE ACTIVEX WITH FREEBASIC

Post by aloberoger »

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

Re: INSIDE ACTIVEX WITH FREEBASIC

Post by aloberoger »

I had another idea while replacing
#Define _FBV2013_ by #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")

In this way the method abstract becomes the method by defect. Of course one will be able to always use the vtbl method while specifying at the beginning of our application #define _FB_COM_VTBL_.
I carried out the essence of work already by modifying the following files:
Win/
- docobj.bi
- Oleidl.bi
- Basetyps.bi
- Ole2.bi
- Oaidl.bi
- UnkNown.bi
- Objidl.bi
- Ddraw.bi
- Amaudio.bi
- Objsafe.bi
- Ole.bi
- Oleacc.bi
- Occidl.bi
- Oledlg.bi
- Richole.bi
- Shlobj.bi
- Vfw.bi
- Comcat.bi

Todo :
- Amvideo.bi
- Dsound.bi
- Control.bi
- Strmif.bi
- D3d9.bi
- Dmusicc.bi
- Dmusici.bi
- Dinput.bi
- Mshtml.bi
- Mshtmlst.bi
- Dshow.bi
- Etc.
- I took again the majority of my projects with the method abstract which is shorter and futuristic because the heritage is allowed, should it be pointed out this method becomes the default method of FREEBASIC.
- As long as the team of freebasic will not decide , one will need to always recompile certain projects.
- Therefore that from me focus again on the projects already posted I rather will continue with new Projects:
- - How to use ActiveX Controls with FREEBASIC with management of events
- - How To create exe ActiveX with FREEBASIC


- Before continuing it should be checked that these files are indeed functional here two great written projects of test both with new the headers.
-



- To test the examples install initially the Files headers in Inc / win folder of freebasic
http://www.2shared.com/file/TVGTfHMq/Post3.html
aloberoger
Posts: 507
Joined: Jan 13, 2009 19:23

Re: INSIDE ACTIVEX WITH FREEBASIC

Post by aloberoger »

Exemple of using ActiveX control in your FB programme

Code: Select all

' Requirements: Automatic Template Libraries (ATL)
'************************************************************************
' Embeds an ACTIVEX control within a Form!
'************************************************************************


#Define _FB_COM_VTBL_     ' Uncoment this to compile with virtual methods

#Include Once "windows.bi"
#include Once "Win/ocidl.bi"
#include Once "Win/commdlg.bi"



 
 Declare Function AtlAxWinInit Lib "atl.dll" Alias "AtlAxWinInit" () As Long

Declare Function AtlAxGetControl Lib "atl.dll" Alias "AtlAxGetControl" ( _
                                               ByVal hWnd As HWND, Byval pp As IUNKNOWN Ptr Ptr) As Dword

Declare Function AtlGetObjectSourceInterface Lib "atl.dll" Alias "AtlGetObjectSourceInterface" ( _
                                    ByVal punkObj As IUNKNOWN Ptr, ByRef plibid As Guid, ByRef piid As Guid, _
                                    ByRef pdwMajor As Word, ByRef pdwMinor As Word) As Dword



 


CONST IDC_CTRL  = 1001
CONST IDC_Button1 = 10
Dim Shared  ActX  AS  HWND
Dim Shared  Form  AS  HWND
Dim Shared  Button1 AS HWND


Dim Shared  ptr_DPdf AS IDispatch PTR

Dim Shared Pth As String

Declare Sub InitInterface()
Declare Sub Loadpdf(f As String)


DIM Shared As Integer Style = WS_OVERLAPPEDWINDOW Or WS_CLIPCHILDREN

Declare Function FileOpen(hWnd As HWND, FTypes As String="Any File (*.*)|*.*",FSuggest As String="",DefaultPath As String=ExePath) As String

 

Function ClientWndProc(BYVAL hwnd AS HWND,    _
                       BYVAL msg AS UINT,    _
                       BYVAL wParam AS WPARAM,  _
                       BYVAL lParam AS LPARAM) AS LRESULT
 
Dim  rc AS RECT
SELECT CASE Msg
  CASE WM_SYSCOMMAND
'*****************************************************
' Capture this message and send a WM_DESTROY
' message or the program will remain in memory
'*****************************************************
  IF (wParam  And &hFFF0) = SC_CLOSE THEN
    SendMessage (hWnd, WM_DESTROY, wParam, lParam)
    EXIT FUNCTION
  END If

   CASE WM_COMMAND
   IF LOWORD(wParam) = IDC_Button1 THEN
   DIM A As String
   a=FileOpen(hWnd)
   IF A  <> "" THEN
      Loadpdf (A )
      A  = ""
   END IF
  END IF
 
  CASE WM_SIZE
  IF wParam <> SIZE_MINIMIZED THEN
    GetClientRect (hWnd, @rc)
    MoveWindow(GetDlgItem(hWnd,IDC_CTRL),0,25, rc.right-rc.left,rc.bottom-rc.top-25,TRUE)
  END If

 
   CASE WM_CLOSE
       sendmessage hwnd,WM_DESTROY,0,0
       Return TRUE
       
   CASE WM_DESTROY
    IF ptr_DPdf Then
    	#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
    	   ptr_DPdf->Release()
    	#Else
    	   ptr_DPdf->lpVtbl->Release(ptr_DPdf)
    	#EndIf   
    End IF
    DestroyWindow(ActX)
    PostQuitMessage(0)
    Return TRUE

 CASE WM_DESTROY
  PostQuitMessage(0)
  EXIT FUNCTION
 
END SELECT
 Return DefWindowProc(hwnd, msg, wParam, lParam)
END Function


SUB InitInterface()

   DIM   pUnk AS IUnknown PTR
   DIM   hr   AS HRESULT

   AtlAxGetControl (ActX, @pUnk)

   #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
       hr = pUnk->QueryInterface(Cast(REFIID,@IID_IDispatch), cast(LPVOID Ptr,@ptr_DPdf))
   #Else
       hr = pUnk->lpVtbl->QueryInterface(pUnk,cast(REFIID,@IID_IDispatch), cast(LPVOID Ptr,@ptr_DPdf))
   #EndIf
   IF FAILED(hr) THEN
      MessaGeBOX NULL,"Failed! No Interface","test activeX control",0
   END IF
    #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
       pUnk->Release()
    #Else
      pUnk->lpVtbl->Release(pUnk)
   #EndIf
    
END SUB

Function StrToBSTR(ByVal cnv_string As String) As BSTR
    Dim sb As BSTR
    Dim As Integer n
    n = (MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, cnv_string, -1, NULL, 0))-1
    sb=SysAllocStringLen(sb,n)
    MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, cnv_string, -1, sb, n)
    Return sb
End Function

Sub Loadpdf(f As String)
   Dim fb AS BSTR, vv AS VARIANT, hr AS HRESULT
   DIM dp AS DISPPARAMS

   VariantInit(@vv)
   vv.vt = VT_BSTR
   fb=strtobstr(f)
   vv.bstrVal = fb 
   sysfreestring(fb)
   dp.cArgs = 1
   dp.rgvarg  = @vv

    #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
       hr = ptr_DPdf->Invoke ( 2,@IID_NULL,LOCALE_USER_DEFAULT, DISPATCH_METHOD, @dp, NULL, NULL, NULL)
    #Else
         hr = ptr_DPdf->lpVtbl->Invoke ( ptr_DPdf, 2,@IID_NULL,LOCALE_USER_DEFAULT, DISPATCH_METHOD, @dp, NULL, NULL, NULL)
   #EndIf
   
   VariantClear(@vv)
END SUB


FUNCTION WINMAIN (BYVAL hInstance AS HINSTANCE, BYVAL hPrevInstance AS HINSTANCE, _
                  lpszCmdLine AS zSTRING PTR, BYVAL nCmdShow AS LONG)   AS LONG
 
 
DIM  msg           AS  MSG
DIM  szClassName   AS ZString * 128
DIM  szWindowTitle AS ZString * 128
DIM  wc            AS WNDCLASSEX
 

szClassName = "testpdf.1"
szWindowTitle = "test pdf.ocx"
 
wc.cbSize = SIZEOF(wc)
wc.style =  CS_VREDRAW OR  CS_HREDRAW
wc.lpfnWndProc = @ClientWndProc
wc.cbClsExtra = 0
wc.cbWndExtra = 0
wc.hInstance = hInstance
wc.hIcon = LoadIcon(NULL, BYVAL IDI_APPLICATION )
wc.hIconSm = LoadIcon(NULL, BYVAL IDI_APPLICATION)
wc.hCursor = LoadCursor(NULL, BYVAL IDC_ARROW)
wc.hbrBackground = Cast(HBRUSH,COLOR_BTNFACE + 1)
wc.lpszMenuName = NULL
wc.lpszClassName = StrPtr(szClassName)
 
IF RegisterClassEx(@wc) = 0 THEN
      MessageBeep(0)
    Return  FALSE
    EXIT FUNCTION
END IF

 
 
 
Form = CreateWindowEx(WS_EX_CONTROLPARENT, _
                        szClassName,   _
                        "pdf.ocx with FB", _
                         WS_OVERLAPPEDWINDOW, _
                         CW_USEDEFAULT, _
                         0,  _
                         500, _
                         400,  _
                        NULL, _
                        NULL, _
                        hInstance, _
                        BYVAL NULL)
                        
  AtlAxWinInit     ()   ' Initialize ATL lib
  ActX =CreateWindowEx(0,"AtlAxWin","PDF.PdfCtrl.5",WS_CHILD Or WS_VISIBLE,0,0,0,0,Form,Cast(HMENU,IDC_CTRL),hInstance,NULL)
  Button1 =CreateWindowEx(0,"button","Load pdf",WS_CHILD Or WS_VISIBLE,0,0,80,24,Form,Cast(HMENU,IDC_Button1),hInstance,NULL)
 
  InitInterface
 
  ShowWindow(Form,  SW_SHOWNORMAL)
  UpdateWindow Form
 
 
   
  
  
  IF Command > "" THEN Loadpdf(Command)
  
' message loop
WHILE GetMessage(@msg, NULL, 0, 0)
      TranslateMessage(@msg)
      DispatchMessage(@msg)
WEND
 
Return  FALSE
 
END FUNCTION
 End WINMAIN(getmoduleHandle(0),NULL,Command,SW_SHOW)
 
Function FileOpen(hWnd As HWND, FTypes As String="Any File (*.*)|*.*",FSuggest As String="",DefaultPath As String=ExePath) As String
	Dim ofn As OPENFILENAME
	Dim filename As ZString * MAX_PATH+1

	Dim strFilter As ZString Ptr
	Dim As UInteger strPos 
	 
	 
	' copy from Filter argument into allocated strFilter
	strFilter = New Byte[Len(FTypes) + 2]  
	 
	*strFilter=FTypes
	' needs to be double null terminated
	strFilter[Len(FTypes) + 1] = 0
	 
	For strPos = 0 To Len(FTypes) - 1
		If strFilter[strPos] = Asc("|") Then
			strFilter[strPos] = 0
		EndIf
	Next strPos
	If Len(FSuggest) Then
		filename = FSuggest
	EndIf
	With ofn
		.lStructSize 			= SizeOf( OPENFILENAME )
		.hwndOwner	 			= hWnd
		.hInstance	 			= GetModuleHandle( NULL )
		.lpstrFilter 			= strFilter
		.lpstrCustomFilter 	= NULL
		.nMaxCustFilter 		= 0
		.nFilterIndex 			= 1
		.lpstrFile				= @filename
		.nMaxFile				= SizeOf( filename )
		.lpstrFileTitle		= NULL
		.nMaxFileTitle			= 0
		.lpstrInitialDir		= StrPtr(DefaultPath)
		.lpstrTitle				= @"Open File"
		.Flags					= OFN_EXPLORER Or OFN_FILEMUSTEXIST Or OFN_PATHMUSTEXIST
		.nFileOffset			= 0
		.nFileExtension		= 0
		.lpstrDefExt			= NULL
		.lCustData				= 0
		.lpfnHook				= NULL
		.lpTemplateName		= NULL
	End With

	If GetOpenFileName( @ofn ) = FALSE Then
		filename = ""
	EndIf
	' free memory from our derived filter
	Delete strFilter 
	Return filename
End Function
aloberoger
Posts: 507
Joined: Jan 13, 2009 19:23

Re: INSIDE ACTIVEX WITH FREEBASIC

Post by aloberoger »

managing excell with Invoke wrapper
ExcellInvoke.bas

Code: Select all


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

 

 
Function Main() As Integer
	
    ' Initialize the OLE Library...
    'OleInitialize(NULL)               ' initialized in createobject

    ' VB: Dim  Excapp As Object
    Dim As oleVARIANT Excapp 

    '' VB: Set Excapp = CreateObject "Excel.Application"
      Excapp=  CreateObject("Excel.Application")
 
 
    ' VB: Excapp.workbooks.add
    Dim As oleVARIANT ExcWorkbook 
    
    InvokePropGet (Excapp,@ExcWorkbook, "workbooks") 
    
    InvokeMethod (ExcWorkbook,@ExcWorkbook,"Add")
     
    
    
   'vb: Excapp.visible = true 
 
    InvokePropPut(Excapp,"Visible",Olevariant(-1,VT_BOOL))   ' see "variants.bi" for special case of VARIANT_BOOL
   '' OR 
    'Dim bval As boolean = TRUE
    'InvokePropPut(Excapp,"Visible",bval)    ' must precise boolean


  ' vb:Excapp.ActiveSheet.Cells(3,1).Value = "Hello"
    
    Dim As oleVARIANT ExcSheet,ExcCells 
    InvokePropGet (Excapp,@ExcSheet,"ActiveSheet")
    InvokePropGet(ExcSheet,@ExcCells,"Cells",3,1)
    InvokePropPut(ExcCells,"Value","Hello")
    
    
  ' Excapp.ActiveSheet.Cells(4,1).Value= " COM "
    
    InvokePropGet(ExcSheet,@ExcCells,"Cells",4L, 1L)
    InvokePropPut(ExcCells,"Value","COM")
 
    
 
    
   'Excapp.ActiveSheet.Cells (4,2).Value     = " With FB "
    
   InvokePropGet(ExcSheet,@ExcCells,"Cells",4,2)
   InvokePropPut(ExcCells,"Value","With FB")
   
   
    
  
  
    Dim temp_var as String,rval As olevariant

   ' ' temp_var  = Excapp.ActiveSheet.Cells(3,1).Value
          
    InvokePropGet (ExcApp, @ExcSheet, "ActiveSheet")  ' you can erase this because  ExcSheet is already get
    InvokePropGet(ExcSheet,@ExcCells,"Cells",3L, 1L)
    InvokePropGet(ExcCells,@rVal, "Value")', 0L, 0L)
   
    temp_var=rval
    messagebox NULL,temp_var , "value of cell(3,1)", 4096
     
   

    ' Terminate the OLE Library...
    OleUninitialize()

    return 0
End Function
End Main

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

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

Dim temp_var as string

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

Sleep(1000)
Excapp.activeworkbook.saved = true
Excapp.quit
Set Excapp = Nothing
'/
you need updated files
InvokeHelper.bi

Code: Select all

#Ifndef _INVOKEHELPER_BI_
#Define _INVOKEHELPER_BI_

#Include Once "windows.bi"
#Include Once "crt/stdio.bi"
#Include Once "crt.bi"
#Include Once "win/ocidl.bi"
 
 #Include Once "vbcompat.bi"
 #Include Once "variants.bi"

#Ifndef SystemErrorMessage
 Sub SystemErrorMessage()  
  dim Buffer AS ZString * 255
  Dim ECode AS Long
  FormatMessage FORMAT_MESSAGE_FROM_SYSTEM, BYVAL NULL, ECode, NULL, buffer, SIZEOF(buffer), BYVAL NULL
  MessageBox NULL, FORMAT$(ECode, "##### ") & Buffer, "System Error!",MB_SETFOREGROUND Or MB_ICONHAND
 END Sub
#EndIf
 


#Ifdef COMWRAP
 'return numeric value from variant
Function Variantv(ByRef v As variant)As Double
	Dim vvar As variant
	VariantChangeTypeEx(@vvar,@v,NULL,VARIANT_NOVALUEPROP,VT_R8)
	Return vvar.dblval
End Function

'return string value from variant
Function Variants(ByRef v As variant)As String
	Dim vvar As variant
	VariantChangeTypeEx(@vvar,@v,NULL,VARIANT_NOVALUEPROP,VT_BSTR)
	Function=*Cast(wstring Ptr,vvar.bstrval)	
End Function

'return bstr value from variant
Function Variantb(ByRef v As variant)As bstr
	Dim vvar As variant
	VariantChangeTypeEx(@vvar,@v,NULL,VARIANT_NOVALUEPROP,VT_BSTR)
	Function=vvar.bstrval	
End Function

Function StrToBSTR(ByVal cnv_string As String) As BSTR
    Dim sb As BSTR
    Dim As Integer n
    n = (MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, cnv_string, -1, NULL, 0))-1
    sb=SysAllocStringLen(sb,n)
    MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, cnv_string, -1, sb, n)
    Return sb
End Function
#EndIf

Function TmpStr (Bites As size_t )As ZString Ptr
   Static As Integer   StrCnt 
  static  StrFunc As ZString*2048 
  StrCnt=(StrCnt + 1) And 2047 
  'if(StrFunc( StrCnt)) free (StrFunc( StrCnt)) 
  return Cast(ZString Ptr,calloc(Bites+128,sizeof(char)))
 End Function 
 
Function WideToAnsi (WideStr As BSTR ,CodePage as UINT=CP_ACP ,dwFlags As DWORD=MB_PRECOMPOSED )As ZString ptr
 
 Dim As ZString Ptr RetStr 
 Dim As  UINT uLen
  uLen=WideCharToMultiByte(CodePage,dwFlags,WideStr,-1,0,0,0,0)
  RetStr=cast(ZString Ptr,TmpStr(uLen))
  WideCharToMultiByte(CodePage,dwFlags,WideStr,-1,RetStr,uLen,0,0)
  return RetStr
End function

Function  AnsiToWide (AnsiStr As ZString Ptr,CodePage As  UINT=CP_ACP ,dwFlags As DWORD=MB_PRECOMPOSED )As LPOLESTR
  Dim As UINT uLen 
  Dim As BSTR WideStr 
  uLen=MultiByteToWideChar(CodePage,dwFlags,AnsiStr,-1,0,0)-1 
  if(uLen<=1) Then Return cast(BSTR,TmpStr(2)) 
  WideStr=cast(BSTR,TmpStr(2*uLen)) 
  MultiByteToWideChar(CodePage,dwFlags,AnsiStr,uLen,WideStr,uLen) 
  return WideStr 
End Function



Function CreateObject(ProgID as string) as VARIANT             ' ProgID can also hold string Clsid

  Dim As VARIANT rVal,Vvar  
	Dim As CLSID clsid 		
	Dim As HRESULT hr 
 	

   OleInitialize(NULL) 
   
   If Len(ProgID)=0 Then Return Type(0,0,0,0,0)
    
    
   If InStr(ProgID,"{") Then
   	hr = CLSIDFromString(WStr(ProgID), @clsid) 
   Else
   	hr = CLSIDFromProgID(WStr(ProgID), @clsid) 
   EndIf
     
	if (FAILED(hr)) Then GoTo errorin
  
	' Create an instance of the OLE Automation object and ask for the IDispatch interface. 
	hr = CoCreateInstance(@clsid, NULL,CLSCTX_LOCAL_SERVER or CLSCTX_INPROC_SERVER, @IID_IUnknown, cast(lpvoid Ptr,@rVal.punkval)) 
	If (FAILED(hr)) Then GoTo errorin 
 	#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
 	       hr = rVal.punkval->QueryInterface(@IID_IDispatch, cast(lpvoid Ptr,@rVal.pdispval))
 	      
 	#Else
 	       hr = rVal.punkval->lpvtbl->QueryInterface(rVal.punkval,@IID_IDispatch, cast(lpvoid Ptr,@rVal.pdispval))
 	      
 	#EndIf 
	if (FAILED(hr)) Then 'Return GoTo errorin 
	    rVal.vt=VT_UNKNOWN
	Else
       rVal.vt=VT_DISPATCH
	End If
	
	 VariantCopy(@Vvar, @rVal) 
	 
	 
	#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
	    rVal.punkval->Release() 
	#Else
	    rVal.punkval->lpvtbl->Release(rVal.punkval) 
	#EndIf  
	
	
	   
       VariantClear(@rVal) 
      Return Vvar
 	 
errorin: 
	#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
	   If (rVal.punkval)  Then rVal.punkval->Release() 
	   If (rVal.pdispval) Then rVal.pdispval->Release() 
	#Else
	   If (rVal.punkval)  Then  rVal.punkval->lpvtbl->Release(rVal.punkval) 
	   If (rVal.pdispval) Then  rVal.pdispval->lpvtbl->Release(rVal.pdispval) 
	#EndIf
	ShowOleError(hr)
	return Type(0,0,0,0,0) 
end Function
 
Function VCreateObject(ProgID as string) as VARIANT  ' Only ProgID

 Dim As VARIANT rVal   ' Temporary result holder
 
    ' Initialize the OLE Library...
    OleInitialize(NULL) 

    
   dim as VARIANT Vvar 

         
       Dim As  CLSID clsid 
       CLSIDFromProgID(WStr(ProgID), @clsid) 
       Dim As  HRESULT hr = CoCreateInstance(@clsid, NULL, CLSCTX_LOCAL_SERVER or CLSCTX_INPROC_SERVER, @IID_IDispatch, cast(lpvoid ptr,@rVal.pdispVal))
        if(FAILED(hr))then
         
              dim buf as zstring*256 
           buf= "CoCreateInstance() for  " & ProgID & " failed. Err=&h" & Hex(CInt(hr))
            MessageBox(NULL, buf, "Error", MB_SETFOREGROUND or MB_ICONHAND) 
            Exit Function 
        end if
        rVal.vt = VT_DISPATCH
     
    VariantCopy(@Vvar, @rVal) 
    VariantClear(@rVal) 
      return Vvar
end Function

' Wrapper function for IDispatch->Invoke().
 Function AutoWrap (autoType As Integer ,pvResult as VARIANT Ptr,pDisp as IDispatch Ptr,ptName As LPOLESTR , cArgs As Integer=0 ,pArgs As VARIANT Ptr=NULL )As HRESULT  
 
    if (0=pDisp)Then
        MessageBox(NULL, "NULL IDispatch passed", "AutoWrap()", MB_SETFOREGROUND or MB_ICONHAND)
        return E_UNEXPECTED
    End If

    ' Variables used...
   Dim As  DISPPARAMS dp = ( NULL, NULL, 0, 0 )
   Dim As  DISPID dispidNamed = DISPID_PROPERTYPUT
   Dim As  DISPID dispID
   Dim As  HRESULT hr
   Dim As ZString*200 buf  
   Dim As ZString*200 szName 

    ' Convert name passed to to ANSI...
    WideCharToMultiByte(CP_ACP, 0, ptName, -1, szName, 200, NULL, NULL)

    ' Get DISPID for name passed...
    #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90") 
         hr = pDisp->GetIDsOfNames(@IID_NULL, @ptName, 1, LOCALE_USER_DEFAULT, @dispID)
    #Else
         hr = pDisp->lpVtbl->GetIDsOfNames(pDisp, @IID_NULL, @ptName, 1, LOCALE_USER_DEFAULT, @dispID)
    #EndIf
    if(FAILED(hr))Then
        buf="IDispatch->GetIDsOfNames(" & *Cast(WString Ptr,ptName) & ") failed with error &h" & Hex(CInt(hr)  )
        MessageBox(NULL, buf, "AutoWrap()", MB_SETFOREGROUND or MB_ICONHAND)
        return hr
    End if

   Dim As VARIANTARG Ptr rgvarg = NULL 
	if(cArgs > 0)Then
	 	rgvarg = new VARIANTARG[cArgs] 
		For   i As Integer= 0  to cArgs-1   
			rgvarg[i] = pArgs[cArgs-i-1]
		next	
	End If


    ' Build DISPPARAMS...
    dp.cArgs = cArgs
    dp.rgvarg = rgvarg

    ' Handle special-case for property-puts!
    if (autoType And DISPATCH_PROPERTYPUT)Then
        dp.cNamedArgs = 1
        dp.rgdispidNamedArgs = @dispidNamed
    End If

    ' Make the call!
    #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90") 
       hr = pDisp->Invoke(dispID, @IID_NULL, LOCALE_SYSTEM_DEFAULT, autoType, @dp, pvResult, NULL, NULL)
    #Else
       hr = pDisp->lpVtbl->Invoke(pDisp, dispID, @IID_NULL, LOCALE_SYSTEM_DEFAULT, autoType, @dp, pvResult, NULL, NULL)
    #EndIf
    
    if (FAILED(hr))Then
     
        sprintf(buf, !"IDispatch->Invoke(\"%s\"=%08lx) failed with error 0x%08lx", szName, dispID, hr)
        MessageBox(NULL, buf, "AutoWrap()", MB_SETFOREGROUND or MB_ICONHAND)
        ' Countinue by freeing the memory.
    End If 

     if(cArgs > 0)Then
	 	for i As Integer= 0  to cArgs-1   
			pArgs[cArgs-i-1]=dp.rgvarg[i]
	 	Next	
   End If

    if(cArgs > 0)Then
		delete[] rgvarg 
	End If	

    return hr
end Function

Function InvokePropPut OverLoad (pDisp as IDispatch Ptr,sName As LPOLESTR , nParamCount As Integer ,pParams As VARIANT Ptr )As HRESULT 
	Return AutoWrap(DISPATCH_PROPERTYPUT , NULL, pDisp,sName,nParamCount, pParams)
End Function

Function InvokePropGet OverLoad (pDisp as IDispatch Ptr,pVarRes As VARIANT Ptr,sName As LPOLESTR , nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT 
	Return AutoWrap(DISPATCH_PROPERTYGET or DISPATCH_METHOD, pVarRes, pDisp, sName, nParamCount, pParams)
End Function
 
Function InvokeMethod OverLoad (pDisp as IDispatch Ptr,pVarRes As VARIANT Ptr,sName As LPOLESTR, nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT 
	Return AutoWrap(DISPATCH_METHOD, pVarRes, pDisp,sName,nParamCount,pParams )
End Function

 
 
 
 
Function InvokePropPut (ByVal pDispV as VARIANT,sName As LPOLESTR, nParamCount As Integer ,pParams As VARIANT Ptr)As HRESULT 
	Return InvokePropPut (pDispV.pdispval,sName,nParamCount, pParams)
End Function

Function InvokePropGet (ByVal pDispV as VARIANT,pVarRes As VARIANT Ptr,sName As LPOLESTR , 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 LPOLESTR, nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT 
	Return InvokeMethod(pDispV.pdispval,pVarRes,sName,nParamCount, pParams)
End Function
 
 Function InvokePropGet (ByVal pDispV as VARIANT,sName As LPOLESTR , nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As VARIANT
 	Dim hr As HRESULT 
 	Dim pVarRes As VARIANT  
 	
         hr= InvokePropGet (pDispV,@pVarRes,sName , nParamCount,pParams)
   If hr=s_ok Then Return pVarRes  Else Return Type(0,0,0,0,0)   
 End Function
 
 
 Function InvokeFunction OverLoad(ByVal pDispV as VARIANT,sName As LPOLESTR, nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As VARIANT 
	Dim hr As HRESULT 
	Dim pVarRes As VARIANT
	hr= InvokeMethod(pDispV,@pVarRes,sName,nParamCount, pParams)
	If hr=s_ok Then Return pVarRes  Else Return Type(0,0,0,0,0)
 End Function
 
 Function InvokeSub OverLoad(ByVal pDispV as VARIANT,sName As LPOLESTR, nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT 
	Return InvokeMethod(pDispV.pdispval,NULL,sName,nParamCount, pParams)
 End Function
 
 ' NOM DES FUNCTIONS EN STRING       VARIANT EN PARAMETRES
 
Function InvokePropPut (ByVal pDispV as VARIANT,sName As string, nParamCount As Integer ,pParams As VARIANT Ptr)As HRESULT 
	Return InvokePropPut (pDispV.pdispval,AnsiToWide(StrPtr(sName)),nParamCount, pParams)
End Function

Function InvokePropGet (ByVal pDispV as VARIANT,pVarRes As VARIANT Ptr,sName As String , nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT 
	Return InvokePropGet (pDispV.pdispval,pVarRes,AnsiToWide(StrPtr(sName)),nParamCount, pParams)
End Function
 
Function InvokeMethod (ByVal pDispV as VARIANT,pVarRes As VARIANT Ptr,sName As String, nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT 
	Return InvokeMethod(pDispV.pdispval,pVarRes,AnsiToWide(StrPtr(sName)),nParamCount, pParams)
End Function
 
 Function InvokePropGet OverLoad (ByVal pDispV as VARIANT,sName As string , nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As VARIANT
 	Dim hr As HRESULT 
 	Dim pVarRes As VARIANT  
         hr= InvokePropGet (pDispV,@pVarRes,sName ,nParamCount,pParams)
   If hr=s_ok Then Return pVarRes  Else Return Type(0,0,0,0,0)   
 End Function
 
  Function PropGet OverLoad(ByVal pDispV as VARIANT,sName As string , nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As String
  	   Dim V As VARIANT
  	   V=InvokePropGet (pDispV,sName , nParamCount,pParams)
   Dim vvar As VARIANT
	VariantChangeTypeEx(@vvar,@v,NULL,VARIANT_NOVALUEPROP,VT_BSTR)
	Return *Cast(wstring Ptr,vvar.bstrval)	
 
  End Function
  
   
  
  
 Function InvokeFunction OverLoad(ByVal pDispV as VARIANT,sName As string , nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As VARIANT 
	Dim hr As HRESULT 
	Dim pVarRes As VARIANT
	hr= InvokeMethod(pDispV,@pVarRes,sName,nParamCount, pParams)
	If hr=s_ok Then Return pVarRes  Else Return Type(0,0,0,0,0)
 End Function

 
 Function InvokeSub (ByVal pDispV as VARIANT,sName As string , nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT 
	Return InvokeMethod(pDispV.pdispval,NULL,sName,nParamCount, pParams)
 End Function
 
 
 
 
 
 Function InvokePropPut (pDisp as IDispatch Ptr,sName As String , nParamCount As Integer ,pParams As VARIANT Ptr)As HRESULT 
	Return AutoWrap(DISPATCH_PROPERTYPUT , NULL, pDisp,AnsiToWide(StrPtr(sName)),nParamCount, pParams)
End Function


Function InvokePropGet (pDisp as IDispatch Ptr,pVarRes As VARIANT Ptr,sName As String , nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT 
	Return AutoWrap(DISPATCH_PROPERTYGET or DISPATCH_METHOD, pVarRes, pDisp, AnsiToWide(StrPtr(sName)), nParamCount, pParams)
End Function
 
Function InvokeMethod (pDisp as IDispatch Ptr,pVarRes As VARIANT Ptr,sName As String, nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT 
	Return AutoWrap(DISPATCH_METHOD, pVarRes, pDisp,AnsiToWide(StrPtr(sName)),nParamCount,pParams )
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 
	#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
	  hr= pDispatch->Invoke(propid, @IID_NULL, LOCALE_USER_DEFAULT,DISPATCH_PROPERTYGET, @dispparams, pVarRes, NULL, NULL) 
	#Else
	  hr= pDispatch->lpvtbl->Invoke(pDispatch,propid, @IID_NULL, LOCALE_USER_DEFAULT, _
			    DISPATCH_PROPERTYGET, @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

''***************************************************************************************
'' InvokePropPut :
''***************************************************************************************
Function InvokePropPut OverLoad (pDispatch  as IDispatch Ptr,propid As DISPID , nParamCount As Integer ,pVarNew As VARIANT Ptr)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), 1, 1)

	'' appel de Invoke
	Dim As HRESULT hr 
	#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
	   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_) And (__FB_VERSION__ >= "0.90")
	     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

Function InvokePropGet OverLoad (v As VARIANT,propid As DISPID ,pVarRes As VARIANT Ptr,nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT 
	Return InvokePropGet(v.pdispval,propid,pVarRes,nParamCount,pParams)
End Function

Function InvokePropPut OverLoad (v As VARIANT,propid As DISPID , nParamCount As Integer ,pVarNew As VARIANT Ptr)As HRESULT 
	Return InvokePropPut(v.pdispval,propid,nParamCount,pVarNew)
End Function

Function InvokeMethod OverLoad (v As VARIANT,pVarRes As VARIANT Ptr,methodid As DISPID, nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT 
	Return InvokeMethod(v.pdispval, pVarRes,methodid,nParamCount,pParams)
End Function

' 12/2013 ******************************** AVEC OLEVARIANT ****************************************************
Function InvokePropGet OverLoad (v As OLEVARIANT,pVarRes As OLEVARIANT Ptr,sName As String )As HRESULT 
	Dim v1 As VARIANT 
	v1=v  
	*pVarRes=InvokePropGet(v1,sName) 
 Return s_ok                           'InvokePropGet(v1 ,Cast(VARIANT Ptr,pVarRes),sName)',0,Cast(VARIANT Ptr,NULL)) ambiguite
End Function

Function InvokePropGet OverLoad (v As OLEVARIANT,pVarRes As OLEVARIANT Ptr,sName As String ,param1 As OLEVARIANT)As HRESULT 
	Dim v1 As VARIANT,Params(1) As VARIANT
	v1=v : Params(0)=param1
	Return InvokePropGet(v1 ,Cast(VARIANT Ptr,pVarRes),sName,1,@Params(0))
End Function

Function InvokePropGet OverLoad (v As OLEVARIANT,pVarRes As OLEVARIANT Ptr,sName As String, param1 As OLEVARIANT,param2 As OLEVARIANT)As HRESULT 
	Dim v1 As VARIANT,Params(2) As VARIANT
	v1=v : Params(0)=param1 : Params(1)=param2
	Return InvokePropGet(v1,Cast(VARIANT Ptr,pVarRes),sName,2,@Params(0))
End Function

Function InvokePropPut OverLoad (v As OLEVARIANT,sName As String ,param1 As OLEVARIANT)As HRESULT 
	Dim v1 As VARIANT,Params(1) As VARIANT
	v1=v : Params(0)=param1  
	Return InvokePropPut(v1,sName,1,@Params(0))
End Function

Function InvokePropPut OverLoad (v As OLEVARIANT,sName As String ,param1 As OLEVARIANT,param2 As OLEVARIANT)As HRESULT 
	Dim v1 As VARIANT,Params(2) As VARIANT
	v1=v : Params(0)=param1 : Params(1)=param2
	Return InvokePropPut(v1,sName,2,@Params(0))
End Function

Function InvokePropPut OverLoad (v As OLEVARIANT,sName As String ,param1 As OLEVARIANT,param2 As OLEVARIANT,param3 As OLEVARIANT)As HRESULT 
	Dim v1 As VARIANT,Params(3) As VARIANT
	v1=v : Params(0)=param1 : Params(1)=param2 : Params(2)=param3
	Return InvokePropPut(v1,sName,3,@Params(0))
End Function

Function InvokeMethod OverLoad (v As OLEVARIANT,sName As String)As HRESULT 
	Dim v1 As VARIANT : v1=v
	Return InvokeMethod(v1, NULL,sName,0,NULL)
End Function


Function InvokeMethod OverLoad (v As OLEVARIANT,pVarRes As OLEVARIANT Ptr,sName As String)As HRESULT 
		Dim v1 As VARIANT : v1=v
	Return InvokeMethod(v1, Cast(VARIANT Ptr,pVarRes),sName,0,Cast(VARIANT Ptr,NULL))
End Function


Function InvokeMethod OverLoad (v As OLEVARIANT,pVarRes As OLEVARIANT Ptr,sName As String,param1 As OLEVARIANT)As HRESULT 
	Dim v1 As VARIANT,Params(1) As VARIANT
	v1=v : Params(0)=param1  
	Return InvokeMethod(v1, Cast(VARIANT Ptr,pVarRes),sName,1,@Params(0))
End Function


Function InvokeMethod OverLoad (v As OLEVARIANT,pVarRes As OLEVARIANT Ptr,sName As String,param1 As OLEVARIANT,param2 As OLEVARIANT)As HRESULT 
	Dim v1 As VARIANT,Params(2) As VARIANT
	v1=v : Params(0)=param1: Params(1)=param2  
	Return InvokeMethod(v1,Cast(VARIANT Ptr,pVarRes),sName,2,@Params(0))
End Function

Function InvokeMethod OverLoad (v As OLEVARIANT,pVarRes As OLEVARIANT Ptr,sName As String,param1 As OLEVARIANT,param2 As OLEVARIANT,param3 As OLEVARIANT)As HRESULT 
	Dim v1 As VARIANT,Params(3) As VARIANT
	v1=v : Params(0)=param1: Params(1)=param2 : Params(2)=param3 
	Return InvokeMethod(v1,Cast(VARIANT Ptr,pVarRes),sName,3,@Params(0))
End Function

Function InvokeMethod OverLoad (v As OLEVARIANT,sName As String,param1 As OLEVARIANT,param2 As OLEVARIANT,param3 As OLEVARIANT)As HRESULT 
	Dim v1 As VARIANT,Params(3) As VARIANT,pVarRes As OLEVARIANT   
	v1=v : Params(0)=param1: Params(1)=param2 : Params(2)=param3 
	Return InvokeMethod(v1,Cast(VARIANT Ptr,@pVarRes),sName,3,@Params(0))
End Function

Function InvokeMethod OverLoad (v As OLEVARIANT,pVarRes As OLEVARIANT Ptr,sName As String,param1 As OLEVARIANT,param2 As OLEVARIANT,param3 As OLEVARIANT,param4 As OLEVARIANT)As HRESULT 
	Dim v1 As VARIANT,Params(4) As VARIANT
	v1=v : Params(0)=param1: Params(1)=param2 : Params(2)=param3 : Params(3)=param4
	Return InvokeMethod(v1,Cast(VARIANT Ptr,pVarRes),sName,4,@Params(0))
End Function

Function InvokeMethod OverLoad (v As OLEVARIANT,sName As String,param1 As OLEVARIANT,param2 As OLEVARIANT,param3 As OLEVARIANT,param4 As OLEVARIANT)As HRESULT 
	Dim v1 As VARIANT,Params(4) As VARIANT,pVarRes As OLEVARIANT  
	v1=v : Params(0)=param1: Params(1)=param2 : Params(2)=param3 : Params(3)=param4
	Return InvokeMethod(v1,Cast(VARIANT Ptr,@pVarRes),sName,4,@Params(0))
End Function

Function InvokeMethod OverLoad (v As OLEVARIANT,pVarRes As OLEVARIANT Ptr,sName As String,param1 As OLEVARIANT,param2 As OLEVARIANT,param3 As OLEVARIANT,param4 As OLEVARIANT,param5 As OLEVARIANT)As HRESULT 
	Dim v1 As VARIANT,Params(5) As VARIANT
	v1=v : Params(0)=param1: Params(1)=param2 : Params(2)=param3 : Params(3)=param4 : Params(4)=param5
	Return InvokeMethod(v1,Cast(VARIANT Ptr,pVarRes),sName,5,@Params(0))
End Function

Function InvokeMethod OverLoad (v As OLEVARIANT,sName As String,param1 As OLEVARIANT,param2 As OLEVARIANT,param3 As OLEVARIANT,param4 As OLEVARIANT,param5 As OLEVARIANT)As HRESULT 
	Dim v1 As VARIANT,Params(5) As VARIANT,pVarRes As OLEVARIANT  
	v1=v : Params(0)=param1: Params(1)=param2 : Params(2)=param3 : Params(3)=param4 : Params(4)=param5
	Return InvokeMethod(v1,Cast(VARIANT Ptr,@pVarRes),sName,5,@Params(0))
End Function
Function InvokeMethod OverLoad (v As OLEVARIANT,pVarRes As OLEVARIANT Ptr,sName As String,param1 As OLEVARIANT,param2 As OLEVARIANT,param3 As OLEVARIANT,param4 As OLEVARIANT,param5 As OLEVARIANT,param6 As OLEVARIANT)As HRESULT 
	Dim v1 As VARIANT,Params(6) As VARIANT
	v1=v : Params(0)=param1: Params(1)=param2 : Params(2)=param3 : Params(3)=param4 : Params(4)=param5: Params(5)=param6 
	Return InvokeMethod(v1,Cast(VARIANT Ptr,pVarRes),sName,6,@Params(0))
End Function

Function InvokeMethod OverLoad (v As OLEVARIANT,sName As String,param1 As OLEVARIANT,param2 As OLEVARIANT,param3 As OLEVARIANT,param4 As OLEVARIANT,param5 As OLEVARIANT,param6 As OLEVARIANT)As HRESULT 
	Dim v1 As VARIANT,Params(6) As VARIANT,pVarRes As OLEVARIANT  
	v1=v : Params(0)=param1: Params(1)=param2 : Params(2)=param3 : Params(3)=param4 : Params(4)=param5: Params(5)=param6 
	Return InvokeMethod(v1,Cast(VARIANT Ptr,@pVarRes),sName,6,@Params(0))
End Function
Function InvokeMethod OverLoad (v As OLEVARIANT,pVarRes As OLEVARIANT Ptr,sName As String,param1 As OLEVARIANT,param2 As OLEVARIANT,param3 As OLEVARIANT,param4 As OLEVARIANT,param5 As OLEVARIANT,param6 As OLEVARIANT,param7 As OLEVARIANT)As HRESULT 
	Dim v1 As VARIANT,Params(7) As VARIANT
	v1=v : Params(0)=param1: Params(1)=param2 : Params(2)=param3 : Params(3)=param4 : Params(4)=param5: Params(5)=param6 : Params(6)=param7
	Return InvokeMethod(v1,Cast(VARIANT Ptr,pVarRes),sName,7,@Params(0))
End Function

Function InvokeMethod OverLoad (v As OLEVARIANT,pVarRes As OLEVARIANT Ptr,sName As String,param1 As OLEVARIANT,param2 As OLEVARIANT,param3 As OLEVARIANT,param4 As OLEVARIANT,param5 As OLEVARIANT,param6 As OLEVARIANT,param7 As OLEVARIANT,param8 As OLEVARIANT)As HRESULT 
	Dim v1 As VARIANT,Params(8) As VARIANT
	v1=v : Params(0)=param1: Params(1)=param2 : Params(2)=param3 : Params(3)=param4 : Params(4)=param5: Params(5)=param6 : Params(6)=param7 : Params(7)=param8
	Return InvokeMethod(v1,Cast(VARIANT Ptr,pVarRes),sName,8,@Params(0))
End Function

Function InvokeMethod OverLoad (v As OLEVARIANT,sName As String,param1 As OLEVARIANT,param2 As OLEVARIANT,param3 As OLEVARIANT,param4 As OLEVARIANT,param5 As OLEVARIANT,param6 As OLEVARIANT,param7 As OLEVARIANT,param8 As OLEVARIANT)As HRESULT 
	Dim v1 As VARIANT,Params(8) As VARIANT,pVarRes As OLEVARIANT  
	v1=v : Params(0)=param1: Params(1)=param2 : Params(2)=param3 : Params(3)=param4 : Params(4)=param5: Params(5)=param6 : Params(6)=param7 : Params(7)=param8
	Return InvokeMethod(v1,Cast(VARIANT Ptr,@pVarRes),sName,8,@Params(0))
End Function

Function InvokeMethod OverLoad (v As OLEVARIANT,pVarRes As OLEVARIANT Ptr,sName As String,param1 As OLEVARIANT,param2 As OLEVARIANT,param3 As OLEVARIANT,param4 As OLEVARIANT,param5 As OLEVARIANT,param6 As OLEVARIANT,param7 As OLEVARIANT,param8 As OLEVARIANT,param9 As OLEVARIANT)As HRESULT 
	Dim v1 As VARIANT,Params(9) As VARIANT
	v1=v : Params(0)=param1: Params(1)=param2 : Params(2)=param3 : Params(3)=param4 : Params(4)=param5: Params(5)=param6 : Params(6)=param7 : Params(7)=param8 : Params(8)=param9
	Return InvokeMethod(v1,Cast(VARIANT Ptr,pVarRes),sName,9,@Params(0))
End Function

Function InvokeMethod OverLoad (v As OLEVARIANT,pVarRes As OLEVARIANT Ptr,sName As String,param1 As OLEVARIANT,param2 As OLEVARIANT,param3 As OLEVARIANT,param4 As OLEVARIANT,param5 As OLEVARIANT,param6 As OLEVARIANT,param7 As OLEVARIANT,param8 As OLEVARIANT,param9 As OLEVARIANT,param10 As OLEVARIANT)As HRESULT 
	Dim v1 As VARIANT,Params(10) As VARIANT
	v1=v : Params(0)=param1: Params(1)=param2 : Params(2)=param3 : Params(3)=param4 : Params(4)=param5: Params(5)=param6 : Params(6)=param7 : Params(7)=param8 : Params(8)=param9 : Params(9)=param10
	Return InvokeMethod(v1,Cast(VARIANT Ptr,pVarRes),sName,10,@Params(0))
End Function

Function InvokeMethod OverLoad (v As OLEVARIANT,pVarRes As OLEVARIANT Ptr,sName As String,param1 As OLEVARIANT,param2 As OLEVARIANT,param3 As OLEVARIANT,param4 As OLEVARIANT,param5 As OLEVARIANT,param6 As OLEVARIANT,param7 As OLEVARIANT,param8 As OLEVARIANT,param9 As OLEVARIANT,param10 As OLEVARIANT,param11 As OLEVARIANT)As HRESULT 
	Dim v1 As VARIANT,Params(11) As VARIANT
	v1=v : Params(0)=param1: Params(1)=param2 : Params(2)=param3 : Params(3)=param4 : Params(4)=param5: Params(5)=param6 : Params(6)=param7 : Params(7)=param8 : Params(8)=param9 : Params(9)=param10: Params(10)=param11
	Return InvokeMethod(v1,Cast(VARIANT Ptr,pVarRes),sName,11,@Params(0))
End Function

Function InvokeMethod OverLoad (v As OLEVARIANT,pVarRes As OLEVARIANT Ptr,sName As String,param1 As OLEVARIANT,param2 As OLEVARIANT,param3 As OLEVARIANT,param4 As OLEVARIANT,param5 As OLEVARIANT,param6 As OLEVARIANT,param7 As OLEVARIANT,param8 As OLEVARIANT,param9 As OLEVARIANT,param10 As OLEVARIANT,param11 As OLEVARIANT,param12 As OLEVARIANT)As HRESULT 
	Dim v1 As VARIANT,Params(12) As VARIANT
	v1=v : Params(0)=param1: Params(1)=param2 : Params(2)=param3 : Params(3)=param4 : Params(4)=param5: Params(5)=param6 : Params(6)=param7 : Params(7)=param8 : Params(8)=param9 : Params(9)=param10: Params(10)=param11 : Params(11)=param12
	Return InvokeMethod(v1,Cast(VARIANT Ptr,pVarRes),sName,12,@Params(0))
End Function

Function InvokeMethod OverLoad (v As OLEVARIANT,pVarRes As OLEVARIANT Ptr,sName As String,param1 As OLEVARIANT,param2 As OLEVARIANT,param3 As OLEVARIANT,param4 As OLEVARIANT,param5 As OLEVARIANT,param6 As OLEVARIANT,param7 As OLEVARIANT,param8 As OLEVARIANT, _
	                              param9 As OLEVARIANT,param10 As OLEVARIANT,param11 As OLEVARIANT,param12 As OLEVARIANT,param13 As OLEVARIANT)As HRESULT 
	Dim v1 As VARIANT,Params(13) As VARIANT
	v1=v : Params(0)=param1: Params(1)=param2 : Params(2)=param3 : Params(3)=param4 : Params(4)=param5: Params(5)=param6 : Params(6)=param7 : Params(7)=param8 : Params(8)=param9 : Params(9)=param10: Params(10)=param11 : Params(11)=param12 : Params(12)=param13
	Return InvokeMethod(v1,Cast(VARIANT Ptr,pVarRes),sName,13,@Params(0))
End Function

Function InvokeMethod OverLoad (v As OLEVARIANT,pVarRes As OLEVARIANT Ptr,sName As String,param1 As OLEVARIANT,param2 As OLEVARIANT,param3 As OLEVARIANT,param4 As OLEVARIANT,param5 As OLEVARIANT,param6 As OLEVARIANT,param7 As OLEVARIANT,param8 As OLEVARIANT, _
	                              param9 As OLEVARIANT,param10 As OLEVARIANT,param11 As OLEVARIANT,param12 As OLEVARIANT,param13 As OLEVARIANT,param14 As OLEVARIANT)As HRESULT  
	Dim v1 As VARIANT,Params(14) As VARIANT
	v1=v : Params(0)=param1: Params(1)=param2 : Params(2)=param3 : Params(3)=param4 : Params(4)=param5: Params(5)=param6 : Params(6)=param7 : Params(7)=param8 : Params(8)=param9 : Params(9)=param10: Params(10)=param11 : Params(11)=param12 : Params(12)=param13 : Params(13)=param14
	Return InvokeMethod(v1,Cast(VARIANT Ptr,pVarRes),sName,14,@Params(0))
End Function



Function InvokeMethod OverLoad (v As OLEVARIANT,pVarRes As OLEVARIANT Ptr,sName As String,param1 As OLEVARIANT,param2 As OLEVARIANT,param3 As OLEVARIANT,param4 As OLEVARIANT,param5 As OLEVARIANT,param6 As OLEVARIANT,param7 As OLEVARIANT,param8 As OLEVARIANT, _
	                              param9 As OLEVARIANT,param10 As OLEVARIANT,param11 As OLEVARIANT,param12 As OLEVARIANT,param13 As OLEVARIANT,param14 As OLEVARIANT,param15 As OLEVARIANT)As HRESULT  
	Dim v1 As VARIANT,Params(15) As VARIANT
	v1=v : Params(0)=param1: Params(1)=param2 : Params(2)=param3 : Params(3)=param4 : Params(4)=param5: Params(5)=param6 : Params(6)=param7 : Params(7)=param8 : Params(8)=param9 : Params(9)=param10: Params(10)=param11 : Params(11)=param12 : Params(12)=param13 : Params(13)=param14 : Params(14)=param15
	Return InvokeMethod(v1,Cast(VARIANT Ptr,pVarRes),sName,15,@Params(0))
End Function

Function InvokeMethod OverLoad (v As OLEVARIANT,pVarRes As OLEVARIANT Ptr,sName As String,param1 As OLEVARIANT,param2 As OLEVARIANT,param3 As OLEVARIANT,param4 As OLEVARIANT,param5 As OLEVARIANT,param6 As OLEVARIANT,param7 As OLEVARIANT,param8 As OLEVARIANT, _
	                              param9 As OLEVARIANT,param10 As OLEVARIANT,param11 As OLEVARIANT,param12 As OLEVARIANT,param13 As OLEVARIANT,param14 As OLEVARIANT,param15 As OLEVARIANT,param16 As OLEVARIANT)As HRESULT  
	Dim v1 As VARIANT,Params(16) As VARIANT
	v1=v : Params(0)=param1: Params(1)=param2 : Params(2)=param3 : Params(3)=param4 : Params(4)=param5: Params(5)=param6 : Params(6)=param7 : Params(7)=param8 : Params(8)=param9 : Params(9)=param10: Params(10)=param11 : Params(11)=param12 : Params(12)=param13 : Params(13)=param14 : Params(14)=param15 : Params(15)=param16
	Return InvokeMethod(v1,Cast(VARIANT Ptr,pVarRes),sName,16,@Params(0))
End Function

Function InvokeMethod OverLoad (v As OLEVARIANT,pVarRes As OLEVARIANT Ptr,sName As String,param1 As OLEVARIANT,param2 As OLEVARIANT,param3 As OLEVARIANT,param4 As OLEVARIANT,param5 As OLEVARIANT,param6 As OLEVARIANT,param7 As OLEVARIANT,param8 As OLEVARIANT, _
	                              param9 As OLEVARIANT,param10 As OLEVARIANT,param11 As OLEVARIANT,param12 As OLEVARIANT,param13 As OLEVARIANT,param14 As OLEVARIANT,param15 As OLEVARIANT,param16 As OLEVARIANT,param17 As OLEVARIANT)As HRESULT  
	Dim v1 As VARIANT,Params(17) As VARIANT
	v1=v : Params(0)=param1: Params(1)=param2 : Params(2)=param3 : Params(3)=param4 : Params(4)=param5: Params(5)=param6 : Params(6)=param7 : Params(7)=param8 : Params(8)=param9 : Params(9)=param10: Params(10)=param11 : Params(11)=param12 : Params(12)=param13 : Params(13)=param14 : Params(14)=param15 : Params(15)=param16 : Params(16)=param17
	Return InvokeMethod(v1,Cast(VARIANT Ptr,pVarRes),sName,17,@Params(0))
End Function

Function InvokeMethod OverLoad (v As OLEVARIANT,pVarRes As OLEVARIANT Ptr,sName As String,param1 As OLEVARIANT,param2 As OLEVARIANT,param3 As OLEVARIANT,param4 As OLEVARIANT,param5 As OLEVARIANT,param6 As OLEVARIANT,param7 As OLEVARIANT,param8 As OLEVARIANT, _
	                              param9 As OLEVARIANT,param10 As OLEVARIANT,param11 As OLEVARIANT,param12 As OLEVARIANT,param13 As OLEVARIANT,param14 As OLEVARIANT,param15 As OLEVARIANT,param16 As OLEVARIANT,param17 As OLEVARIANT,param18 As OLEVARIANT)As HRESULT  
	Dim v1 As VARIANT,Params(18) As VARIANT
	v1=v : Params(0)=param1: Params(1)=param2 : Params(2)=param3 : Params(3)=param4 : Params(4)=param5: Params(5)=param6 : Params(6)=param7 : Params(7)=param8 : Params(8)=param9 : Params(9)=param10: Params(10)=param11 : Params(11)=param12 : Params(12)=param13 : Params(13)=param14 : Params(14)=param15 : Params(15)=param16 : Params(16)=param17 : Params(17)=param18
	Return InvokeMethod(v1,Cast(VARIANT Ptr,pVarRes),sName,18,@Params(0))
End Function

Function InvokeMethod OverLoad (v As OLEVARIANT,pVarRes As OLEVARIANT Ptr,sName As String,param1 As OLEVARIANT,param2 As OLEVARIANT,param3 As OLEVARIANT,param4 As OLEVARIANT,param5 As OLEVARIANT,param6 As OLEVARIANT,param7 As OLEVARIANT,param8 As OLEVARIANT, _
	                              param9 As OLEVARIANT,param10 As OLEVARIANT,param11 As OLEVARIANT,param12 As OLEVARIANT,param13 As OLEVARIANT,param14 As OLEVARIANT,param15 As OLEVARIANT,param16 As OLEVARIANT,param17 As OLEVARIANT,param18 As OLEVARIANT,param19 As OLEVARIANT)As HRESULT  
	Dim v1 As VARIANT,Params(19) As VARIANT
	v1=v : Params(0)=param1: Params(1)=param2 : Params(2)=param3 : Params(3)=param4 : Params(4)=param5: Params(5)=param6 : Params(6)=param7 : Params(7)=param8 : Params(8)=param9 : Params(9)=param10: Params(10)=param11 : Params(11)=param12 : Params(12)=param13 : Params(13)=param14 : Params(14)=param15 : Params(15)=param16 : Params(16)=param17: Params(17)=param18 : Params(18)=param19
	Return InvokeMethod(v1,Cast(VARIANT Ptr,pVarRes),sName,19,@Params(0))
End Function

Function InvokeMethod OverLoad (v As OLEVARIANT,pVarRes As OLEVARIANT Ptr,sName As String,param1 As OLEVARIANT,param2 As OLEVARIANT,param3 As OLEVARIANT,param4 As OLEVARIANT,param5 As OLEVARIANT,param6 As OLEVARIANT,param7 As OLEVARIANT,param8 As OLEVARIANT, _
	                              param9 As OLEVARIANT,param10 As OLEVARIANT,param11 As OLEVARIANT,param12 As OLEVARIANT,param13 As OLEVARIANT,param14 As OLEVARIANT,param15 As OLEVARIANT,param16 As OLEVARIANT,param17 As OLEVARIANT,param18 As OLEVARIANT,param19 As OLEVARIANT,param20 As OLEVARIANT)As HRESULT  
	Dim v1 As VARIANT,Params(20) As VARIANT
	v1=v : Params(0)=param1: Params(1)=param2 : Params(2)=param3 : Params(3)=param4 : Params(4)=param5: Params(5)=param6 : Params(6)=param7 : Params(7)=param8 : Params(8)=param9 : Params(9)=param10: Params(10)=param11 : Params(11)=param12 : Params(12)=param13 : Params(13)=param14 : Params(14)=param15 : Params(15)=param16 : Params(16)=param17 : Params(17)=param18: Params(18)=param19 : Params(19)=param20
	Return InvokeMethod(v1,Cast(VARIANT Ptr,pVarRes),sName,20,@Params(0))
End Function

' Plus de 20 parametres

Function InvokeMethod OverLoad (v As OLEVARIANT,pVarRes As OLEVARIANT Ptr,sName As String,nparamcount As Integer,pparams As OLEVARIANT Ptr)As HRESULT 
		Dim v1 As VARIANT : v1=v
	Return InvokeMethod(v1, Cast(VARIANT Ptr,Cast(OLEVARIANT Ptr,pVarRes)),sName,nparamcount,Cast(VARIANT Ptr,pparams))
End Function

 Function InvokeFunction OverLoad (v As OLEVARIANT,sName As String,nparamcount As Integer,pparams As OLEVARIANT Ptr)As olevariant
		Dim pVarRes As OLEVARIANT ,hr As HRESULT 
		Dim v1 As VARIANT : v1=v
	  hr=InvokeMethod(v1, Cast(VARIANT Ptr,Cast(OLEVARIANT Ptr,@pVarRes)),sName,nparamcount,Cast(VARIANT Ptr,pparams))
	  'ShowOleError(hr)
	  Return pVarRes
End Function

#EndIf

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

Re: INSIDE ACTIVEX WITH FREEBASIC

Post by aloberoger »

And
variants.bi

Code: Select all

#include once "windows.bi"
#include once "win/ole2.bi"

#include Once "crt/string.bi"

#Ifndef SysErrorMessage
Function SysErrorMessage(Errorn As Integer) As String
     Dim Buffer As String
     Buffer = Space$(256)
     #Ifdef __WIN32API
     FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, 0, Errorn, LANG_NEUTRAL, @Buffer, 200, 0)
     #ENDIF
     Return RTrim$(Buffer)
End Function
#EndIf

Function CheckError(hr As HRESULT) As String
	IF hr <> S_OK THEN
    Select Case  hr
      Case REGDB_E_CLASSNOTREG
            Return  "A specified class is not registered in the registration database."
    	Case CLASS_E_NOAGGREGATION
            Return  "This class cannot be created as part of an aggregate."
    	Case CLASS_E_CLASSNOTAVAILABLE
            Return  "Class Not Available."
    	Case Else
         Return "Control creation Failed - Error number: " & str$(CInt(hr))
         
    END Select         
END IF

 End Function
 
'#EndIf


#Ifndef ShowOleError
Sub ShowOleError  (hr As HRESULT, addit As String="")
 Dim serr As String
 If hr=s_ok Then 
 	Exit Sub
 Else
 	serr=CheckError(hr) & addit
	MessageBox (getactiveWindow(),serr,"OLE ERROR ",MB_OK OR MB_ICONERROR  OR MB_SYSTEMMODAL)
endif
End Sub
#EndIf
 

 'NB: the operator like += -= or not - = + etc. are not important since you can use them with standard type and then assign to olevariant


Type _RECORD
	pvRecord AS PVOID
	pRecInfo AS IRecordInfo Ptr
End Type

Type Widestring As BSTR
       
Type OleVariant
    private:
       dim v as VARIANT
    public:
      
      declare constructor()
      declare constructor(ByRef value As OleVariant) ' pour retouner un Olevariant dans une function
      declare constructor(Byval value As OleVariant Ptr) ' pour retouner un Olevariant dans une function
      declare constructor(ByVal value As VARIANT)    ' pour pouvoir écrire: dim as olevariant vv=v
      declare Constructor (ByVal value As VARIANT Ptr)
      declare Constructor (byval value as String )
      declare Constructor (byval value as String Ptr)
      declare Constructor (ByVal value as wstring Ptr)
      declare constructor(ByVal value As Single)
      declare constructor(ByVal value As Single Ptr)
      declare constructor(ByVal value As BSTR)
      declare constructor(ByVal value As BSTR PTR)
      Declare constructor(ByVal value As Integer)
      Declare constructor(ByVal value As Integer Ptr)
      declare constructor(ByVal value As Long)
      declare constructor(ByVal value As Long Ptr)
      declare constructor(ByVal value As SAFEARRAY Ptr)
      declare constructor(ByVal value As SAFEARRAY Ptr Ptr) 
      declare constructor(ByVal value As IDispatch Ptr)
      declare constructor(ByVal value As IDispatch Ptr Ptr)
      declare Constructor(ByVal value as  IUnknown Ptr)
      declare Constructor(ByVal value as  IUnknown Ptr Ptr) 
      Declare Constructor (ByVal As IFONTDISP Ptr)
      Declare Constructor (ByVal value As IFONTDISP Ptr Ptr)
      Declare Constructor (ByVal As IPICTUREDISP Ptr)
      declare destructor()
      Declare Constructor(value As Short , vtSrc as VARTYPE = VT_I2) 	' Creates a VT_I2, or a VT_BOOL
      Declare Constructor(value As Short Ptr , vtSrc as VARTYPE = VT_I2) 	' Creates a VT_I2, or a VT_BOOL
	  
      Declare Constructor(value As Double , vtSrc as VARTYPE = VT_R8) 	' Creates a VT_R8, or a VT_DATE
	   Declare Constructor(value As Double ptr, vtSrc as VARTYPE = VT_R8)
	   Declare Constructor(byref value AS  CY ) 								' Creates a VT_CY
      Declare Constructor(byref value  AS DECIMAL )  						' Creates a VT_DECIMAL
	   Declare Constructor(value As Byte )
      Declare Constructor(byref value AS  CY Ptr) 								' Creates a VT_CY
      Declare Constructor(byref value  AS DECIMAL Ptr )  						' Creates a VT_DECIMAL
	   Declare Constructor(value As Byte Ptr )
	   declare Constructor (BYVAL value AS Boolean)
      'Declare Constructor(value As pvRecord AS LPVOID Ptr,pRecInfo AS IRecordInfo Ptr)
      Declare Sub Clear ()
      Declare Sub Copy (ByVal value AS VARIANT)
      Declare Sub CopyInd (ByVal value AS VARIANT)
      Declare Sub Attach(byref value As  VARIANT ) 
      Declare Function IsArray As Boolean
      Declare Property vt As VARTYPE
      
      
      
      declare operator let(byval value as Single)
      declare operator let(byval value as Single Ptr)
      declare operator let(byval d as double)
       declare operator let(byval d as Double ptr)
      Declare operator let(byval d as BSTR)
      Declare operator let(byval d as BSTR Ptr)
      declare operator let(byval s as String)
      declare operator let(byval s as String Ptr)
      Declare Operator Let (ByVal value AS WSTRING Ptr)
   
      declare operator let(byval value as Byte)
      declare operator let(byval value as Byte Ptr)
      Declare Operator Let (BYVAL value AS Short)
      Declare Operator Let (BYVAL value AS Short Ptr) 
      Declare Operator Let (ByVal value AS UShort) 
     '  Declare Operator Let (ByVal value AS UShort Ptr)  
      Declare Operator Let (ByVal value As Integer)
      Declare Operator Let (ByVal value As Integer Ptr)
      Declare Operator Let (ByVal value As UInteger)
      Declare Operator Let (ByVal value As UInteger Ptr)
      declare operator Let (byval value as LONG)
      declare operator Let (byval value as Long Ptr)
      Declare Operator Let (BYVAL value AS ULong)
      Declare Operator Let (BYVAL value AS ULong Ptr) 
      Declare Operator Let (BYVAL value AS LONGLONG)
      'Declare Operator Let (BYVAL value AS LONGLONG Ptr)
      Declare Operator Let (BYVAL value AS ULONGLONG)
      'Declare Operator Let (BYVAL value AS ULONGLONG Ptr)
      declare Operator Let (BYVAL value AS Boolean)
      declare Operator Let (BYVAL value AS Boolean Ptr)
  
      Declare Operator Let (BYVAL value AS  CY)
      Declare Operator Let (BYVAL value AS  CY Ptr)
      Declare Operator Let (BYVAL value AS DECIMAL)
      Declare Operator Let (BYVAL value AS DECIMAL Ptr) 
      Declare Operator let(ByVal value as VARIANT)
      Declare Operator let(ByVal value as VARIANT Ptr)
      declare operator Let(ByRef value as oleVARIANT)
      declare operator Let(ByRef value as oleVARIANT Ptr)
      declare operator let(byval d as SAFEARRAY Ptr)
      declare operator let(byval d as SAFEARRAY Ptr Ptr)
      Declare Operator Let (BYVAL pDisp AS IDispatch Ptr)
      Declare Operator Let (BYVAL pDisp AS IDispatch Ptr Ptr)  
      Declare Operator Let(BYVAL pUnk AS IUnknown Ptr)
      Declare Operator Let(BYVAL pUnk AS IUnknown Ptr Ptr) 
      Declare Operator Let(BYVAL pr AS _RECORD)
      Declare Operator Let(BYVAL pr AS _RECORD Ptr)

      declare operator Cast() as Single
      declare operator Cast() as Single Ptr
      declare operator cast() as Double
      declare operator cast() as Double Ptr
      declare Operator cast() as BSTR
      declare Operator cast() as BSTR Ptr
      declare operator cast() as String
      declare operator cast() as String Ptr
      Declare Operator cast() as  WString Ptr
    
      Declare Operator cast() as  Byte
      Declare Operator cast() as  Byte Ptr
      Declare Operator cast() as  Short
      Declare Operator cast() as  Short Ptr 
      Declare Operator cast() as  UShort
   '   Declare Operator cast() as  UShort Ptr
      Declare Operator Cast() As Integer
      Declare Operator Cast() As Integer Ptr 
      Declare Operator Cast() As UInteger 
      Declare Operator Cast() As UInteger  Ptr 
      declare operator cast() as Long
      declare operator cast() as Long Ptr
      Declare Operator cast() as  ULong
      Declare Operator cast() as  ULong Ptr 
      Declare Operator cast() As  LONGLONG
      'Declare Operator cast() As  LONGLONG Ptr
      Declare Operator cast() As  ULONGLONG 
      'Declare Operator cast() As  ULONGLONG Ptr
      Declare Operator cast() as  Boolean 
      Declare Operator cast() as  Boolean  Ptr
   
      Declare Operator Cast() As CY
       Declare Operator Cast() As CY Ptr
      Declare Operator Cast() As DECIMAL
      Declare Operator Cast() As DECIMAL Ptr 
      declare operator cast() as VARIANT
      declare operator cast() as VARIANT Ptr
      declare operator cast() as SAFEARRAY Ptr
      declare operator cast() as SAFEARRAY Ptr Ptr
      Declare Operator cast() as IDispatch Ptr
      Declare Operator cast() as IDispatch Ptr Ptr 
      Declare Operator cast() as IUnknown Ptr
      Declare Operator cast() as IUnknown Ptr Ptr 
      Declare Operator Cast() As _RECORD
      Declare Operator Cast() As _RECORD Ptr
      Declare Operator Cast() as IFONTDISP Ptr 
      Declare Operator Cast() as IPICTUREDISP Ptr 
end Type


  
 


constructor OleVariant
  variantClear(@v)
  variantinit(@v)
end constructor
 
 destructor OleVariant()  
   variantClear(@v)
 end Destructor
 
 Constructor OleVariant(ByRef value As OleVariant)
    v=value
 End Constructor
 Constructor OleVariant(ByVal value As OleVariant Ptr)
    v=*value
 End Constructor
Constructor OleVariant(ByVal value As VARIANT)
     variantcopy(@v,@value)
 End Constructor
 
 Constructor OleVariant(ByVal value As VARIANT Ptr)
     'variantcopy(@v,value)
     variantClear(@v)
     v.vt=VT_BYREF Or VT_VARIANT
     v.pvarval=value
end Constructor

constructor OleVariant (byval value as String )
	VariantInit( @v )
	Var wlen = MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, value, -1, 0, 0)-1
	
 	V_VT(@v) = VT_BSTR
	V_BSTR(@v) = SysAllocStringLen(NULL, wlen)	
	
	MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED,value, -1, V_BSTR(@v), wlen)
	
end constructor

 


constructor OleVariant (byval value as String Ptr)
	VariantInit( @v )
	Var wlen = MultiByteToWideChar(CP_ACP, NULL, StrPtr(*value), &HFFFFFFFF, 0, 0)-1
	
 	v.vt = VT_BYREF Or VT_BSTR
	v.pbstrval = CPtr(BSTR Ptr,SysAllocStringLen(NULL, wlen))	
	
	MultiByteToWideChar(CP_ACP, NULL, StrPtr(*value), &HFFFFFFFF, V_BSTR(@v), wlen)
	
end Constructor
'':::::
constructor OleVariant (ByVal value as wstring Ptr)
	VariantInit( @v)
	V_VT(@v) = VT_BSTR
	V_BSTR(@v) = SysAllocStringlen(value, len(*value) )
	if (v.bstrval = NULL And value <> NULL) Then
		ShowOleError(E_OUTOFMEMORY)
	End If
end constructor


 Constructor OleVariant(ByVal value As BSTR)
   VariantClear(@V)
   v.vt=VT_BSTR
   V.bstrval=sysallocstring(Cast(OLECHAR Ptr,value))
 End Constructor
 
 Constructor OleVariant(ByVal value As BSTR Ptr)
   VariantClear(@V)
   v.vt=VT_BSTR Or VT_BYREF
   V.pbstrval=value
 End Constructor
 
 Constructor OleVariant(ByVal value As Single)
    VariantClear(@V)
    v.vt=VT_R4
    V.fltVal=value
 End Constructor
 
 Constructor OleVariant(ByVal value As Single Ptr)
    VariantClear(@V)
    v.vt=VT_R4 Or VT_BYREF
    V.pfltVal=value
 End Constructor
 
/' 
 Constructor OleVariant(ByVal value As Double)
   VariantClear(@V)
    v.vt=VT_R8
    V.dblval=value
 End Constructor
 '/
 
 
 
  
 	
 Constructor OleVariant(ByVal value As Integer)
    VariantClear(@V)
  		v.vt=VT_I4
   	v.lVal=value
 End Constructor
 
 Constructor OleVariant(ByVal value As Integer Ptr)
    VariantClear(@V)
  		v.vt=VT_I4  Or VT_BYREF
   	v.plVal=value
 End Constructor
 
 Constructor OleVariant(ByVal value As Long)
    VariantClear(@V)
  		v.vt=VT_I4
   	v.lVal=value
 End Constructor
 
 
 
 Constructor OleVariant(ByVal value As Long Ptr)
    VariantClear(@V)
  		v.vt=VT_I4 Or VT_BYREF
   	v.plVal=value
   	
 End Constructor
 
Constructor OleVariant(ByVal value As SAFEARRAY Ptr)
   VariantClear(@V)
   Dim vvt As VARTYPE
   SafeArrayGetVartype(value,@vvt)
	v.vt=vvt Or VT_ARRAY
	v.parray=value
End Constructor

Constructor OleVariant(ByVal value As SAFEARRAY Ptr Ptr) 
   VariantClear(@V)
   Dim vvt As VARTYPE
   SafeArrayGetVartype(*value,@vvt)
	v.vt=vvt Or (VT_ARRAY Or VT_BYREF)    
	v.pparray=value
End Constructor

 Constructor OleVariant(ByVal value As IDispatch Ptr)
    VariantClear(@V)
      v.vt = VT_DISPATCH
      v.pdispVal = value 
 End Constructor
 
 Constructor OleVariant(ByVal value As IDispatch Ptr Ptr)
    VariantClear(@V)
      v.vt = VT_DISPATCH  Or VT_BYREF
      v.ppdispVal = value 
 End Constructor
 
 Constructor OleVariant(ByVal value as  IUnknown Ptr)
     VariantClear(@V)
      v.vt = VT_UNKNOWN
      v.punkval = value 
 End Constructor
 
 Constructor OleVariant(ByVal value As IFONTDISP Ptr)
    VariantClear(@V)
      v.vt = VT_DISPATCH   
      v.pdispVal = Cast(IDISPATCH Ptr,value) 
 End Constructor
 
 Constructor OleVariant(ByVal value As IFONTDISP Ptr Ptr)
    VariantClear(@V)
      v.vt = VT_DISPATCH Or VT_BYREF  
      v.ppdispVal = Cast(IDISPATCH Ptr Ptr,value) 
 End Constructor
 
 Constructor OleVariant(ByVal value As IPICTUREDISP Ptr)
    VariantClear(@V)
      v.vt = VT_DISPATCH   
      v.pdispVal = Cast(IDISPATCH Ptr,value) 
 End Constructor
 
 Constructor OleVariant(ByVal value as  IUnknown Ptr Ptr)
     VariantClear(@V)
      v.vt = VT_UNKNOWN  Or VT_BYREF
      v.ppunkval = value 
 End Constructor
 
 ' Creates a VT_I2, or a VT_BOOL
  Constructor OleVariant(value As Short , vtSrc as VARTYPE = VT_I2) 
  if ((vtSrc <> VT_I2) And  (vtSrc <> VT_BOOL)) Then
		ShowOleError(E_INVALIDARG)
	End If

   VariantClear(@V)
   
	if (vtSrc = VT_BOOL) Then
		V.VT  = VT_BOOL 
		V.boolval = iif(value , VARIANT_TRUE , VARIANT_FALSE) 
	 
	else  
		v.vt = VT_I2 
		V.ival = value  
	End If
  End Constructor
  
  Constructor OleVariant(value As Short Ptr , vtSrc as VARTYPE = VT_I2) 
  if ((vtSrc <> VT_I2) And  (vtSrc <> VT_BOOL)) Then
		ShowOleError(E_INVALIDARG)
	End If
   
   VariantClear(@V)
   
	if (vtSrc = VT_BOOL) Then
		V.VT  = VT_BOOL  Or VT_BYREF
		Dim pvalue As VARIANT_BOOL
		 If *value=VARIANT_TRUE Then
		 	  pvalue=VARIANT_TRUE
		 	  V.pboolval =@pvalue
		 Else
		 	 pvalue=VARIANT_FALSE
		 	  V.pboolval =@pvalue
		 EndIf
		 
	 
	else  
		v.vt = VT_I2  Or VT_BYREF
		V.pival = value  
	End If
  End Constructor
  
  
 ' Creates a VT_I4, a VT_ERROR, or a VT_BOOL
'Constructor OleVariant(value As Long, vtSrc as VARTYPE = VT_I4) 
'if ((vtSrc <> VT_I4) AND (vtSrc <> VT_ERROR) And (vtSrc <> VT_BOOL)) Then
'		ShowOleError(E_INVALIDARG)
'	End If
' 
'   VariantClear(@V)
'	if (vtSrc = VT_ERROR) Then
'		V.VT  = VT_ERROR
'		V.scode = value
'	 
'	elseif (vtSrc = VT_BOOL) Then
'		V.VT  = VT_BOOL
'		V.boolval = iif(value , VARIANT_TRUE , VARIANT_FALSE)
'	 
'	else  
'		V.VT  = VT_I4
'		V.lval = value
'	End If
'End Constructor

'Constructor OleVariant(value As Long Ptr, vtSrc as VARTYPE = VT_I4) 
'if ((vtSrc <> VT_I4) AND (vtSrc <> VT_ERROR) And (vtSrc <> VT_BOOL)) Then
'		ShowOleError(E_INVALIDARG)
'	End If
' 
'   VariantClear(@V)
'	if (vtSrc = VT_ERROR) Then
'		V.VT  = VT_ERROR
'		V.scode = value
'	 
'	elseif (vtSrc = VT_BOOL) Then
'		V.VT  = VT_BOOL Or VT_BYREF
'		V.pboolval = iif(*value , @VARIANT_TRUE , @VARIANT_FALSE)
'	 
'	else  
'		V.VT  = VT_I4 Or VT_BYREF
'		V.plval = value
'	End If
'End Constructor

 ' Creates a VT_I4, a VT_ERROR, or a VT_BOOL
	' Constructor OleVariant(value As Integer, vtSrc as VARTYPE = VT_I4)
	'if ((vtSrc <> VT_I4) AND (vtSrc <> VT_ERROR) And (vtSrc <> VT_BOOL)) Then
	'	ShowOleError(E_INVALIDARG)
	'End If

   'VariantClear(@V)
	'if (vtSrc = VT_ERROR) Then
	'	V.VT  = VT_ERROR
	'	V.scode = value
	' 
	'elseif (vtSrc = VT_BOOL) Then
	'	V.VT  = VT_BOOL
	'	V.boolval = iif(value , VARIANT_TRUE , VARIANT_FALSE)
	' 
	'else  
	'	V.VT  = VT_I4
	'	V.lval = value
	'End If
	' End Constructor
	 
	' Creates a VT_R8, or a VT_DATE 
 Constructor OleVariant(value As Double , vtSrc as VARTYPE = VT_R8)
   If ((vtSrc <> VT_R8) And (vtSrc <> VT_DATE)) Then
		ShowOleError(E_INVALIDARG)
	End If

   VariantClear(@V)
   
	if (vtSrc = VT_DATE) Then
		V.VT  = VT_DATE
		V.date = value
	 
	else  
		V.VT  = VT_R8
		V.dblval = value
	End If
      End Constructor
      
      
      Constructor OleVariant(value As Double Ptr, vtSrc as VARTYPE = VT_R8)
   If ((vtSrc <> VT_R8) And (vtSrc <> VT_DATE)) Then
		ShowOleError(E_INVALIDARG)
	End If

   VariantClear(@V)
   
	if (vtSrc = VT_DATE) Then
		V.VT  = VT_DATE Or VT_BYREF
		V.pdate = value
	 
	else  
		V.VT  = VT_R8  Or VT_BYREF
		V.pdblval = value
	End If
      End Constructor
      
  ' Creates a VT_CY    
Constructor OleVariant(byref value AS  CY ) 	
	   VariantClear(@V)			
	    	V.VT  = VT_CY
	      V.cyval = value
End Constructor
Constructor OleVariant(byref value AS  CY Ptr ) 	
	   VariantClear(@V)			
	    	V.VT  = VT_CY  Or VT_BYREF
	      V.pcyval = value
End Constructor	
   
	 ' Creates a VT_DECIMAL  
Constructor OleVariant(byref value  AS DECIMAL )  
      	' Order is important here! Setting V_DECIMAL wipes out the entire VARIANT
   VariantClear(@V)
	V.decval = value
	V.VT  = VT_DECIMAL
End Constructor
      
Constructor OleVariant(byref value  AS DECIMAL Ptr)  
      	' Order is important here! Setting V_DECIMAL wipes out the entire VARIANT
   VariantClear(@V)
	V.pdecval = value
	V.VT  = VT_DECIMAL  Or VT_BYREF
End Constructor
      
Constructor OleVariant(value As Byte )
     VariantClear(@V)
	  V.VT = VT_UI1 
	  V.bval = value 
 End Constructor

Constructor OleVariant(value As Byte Ptr)
     VariantClear(@V)
	  V.VT = VT_UI1 Or VT_BYREF
	  V.pbval = value 
 End Constructor
 
 Constructor oleVariant(BYVAL value AS Boolean) 
	VariantClear(@V)
      v.vt = VT_BOOL
      v.boolVal = IIf(value = 0,VARIANT_FALSE,VARIANT_TRUE)
End Constructor

 
 
 'Constructor OleVariant(value As pvRecord AS PVOID,pRecInfo AS IRecordInfo Ptr)
 ' VariantClear(@V)
 '      v.vt = VT_RECORD
 '      v.pvRecord = value
 '      v.pRecInfo = pRecInfo 
 'End Constructor
 /'
 Constructor oleVariant  (BYVAL value AS UShort)
  	VariantClear(@V)
      v.vt = VT_UI2
      v.uiVal =value
   
  END Operator

     
 
Constructor oleVariant  (BYVAL value AS LONGLONG)
 	VariantClear(@V)
      v.vt = VT_I8
      v.llVal = value
 End Constructor

   
Constructor oleVariant (BYVAL value AS ULONGLONG) 
  	VariantClear(@V)
      v.vt = VT_UI8
      v.ullVal= value
 End Constructor
   

Constructor OleVariant (ByVal value As UInteger)
 	VariantClear(@V)
 	 v.vt=VT_UI4
     V.uintVal=value
 End Constructor
 
 '/


 
 
Sub oleVariant.Clear ()
    VariantClear(@V)
END Sub
   
   ' =====================================================================================
   ' Copies the contents of one VARIANT structure to olevariant.
   ' =====================================================================================
Sub oleVariant.Copy (ByVal value AS VARIANT)
   'VariantCopy(@v, @value)
   v=value
End Sub
 
 Sub Olevariant.Attach(byref value As  VARIANT ) 
	'
	' Free up previous VARIANT
	'
	Clear()

	'
	' Give control of data to Olevariant
	'
	memcpy(@v, @value, sizeof(value)) 
	V_VT(@value) = VT_EMPTY
End Sub  
   ' =====================================================================================
   ' Frees any existing content of the destination variant and makes a copy of the source
   ' VARIANT, performing the necessary indirection if the source is specified to be VT_BYREF.
   ' =====================================================================================
 Sub oleVariant.CopyInd (ByVal value AS VARIANT)
      VariantCopyInd(@v, @value)
 End Sub
 
 Function oleVariant.IsArray As boolean
 	 Return IIf((v.vt AND VT_ARRAY)=VT_ARRAY,TRUE,FALSE)
 End Function
 
 Property oleVariant.vt As VARTYPE
   Return v.vt
 End Property
 
 
 
  operator OleVariant.let(byval value as Single)
  	VariantClear(@V)
    v.vt=VT_R4
    V.fltVal=value
  end Operator
  
  operator OleVariant.let(byval value as Single Ptr)
  	VariantClear(@V)
    v.vt=VT_R4 Or VT_BYREF
    V.pfltVal=value
  end Operator
 operator OleVariant.let(byval d as double)
 	VariantClear(@V)
    v.vt=VT_R8
    V.dblval=d
  end Operator
 
 operator OleVariant.let(byval d as Double Ptr)
 	VariantClear(@V)
    v.vt=VT_R8 Or VT_Byref
    V.pdblval=d
  end Operator
operator OleVariant.let(byval d as BSTR)
	VariantClear(@V)
   v.vt=VT_BSTR
   V.bstrval=sysallocstring(Cast(OLECHAR Ptr,d))
End Operator

operator OleVariant.let(byval d as BSTR Ptr)
	VariantClear(@V)
   v.vt=VT_BSTR Or VT_BYREF
   V.pbstrval=d
End Operator


/'
operator OleVariant.let(byval s as ZString Ptr)
	VariantClear(@V)
   v.vt=VT_BSTR
   V.bstrval=sysallocstringbytelen(s,len(*s))
end Operator
'/
operator OleVariant.let(byval s as STRING)
	 VariantClear(@V)
	Var wlen = MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED,  s , -1, 0, 0)-1
	
 	V_VT(@v) = VT_BSTR
	V_BSTR(@v) = SysAllocStringLen(NULL, wlen)	
	
	MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED,  s , -1, V_BSTR(@v), wlen)
End Operator
operator OleVariant.let(byval s as String Ptr)
	 VariantClear(@V)
	Var wlen = MultiByteToWideChar(CP_ACP, NULL, *s , &HFFFFFFFF, 0, 0)-1
	
 	V_VT(@v) = VT_BSTR
	V_BSTR(@v) = SysAllocStringLen(NULL, wlen)	
	
	MultiByteToWideChar(CP_ACP, NULL, StrPtr(*s), &HFFFFFFFF, V_BSTR(@v), wlen)
End Operator
 Operator oleVariant.Let (ByVal value AS WSTRING Ptr)  
      Dim hr AS HRESULT
      VariantClear(@V)
      v.vt = VT_BSTR
      v.bstrVal = SysAllocStringlen(value,Len(*value))
      hr = IIF (v.bstrVal <> 0, S_OK, E_OUTOFMEMORY)
      IF FAILED(hr) THEN VariantInit(@v)
 end Operator
 
 
 
/'    
 Operator oleVariant.Let (BYVAL value AS CHAR) 
      v.vt = VT_I1
      v.cVal = value
 END operator
 
'/ 
  
  Operator oleVariant.Let (BYVAL value AS Byte)
  	   VariantClear(@V)
      v.vt = VT_UI1
      v.bval =value
   
  END Operator 
   
   Operator oleVariant.Let (BYVAL value AS Byte Ptr)
  	   VariantClear(@V)
      v.vt = VT_UI1  Or VT_BYREF
      v.pbval =value
   
  END Operator  
    
   Operator oleVariant.Let (ByVal value AS Short) 
   	   	
      If V.vt =  VT_I2 Then
          v.iVal = value
          
      ElseIf (V.vt = VT_BOOL)Then
		  V.boolval = iif(value , VARIANT_TRUE , VARIANT_FALSE) 
	 
      Else  
      	VariantClear(@V)
			V.vt = VT_I2 
		   v.iVal = value
      End If
   END operator
 
  Operator oleVariant.Let (ByVal value AS Short Ptr) 
   	   	
      If V.vt =  VT_I2  Or VT_BYREF Then
          v.piVal = value
          
      ElseIf (V.vt = VT_BOOL  Or VT_BYREF)Then
      	Dim pvalue As VARIANT_BOOL
		    If *value=VARIANT_TRUE Then
		    	pvalue=VARIANT_TRUE 
		         V.pboolval =@pvalue
		    Else  
		    	    pvalue=VARIANT_FALSE
		          V.pboolval =@pvalue
		    End If
      Else  
      	VariantClear(@V)
			V.vt = VT_I2  Or VT_BYREF 
		   v.piVal = value
      End If
  END Operator
  
  Operator oleVariant.Let (BYVAL value AS UShort)
  	VariantClear(@V)
      v.vt = VT_UI2
      v.uiVal =value
  END Operator
     
  'Operator oleVariant.Let (BYVAL value AS UShort Ptr)
  '	VariantClear(@V)
  '    v.vt = VT_UI2 Or VT_BYREF 
  '    v.puiVal =value
  ' 
  'END Operator
  
 Operator oleVariant.Let (BYVAL value AS LONGLONG)
 	VariantClear(@V)
      v.vt = VT_I8
      v.llVal = value
  END Operator
  
   
  Operator oleVariant.Let (BYVAL value AS ULONGLONG) 
  	VariantClear(@V)
      v.vt = VT_UI8
      v.ullVal= value
  END Operator
   
   
   
Operator   OleVariant.Let ( ByVal value As Integer)
	VariantClear(@V)
  		v.vt=VT_I4
   	v.lVal=value
End Operator

Operator   OleVariant.Let ( ByVal value As Integer Ptr)
	VariantClear(@V)
  		v.vt=VT_I4  Or VT_BYREF
   	v.plVal=value
End Operator

 Operator OleVariant.Let (ByVal value As UInteger)
 	VariantClear(@V)
 	 v.vt=VT_UI4
     V.uintVal=value
 End Operator

Operator OleVariant.Let (ByVal value As UInteger Ptr)
 	VariantClear(@V)
 	 v.vt=VT_UI4  Or VT_BYREF
     V.puintVal=value
 End Operator

operator OleVariant.let(ByVal value As LONG)
	VariantClear(@V)
   v.vt=VT_I4
   V.lval=value
End operator


operator OleVariant.let(ByVal value As Long Ptr)
	VariantClear(@V)
   v.vt=VT_I4 Or VT_BYREF
   V.plval=value
   	 
end Operator
 Operator oleVariant.Let  (BYVAL value AS ULong)
 	VariantClear(@V)
      v.vt = VT_UI4
      v.ulVal = value
   END Operator

Operator oleVariant.Let  (BYVAL value AS ULong Ptr)
 	VariantClear(@V)
      v.vt = VT_UI4 Or VT_BYREF
      v.pulVal = value
END Operator

Operator oleVariant.Let(BYVAL value AS Boolean) 
	VariantClear(@V)
      v.vt = VT_BOOL
      v.boolVal = IIf(value <> 0, -1, 0)
End Operator
    
Operator oleVariant.Let(BYVAL value AS Boolean Ptr) 
	VariantClear(@V)
      v.vt = VT_BOOL Or VT_BYREF
      Dim b As VARIANT_BOOL
      If *value <> 0 Then
      	b=VARIANT_TRUE
      	v.pboolVal =@b
      Else
      	b=VARIANT_FALSE
      	v.pboolVal =@b
      EndIf
      'v.pboolVal = IIf(*value <> 0, -1, 0)
End Operator
    
 /' 
 Operator oleVariant.Let  (BYVAL value AS VARIANT_BOOL) 
      v.vt = VT_BOOL
      v.boolVal = value
 End Operator

  Operator   OleVariant.Let (ByVal value As DATE_)
   v.vt=VT_DATE
   v.date=value 
End Operator
 
'/

   
 Operator   OleVariant.Let (BYVAL value AS  CY) 
 	VariantClear(@V)
   V.vt= VT_CY
   V.cyVal=value
 End Operator
 
 Operator   OleVariant.Let (BYVAL value AS  CY Ptr) 
 	VariantClear(@V)
   V.vt= VT_CY  Or VT_BYREF
   V.pcyVal=value
 End Operator
 
 Operator   OleVariant.Let (BYVAL value AS  DECIMAL)  
 	VariantClear(@V)
   V.vt= VT_DECIMAL
   V.decVal =value
 End Operator
 
 Operator   OleVariant.Let (BYVAL value AS  DECIMAL Ptr)  
 	VariantClear(@V)
   V.vt= VT_DECIMAL  Or VT_BYREF
   V.pdecVal =value
 End Operator
 
operator OleVariant.let(ByVal value as VARIANT)
	 variantcopy(@V,@value)
end operator

operator OleVariant.let(ByVal value as VARIANT Ptr)
	' variantcopy(@V,value)
	  v.vt=VT_BYREF Or VT_VARIANT
     v.pvarval=value
end Operator

operator OleVariant.let(byval p as SAFEARRAY Ptr)
	VariantClear(@V)
	Dim vvt As VARTYPE
   SafeArrayGetVartype(p,@vvt)
	v.vt= vvt Or VT_ARRAY
	v.parray=p
End Operator

operator OleVariant.let(byval p as SAFEARRAY Ptr Ptr)
	VariantClear(@V)
	Dim vvt As VARTYPE
   SafeArrayGetVartype(*p,@vvt)
	v.vt=vvt Or VT_ARRAY Or VT_BYREF
	v.pparray=p
End Operator

 Operator oleVariant.Let (BYVAL pDisp AS IDispatch Ptr)
 	VariantClear(@V)
      v.vt = VT_DISPATCH
      v.pdispVal =  pDisp 
 End Operator
  
   Operator oleVariant.Let (BYVAL pDisp AS IDispatch Ptr Ptr)
 	VariantClear(@V)
      v.vt = VT_DISPATCH  Or VT_BYREF
      v.ppdispVal =  pDisp 
   End Operator
   
 Operator oleVariant.Let(BYVAL pUnk AS IUnknown Ptr)
 	VariantClear(@V)
      v.vt = VT_UNKNOWN
      v.punkVal =  pUnk 
      #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
            If v.punkVal THEN pUnk->AddRef()
      #Else
            IF v.punkVal THEN pUnk->lpvtbl->AddRef(pUnk)
      #EndIf
END Operator
  
Operator oleVariant.Let(BYVAL pUnk AS IUnknown Ptr Ptr)
 	VariantClear(@V)
      v.vt = VT_UNKNOWN Or VT_BYREF
      v.ppunkVal =  pUnk 
      #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
            If v.ppunkVal THEN (*pUnk)->AddRef()
      #Else
            IF v.ppunkVal THEN (*pUnk)->lpvtbl->AddRef(*pUnk)
      #EndIf
END Operator

 Operator oleVariant.Let(BYVAL pr AS _RECORD) 
 	VariantClear(@V)
       v.vt = VT_RECORD
       v.pvRecord = pR.pvRecord
       v.pRecInfo =  pR.pRecInfo 
 End Operator
  
 operator OleVariant.let(ByRef value as oleVARIANT)
  	 v=value
 End Operator
 
 operator OleVariant.let(ByRef value as oleVARIANT Ptr)
  	 v=*value
 End Operator
 
operator  OleVariant.cast()as Single
   If v.vt=VT_R4 then 
   	return v.fltval
   Else
   	Dim vvar As variant
	   VariantChangeTypeEx(@vvar,@v,NULL,VARIANT_NOVALUEPROP,VT_R4)
	   Return vvar.fltval
   EndIf
end Operator

operator  OleVariant.cast()as Single Ptr
   If v.vt=VT_R4 Or VT_BYREF then 
   	return v.pfltval
   Else
   	Dim vvar As variant
	   VariantChangeTypeEx(@vvar,@v,NULL,VARIANT_NOVALUEPROP,VT_R4 Or VT_BYREF)
	   Return vvar.pfltval
   EndIf
end Operator

Operator  OleVariant.cast()as double
   if v.vt=VT_R8 then 
   	return v.dblval
   Else
   	Dim vvar As variant
	   VariantChangeTypeEx(@vvar,@v,NULL,VARIANT_NOVALUEPROP,VT_R8)
	   Operator= vvar.dblval
	   variantClear(@vvar)
   EndIf
end Operator

Operator  OleVariant.cast()as Double Ptr
   if v.vt=VT_R8 Or VT_BYREF Then 
   	return v.pdblval
   Else
   	Dim vvar As variant
	   VariantChangeTypeEx(@vvar,@v,NULL,VARIANT_NOVALUEPROP,VT_R8 Or VT_BYREF)
	   Operator= vvar.pdblval
	   variantClear(@vvar)
   EndIf
end Operator


 operator  OleVariant.cast() as BSTR
  if v.vt=VT_BSTR then 
  	return v.bstrval
  Else
 	Dim vvar As variant
 	VariantChangeTypeEx(@vvar,@v,NULL,VARIANT_NOVALUEPROP,VT_BSTR)
	return vvar.bstrval
  EndIf
 end Operator
 
 
 operator  OleVariant.cast() as BSTR Ptr
  if v.vt=VT_BSTR Or VT_BYREF then 
  	return v.pbstrval
  Else
 	Dim vvar As variant
 	VariantChangeTypeEx(@vvar,@v,NULL,VARIANT_NOVALUEPROP,VT_BSTR Or VT_BYREF)
	return vvar.pbstrval
  EndIf
 end Operator
 
/'
operator  OleVariant.cast() as ZString Ptr
 if v.vt=VT_BSTR then 
 	return strptr(*cast(WSTRING PTR,v.bstrval))
 Else
 	Dim vvar As variant
 	VariantChangeTypeEx(@vvar,@v,NULL,VARIANT_NOVALUEPROP,VT_BSTR)
	return strptr(*Cast(WString Ptr,vvar.bstrval))
 EndIf
end Operator
'/

operator  OleVariant.cast() as STRING
  'If v.vt=VT_BSTR then 
  '	 Return *Cast(WString Ptr,v.bstrval)
  'Else
 	Dim vvar As variant
 	VariantChangeTypeEx(@vvar,@v,NULL,VARIANT_NOVALUEPROP,VT_BSTR)
	return *Cast(wString Ptr,vvar.bstrval)
  'EndIf
end operator

operator  OleVariant.cast() as String Ptr
  'If v.vt=VT_BSTR then 
  '	 Return Cast(String Ptr,*Cast(WString Ptr,v.bstrval))
  'Else
 	Dim vvar As variant
 	VariantChangeTypeEx(@vvar,@v,NULL,VARIANT_NOVALUEPROP,VT_BSTR  Or VT_BYREF)
	return Cast(String Ptr,*Cast(wString Ptr Ptr, vvar.pbstrval))
  'EndIf
end Operator

Operator OleVariant.cast() as  WString Ptr 
 If v.vt=VT_BSTR then 
 	Return Cast(WString PTR,v.bstrval)
 Else
 	Dim vvar As variant
 	VariantChangeTypeEx(@vvar,@v,NULL,VARIANT_NOVALUEPROP,VT_BSTR)
	return Cast(wstring Ptr,vvar.bstrval)
 EndIf
End Operator

/'
 Operator OleVariant.cast() as CHAR
 	 if v.vt=VT_I1 then return v.cval
 End Operator
'/ 
 
 Operator OleVariant.cast() as  Byte
 	 If v.vt=VT_UI1 then 
 	 	return v.bVal
 	 Else
   	Dim vvar As variant
	   VariantChangeTypeEx(@vvar,@v,NULL,VARIANT_NOVALUEPROP,VT_UI1)
	   Return vvar.bval
  EndIf
 End Operator

 Operator OleVariant.cast() as  Byte Ptr
 	 If v.vt=VT_UI1  Or VT_BYREF then 
 	 	return v.pbVal
 	 EndIf
 End Operator
 
 Operator OleVariant.cast() as  Short
 	 if v.vt=VT_I2 then 
 	 	return v.ival
 	  Else
   	Dim vvar As variant
	   VariantChangeTypeEx(@vvar,@v,NULL,VARIANT_NOVALUEPROP,VT_I2)
	   Return vvar.ival
  EndIf
 End Operator
 
 Operator OleVariant.cast() as  Short Ptr
 	 if v.vt=VT_I2  Or VT_BYREF then 
 	 	return v.pival
 	 Else
   	Dim vvar As variant
	   VariantChangeTypeEx(@vvar,@v,NULL,VARIANT_NOVALUEPROP,VT_I2 Or VT_BYREF)
	   Return vvar.pival
  EndIf
 End Operator
 
 Operator OleVariant.cast() as  UShort 
 	 if v.vt=VT_UI2 then 
 	 	return v.uiVal
 	 Else
   	Dim vvar As variant
	   VariantChangeTypeEx(@vvar,@v,NULL,VARIANT_NOVALUEPROP,VT_UI2)
	   Return vvar.uival
  EndIf
 End Operator

 Operator   OleVariant.cast()AS Integer
   If v.vt=VT_I4 Then  
   	return	v.lVal
   Else
   	Dim vvar As variant
	   VariantChangeTypeEx(@vvar,@v,NULL,VARIANT_NOVALUEPROP,VT_I4)
	   Return vvar.lval
  EndIf
 End Operator
 
 Operator   OleVariant.cast()AS Integer Ptr
   If v.vt=VT_I4  Or VT_BYREF Then  
   	return	v.plVal
   Else
   	Dim vvar As variant
	   VariantChangeTypeEx(@vvar,@v,NULL,VARIANT_NOVALUEPROP,VT_I4  Or VT_BYREF)
	   Return vvar.plval
  EndIf
 End Operator
 
 Operator   OleVariant.cast()AS UInteger
   If v.vt=VT_UI4 Then  return	v.uintVal
 End Operator
 
 Operator   OleVariant.cast()AS UInteger Ptr
   If v.vt=VT_UI4  Or VT_BYREF Then  return	v.puintVal
 End Operator
 
 operator  OleVariant.cast() as LONG
  if v.vt=VT_I4 then 
    	return v.lval
  Else
   	Dim vvar As variant
	   VariantChangeTypeEx(@vvar,@v,NULL,VARIANT_NOVALUEPROP,VT_I4)
	   Return vvar.lval
  EndIf
end operator

 
operator  OleVariant.cast() as Long Ptr
  if v.vt=VT_I4 Or VT_BYREF Then 
  		return v.plval
  Else
   	Dim vvar As variant
	   VariantChangeTypeEx(@vvar,@v,NULL,VARIANT_NOVALUEPROP,VT_I4 Or VT_BYREF)
	   Return vvar.plval
  EndIf
end Operator

 Operator OleVariant.cast() as  ULong 
  	 if v.vt=VT_UI4 then return v.ulVal
 End Operator
 
  Operator OleVariant.cast() as  ULong Ptr
  	 if v.vt=VT_UI4  Or VT_BYREF then return v.pulVal
  End Operator
  
 Operator OleVariant.cast() as  LONGLONG
 	 if v.vt=VT_I8 then return v.llVal
 End Operator
 
 Operator OleVariant.cast() as  ULONGLONG
 	 if v.vt=VT_UI8 then return v.ullVal
 End Operator
 
 Operator OleVariant.cast() as  Boolean 
 	 if v.vt=VT_BOOL then return IIf(v.boolVal<>0,TRUE,FALSE)
 End Operator
 
 Operator OleVariant.cast() as  Boolean Ptr
 	 if v.vt=VT_BOOL  Or VT_BYREF then 
 	 	Dim b As Boolean
 	 	If v.pboolVal<>0 Then 
 	 		  b=TRUE
 	 		  Return @b
 	 	Else
 	 		b=FALSE
 	 		Return @b
 	 	EndIf
 	 	 
 	 EndIf
 End Operator
 
 /'
 Operator OleVariant.cast() as  VARIANT_BOOL
 		 if v.vt=VT_BOOL then return v.boolVal
 	End Operator
 	
 	 Operator OleVariant.cast() As DATE_
   if value.vt=VT_DATE Then Return 	v.date 
 End Operator
'/

  
 Operator OleVariant.cast() As CY
   	if v.vt=VT_CY Then 
   		Return v.cyVal 
   	Else
   	  Dim vvar As variant
	     VariantChangeTypeEx(@vvar,@v,NULL,VARIANT_NOVALUEPROP,VT_CY)
	     Return vvar.cyVal
      EndIf
  End Operator
 
 Operator OleVariant.cast() As CY ptr
   	if v.vt=VT_CY  Or VT_BYREF Then 
   		Return v.pcyVal 
   	Else
   	  Dim vvar As variant
	     VariantChangeTypeEx(@vvar,@v,NULL,VARIANT_NOVALUEPROP,VT_CY Or VT_BYREF)
	     Return vvar.pcyVal
      EndIf
 End Operator
 
 Operator OleVariant.cast() As DECIMAL
   	if v.vt=VT_DECIMAL Then Return v.decVal 
  End Operator
  
  Operator OleVariant.cast() As DECIMAL Ptr
   	if v.vt=VT_DECIMAL  Or VT_BYREF Then Return v.pdecVal 
  End Operator
  
operator  OleVariant.cast() as VARIANT
     If this.isarray=TRUE Then 
     	  Static v1 As VARIANT
     	  variantcopy(@v1,@v)
     	  Return v1
     EndIf
     Return v
end operator

operator  OleVariant.cast() as VARIANT Ptr
   If v.vt=VT_BYREF Or VT_VARIANT Then
        return v.pvarval
   End If     
end Operator

operator OleVariant.cast() as SAFEARRAY Ptr
	if (v.vt And VT_ARRAY)=VT_ARRAY Then  
	   Return v.parray
	Else
	  	Dim vvar As variant
	   VariantChangeTypeEx(@vvar,@v,NULL,VARIANT_NOVALUEPROP,VT_ARRAY Or (v.vt Xor VT_ARRAY) )
	   Return vvar.parray
   EndIf    
End Operator

operator OleVariant.cast() as SAFEARRAY Ptr Ptr
	if (v.vt And (VT_ARRAY  Or VT_BYREF))=(VT_ARRAY  Or VT_BYREF) then 
	    Return v.pparray
	 Else  
   	Dim vvar As variant
      VariantChangeTypeEx(@vvar,@v,NULL,VARIANT_NOVALUEPROP,(VT_ARRAY  Or VT_BYREF) Or (v.vt Xor (VT_ARRAY  Or VT_BYREF)))
	   Return vvar.pparray
   EndIf    
End Operator
 	
 Operator OleVariant.cast() as  IDispatch Ptr 
 	 if v.vt=VT_DISPATCH then 
 	 	return v.pdispVal
 	 Else
   	Dim vvar As variant
	   VariantChangeTypeEx(@vvar,@v,NULL,VARIANT_NOVALUEPROP,VT_DISPATCH)
	   Return vvar.pdispVal
   EndIf
 End Operator
 
 Operator OleVariant.cast() as  IDispatch Ptr Ptr
 	 if v.vt=VT_DISPATCH  Or VT_BYREF then 
 	 	return v.ppdispVal
 	 Else
   	Dim vvar As variant
	   VariantChangeTypeEx(@vvar,@v,NULL,VARIANT_NOVALUEPROP,VT_DISPATCH  Or VT_BYREF)
	   Return vvar.ppdispVal
   EndIf
 End Operator
 
Operator OleVariant.cast() as  IUnknown Ptr 
	 if v.vt=VT_UNKNOWN then 
	 	   #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
	 	        v.punkVal->AddRef()
	 	   #Else
	 	        v.punkVal->lpvtbl->AddRef(v.punkVal)
	 	   #endif
	 	   Return v.punkVal
	 Else
	 	Dim vvar As variant
	   VariantChangeTypeEx(@vvar,@v,NULL,VARIANT_NOVALUEPROP,VT_UNKNOWN)
	   #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
	 	        vvar.punkVal->AddRef()
	 	   #Else
	 	        vvar.punkVal->lpvtbl->AddRef(vvar.punkVal)
	 	   #EndIf
	   Return vvar.punkVal
	 EndIf
End Operator

Operator OleVariant.cast() as  IUnknown Ptr Ptr
	 if v.vt=VT_UNKNOWN Or VT_BYREF Then 
	 	   #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
	 	        Cast(IUnknown Ptr,*(v.ppunkVal))->AddRef()
	 	   #Else
	 	         Cast(IUnknown Ptr,*(v.ppunkVal))->lpvtbl->AddRef(Cast(IUnknown Ptr,*(v.ppunkVal)))
	 	   #endif
	 	   Return v.ppunkVal
	 Else
	 	Dim vvar As variant
	   VariantChangeTypeEx(@vvar,@v,NULL,VARIANT_NOVALUEPROP,VT_UNKNOWN  Or VT_BYREF)
	   #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
	 	        Cast(IUnknown Ptr,*(vvar.ppunkVal))->AddRef()
	 	   #Else
	 	        Cast(IUnknown Ptr,*(vvar.ppunkVal))->lpvtbl->AddRef(Cast(IUnknown Ptr,*(vvar.ppunkVal)))
	 	   #EndIf
	   Return vvar.ppunkVal
	 EndIf
End Operator

 
 Operator OleVariant.cast() As _RECORD
     If v.vt = VT_RECORD Then 
     	 Dim r As _RECORD
     	    r.pvRecord =v.pvRecord
     	    r.pRecInfo =v.pRecInfo
     	  Return r
     EndIf
End Operator
 
  Operator OleVariant.cast() As _RECORD Ptr
     If v.vt = VT_RECORD  Or VT_BYREF Then 
     	 Dim r As _RECORD
     	    r.pvRecord =v.pvRecord
     	    r.pRecInfo =v.pRecInfo
     	  Return @r
     EndIf
  End Operator
  
  Operator OleVariant.cast() as IFONTDISP Ptr 
 	 if v.vt=VT_DISPATCH then 
 	 	return Cast(IFONTDISP Ptr,v.pdispVal)
 	 Else
   	Dim vvar As variant
	   VariantChangeTypeEx(@vvar,@v,NULL,VARIANT_NOVALUEPROP,VT_DISPATCH)
	   Return Cast(IFONTDISP Ptr,vvar.pdispVal)
   EndIf
  End Operator
  
  Operator OleVariant.cast() as IPICTUREDISP Ptr 
 	 if v.vt=VT_DISPATCH then 
 	 	return Cast(IPICTUREDISP Ptr,v.pdispVal)
 	 Else
   	Dim vvar As variant
	   VariantChangeTypeEx(@vvar,@v,NULL,VARIANT_NOVALUEPROP,VT_DISPATCH)
	   Return Cast(IPICTUREDISP Ptr,vvar.pdispVal)
   EndIf
  End Operator
aloberoger
Posts: 507
Joined: Jan 13, 2009 19:23

Re: INSIDE ACTIVEX WITH FREEBASIC

Post by aloberoger »

manging Word with Invokehelper

Code: Select all

#Include Once "InvokeHelper.bi"
 

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

    ' Initialize the OLE Library...
    OleInitialize(NULL)  ' still in cfreateobject but can put it heare

    ' VB: Dim wdApp As Object
    Dim As oleVARIANT wdApp , WdFont,WdSelection,wdShapes,wdParagraph

    ' VB: Set wdApp = CreateObject "Word.Application"
        wdApp = CreateObject("Word.Application") 
     
    
    
    ' VB: wdApp.Visible = 1
  
    InvokePropPut(wdApp,"Visible", Olevariant(VARIANT_TRUE,VT_BOOL) )
    
     
    ' VB: Dim wdDoc As Object
     Dim As  oleVARIANT wdDoc  

    ' VB: Set wdDoc = wdApp.Documents.Add
    InvokePropGet(wdApp,@wdDoc, "Documents")
    InvokePropGet(wdDoc,@wdDoc, "Add")
  
     
    
    ' VB wdApp.Selection.TypeText Hello World!
   
    InvokePropGet(wdApp,@wdSelection,"Selection") 
    InvokeMethod(wdSelection,NULL,"TypeText","Hello World")
   
  

    ' VB: Dim wdRange As Object
   Dim As  oleVARIANT wdRange 

    ' VB: Set wdRange = wdApp.Selection.Range 
       InvokePropGet(wdSelection, @wdRange,"Range")

    ' VB: wdRange.WholeStory
     InvokeMethod( wdRange,  NULL, "WholeStory")
    

    ' VB: With wdRange.Font 
     InvokePropGet(wdRange, @wdFont, "Font")
   

    ' VB: .Bold = 1 

    InvokePropPut(wdFont, "Bold", 1)
 

    ' VB: .Size = 30 
 
    InvokePropPut(wdFont,"Size", 30)
  

    ' VB: .Animation = 3 
 
    InvokePropPut(wdFont,"Animation", 3)
 

    ' VB: End With 
    'VariantClear(@wdFont) 

    ' VB: wdRange.ParagraphFormat.Alignment = 1 
 
    InvokePropGet(wdRange, @wdParagraph, "ParagraphFormat" ) 
    InvokePropPut(wdParagraph, "Alignment", 1)
   
  

    ' VB: wdDoc.Shapes.AddTextEffect 15 , Microsoft Word! , Arial Black , 36 , 0 , 0 , 210 , 120 
  
    InvokePropGet(wdDoc,@wdShapes, "Shapes") 

     InvokeMethod(wdShapes,NULL,"AddTextEffect",15,"Microsoft Word","Arial Black",36,0,0,210,120)
    
    'NB: see in Invokehelper up to 20 parameters another surchages of the method
   
/'
    ' VB: wdDoc.Saved = 1 
     InvokePropPut(wdDoc.pdispVal, "Saved", 1)
  
    '' VB: wdApp.Quit 
    InvokeMethod(wdApp.pdispVal,NULL,"Quit")
 '/ 

   
    
    ' Terminate the OLE Library...
    OleUninitialize()

    return 0
 end Function
 End Main
 
aloberoger
Posts: 507
Joined: Jan 13, 2009 19:23

Re: INSIDE ACTIVEX WITH FREEBASIC

Post by aloberoger »

Using MSFlexgrid.ocx with FB

Code: Select all


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


Dim Shared hWnd  As HWND
 
Declare Function AtlAxWinInit Lib "atl.dll" Alias "AtlAxWinInit" () As Long

Declare Function AtlAxGetControl Lib "atl.dll" Alias "AtlAxGetControl" ( _
                                               ByVal hWnd As HWND, ByVal pp As IUNKNOWN Ptr Ptr) As Dword

Declare Function AtlGetObjectSourceInterface Lib "atl.dll" Alias "AtlGetObjectSourceInterface" ( _
                                    ByVal punkObj As IUNKNOWN Ptr, ByRef plibid As Guid, ByRef piid As Guid, _
                                    ByRef pdwMajor As Word, ByRef pdwMinor As Word) As Dword



Dim Shared As OLEVARIANT	g_pMSFlexGrid  

 

Function MSFlexGrid_getdispatch OverLoad (punk As IUNKNOWN Ptr) As IDISPATCH Ptr
	Dim g_pMSFlex As IDISPATCH Ptr
	punk->QueryInterface(@IID_IDispatch, Cast(LPVOID Ptr,@g_pMSFlex)) 
   Return g_pMSFlex
End Function

Function MSFlexGrid_getdispatch OverLoad (hwnd As HWND) As IDISPATCH Ptr  
	Dim punk As IUnknown Ptr,pdisp As IDISPATCH Ptr, hr As HRESULT
	AtlAxGetControl(hWnd,  @punk)  ' Get IUnknown-Interface
	 hr=punk->QueryInterface(@IID_IDispatch, Cast(LPVOID Ptr,@pdisp)) 
	If hr Then Return  Cast(IDISPATCH Ptr,punk) 
   Return  pdisp 
End Function

 
Sub MSFlexGrid_Init()  

	' ajout de lignes et colonnes
	 
			' affectation nombre de lignes et de colonnes
		Dim As Long nCol, nRow ,r,c
		Dim As Long  nColCount = 10 
		Dim As Long  nRowCount = 20 
 
		InvokePropPut(g_pMSFlexGrid, "Cols", nColCount) 
  
		InvokePropPut(g_pMSFlexGrid, "Rows", nRowCount) 

		' entêtes colonnes (ligne 0)
		 r=0
		InvokePropPut(g_pMSFlexGrid, "Row", r) 
		for nCol = 1 to  nColCount-1
		 
			' numéro de colonne
		 
			InvokePropPut(g_pMSFlexGrid, "Col", nCol)  
			InvokePropPut(g_pMSFlexGrid, "Text", "col" & nCol ) 
		 
		Next

		' entêtes lignes (colonne 0)
		 c=0
		InvokePropPut(g_pMSFlexGrid, "Col", 0L) ' 0L to specify postfix Long is the default one
		for nRow = 1 To  nRowCount-1
		 
			' numéro de ligne
			InvokePropPut(g_pMSFlexGrid, "Row", nRow) 
			InvokePropPut(g_pMSFlexGrid, "Text", "row" & nRow) 
			 
		Next
	 
End Sub

'***************************************************************************************
' MSFlexGrid_Free :
'***************************************************************************************
sub MSFlexGrid_Free()
 	' libération MSFlexGrid
	'if(g_pMSFlexGrid.pdispval  <> NULL)Then g_pMSFlexGrid->Release() 
	g_pMSFlexGrid = NULL 
End Sub


Sub AtlAxWinTerm()
     UnregisterClass("AtlAxWin", GetModuleHandle(0))
End Sub


#Define MsgBox(s) MessageBox(getactivewindow(),s,"useactivex",MB_ok)



Function WndProc (ByVal hWnd As HWND, ByVal wMsg As UINT, ByVal wParam As WPARAM, ByVal lParam As LPARAM)  As Long
    Select Case wMsg
    	Case WM_DESTROY
    		   MSFlexGrid_Free
            PostQuitMessage 0
            Function = 0
            Exit Function
    End Select
    Function = DefWindowProc(hWnd, wMsg, wParam, lParam)
End Function

 

Function winMain(hints As HINSTANCE,hprev As HINSTANCE,lpcommnad As ZString Ptr,ncmdshow As Long) As Integer
    Dim wndName         As ZSTRING * 255
    Dim Msg             As  MSG
    Dim hResult         As HRESULT
    Dim vInt            As Variant
   
     

    AtlAxWinInit ' Initialisation de ATL.DLL


    wndName = "MSFlexGridLib.MSFlexGrid.1"

    hWnd = CreateWindow("AtlAxWin", _
                        wndName, _
                         WS_VISIBLE Or  WS_SYSMENU Or  WS_MAXIMIZEBOX _
                        Or  WS_MINIMIZEBOX, _
                        10, 10, 800, 600,  NULL,  NULL, _
                        GetModuleHandle(  0),  NULL)

    If hWnd = 0 Then
          MsgBox ("Unable to create window")
          Exit Function
    End If

      SetWindowText(hwnd, "ATL ActiveX Demo Application for freebasic")
     
    '' this also work but a bit long 
    ' Dim pUnk       As IUnknown Ptr    ' IUnknown - Interface: Undocumented yet, but works
    '' Get IUnknown-Interface
    '  AtlAxGetControl(hWnd,  @pUnk)

    '' QueryInterface IDispatch (late) or MSFlexGrid (early)
    ' g_pMSFlexGrid=MSFlexGrid_getdispatch(pUnk)  
    
    ''OR
    
     g_pMSFlexGrid=MSFlexGrid_getdispatch(hwnd)
     
    
     MSFlexGrid_Init()
   
cont:
      SetWindowLong(hWnd,  GWL_WNDPROC, Cast(DWORD,@WndProc))
    ShowWindow hWnd,  SW_SHOW

    UpdateWindow hWnd

    Do While GetMessage(@Msg,  NULL, 0, 0)
        TranslateMessage @Msg
        DispatchMessage @Msg
    Loop

    AtlAxWinTerm
    Function = msg.wParam
End Function

End winmain(getmodulehandle(0),0,Command(),SW_SHOW)
aloberoger
Posts: 507
Joined: Jan 13, 2009 19:23

Re: INSIDE ACTIVEX WITH FREEBASIC

Post by aloberoger »

How to use Automation with Invokehelper
How to Use Microsoft Flexgrid with Freebasic
These topics are treated in this link: http://www.2shared.com/file/Ts6T7Jg-/Post4.html
aloberoger
Posts: 507
Joined: Jan 13, 2009 19:23

Re: INSIDE ACTIVEX WITH FREEBASIC

Post by aloberoger »

These two files are goiung to be usefull in the next post
olefont.bi

Code: Select all

#Include Once "win/olectl.bi"


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 IFONTDISP Ptr)
   Declare Operator cast() As IFONTDISP 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
  
     Operator OleFont.cast() As IFONTDISP Ptr 
     	  Return Cast(IFONTDISP Ptr,vDispatch.pdispval)
     End Operator
     
     Operator OleFont.Let(ByRef value  As IFONTDISP Ptr)
     	  vDispatch.pdispval=Cast(IDISPATCH Ptr,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 DISPID
     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 uDispParams AS DISPPARAMS
     DIM hr AS HRESULT
     DIM vResult AS VARIANT
     
     IF  vDispatch.pdispval=NULL THEN Return ""
     
   #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
     hr = vDispatch.pdispval->Invoke(0, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
   #Else  
     hr = vDispatch.pdispval->lpvtbl->Invoke(vDispatch.pdispval,0, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
   #EndIf 

     Return *cast(WSTRING PTR,vResult.bstrval)

  END Property


Property OleFont.Size (BYVAL psize AS float )
     DIM uDispParams AS DISPPARAMS
     DIM hr AS HRESULT
     DIM DISPIDPROPERTYPUT AS DISPID
     DIM vArgs(0) AS VARIANT

     vArgs(0).Vt=VT_CY
     vArgs(0).cyval.int64=psize *10000
 
     IF vDispatch.pdispval=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 = vDispatch.pdispval->Invoke(2, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
     #Else
         hr = vDispatch.pdispval->lpvtbl->Invoke(vDispatch.pdispval,2, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
     #EndIf
     
  END Property

  Property OleFont.Size ()  AS float 
     DIM oDispatch AS IDISPATCH PTR
     DIM uDispParams AS DISPPARAMS
     DIM hr AS HRESULT
     DIM vResult AS VARIANT

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

     RETURN   vResult.Cyval.int64/10000

  END Property


  Property OleFont.Bold ()  AS VARIANT_BOOL 
     DIM uDispParams AS DISPPARAMS
     DIM hr AS HRESULT
     DIM vResult AS VARIANT
  
     IF vDispatch.pdispval=NULL THEN EXIT Property
     
     #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
         hr = vDispatch.pdispval->Invoke(3, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
     #Else
         hr = vDispatch.pdispval->lpvtbl->Invoke(vDispatch.pdispval,3, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
     #EndIf
     Return vResult.boolval
  END Property

   Property OleFont.Bold (BYVAL pbold AS VARIANT_BOOL )
     DIM uDispParams AS DISPPARAMS
     DIM hr AS HRESULT
     DIM DISPIDPROPERTYPUT AS DISPID
     DIM vArgs(0) AS VARIANT

      vArgs(0).vt =VT_BOOL
     vArgs(0).boolval =pbold
 
     IF vDispatch.pdispval=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 = vDispatch.pdispval->Invoke(3, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
     #Else
       hr = vDispatch.pdispval->lpvtbl->Invoke(vDispatch.pdispval,3, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
     #EndIf
     
  END Property
  
  Property OleFont.Italic ()  AS VARIANT_BOOL 
     DIM uDispParams AS DISPPARAMS
     DIM hr AS HRESULT
     DIM vResult AS VARIANT
     IF vDispatch.pdispval=NULL THEN EXIT Property
     
     #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
        hr = vDispatch.pdispval->Invoke(4, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
     #Else
     hr = vDispatch.pdispval->lpvtbl->Invoke(vDispatch.pdispval,4, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
     #EndIf
     Property = vResult.boolval

  END Property

  Property OleFont.Italic (BYVAL pitalic AS VARIANT_BOOL)
     DIM uDispParams AS DISPPARAMS
     DIM hr AS HRESULT
     DIM DISPIDPROPERTYPUT AS DISPID
     DIM vArgs(0) AS VARIANT

      vArgs(0).vt =VT_BOOL
      vArgs(0).boolval =pitalic
 
     IF vDispatch.pdispval=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 = vDispatch.pdispval->Invoke(4, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
     #Else
        hr = vDispatch.pdispval->lpvtbl->Invoke(vDispatch.pdispval,4, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
     #EndIf
  END Property
  
  Property OleFont.Underline ()  AS VARIANT_BOOL 
     DIM uDispParams AS DISPPARAMS
     DIM hr AS HRESULT
     DIM vResult AS VARIANT
       
     IF vDispatch.pdispval=NULL THEN EXIT Property
     
   #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
     hr = vDispatch.pdispval->Invoke(5, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
   #Else  
     hr = vDispatch.pdispval->lpvtbl->Invoke(vDispatch.pdispval,5, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
    #EndIf
     Property = vResult.boolval

  END Property

   Property OleFont.Underline ( BYVAL punderline AS VARIANT_BOOL )
     DIM uDispParams AS DISPPARAMS
     DIM hr AS HRESULT
     DIM DISPIDPROPERTYPUT AS DISPID
     DIM vArgs(0) AS VARIANT

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

       
     IF vDispatch.pdispval=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 = vDispatch.pdispval->Invoke(5, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
     #Else
         hr = vDispatch.pdispval->lpvtbl->Invoke(vDispatch.pdispval,5, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
     #EndIf
  END Property
  
  Property OleFont.Strikethrough ()  AS VARIANT_BOOL 
     DIM uDispParams AS DISPPARAMS
     DIM hr AS HRESULT
     DIM vResult AS VARIANT
      
     IF vDispatch.pdispval=NULL THEN EXIT Property
     
     #If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
          hr = vDispatch.pdispval->Invoke(6, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
     #Else
          hr = vDispatch.pdispval->lpvtbl->Invoke(vDispatch.pdispval,6, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
     #EndIf
     Property = vResult.boolval

  END Property

   Property OleFont.Strikethrough (BYVAL pstrikethrough AS VARIANT_BOOL)
 
     DIM uDispParams AS DISPPARAMS
     DIM hr AS HRESULT
     DIM DISPIDPROPERTYPUT AS DISPID
     DIM vArgs(0) AS VARIANT

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

       
     IF vDispatch.pdispval=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 = vDispatch.pdispval->Invoke(6, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
     #Else
        hr = vDispatch.pdispval->lpvtbl->Invoke(vDispatch.pdispval,6, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
      #EndIf
  END Property

  Property OleFont.Weight ()  AS integer 
     DIM uDispParams AS DISPPARAMS
     DIM hr AS HRESULT
     DIM vResult AS VARIANT

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

     RETURN  vResult.intval

  END Property

  Property OleFont.Weight ( BYVAL pweight AS integer )
     DIM uDispParams AS DISPPARAMS
     DIM hr AS HRESULT
     DIM DISPIDPROPERTYPUT AS DISPID
     DIM vArgs(0) AS VARIANT

     vArgs(0).vt =VT_INT
     vArgs(0).intval =pweight
       
     IF vDispatch.pdispval=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 = vDispatch.pdispval->Invoke(7, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
     #Else
        hr = vDispatch.pdispval->lpvtbl->Invoke(vDispatch.pdispval,7, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
     #EndIf
     
  END Property
  
  Property OleFont.Charset ()  AS integer 
     DIM uDispParams AS DISPPARAMS
     DIM hr AS HRESULT
     DIM vResult AS VARIANT

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

     RETURN vResult.intval

  END Property


  Property OleFont.Charset (BYVAL pcharset AS integer )
     DIM uDispParams AS DISPPARAMS
     DIM hr AS HRESULT
     DIM DISPIDPROPERTYPUT AS DISPID
     DIM vArgs(0) AS VARIANT

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

       
     IF vDispatch.pdispval=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 = vDispatch.pdispval->Invoke(8, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
     #Else
         hr = vDispatch.pdispval->lpvtbl->Invoke(vDispatch.pdispval,8, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
     #EndIf
     
  End Property

/' avec la methode Invoke
Property MSFlexGrid.Font() As OleFont
	dim as LPDISPATCH pDispatch 
	InvokeHelper(DISPID_FONT, DISPATCH_PROPERTYGET, VT_DISPATCH, cast(LPVOID PTR,@pDispatch), NULL) 
	return OleFont(pDispatch) 
End Property

Property MSFlexGrid.RefFont(newValue as LPDISPATCH )
		InvokeHelper(DISPID_FONT, DISPATCH_PROPERTYPUTREF, VT_EMPTY, NULL, parms,newValue) 
End Property

'/
OlefontEx.bi

Code: Select all

 
 
Type OleFont     ' peut s'utiliser ou on attend un IFONTDISP ptr
	Private:
       o_oleFont AS olevariant 
   Public:
   Declare Constructor
   Declare Constructor(ByRef value  As olevariant)
   Declare Constructor(ByRef value  As OleFont ) 
   Declare Operator cast() As olevariant 
   Declare Operator Let(ByRef value  As olevariant) 
   Declare Sub release()  
   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 Boolean 
   Declare Property Bold (ByVal pbold AS Boolean )
   Declare Property Italic () AS Boolean
   Declare Property Italic (ByVal pitalic AS Boolean ) 
   Declare Property Underline () AS Boolean 
   Declare Property Underline (ByVal punderline AS Boolean)
   Declare Property Strikethrough ( ) AS Boolean 
   Declare Property Strikethrough (ByVal pstrikethrough AS Boolean )

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

 
     Constructor OleFont
       Dim hr As HRESULT
       Dim pdisp As IDISPATCH Ptr
      hr = CoCreateInstance(@CLSID_StdFont, NULL, CLSCTX_SERVER, @IID_IDISPATCH,cast(LPVOID PTr,@pdisp))
      o_oleFont=pdisp
     End Constructor
     Constructor OleFont(ByRef value As olevariant)
         o_oleFont=value
     End Constructor
     Constructor OleFont(ByRef value  As OleFont )
        This=value
        o_oleFont=value
     End Constructor
     Operator OleFont.cast() As olevariant 
     	  Return o_oleFont
     End Operator
     Operator OleFont.Let(ByRef value  As olevariant)
     	  o_oleFont=value
     End Operator
     
     Sub  OleFont.Release()
     	  variantclear(Cast(VARIANT Ptr,@o_oleFont)) 
     End Sub

  Property OleFont.Name (BYVAL pname AS string )
     InvokePropPut(o_oleFont,"Name",pname)
  End Property
  
Property OleFont.Name ()  AS string 
Dim PvarRes as oleVariant
InvokePropGet(o_oleFont,@pvarRes,"Name")
	Return pVarRes
End Property


Property OleFont.Size (BYVAL psize AS float )
InvokePropPut(o_oleFont,"Size",psize)
  END Property

  Property OleFont.Size ()  AS float 
Dim PvarRes as oleVariant
InvokePropGet(o_oleFont,@pvarRes,"Size")
	Return pVarRes
   END Property


  Property OleFont.Bold ()  AS Boolean 
Dim PvarRes as oleVariant
InvokePropGet(o_oleFont,@pvarRes,"Bold")
	Return pVarRes
  END Property

   Property OleFont.Bold (BYVAL pbold AS Boolean )
InvokePropPut(o_oleFont,"Bold",pbold)
   END Property
  
  Property OleFont.Italic ()  AS Boolean 
Dim PvarRes as oleVariant
InvokePropGet(o_oleFont,@pvarRes,"Italic")
	Return pVarRes
  END Property

  Property OleFont.Italic (BYVAL pitalic AS Boolean)
 InvokePropPut(o_oleFont,"Italic",pitalic) 
  END Property
  
  Property OleFont.Underline ()  AS Boolean 
Dim PvarRes as oleVariant
InvokePropGet(o_oleFont,@pvarRes,"Underline")
	Return pVarRes
  END Property

   Property OleFont.Underline ( BYVAL punderline AS Boolean )
    InvokePropPut(o_oleFont,"Underline",punderline) 
  END Property
  
  Property OleFont.Strikethrough ()  AS Boolean 
Dim PvarRes as oleVariant
InvokePropGet(o_oleFont,@pvarRes,"Strikethrough")
	Return pVarRes
  END Property

   Property OleFont.Strikethrough (BYVAL pstrikethrough AS Boolean)
InvokePropPut(o_oleFont,"Strikethrough",pstrikethrough) 
  END Property

  Property OleFont.Weight ()  AS Long 
Dim PvarRes as oleVariant
InvokePropGet(o_oleFont,@pvarRes,"Weight")
	Return pVarRes
  END Property

  Property OleFont.Weight ( BYVAL pweight AS Long )
 InvokePropPut(o_oleFont,"Weight",pweight) 
  END Property
  
  Property OleFont.Charset ()  AS Long 
Dim PvarRes as oleVariant
InvokePropGet(o_oleFont,@pvarRes,"Charset")
	Return pVarRes
  END Property


  Property OleFont.Charset (BYVAL pcharset AS Long )
InvokePropPut(o_oleFont,"Charset",pcharset)
  End Property
  
  
  
  

/' avec la methode Invoke
Property MSFlexGrid.Font() As OleFont
	LPDISPATCH pDispatch;
	InvokeHelper(DISPID_FONT, DISPATCH_PROPERTYGET, VT_DISPATCH, cast(LPVOID PTR,@pDispatch), NULL) 
	return OleFont(pDispatch) 
End Property

Property MSFlexGrid.RefFont(newValue as LPDISPATCH )
		InvokeHelper(DISPID_FONT, DISPATCH_PROPERTYPUTREF, VT_EMPTY, NULL, parms,newValue) 
End Property

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

Re: INSIDE ACTIVEX WITH FREEBASIC

Post by aloberoger »

theses examples show how to loadpicture with ole (we don't need to initialize ole at all) and also show how to implement stdFont and stdpicture.
Now in your ActiveX project you can use them in object Oriented manners where IFONTDISP PTR and IPICTUREDIP Ptr
are espected.
http://www.2shared.com/file/jQs_53Q9/po ... _2014.html
aloberoger
Posts: 507
Joined: Jan 13, 2009 19:23

Re: INSIDE ACTIVEX WITH FREEBASIC

Post by aloberoger »

this post show how to handles Events on the Flexgrid
the next post will show how it is easy to use polymorphism.
the feedback will be welcome.
http://www.2shared.com/file/8ns9XxQ7/ms ... 01_20.html
Post Reply