INSIDE ACTIVEX WITH FREEBASIC
-
- Posts: 507
- Joined: Jan 13, 2009 19:23
INSIDE ACTIVEX WITH FREEBASIC
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
http://www.2shared.com/file/-XG27yjo/Post1.html
Re: INSIDE ACTIVEX WITH FREEBASIC
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.
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.
-
- Posts: 507
- Joined: Jan 13, 2009 19:23
Re: INSIDE ACTIVEX WITH FREEBASIC
there will be an improvement be sure
-
- Posts: 507
- Joined: Jan 13, 2009 19:23
Re: INSIDE ACTIVEX WITH FREEBASIC
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 " .
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
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
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.
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
" 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
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.
-
- Posts: 507
- Joined: Jan 13, 2009 19:23
Re: INSIDE ACTIVEX WITH FREEBASIC
New Post to download at http://www.2shared.com/file/OWXFhJdX/Post2.html
-
- Posts: 507
- Joined: Jan 13, 2009 19:23
Re: INSIDE ACTIVEX WITH FREEBASIC
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
#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
-
- Posts: 507
- Joined: Jan 13, 2009 19:23
Re: INSIDE ACTIVEX WITH FREEBASIC
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
-
- Posts: 507
- Joined: Jan 13, 2009 19:23
Re: INSIDE ACTIVEX WITH FREEBASIC
managing excell with Invoke wrapper
ExcellInvoke.bas
you need updated files
InvokeHelper.bi
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
'/
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
-
- Posts: 507
- Joined: Jan 13, 2009 19:23
Re: INSIDE ACTIVEX WITH FREEBASIC
And
variants.bi
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
-
- Posts: 507
- Joined: Jan 13, 2009 19:23
Re: INSIDE ACTIVEX WITH FREEBASIC
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
-
- Posts: 507
- Joined: Jan 13, 2009 19:23
Re: INSIDE ACTIVEX WITH FREEBASIC
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)
-
- Posts: 507
- Joined: Jan 13, 2009 19:23
Re: INSIDE ACTIVEX WITH FREEBASIC
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
How to Use Microsoft Flexgrid with Freebasic
These topics are treated in this link: http://www.2shared.com/file/Ts6T7Jg-/Post4.html
-
- Posts: 507
- Joined: Jan 13, 2009 19:23
Re: INSIDE ACTIVEX WITH FREEBASIC
These two files are goiung to be usefull in the next post
olefont.bi
OlefontEx.bi
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
'/
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
'/
-
- Posts: 507
- Joined: Jan 13, 2009 19:23
Re: INSIDE ACTIVEX WITH FREEBASIC
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
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
-
- Posts: 507
- Joined: Jan 13, 2009 19:23
Re: INSIDE ACTIVEX WITH FREEBASIC
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
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