the source for RegReadtlb.dll is not includedHere is source code of FBTLBWTR.exe
INSIDE ACTIVEX WITH FREEBASIC
Re: INSIDE ACTIVEX WITH FREEBASIC
@aloberoger , thanks
Re: INSIDE ACTIVEX WITH FREEBASIC
@aloberoger
the link is not workingcomobject.dll
comobject in a dll, you can also build a static library
http://www.2shared.com/file/yF2nCKcg/po ... bject.html
-
- Posts: 507
- Joined: Jan 13, 2009 19:23
Re: INSIDE ACTIVEX WITH FREEBASIC
source for Regreadtlb.dll
Code: Select all
#Include Once "windows.bi"
#Include Once "win/commctrl.bi"
#Include Once "strwrap.bi"
#Include Once "lv.bi"
Function RegSearchWin32 (tszKey AS string) AS STRING
Dim szKeyName AS zstring * max_PATH
Dim szKey AS zstring * max_PATH
Dim szClass AS zstring * max_PATH
dim ft AS FILETIME
Dim hKey AS HKEY
Dim dwIdx AS uinteger
Dim hr AS uinteger
Dim dwname as uinteger=max_path
Dim dwclass as uinteger=max_path
szkey=tszkey
DO
hr = RegOpenKeyEx (hkey_CLASSES_ROOT, @szKey, 0, KEY_READ, @hKey)
IF hr=ERROR_NO_MORE_ITEMS THEN EXIT FUNCTION
IF hKey = 0 THEN EXIT FUNCTION
dwname=max_path
dwclass=max_path
hr = RegEnumKeyEx (hKey, dwIdx, @szKeyName, @dwname, 0, @szClass, @dwclass, @ft)
IF hr<>0 THEN EXIT DO
IF UCASE$(szKeyName) = "WIN32" THEN EXIT DO
dwIdx+=1
LOOP WHILE hr = 0
RegCloseKey hKey
IF hr <> 0 OR szKeyName = "" THEN EXIT FUNCTION
FUNCTION = szKey
END FUNCTION
FUNCTION RegEnumDirectory (sKey AS STRING) AS STRING
Dim szKey AS zstring * max_PATH
Dim szKeyName AS zstring * max_PATH
Dim szClass AS zstring * max_PATH
Dim ft AS FILETIME
Dim hKey AS HKEY
Dim dwIdx AS uinteger
Dim hr AS uinteger
dim sSubkey AS STRING
Dim dwname as uinteger
Dim dwclass as uinteger
' Searches the HKEY_CLASSES_ROOT\TypeLib\<LIBID> node.
szKey = sKey
hr = RegOpenKeyEx (hkey_CLASSES_ROOT, @szKey, 0, KEY_READ, @hKey)
IF hr <> ERROR_SUCCESS THEN EXIT FUNCTION
IF hKey = 0 THEN EXIT FUNCTION
dwIdx = 0
DO
dwname=max_path
dwclass=max_path
hr = RegEnumKeyEx (hKey, dwIdx, @szKeyName, @dwname, 0, @szClass, @dwclass, @ft)
IF hr=ERROR_NO_MORE_ITEMS THEN EXIT DO
sSubkey = RegSearchWin32(szKey & "\" & szKeyName)
IF LEN(sSubkey) THEN EXIT DO
dwIdx+=1
LOOP
RegCloseKey hKey
IF hr <> 0 OR sSubkey = "" THEN EXIT FUNCTION
dim szValueName AS zstring * max_PATH
Dim KeyType AS DWORD
Dim szKeyValue AS zstring * max_PATH
Dim cValueName AS DWORD
Dim cbData AS DWORD
' win32 node
dwIdx = 0
cValueName = max_PATH
cbData = max_PATH
szKey = sSubkey & "\" & "win32"
hr = RegOpenKeyEx (hkey_CLASSES_ROOT, @szKey, 0, KEY_READ, @hKey)
IF hr <> ERROR_SUCCESS THEN EXIT FUNCTION
hr = RegEnumValue (hKey, dwIdx, @szValueName, @cValueName, BYVAL NULL, @KeyType, @szKeyValue, @cbData)
RegCloseKey hKey
FUNCTION = szKeyValue
END FUNCTION
Function CheckEnvVar(BYVAL sTextIn AS STRING) AS STRING
Dim iPos AS LONG
dim iSafety AS LONG
Dim sTemp AS STRING
Dim sNew AS String
Dim ttxt As String
ttxt=stextin
DO UNTIL str_TALLY(ttxt,"%") < 2
iPos = INSTR(1,ttxt,"%") 'get first position
sTemp = MID$(ttxt,iPos + 1,(INSTR(iPos +1,ttxt,"%")- (iPos + 1)))
sNew = ENVIRON$(sTemp)
ttxt=str_replace( "%" + sTemp + "%",sNew,ttxt)
iSafety+=1 : IF iSafety > 5 THEN EXIT do 'if we find more than 5 vars... something is wrong
LOOP
FUNCTION = ttxt
End FUNCTION
Function RegEnumVersions (hlist As HWND,sCLSID AS STRING) AS LONG
Dim szKey AS zstring * max_PATH
dim szKeyName AS zstring * max_PATH
dim szClass AS zstring * max_PATH
dim ft AS FILETIME
dim hKey AS HKEY
Dim dwIdx AS DWORD
dim hr AS DWORD
dim idx AS LONG
dim sPath AS STRING
dim PathPos AS LONG
dim sFile AS STRING
dim i AS LONG
dim lvi as lv_item
dim szValueName AS zstring * max_PATH
dim KeyType AS DWORD
dim szKeyValue AS zstring * max_PATH
dim tsz AS zstring * max_PATH
dim cValueName AS DWORD
dim cbData AS DWORD
dim hVerKey AS HKEY
dim verIdx AS DWORD
dim vmax_path as uinteger
dim dwname as uinteger
dim dwclass as uinteger
cValueName = max_PATH
cbData = max_PATH
' // Searches the HKEY_CLASSES_ROOT\TypeLib\<LIBID> node.
szKey = "TypeLib\" & sCLSID
hr = RegOpenKeyEx (hkey_CLASSES_ROOT, @szKey, 0, KEY_READ, @hKey)
IF hr <> ERROR_SUCCESS THEN EXIT Function
IF hKey = 0 THEN EXIT FUNCTION
dwIdx = 0
' // Open the subtrees of the different versions of the TypeLib library
' // and store the filenames, descriptions, paths and CLSIDs in a 4D array.
DO
dwname=max_path
dwclass=max_path
hr = RegEnumKeyEx (hKey, dwIdx, @szKeyName, @dwname, 0, @szClass, @dwclass, @ft)
IF hr=ERROR_NO_MORE_ITEMS THEN EXIT DO
lvi.iItem = 0
lvi.mask = LVIF_TEXT
lvi.iSubItem = 0
tsz=UCASE$(sCLSID)
lvi.pszText = StrPtr(tsz)
SendMessage hlist,LVM_INSERTITEM,0,Cast(LPARAM,@lvi)
' -- Get default value -------------------------------------------
verIdx = 0
cvaluename=max_path
cbdata=max_path
tsz=szKey & "\" & szKeyName
hr = RegOpenKeyEx (hkey_CLASSES_ROOT,@tsz,0,KEY_READ, @hVerKey)
hr = RegEnumValue(hVerKey, verIdx, @szValueName, @cValueName, NULL, @KeyType, @szKeyValue, @cbData) 'Default value
RegCloseKey hVerKey
IF szValueName = "" THEN
lvi.iSubItem =1
lvi.pszText = @szKeyvalue
SendMessage hlist,LVM_SETITEM,0,Cast(LPARAM,@lvi)
Else
lvi.iSubItem = 1
lvi.pszText = @szValueName
SendMessage hlist,LVM_SETITEM,0,Cast(LPARAM,@lvi)
End IF
'-----------------------------------------------------------------
sPath = RegEnumDirectory(szKey & "\" & szKeyName)
' Check for environment variables
IF INSTR(sPath, "%") THEN
sPath = CheckEnvVar(sPath)'-- added in July 25th, 2003
EndIf
lvi.iSubItem = 3
lvi.pszText = strptr(spath)
SendMessage hlist,LVM_SETITEM,0,Cast(LPARAM,@lvi)
sfile=str_parse(spath,"\",str_numparse(spath,"\"))
If InStr(sfile,".")=0 Then sfile=str_parse(spath,"\",str_numparse(spath,"\")-1)
lvi.iSubItem = 2
lvi.pszText = strptr(sfile)
SendMessage hlist,LVM_SETITEM,0,Cast(LPARAM,@lvi)
dwIdx+=1
Loop
' // Close the registry
RegCloseKey hKey
Return 0
END FUNCTION
' *********************************************************************************************
' Enumerates all the typelibs.
' *********************************************************************************************
SUB RegEnumTypeLibs(hlist As HWND)
Dim szKey AS zstring*max_path
dim szKeyName AS zstring*max_path
dim szClass AS zstring*max_path
dim ft AS FILETIME
dim hKey AS hkey
dim dwIdx AS uinteger
dim hr AS uinteger
dim ttxt as string
dim dwname as dword
dim dwclass as dword
' // Open the HKEY_CLASSES_ROOT\TypeLib subtree.
szKey = "TypeLib"
hr = RegOpenKeyEx (HKEY_CLASSES_ROOT, @szKey,0,key_read,@hKey)
IF hr <> ERROR_SUCCESS THEN EXIT SUB
IF hKey = 0 THEN EXIT SUB
' // Parse all the TypeLib subtree and get the CLSIDs of all the TypeLibs.
dwIdx = 0
Do
dwname=MAX_PATH:dwclass=max_path
hr = RegEnumKeyEx (hKey, dwIdx, @szKeyName, @dwname, 0, @szClass, @dwclass, @ft)
IF hr=ERROR_NO_MORE_ITEMS THEN EXIT DO
dwIdx +=1
RegEnumVersions(hlist,Left(szKeyName,dwname))
LOOP
' // Close the registry
RegCloseKey(hKey)
End SUB
#define ListView_SetItemCountEx(l,c,f) SendMessage(L, LVM_SETITEMCOUNT, c, F)
Extern "windows-ms"
FUNCTION SearchTypeLibs (hlist As HWND) AS Long Export
SendMessage hlist,LVM_DELETEALLITEMS,0,0
RegEnumTypeLibs(hlist)
Return 0
End Function
End Extern
-
- Posts: 507
- Joined: Jan 13, 2009 19:23
Re: INSIDE ACTIVEX WITH FREEBASIC
marpon said
try the new link in the previous post.the link is not working
Re: INSIDE ACTIVEX WITH FREEBASIC
@aloberoger thanks again
on the fbtlbreader.bas (extract)
you are genereting code referring to :
Comobjects.bi
olefont.bi
olepictureex.bi
Invoke.bi
but i did not find these files...
on the fbtlbreader.bas (extract)
Code: Select all
Else
ss &="#Include Once " & DQ & "Comobjects.bi" & DQ & CRLF
ss &= CRLF
End If
If icode=ABSTRACTCLASS_CODE Or INVOKE_INVOKE Then
If UseIfont=TRUE Or UseIFontDisp=TRUE Then
If UseOleFontWrapper=TRUE Then ss &="#Include Once " & DQ & "olefont.bi" & DQ & CRLF
End If
If UseIPicture=TRUE Or UseIPictureDisp=TRUE Then
If UseOleFontWrapper=TRUE Then ss &="#Include Once " & DQ & "olepictureex.bi" & DQ & CRLF
End If
End If
If icode=INVOKE_INVOKE Then
ss &="#include once " & DQ & "Invoke.bi" & DQ & CRLF
EndIf
Comobjects.bi
olefont.bi
olepictureex.bi
Invoke.bi
but i did not find these files...
-
- Posts: 507
- Joined: Jan 13, 2009 19:23
Re: INSIDE ACTIVEX WITH FREEBASIC
oleFont.bi
olepictureex.bi
Code: Select all
Type OleFont ' peut s'utiliser ou on attend un IFONTDISP ptr
Private:
vDispatch AS VARIANT
Public:
Declare Constructor
Declare Constructor(ByRef value As IDISPATCH Ptr)
Declare Constructor(ByRef value As OleFont )
Declare Operator cast() As IDISPATCH Ptr
Declare Operator Let(ByRef value As IDISPATCH Ptr)
Declare Property Name () AS string
Declare Property Name ( BYVAL pname AS string)
Declare Property Size () AS float
Declare Property Size (ByVal psize AS float )
Declare Property Bold () AS VARIANT_BOOL
Declare Property Bold (ByVal pbold AS VARIANT_BOOL )
Declare Property Italic () AS VARIANT_BOOL
Declare Property Italic (ByVal pitalic AS VARIANT_BOOL )
Declare Property Underline () AS VARIANT_BOOL
Declare Property Underline (ByVal punderline AS VARIANT_BOOL)
Declare Property Strikethrough ( ) AS VARIANT_BOOL
Declare Property Strikethrough (ByVal pstrikethrough AS VARIANT_BOOL )
Declare Property Weight () AS integer
Declare Property Weight (ByVal pweight AS integer)
Declare Property Charset () AS integer
Declare Property Charset (ByVal pcharset AS integer)
End Type
Constructor OleFont
Dim hr As HRESULT
hr = CoCreateInstance(@CLSID_StdFont, NULL, CLSCTX_SERVER, @IID_IDISPATCH,cast(LPVOID PTr,@vDispatch))
End Constructor
Constructor OleFont(ByRef value As IDISPATCH Ptr)
vDispatch.pdispval=value
End Constructor
Constructor OleFont(ByRef value As OleFont )
This=value
vDispatch.pdispval=value
End Constructor
Operator OleFont.cast() As IDISPATCH Ptr
Return vDispatch.pdispval
End Operator
Operator OleFont.Let(ByRef value As IDISPATCH Ptr)
vDispatch.pdispval=value
End Operator
Property OleFont.Name (BYVAL pname AS string )
DIM oDispatch AS IDISPATCH PTR
DIM uDispParams AS DISPPARAMS
DIM hr AS HRESULT
DIM DISPIDPROPERTYPUT AS LONG
DIM vArgs(0) AS VARIANT
vArgs(0).vt =VT_BSTR
vArgs(0).bstrval =strtobstr(pname)
oDispatch = vDispatch.pdispval
IF oDispatch=NULL THEN EXIT Property
uDispParams.CNamedArgs = 1
DISPIDPROPERTYPUT = -3
uDispParams.rgdispidNamedArgs = VARPTR(DISPIDPROPERTYPUT)
uDispParams.CArgs = 1
uDispParams.rgvarg = @vArgs(0)
#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
hr = oDispatch->Invoke(0, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
#Else
hr = oDispatch->lpvtbl->Invoke(oDispatch,0, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
#EndIf
oDispatch = NULL
END Property
Property OleFont.Name () AS string
DIM oDispatch AS IDISPATCH PTR
DIM uDispParams AS DISPPARAMS
DIM hr AS HRESULT
DIM vResult AS VARIANT
oDispatch = vDispatch.pdispval
IF oDispatch=NULL THEN EXIT Property
#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
hr = oDispatch->Invoke(0, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
#Else
hr = oDispatch->lpvtbl->Invoke(oDispatch,0, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
#EndIf
oDispatch = NULL
Property = *cast(WSTRING PTR,vResult.bstrval)
END Property
Property OleFont.Size (BYVAL psize AS float )
DIM oDispatch AS IDISPATCH PTR
DIM uDispParams AS DISPPARAMS
DIM hr AS HRESULT
DIM DISPIDPROPERTYPUT AS LONG
DIM vArgs(0) AS VARIANT
vArgs(0).Vt=VT_CY
vArgs(0).cyval.int64=psize *10000
oDispatch = vDispatch.pdispval
IF oDispatch=NULL THEN EXIT Property
uDispParams.CNamedArgs = 1
DISPIDPROPERTYPUT = -3
uDispParams.rgdispidNamedArgs = VARPTR(DISPIDPROPERTYPUT)
uDispParams.CArgs = 1
uDispParams.rgvarg = @vArgs(0)
#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
hr = oDispatch->Invoke(2, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
#Else
hr = oDispatch->lpvtbl->Invoke(oDispatch,2, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
#EndIf
oDispatch = NULL
END Property
Property OleFont.Size () AS float
DIM oDispatch AS IDISPATCH PTR
DIM uDispParams AS DISPPARAMS
DIM hr AS HRESULT
DIM vResult AS VARIANT
oDispatch = vDispatch.pdispval
IF oDispatch=NULL THEN EXIT Property
#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
hr = oDispatch->Invoke(2, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
#Else
hr = oDispatch->lpvtbl->Invoke(oDispatch,2, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
#EndIf
oDispatch = NULL
RETURN vResult.Cyval.int64/10000
END Property
Property OleFont.Bold () AS VARIANT_BOOL
DIM oDispatch AS IDISPATCH PTR
DIM uDispParams AS DISPPARAMS
DIM hr AS HRESULT
DIM vResult AS VARIANT
oDispatch = vDispatch.pdispval
IF oDispatch=NULL THEN EXIT Property
#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
hr = oDispatch->Invoke(3, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
#Else
hr = oDispatch->lpvtbl->Invoke(oDispatch,3, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
#EndIf
oDispatch = NULL
Property = vResult.boolval
END Property
Property OleFont.Bold (BYVAL pbold AS VARIANT_BOOL )
DIM oDispatch AS IDISPATCH PTR
DIM uDispParams AS DISPPARAMS
DIM hr AS HRESULT
DIM DISPIDPROPERTYPUT AS LONG
DIM vArgs(0) AS VARIANT
vArgs(0).vt =VT_BOOL
vArgs(0).boolval =pbold
oDispatch = vDispatch.pdispval
IF oDispatch=NULL THEN EXIT Property
uDispParams.CNamedArgs = 1
DISPIDPROPERTYPUT = -3
uDispParams.rgdispidNamedArgs = VARPTR(DISPIDPROPERTYPUT)
uDispParams.CArgs = 1
uDispParams.rgvarg = @vArgs(0)
#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
hr = oDispatch->Invoke(3, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
#Else
hr = oDispatch->lpvtbl->Invoke(oDispatch,3, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
#EndIf
oDispatch = NULL
END Property
Property OleFont.Italic () AS VARIANT_BOOL
DIM oDispatch AS IDISPATCH PTR
DIM uDispParams AS DISPPARAMS
DIM hr AS HRESULT
DIM vResult AS VARIANT
oDispatch = vDispatch.pdispval
IF oDispatch=NULL THEN EXIT Property
#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
hr = oDispatch->Invoke(4, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
#Else
hr = oDispatch->lpvtbl->Invoke(oDispatch,4, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
#EndIf
oDispatch = NULL
Property = vResult.boolval
END Property
Property OleFont.Italic (BYVAL pitalic AS VARIANT_BOOL)
DIM oDispatch AS IDISPATCH PTR
DIM uDispParams AS DISPPARAMS
DIM hr AS HRESULT
DIM DISPIDPROPERTYPUT AS LONG
DIM vArgs(0) AS VARIANT
vArgs(0).vt =VT_BOOL
vArgs(0).boolval =pitalic
oDispatch = vDispatch.pdispval
IF oDispatch=NULL THEN EXIT Property
uDispParams.CNamedArgs = 1
DISPIDPROPERTYPUT = -3
uDispParams.rgdispidNamedArgs = VARPTR(DISPIDPROPERTYPUT)
uDispParams.CArgs = 1
uDispParams.rgvarg = @vArgs(0)
#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
hr = oDispatch->Invoke(4, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
#Else
hr = oDispatch->lpvtbl->Invoke(oDispatch,4, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
#EndIf
oDispatch = NULL
END Property
Property OleFont.Underline () AS VARIANT_BOOL
DIM oDispatch AS IDISPATCH PTR
DIM uDispParams AS DISPPARAMS
DIM hr AS HRESULT
DIM vResult AS VARIANT
oDispatch = vDispatch.pdispval
IF oDispatch=NULL THEN EXIT Property
#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
hr = oDispatch->Invoke(5, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
#Else
hr = oDispatch->lpvtbl->Invoke(oDispatch,5, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
#EndIf
oDispatch = NULL
Property = vResult.boolval
END Property
Property OleFont.Underline ( BYVAL punderline AS VARIANT_BOOL )
DIM oDispatch AS IDISPATCH PTR
DIM uDispParams AS DISPPARAMS
DIM hr AS HRESULT
DIM DISPIDPROPERTYPUT AS LONG
DIM vArgs(0) AS VARIANT
vArgs(0).vt =VT_BOOL
vArgs(0).boolval =punderline
oDispatch = vDispatch.pdispval
IF oDispatch=NULL THEN EXIT Property
uDispParams.CNamedArgs = 1
DISPIDPROPERTYPUT = -3
uDispParams.rgdispidNamedArgs = VARPTR(DISPIDPROPERTYPUT)
uDispParams.CArgs = 1
uDispParams.rgvarg = @vArgs(0)
#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
hr = oDispatch->Invoke(5, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
#Else
hr = oDispatch->lpvtbl->Invoke(oDispatch,5, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
#EndIf
oDispatch = NULL
END Property
Property OleFont.Strikethrough () AS VARIANT_BOOL
DIM oDispatch AS IDISPATCH PTR
DIM uDispParams AS DISPPARAMS
DIM hr AS HRESULT
DIM vResult AS VARIANT
oDispatch = vDispatch.pdispval
IF oDispatch=NULL THEN EXIT Property
#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
hr = oDispatch->Invoke(6, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
#Else
hr = oDispatch->lpvtbl->Invoke(oDispatch,6, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
#EndIf
oDispatch = NULL
Property = vResult.boolval
END Property
Property OleFont.Strikethrough (BYVAL pstrikethrough AS VARIANT_BOOL)
DIM oDispatch AS IDISPATCH PTR
DIM uDispParams AS DISPPARAMS
DIM hr AS HRESULT
DIM DISPIDPROPERTYPUT AS LONG
DIM vArgs(0) AS VARIANT
vArgs(0).vt =VT_BOOL
vArgs(0).boolval =pstrikethrough
oDispatch = vDispatch.pdispval
IF oDispatch=NULL THEN EXIT Property
uDispParams.CNamedArgs = 1
DISPIDPROPERTYPUT = -3
uDispParams.rgdispidNamedArgs = VARPTR(DISPIDPROPERTYPUT)
uDispParams.CArgs = 1
uDispParams.rgvarg = @vArgs(0)
#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
hr = oDispatch->Invoke(6, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
#Else
hr = oDispatch->lpvtbl->Invoke(oDispatch,6, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
#EndIf
oDispatch = NULL
END Property
Property OleFont.Weight () AS integer
DIM oDispatch AS IDISPATCH PTR
DIM uDispParams AS DISPPARAMS
DIM hr AS HRESULT
DIM vResult AS VARIANT
oDispatch = vDispatch.pdispval
IF oDispatch=NULL THEN EXIT Property
#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
hr = oDispatch->Invoke(7, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
#Else
hr = oDispatch->lpvtbl->Invoke(oDispatch,7, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
#EndIf
oDispatch = NULL
RETURN vResult.intval
END Property
Property OleFont.Weight ( BYVAL pweight AS integer )
DIM oDispatch AS IDISPATCH PTR
DIM uDispParams AS DISPPARAMS
DIM hr AS HRESULT
DIM DISPIDPROPERTYPUT AS LONG
DIM vArgs(0) AS VARIANT
vArgs(0).vt =VT_INT
vArgs(0).intval =pweight
oDispatch = vDispatch.pdispval
IF oDispatch=NULL THEN EXIT Property
uDispParams.CNamedArgs = 1
DISPIDPROPERTYPUT = -3
uDispParams.rgdispidNamedArgs = VARPTR(DISPIDPROPERTYPUT)
uDispParams.CArgs = 1
uDispParams.rgvarg = @vArgs(0)
#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
hr = oDispatch->Invoke(7, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
#Else
hr = oDispatch->lpvtbl->Invoke(oDispatch,7, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
#EndIf
oDispatch = NULL
END Property
Property OleFont.Charset () AS integer
DIM oDispatch AS IDISPATCH PTR
DIM uDispParams AS DISPPARAMS
DIM hr AS HRESULT
DIM vResult AS VARIANT
oDispatch = vDispatch.pdispval
IF oDispatch=NULL THEN EXIT Property
#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
hr = oDispatch->Invoke(8, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
#Else
hr = oDispatch->lpvtbl->Invoke(oDispatch,8, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL, NULL)
#EndIf
oDispatch = NULL
RETURN vResult.intval
END Property
Property OleFont.Charset (BYVAL pcharset AS integer )
DIM oDispatch AS IDISPATCH PTR
DIM uDispParams AS DISPPARAMS
DIM hr AS HRESULT
DIM DISPIDPROPERTYPUT AS LONG
DIM vArgs(0) AS VARIANT
vArgs(0).vt =VT_INT
vArgs(0).intval =pcharset
oDispatch = vDispatch.pdispval
IF oDispatch=NULL THEN EXIT Property
uDispParams.CNamedArgs = 1
DISPIDPROPERTYPUT = -3
uDispParams.rgdispidNamedArgs = VARPTR(DISPIDPROPERTYPUT)
uDispParams.CArgs = 1
uDispParams.rgvarg = @vArgs(0)
#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
hr = oDispatch->Invoke(8, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
#Else
hr = oDispatch->lpvtbl->Invoke(oDispatch,8, @IID_NULL, 0, 4, @uDispParams, NULL, NULL, NULL)
#EndIf
oDispatch = NULL
End Property
Code: Select all
Type OlePicture ' can be used where IPICTUREDISP PTR is needed
Private:
oPicture AS IPICTUREDISP Ptr
m_handle As ..HANDLE
m_typ As Short
m_Own As VARIANT_BOOL
Public:
Declare Constructor
Declare Constructor(ByRef value As IDISPATCH Ptr)
Declare Constructor(ByRef value As OlePicture )
Declare Operator cast() As IDISPATCH Ptr
Declare Operator Let(ByRef value As iDispatCH Ptr)
Declare Operator cast() As IPICTUREDISP Ptr
Declare Operator Let(ByRef value As IPICTUREDISP Ptr)
Declare SUB Release()
Declare Property Handle (value As HANDLE)
Declare Property Handle () AS ..HANDLE
Declare Property Typ (AS Short) ' PICTYPE_BITMAP,PICTYPE_METAFILE,PICTYPE_ICON,PICTYPE_ENHMETAFILE
Declare Property Own(value As BOOL)
Declare Sub Create() ' create if handle is set (hbitmaP,hicon,HMETAFILE), and typ
Declare Property Width () AS OLE_XSIZE_HIMETRIC
Declare Property Height ()As OLE_XSIZE_HIMETRIC
Declare Sub LoadPictureFile(szFile As String) ' create from a file
Declare Sub LoadPicRes(hInst As HINSTANCE , resID As Integer) ' create from rc RCDATA value for bitmap icon etc
Declare Function IsNULL() As BOOL
End Type
Constructor OlePicture
' Dim hr As HRESULT
' coinitialize(NULL)
'hr = CoCreateInstance(@CLSID_StdPicture, NULL, CLSCTX_ALL, @IID_IPICTURE,cast(LPVOID PTr,@oPicture))
'Not need This at all because vDispatch will be created but With no image
End Constructor
Constructor OlePicture(ByRef value As iDispatCH Ptr)
oPicture=Cast(IPICTUREDISP Ptr,value)
End Constructor
Constructor OlePicture(ByRef value As OlePicture )
This=value
oPicture=value.oPicture
End Constructor
Operator OlePicture.cast() As iDispatCH Ptr
Return Cast(iDispatCH Ptr,oPicture)
End Operator
Operator OlePicture.Let(ByRef value As iDispatCH Ptr)
oPicture=Cast(IPICTUREDISP Ptr,value)
End Operator
Operator OlePicture.cast() As IPICTUREDISP Ptr
Return oPicture
End Operator
Operator OlePicture.Let(ByRef value As IPICTUREDISP Ptr)
oPicture= value
End Operator
SUB OlePicture.Release()
#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
oPicture->Release()
#Else
oPicture->lpvtbl->Release(oPicture)
#EndIf
End Sub
Property OlePicture.Handle (value As ..HANDLE)
m_Handle=value
End Property
Property OlePicture.Handle () AS ..HANDLE
Dim uDispParams AS DISPPARAMS
DIM hr AS HRESULT
DIM vResult AS VARIANT
IF oPicture=NULL THEN EXIT Property
#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
hr = oPicture->Invoke(0, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL,NULL)
#Else
hr = oPicture->lpvtbl->Invoke(oPicture,0, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL,NULL)
#EndIf
m_Handle=Cast(..HANDLE,vResult.lval)
RETURN m_Handle
END Property
Property OlePicture.Typ(value AS Short )
m_typ=value
END Property
Property OlePicture.Own(value As BOOL)
m_Own=value
End Property
Property OlePicture.Width () AS OLE_XSIZE_HIMETRIC
Dim res As OLE_XSIZE_HIMETRIC
DIM uDispParams AS DISPPARAMS
DIM hr AS HRESULT
DIM vResult AS VARIANT
If oPicture=NULL THEN EXIT Property
#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
hr = oPicture->Invoke(4, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL,NULL)
#Else
hr = oPicture->lpvtbl->Invoke(opicture,4, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL,NULL)
#EndIf
res= Cast(OLE_XSIZE_HIMETRIC,vResult.lval)
Return res
END Property
Property OlePicture.Height () As OLE_XSIZE_HIMETRIC
Dim res As OLE_XSIZE_HIMETRIC
DIM uDispParams AS DISPPARAMS
DIM hr AS HRESULT
DIM vResult AS VARIANT
If oPicture=NULL THEN EXIT Property
#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
hr = oPicture->Invoke(5, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL,NULL)
#Else
hr = oPicture->lpvtbl->Invoke(opicture,5, @IID_NULL, 0, 1, @uDispParams, @vResult, NULL,NULL)
#EndIf
res= Cast(OLE_XSIZE_HIMETRIC,vResult.lval)
Return res
END Property
Sub OlePicture.Create()
Dim tpd AS PICTDESC
IF m_Handle = 0 THEN return
SELECT CASE m_Typ
CASE PICTYPE_BITMAP ' Bitmap
tpd.bmp.hbitmap = m_Handle
CASE PICTYPE_ICON ' Icon
tpd.icon.hicon = m_Handle
Case PICTYPE_METAFILE
tpd.wmf.hmeta=m_Handle
'tpd.wmf.xExt=
'tpd.wmf.yExt=
Case PICTYPE_ENHMETAFILE
tpd.emf.hemf=m_Handle
CASE ELSE
Return
END SELECT
tpd.cbSizeOfStruct = SIZEOF(PICTDESC)
tpd.picType = m_Typ
IF m_Own THEN m_Own = -1
OleCreatePictureIndirect(@tpd, @IID_IDispatch, m_Own, @oPicture)
End Sub
Sub OlePicture.LoadPictureFile(szFile As String)
STATIC hFile AS ..HANDLE
STATIC dwFileSize AS DWORD
STATIC pvData AS LPVOID
STATIC hGlobal AS HGLOBAL
STATIC dwBytesRead AS DWORD
STATIC bRead AS BOOL
STATIC pstm AS LPSTREAM
STATIC hr AS HRESULT
hFile = CreateFile(szFile, GENERIC_READ, 0, NULL, OPEN_EXISTING, 0, NULL)
dwFileSize = GetFileSize(hFile, NULL)
pvData = NULL
hGlobal = GlobalAlloc(GMEM_MOVEABLE, dwFileSize)
pvData = GlobalLock(hGlobal)
dwBytesRead = 0
bRead = ReadFile(hFile, pvData, dwFileSize, @dwBytesRead, NULL)
GlobalUnlock(hGlobal)
CloseHandle(hFile)
pstm = NULL
hr = CreateStreamOnHGlobal(hGlobal, TRUE, @pstm)
if oPicture THEN
#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
oPicture->Release()
#Else
oPicture->lpvtbl->Release(oPicture)
#EndIf
EndIf
hr=OleLoadPicture(pstm,dwFileSize,FALSE,@IID_IPictureDisp,Cast(LPVOID Ptr, @oPicture))
#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
pstm->Release()
#Else
pstm->lpvtbl->Release(pstm)
#EndIf
End Sub
' This function loads a file into an IStream.
Sub OlePicture.LoadPicRes(hInst As HINSTANCE , resID As Integer)
Dim mname As ZString*100
mname="#" & resID
' Make resource ident string e.g. "#307"
' Load resource
Dim As HRSRC hRes = FindResource(hInst, mname, RT_RCDATA)
Dim As DWORD dwResSize = SizeofResource(hInst, hRes)
Dim As HGLOBAL hResGlobal = LoadResource(hInst, hRes)
Dim As LPVOID lpResMem = LockResource(hResGlobal)
' The
' Make a new global memory block with GMEM_MOVEABLE
Dim As HGLOBAL hNewMem = GlobalAlloc(GMEM_MOVEABLE, dwResSize)
Dim As LPVOID lpNewMem = GlobalLock(hNewMem)
' Copy old to new
memcpy(lpNewMem, lpResMem, dwResSize)
' Unlock both memory's
GlobalUnlock(hNewMem)
GlobalUnlock(hResGlobal)
' Pass new memory to CreateStreamOnHGlobal and create IStream* from global memory
' The memory must be MOVEABLE for this to work. I tried making the return
' from LoadResource() MOVEABLE with GlobalReAlloc() but it would not work.
Dim As LPSTREAM pstm = NULL
Dim As HRESULT hr = CreateStreamOnHGlobal(hNewMem, TRUE, @pstm)
' Destroy last picture if exists
if ( oPicture) Then
#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
oPicture->Release()
#Else
oPicture->lpvtbl->Release(oPicture)
#EndIf
EndIf
' Create IPicture from image file
hr = OleLoadPicture(pstm, dwResSize, FALSE, @IID_IPictureDisp, cast(LPVOID PTR, @oPicture))
#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
pstm->Release()
#Else
pstm->lpvtbl->Release(pstm)
#EndIf
End Sub
Function OlePicture.IsNULL() As BOOL
If (oPicture=NULL) Then Return TRUE
Return FALSE
End Function
-
- Posts: 507
- Joined: Jan 13, 2009 19:23
Re: INSIDE ACTIVEX WITH FREEBASIC
Invoke.bi
Code: Select all
#Ifndef _INVOKE_BI_
#Define _INVOKE_BI_
#Include Once "windows.bi"
#Include Once "win/ocidl.bi"
Dim Shared ComWrapper_oleInitialized As bool
''=======================================================================================
'' Fonctions globales.
''=======================================================================================
Declare Function CheckError(hr As HRESULT) As String
Declare Sub ShowOleError ( hr As HRESULT, addit As String="")
Declare Function CreateObject OverLoad (ByVal ProgID as String,ByVal ppdisp As IDISPATCH Ptr Ptr) as HRESULT
Declare Function CreateObject(ByVal ProgID as String,ByVal ppunk As IUNKNOWN Ptr Ptr) as HRESULT
Declare Function CreateObject(ByVal ProgID as string) as VARIANT ' ProgID is progid or clsid string result is variant(iunknown or idispatch)
Declare Function CreateObject (ByVal szProgId As String ,ByVal riid As REFIID ,ByVal dwClsContext As DWORD , _
ByVal mpServerInfo As COSERVERINFO ptr ,ByVal ppv as lpvoid Ptr ) As HRESULT
Declare Function GetObjectEx(ByVal szPathName As String ,ByVal szProgId As String ,ByVal riid As REFIID , _
ByVal dwClsContext As DWORD ,ByVal lpvReserved As LPVOID ,ByVal ppv As LPVOID Ptr) As HRESULT
Declare Function _GetObject OverLoad (ByVal szPathName As String ,ByVal szProgId As String ,ByVal ppDisp As IDispatch Ptr ptr ) As HRESULT
Declare Function _GetObject (ByVal szPathName As String="" ,ByVal szProgId As String ) As IDispatch Ptr
Declare Function GetObjectV (ByVal szPathName As String ="",ByVal szProgId As String) As VARIANT
''***************************************************************************************
'' InvokeGetDISPID :
''***************************************************************************************
Declare Function InvokeGetDISPID(pDispatch as IDispatch Ptr,lpszName As LPCWSTR , pdispid as DISPID ptr) As HRESULT
' IDispatch Ptr + ID DES FunctionS
Declare Function InvokePropGet OverLoad (pDispatch as IDispatch Ptr,propid As DISPID ,pVarRes As VARIANT Ptr,nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT
Declare Function InvokePropPut OverLoad (pDispatch as IDispatch Ptr,propid As DISPID , nParamCount As Integer =0,pVarNew As VARIANT Ptr=NULL )As HRESULT
Declare Function InvokeMethod OverLoad (pDispatch as IDispatch Ptr,pVarRes As VARIANT Ptr,methodid As DISPID, nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT
Declare Function InvokePropGet OverLoad (pDispatch as IDispatch Ptr,pVarRes As VARIANT Ptr,lpszPropName As LPCWSTR , nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT
Declare Function InvokePropPut OverLoad (pDispatch as IDispatch Ptr,lpszPropName As LPCWSTR , nParamCount As Integer =0,pVarNew As VARIANT Ptr=NULL )As HRESULT
Declare Function InvokeMethod OverLoad (pDispatch as IDispatch Ptr,pVarRes As VARIANT Ptr,lpszMethodName As LPCWSTR, nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT
' VARIANT + NOM DES FunctionS EN LPCWSTR
Declare Function InvokePropPut (ByVal pDispV as VARIANT,sName As LPCWSTR, nParamCount As Integer =1,pParams As VARIANT Ptr=NULL )As HRESULT
Declare Function InvokePropGet (ByVal pDispV as VARIANT,pVarRes As VARIANT Ptr,sName As LPCWSTR , nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT
Declare Function InvokeMethod (ByVal pDispV as VARIANT,pVarRes As VARIANT Ptr,sName As LPCWSTR, nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT
' VARIANT + NOM DES FunctionS EN STRING
Declare Function InvokePropPut (ByVal pDispV as VARIANT,sName As String,pParams As VARIANT Ptr=NULL,nParamCount As Integer =1 )As HRESULT
Declare Function InvokePropGet (ByVal pDispV as VARIANT,pVarRes As VARIANT Ptr,sName As String,pParams As VARIANT Ptr=NULL , nParamCount As Integer =0)As HRESULT
Declare Function InvokePropGet (ByVal pDispV as VARIANT,sName As String,pParams As VARIANT Ptr=NULL , nParamCount As Integer =0)As VARIANT
Declare Function InvokeMethod (ByVal pDispV as VARIANT,pVarRes As VARIANT Ptr,sName As String,pParams As VARIANT Ptr=NULL, nParamCount As Integer =0 )As HRESULT
Declare Function InvokeMethod (ByVal pDispV as VARIANT,sName As String,pParams As VARIANT Ptr=NULL, nParamCount As Integer =0 )As VARIANT
' IDispatch Ptr + NOM DES FunctionS EN STRING
Declare Function InvokePropPut (pDisp as IDispatch Ptr,sName As String,pParams As VARIANT Ptr=NULL , nParamCount As Integer =1 )As HRESULT
Declare Function InvokePropGet (pDisp as IDispatch Ptr,pVarRes As VARIANT Ptr,sName As String ,pParams As VARIANT Ptr=NULL, nParamCount As Integer =0 )As HRESULT
Declare Function InvokePropGet (ByVal pDispV as IDispatch Ptr,sName As String,pParams As VARIANT Ptr=NULL , nParamCount As Integer =0)As VARIANT
Declare Function InvokeMethod (pDisp as IDispatch Ptr,pVarRes As VARIANT Ptr,sName As String,pParams As VARIANT Ptr=NULL, nParamCount As Integer =0 )As HRESULT
Declare Function InvokeMethod (ByVal pDispV as IDispatch Ptr,sName As String,pParams As VARIANT Ptr=NULL, nParamCount As Integer =0 )As VARIANT
Function CheckError(hr As HRESULT) As String
Dim As Any Ptr pMsg
FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_FROM_SYSTEM,NULL,hr, _
MAKELANGID(LANG_NEUTRAL,SUBLANG_DEFAULT),Cast(LPTSTR,@pMsg),0,NULL)
CheckError= " : Error(&h" & Hex(hr) & "): " & *Cast(ZString Ptr,pMsg)
LocalFree(pMsg)
End Function
Sub ShowOleError ( hr As HRESULT, addit As String="")
Dim serr As String
If hr=s_ok Then Exit Sub
serr=addit & " " & CheckError(hr)
MessageBox (getactiveWindow(),serr,"OLE ERROR ",MB_ICONERROR Or MB_TASKMODAL)
End Sub
Function CreateObject OverLoad (ByVal ProgID as String,ByVal ppdisp As IDISPATCH Ptr Ptr) as HRESULT
Dim As IDISPATCH Ptr pdisp = NULL
Dim As IUNKNOWN Ptr punk = NULL
Dim as HRESULT hr
If ComWrapper_oleInitialized=false Then
oleInitialize(NULL)
ComWrapper_oleInitialized=TRUE
EndIf
*ppdisp=NULL
Dim As CLSID clsid
hr=CLSIDFromProgID(WStr(ProgID), @clsid)
If clsid=CLSID_NULL Then hr=CLSIDFromString(WStr(ProgID), @clsid)
If clsid=CLSID_NULL Then goto errorn
hr = CoCreateInstance(@clsid, NULL, CLSCTX_SERVER, @IID_IUNKNOWN, cast(LPVOID Ptr,@punk))
If FAILED(hr) then goto errorn
#If Not Defined( _FB_COM_VTBL_)
hr = punk->QueryInterface(@IID_IDispatch, cast(LPVOID Ptr,@pdisp))
#Else
hr = punk->lpvtbl->QueryInterface(punk,@IID_IDispatch, cast(LPVOID Ptr,@pdisp))
#EndIf
If FAILED(hr) Then goto errorn
*ppdisp = pdisp
#If Not Defined( _FB_COM_VTBL_)
punk->Release()
#Else
punk->lpvtbl->Release(punk)
#EndIf
Return NOERROR
errorn:
ShowOleError(hr,"CreateObject(" & ProgID & ")" )
#If Not Defined( _FB_COM_VTBL_)
If (punk) Then punk->Release()
If (pdisp) Then pdisp->Release()
#Else
If (punk) Then punk->lpvtbl->Release(punk)
If (pdisp) Then pdisp->lpvtbl->Release(pdisp)
#EndIf
return hr
end Function
Function CreateObject(ByVal ProgID as String,ByVal ppunk As IUNKNOWN Ptr Ptr) as HRESULT
Dim As IUNKNOWN Ptr punk = NULL
Dim as HRESULT hr
If ComWrapper_oleInitialized=false Then
oleInitialize(NULL)
ComWrapper_oleInitialized=TRUE
EndIf
*ppunk=NULL
Dim As CLSID clsid
hr=CLSIDFromProgID(WStr(ProgID), @clsid)
If clsid=CLSID_NULL Then hr=CLSIDFromString(WStr(ProgID), @clsid)
If clsid=CLSID_NULL Then goto errorn
hr = CoCreateInstance(@clsid, NULL, CLSCTX_SERVER, @IID_IUNKNOWN, cast(LPVOID Ptr,@punk))
If FAILED(hr) then goto errorn
*ppunk = punk
Return NOERROR
errorn:
ShowOleError(hr,"CreateObject(" & ProgID & ")" )
If (punk) Then
#If Not Defined( _FB_COM_VTBL_)
punk->Release()
#Else
punk->lpvtbl->Release(punk)
#EndIf
EndIf
return hr
end Function
Function CreateObject(ByVal ProgID as string) as VARIANT ' ProgID is progid or clsid string result is variant(iunknown or idispatch)
Dim As HRESULT hr
Dim As IUNKNOWN Ptr punk = NULL
If ComWrapper_oleInitialized=false Then
oleInitialize(NULL)
ComWrapper_oleInitialized=TRUE
EndIf
Dim as VARIANT Vvar
VariantInit(@Vvar)
Dim As CLSID clsid
hr=CLSIDFromProgID(WStr(ProgID), @clsid)
If clsid=CLSID_NULL Then hr=CLSIDFromString(WStr(ProgID), @clsid)
If clsid=CLSID_NULL Then
Vvar .vt = VT_ERROR
Vvar .scode = -1
ShowOleError(hr,"CreateObject(" & ProgID & ")" )
Return Vvar
EndIf
hr = CoCreateInstance(@clsid, NULL,CLSCTX_SERVER,@IID_IUNKNOWN, cast(LPVOID Ptr,@punk))
if(FAILED(hr))then
ShowOleError(hr,"CreateObject(" & ProgID & ")" )
Exit Function
end if
#If Not Defined( _FB_COM_VTBL_)
hr = punk->QueryInterface(@IID_IDispatch, cast(LPVOID Ptr,@Vvar.pdispval))
#Else
hr=punk->lpvtbl->QueryInterface(punk,@IID_IDispatch, cast(LPVOID Ptr,@Vvar.pdispval))
#EndIf
If (FAILED(hr)) Then
Vvar.vt = VT_UNKNOWN
Vvar.punkval = punk
Return Vvar
EndIf
#If Not Defined( _FB_COM_VTBL_)
punk->Release()
#Else
If (punk) Then punk->lpvtbl->Release(punk)
#EndIf
Vvar.vt = VT_DISPATCH
return Vvar
end Function
Function CreateObject (ByVal szProgId As String ,ByVal riid As REFIID ,ByVal dwClsContext As DWORD , _
ByVal mpServerInfo As COSERVERINFO ptr ,ByVal ppv as lpvoid Ptr ) As HRESULT
Dim As CLSID clsid
Dim As HRESULT hr
Dim As IClassFactory ptr pCf = NULL
if (Len(szProgId)=0 or riid=NULL or ppv=NULL) Then Return E_INVALIDARG
if InStr(szProgId,"{") Then
hr = CLSIDFromString(WStr(szProgId), @clsid)
else
hr = CLSIDFromProgID(WStr(szProgId), @clsid)
End If
if (SUCCEEDED(hr)) Then hr = CoGetClassObject(@clsid, dwClsContext, mpServerInfo, @IID_IClassFactory, Cast(lpvoid Ptr, @pCf))
#If Not Defined( _FB_COM_VTBL_)
If (SUCCEEDED(hr)) Then hr = pCf->CreateInstance(NULL, riid, ppv)
if (pCf) Then pCf->Release()
#Else
If (SUCCEEDED(hr)) Then hr = pCf->lpVtbl->CreateInstance(pCf, NULL, riid, ppv)
if (pCf) Then pCf->lpVtbl->Release(pCf)
#EndIf
return hr
End Function
Function GetObjectEx(ByVal szPathName As String ,ByVal szProgId As String ,ByVal riid As REFIID , _
ByVal dwClsContext As DWORD ,ByVal lpvReserved As LPVOID ,ByVal ppv As LPVOID Ptr) As HRESULT
Dim As HRESULT hr
if ((Len(szProgId)=0 and Len(szPathName)=0) Or riid=NULL Or ppv=NULL Or lpvReserved<>0) Then Return E_INVALIDARG
if Len(szPathName) Then
if len(szProgId)=0 Then
hr = CoGetObject(WStr(szPathName), NULL, riid, ppv)
else
Dim As IPersistFile ptr ppf = NULL
hr = CreateObject(szProgId, @IID_IPersistFile, dwClsContext, NULL, cast(lpvoid Ptr, @ppf))
#If Not Defined( _FB_COM_VTBL_)
If (SUCCEEDED(hr)) Then hr = ppf->Load(szPathName, 0)
If (SUCCEEDED(hr)) Then hr = ppf->QueryInterface(riid, ppv)
If (ppf) Then ppf->Release()
#Else
If (SUCCEEDED(hr)) Then hr = ppf->lpVtbl->Load(ppf, szPathName, 0)
If (SUCCEEDED(hr)) Then hr = ppf->lpVtbl->QueryInterface(ppf, riid, ppv)
If (ppf) Then ppf->lpVtbl->Release(ppf)
#EndIf
EndIf
else
Dim As CLSID clsid
Dim As IUnknown Ptr pUnk = NULL
if InStr(szProgId,"{" ) Then
hr = CLSIDFromString(WStr(szProgId), @clsid)
else
hr = CLSIDFromProgID(WStr(szProgId), @clsid)
EndIf
if (SUCCEEDED(hr)) Then hr = GetActiveObject(@clsid, NULL, @pUnk)
#If Not Defined( _FB_COM_VTBL_)
If (SUCCEEDED(hr)) Then hr = pUnk->QueryInterface(riid, ppv)
If (pUnk) Then pUnk->Release()
#Else
If (SUCCEEDED(hr)) Then hr = pUnk->lpVtbl->QueryInterface(pUnk, riid, ppv)
If (pUnk) Then pUnk->lpVtbl->Release(pUnk)
#EndIf
EndIf
return hr
End Function
Function _GetObject OverLoad (ByVal szPathName As String ,ByVal szProgId As String ,ByVal ppDisp As IDispatch Ptr ptr ) As HRESULT
return GetObjectEx(szPathName, szProgId, @IID_IDispatch,CLSCTX_LOCAL_SERVER Or CLSCTX_INPROC_SERVER, NULL, cast(lpvoid Ptr,ppDisp))
End Function
Function _GetObject (ByVal szPathName As String="" ,ByVal szProgId As String ) As IDispatch Ptr
Dim pDisp As IDispatch Ptr
GetObjectEx(szPathName, szProgId, @IID_IDispatch,CLSCTX_LOCAL_SERVER Or CLSCTX_INPROC_SERVER, NULL, cast(lpvoid Ptr,@pDisp))
return pDisp
End Function
Function GetObjectV (ByVal szPathName As String ="",ByVal szProgId As String) As VARIANT
Dim pDisp As IDispatch Ptr
GetObjectEx(szPathName, szProgId, @IID_IDispatch,CLSCTX_LOCAL_SERVER Or CLSCTX_INPROC_SERVER, NULL,@pDisp) ' curiosly bug with Cast(LPVOID Ptr,@pDisp))
Dim V As VARIANT
v.vt=VT_DISPATCH
v.pdispval=pDisp
Return V
End Function
''=======================================================================================
'' Fonctions globales.
''=======================================================================================
''***************************************************************************************
'' InvokeGetDISPID :
''***************************************************************************************
Function InvokeGetDISPID(pDispatch as IDispatch Ptr,lpszName As LPCWSTR , pdispid as DISPID ptr) As HRESULT
if (pDispatch=NULL)Then
MessageBox(NULL, "NULL IDispatch passed", "InvokeGetDISPID()", MB_SETFOREGROUND or MB_ICONHAND)
return E_UNEXPECTED
End If
'' Id associé au nom
Dim As HRESULT hr
#If Not Defined( _FB_COM_VTBL_)
hr = pDispatch->GetIDsOfNames(@IID_NULL,Cast(LPOLESTR PTR,@lpszName), 1,LOCALE_USER_DEFAULT, pdispid)
#Else
hr = pDispatch->lpvtbl->GetIDsOfNames(pDispatch,@IID_NULL,Cast(LPOLESTR PTR,@lpszName), 1,LOCALE_USER_DEFAULT, pdispid)
#EndIf
Dim Buf As ZString*250
if(FAILED(hr))Then
ShowOleError(hr," in InvokeGetDISPID: " & *lpszName)
return hr
End If
return hr
End Function
''***************************************************************************************
'' InvokePropGet :
''***************************************************************************************
Function InvokePropGet OverLoad (pDispatch as IDispatch Ptr,propid As DISPID ,pVarRes As VARIANT Ptr,nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT
Dim buf As ZString*250
'' paramètres de l'appel à Invoke (ordre des paramètres inversé)
Dim As VARIANTARG Ptr rgvarg = NULL
if(nParamCount > 0)Then
rgvarg = new VARIANTARG[nParamCount]
for i As Integer= 0 to nParamCount-1
rgvarg[i] = pParams[nParamCount-i-1]
next
End If
'' initialisation structure DISPPARAMS
Dim As DISPPARAMS dispparams = (rgvarg, NULL, nParamCount, 0)
'' appel de Invoke
Dim As HRESULT hr = pDispatch->Invoke(propid, @IID_NULL, LOCALE_USER_DEFAULT, _
DISPATCH_PROPERTYGET, @dispparams, pVarRes, NULL, NULL)
if(nParamCount > 0)Then
for i As Integer= 0 to nParamCount-1
pParams[nParamCount-i-1]=rgvarg[i]
next
End If
'' libération mémoire
if(nParamCount > 0)Then
delete[] rgvarg
End If
'' retour
return hr
End Function
''***************************************************************************************
'' InvokePropPut :
''***************************************************************************************
Function InvokePropPut OverLoad (pDispatch as IDispatch Ptr,propid As DISPID , nParamCount As Integer =0,pVarNew As VARIANT Ptr=NULL )As HRESULT
Dim buf As ZString*250
Dim As VARIANTARG Ptr rgvarg = NULL
if(nParamCount > 0)Then
rgvarg = new VARIANTARG[nParamCount]
for i As Integer= 0 to nParamCount-1
rgvarg[i] = pVarNew[nParamCount-i-1]
next
End If
Dim As DISPID rgdispidNamedArgs(1)
rgdispidNamedArgs(0) = DISPID_PROPERTYPUT
'' initialisation structure DISPPARAMS
Dim As DISPPARAMS dispparams = (rgvarg, @rgdispidNamedArgs(0),nParamCount, 1)
'' appel de Invoke
Dim As HRESULT hr
#If Not Defined( _FB_COM_VTBL_)
hr = pDispatch->Invoke(propid, @IID_NULL, LOCALE_USER_DEFAULT, _
DISPATCH_PROPERTYPUT, @dispparams, NULL, NULL, NULL)
#Else
hr= pDispatch->lpvtbl->Invoke(pDispatch,propid, @IID_NULL, LOCALE_USER_DEFAULT, _
DISPATCH_PROPERTYPUT, @dispparams, NULL, NULL, NULL)
#EndIf
if(nParamCount > 0)Then
for i As Integer= 0 to nParamCount-1
pVarNew[nParamCount-i-1]=rgvarg[i]
next
End If
'' libération mémoire
if(nParamCount > 0)Then
delete[] rgvarg
End If
'' retour
return hr
End Function
''***************************************************************************************
'' InvokeMethod :
''***************************************************************************************
Function InvokeMethod OverLoad (pDispatch as IDispatch Ptr,pVarRes As VARIANT Ptr,methodid As DISPID, nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT
'' paramètres de l'appel à Invoke (ordre des paramètres inversé)
Dim As VARIANTARG Ptr rgvarg = NULL
if(nParamCount > 0)Then
rgvarg = new VARIANTARG[nParamCount]
for i As Integer= 0 to nParamCount-1
rgvarg[i] = pParams[nParamCount-i-1]
next
End If
'' initialisation structure DISPPARAMS
Dim As DISPPARAMS dispparams = (rgvarg, NULL, nParamCount, 0)
'' appel de Invoke
Dim As HRESULT hr
#If Not Defined( _FB_COM_VTBL_)
hr = pDispatch->Invoke(methodid, @IID_NULL, LOCALE_USER_DEFAULT, _
DISPATCH_METHOD, @dispparams, pVarRes, NULL, NULL)
#Else
hr = pDispatch->lpvtbl->Invoke(pDispatch,methodid, @IID_NULL, LOCALE_USER_DEFAULT, _
DISPATCH_METHOD, @dispparams, pVarRes, NULL, NULL)
#EndIf
if(nParamCount > 0)Then
for i As Integer= 0 to nParamCount-1
pParams[nParamCount-i-1]=rgvarg[i]
next
End If
'' libération mémoire
if(nParamCount > 0)Then
delete[] rgvarg
End If
'' retour
return hr
End FUNCTION
''***************************************************************************************
'' InvokePropGet :
''***************************************************************************************
Function InvokePropGet OverLoad (pDispatch as IDispatch Ptr,pVarRes As VARIANT Ptr,lpszPropName As LPCWSTR , nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT
Dim buf As ZString*250
'' Id de la propriété
Dim As DISPID propid
Dim As HRESULT hr
#If Not Defined( _FB_COM_VTBL_)
hr = pDispatch->GetIDsOfNames(@IID_NULL, cast(LPOLESTR PTR,@lpszPropName), 1,LOCALE_USER_DEFAULT, @propid)
#Else
hr = pDispatch->lpvtbl->GetIDsOfNames(pDispatch,@IID_NULL, cast(LPOLESTR PTR,@lpszPropName), 1,LOCALE_USER_DEFAULT, @propid)
#EndIf
'' récupération en cas de réussite
if(SUCCEEDED(hr))Then hr = InvokePropGet(pDispatch,propid,pVarRes,nParamCount,pParams)
if (FAILED(hr))Then
ShowOleError(hr," in InvokePropGet: " & *lpszPropName)
End If
return hr
End Function
''***************************************************************************************
'' InvokePropPut :
''***************************************************************************************
Function InvokePropPut OverLoad (pDispatch as IDispatch Ptr,lpszPropName As LPCWSTR , nParamCount As Integer =0,pVarNew As VARIANT Ptr=NULL )As HRESULT
Dim buf As ZString*250
'' Id de la propriété
Dim As DISPID propid
Dim As HRESULT hr
#If Not Defined( _FB_COM_VTBL_)
hr = pDispatch->GetIDsOfNames(@IID_NULL, cast(LPOLESTR PTR,@lpszPropName), 1, LOCALE_USER_DEFAULT, @propid)
#Else
hr = pDispatch->lpvtbl->GetIDsOfNames(pDispatch,@IID_NULL, cast(LPOLESTR PTR,@lpszPropName), 1, LOCALE_USER_DEFAULT, @propid)
#EndIf
'' affectation en cas de réussite
if(SUCCEEDED(hr))Then hr = InvokePropPut(pDispatch ,propid , nParamCount ,pVarNew )
if (FAILED(hr))Then
ShowOleError(hr," in InvokePropPut: " & *lpszPropName)
End If
return hr
End Function
''***************************************************************************************
'' InvokeMethod :
''***************************************************************************************
Function InvokeMethod OverLoad (pDispatch as IDispatch Ptr,pVarRes As VARIANT Ptr,lpszMethodName As LPCWSTR, nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT
Dim buf As ZString*250
'' Id de la méthode
Dim As DISPID methodid
Dim As HRESULT hr
#If Not Defined( _FB_COM_VTBL_)
hr = pDispatch->GetIDsOfNames(@IID_NULL, cast(LPOLESTR PTR,@lpszMethodName), 1,LOCALE_USER_DEFAULT, @methodid)
#Else
hr = pDispatch->lpvtbl->GetIDsOfNames(pDispatch,@IID_NULL, cast(LPOLESTR PTR,@lpszMethodName), 1,LOCALE_USER_DEFAULT, @methodid)
#EndIf
'' appel en cas de réussite
if(SUCCEEDED(hr)) Then hr = InvokeMethod (pDispatch ,pVarRes ,methodid, nParamCount ,pParams )
if (FAILED(hr))Then
ShowOleError(hr," in InvokeMethod: " & *lpszMethodName)
End If
return hr
End Function
' VARIANT + NOM DES FUNCTIONS EN LPCWSTR
Function InvokePropPut (ByVal pDispV as VARIANT,sName As LPCWSTR, nParamCount As Integer =1,pParams As VARIANT Ptr=NULL )As HRESULT
Return InvokePropPut (pDispV.pdispval,sName,nParamCount, pParams)
End Function
Function InvokePropGet (ByVal pDispV as VARIANT,pVarRes As VARIANT Ptr,sName As LPCWSTR , nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT
Return InvokePropGet (pDispV.pdispval,pVarRes,sName,nParamCount, pParams)
End Function
Function InvokeMethod (ByVal pDispV as VARIANT,pVarRes As VARIANT Ptr,sName As LPCWSTR, nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT
Return InvokeMethod(pDispV.pdispval,pVarRes,sName,nParamCount, pParams)
End Function
' VARIANT + NOM DES FUNCTIONS EN STRING
Function InvokePropPut (ByVal pDispV as VARIANT,sName As String,pParams As VARIANT Ptr=NULL,nParamCount As Integer =1 )As HRESULT
Return InvokePropPut (pDispV.pdispval,OLESTR(sName),nParamCount, pParams)
End Function
Function InvokePropGet (ByVal pDispV as VARIANT,pVarRes As VARIANT Ptr,sName As String,pParams As VARIANT Ptr=NULL , nParamCount As Integer =0)As HRESULT
Return InvokePropGet (pDispV.pdispval,pVarRes,OLESTR(sName),nParamCount, pParams)
End Function
Function InvokePropGet (ByVal pDispV as VARIANT,sName As String,pParams As VARIANT Ptr=NULL , nParamCount As Integer =0)As VARIANT
dim VarRes As VARIANT
variantInit(@VarRes)
Dim As HRESULT hr=InvokePropGet(pDispV,@VarRes, sName, pParams,nParamCount)
If hr=s_ok Then
Return VarRes
Else
VarRes.vt = VT_ERROR
VarRes.scode = -1
return VarRes
EndIf
End Function
Function InvokeMethod (ByVal pDispV as VARIANT,pVarRes As VARIANT Ptr,sName As String,pParams As VARIANT Ptr=NULL, nParamCount As Integer =0 )As HRESULT
Return InvokeMethod(pDispV.pdispval,pVarRes,OLESTR(sName),nParamCount, pParams)
End Function
Function InvokeMethod (ByVal pDispV as VARIANT,sName As String,pParams As VARIANT Ptr=NULL, nParamCount As Integer =0 )As VARIANT
dim VarRes As VARIANT
variantInit(@VarRes)
Dim As HRESULT hr=InvokeMethod(pDispV,@VarRes,sName, pParams,nParamCount)
If hr=s_ok Then
Return VarRes
Else
VarRes.vt = VT_ERROR
VarRes.scode = -1
return VarRes
EndIf
End Function
' IDispatch Ptr + NOM DES FUNCTIONS EN STRING
Function InvokePropPut (pDisp as IDispatch Ptr,sName As String,pParams As VARIANT Ptr=NULL , nParamCount As Integer =1 )As HRESULT
Return InvokePropPut( pDisp,OLESTR(sName),nParamCount, pParams)
End Function
Function InvokePropGet (pDisp as IDispatch Ptr,pVarRes As VARIANT Ptr,sName As String ,pParams As VARIANT Ptr=NULL, nParamCount As Integer =0 )As HRESULT
Return InvokePropGet( pDisp,pVarRes, OLESTR(sName), nParamCount, pParams)
End Function
Function InvokePropGet (ByVal pDispV as IDispatch Ptr,sName As String,pParams As VARIANT Ptr=NULL , nParamCount As Integer =0)As VARIANT
dim VarRes As VARIANT
Dim As HRESULT hr=InvokePropGet (pDispV,@VarRes,sName,pParams,nParamCount)
If hr=s_ok Then
Return VarRes
Else
VarRes.vt = VT_ERROR
VarRes.scode = -1
return VarRes
EndIf
End Function
Function InvokeMethod (pDisp as IDispatch Ptr,pVarRes As VARIANT Ptr,sName As String,pParams As VARIANT Ptr=NULL, nParamCount As Integer =0 )As HRESULT
Return InvokeMethod (pDisp, pVarRes, OLESTR(sName),nParamCount,pParams )
End Function
Function InvokeMethod (ByVal pDispV as IDispatch Ptr,sName As String,pParams As VARIANT Ptr=NULL, nParamCount As Integer =0 )As VARIANT
dim VarRes As VARIANT
variantInit(@VarRes)
Dim As HRESULT hr=InvokeMethod(pDispV,@VarRes,sName, pParams,nParamCount)
If hr=s_ok Then
Return VarRes
Else
VarRes.vt = VT_ERROR
VarRes.scode = -1
return VarRes
EndIf
End Function
#EndIf
-
- Posts: 507
- Joined: Jan 13, 2009 19:23
Re: INSIDE ACTIVEX WITH FREEBASIC
Comobjects.bi
source code of the library
http://www.2shared.com/file/wrQXkGRb/Co ... s_lib.html
Code: Select all
#Include Once "windows.bi"
#Include Once "win/ocidl.bi"
#Include Once "crt.bi"
Common Shared ComWrapper_oleInitialized As BOOL
#Inclib "comObjects"
'Declare(s) for "variants.bi"
DECLARE Function StrToBSTR(ByVal cnv_string As String) AS BSTR
DECLARE Function Variantvt(ByRef v As variant) AS VARTYPE
DECLARE Function SafeArrayIsCreated(Mat As SAFEARRAY Ptr) AS INTEGER
DECLARE Function SafearrayVartype(ByVal P As SAFEARRAY Ptr) AS VARTYPE
Declare Sub safearrayofRecord(tlbfileName As String,iidRec As REFIID,rgbounds As SAFEARRAYBOUND)
Declare Function Variantv(ByRef v As variant)As Double 'return numeric value from variant
Declare Function Variants(ByRef v As variant)As String 'return string value from variant
Declare Function Variantb(ByRef v As variant)As bstr 'return bstr value from variant
Declare Sub ArrayToSafeArray OverLoad (ByRef P As SAFEARRAY Ptr,A() As Double)
Declare Sub ArrayToSafeArray (ByRef P As SAFEARRAY Ptr,A() As Single)
Declare Sub ArrayToSafeArray (ByRef P As SAFEARRAY Ptr,A() As LONG)
Declare Sub ArrayToSafeArray (ByRef P As SAFEARRAY Ptr,A() As Short)
Declare Sub ArrayToSafeArray (ByRef P As SAFEARRAY Ptr,A() As Integer)
Declare Sub ArrayToSafeArray (ByRef P As SAFEARRAY Ptr,A() As String)
Declare Sub ArrayToSafeArray (ByRef P As SAFEARRAY Ptr,A() As BSTR)
Declare Sub ArrayToSafeArray (ByRef P As SAFEARRAY Ptr,A() As VARIANT)
Declare Sub ArrayToSafeArray (ByRef P As SAFEARRAY Ptr,A() As IDISPATCH Ptr)
Declare Sub ArrayToSafeArray (ByRef P As SAFEARRAY Ptr,A() As IUNKNOWN Ptr)
Declare Sub ArrayToSafeArray (ByRef P As SAFEARRAY Ptr,A() As Any Ptr)
Declare Function ArrayToSafeArray (A() As Double)As SAFEARRAY Ptr
Declare Function ArrayToSafeArray (A() As Single)As SAFEARRAY Ptr
Declare Function ArrayToSafeArray (A() As Short)As SAFEARRAY Ptr
Declare Function ArrayToSafeArray (A() As Integer)As SAFEARRAY Ptr
Declare Function ArrayToSafeArray (A() As Long)As SAFEARRAY Ptr
Declare Function ArrayToSafeArray (A() As BSTR)As SAFEARRAY Ptr
Declare Function ArrayToSafeArray (A() As String)As SAFEARRAY Ptr
Declare Function ArrayToSafeArray (A() As VARIANT)As SAFEARRAY Ptr
Declare Function ArrayToSafeArray (A() As IDISPATCH Ptr)As SAFEARRAY Ptr
Declare Function ArrayToSafeArray (A() As IUNKNOWN Ptr)As SAFEARRAY Ptr
Declare Function ArrayToSafeArray (A() As Any Ptr)As SAFEARRAY Ptr
Declare Sub SafeArrayToArray OverLoad ( A()As Double,P As SAFEARRAY Ptr)
Declare Sub SafeArrayToArray ( A() As Single,P As SAFEARRAY Ptr)
Declare Sub SafeArrayToArray ( A() As BSTR,P As SAFEARRAY Ptr)
Declare Sub SafeArrayToArray ( A() As STRING,P As SAFEARRAY Ptr)
Declare Sub SafeArrayToArray ( A() As Long,P As SAFEARRAY Ptr)
Declare Sub SafeArrayToArray ( A() As Integer,P As SAFEARRAY Ptr)
Declare Sub SafeArrayToArray ( A() As Short,P As SAFEARRAY Ptr)
Declare Sub SafeArrayToArray ( A() As VARIANT,P As SAFEARRAY Ptr)
Declare Sub SafeArrayToArray ( A() As IDISPATCH Ptr,P As SAFEARRAY Ptr)
Declare Sub SafeArrayToArray ( A() As IUNKNOWN Ptr,P As SAFEARRAY Ptr)
Declare Sub SafeArrayToArray ( A() As Any Ptr,P As SAFEARRAY Ptr)
Declare Function ArrayToVariant OverLoad (A() As Double)As VARIANT
Declare Function ArrayToVariant(A() As Single)As VARIANT
Declare Function ArrayToVariant(A() As BSTR)As VARIANT
Declare Function ArrayToVariant(A() As Long)As VARIANT
Declare Function ArrayToVariant(A() As Integer)As VARIANT
Declare Function ArrayToVariant(A() As Short)As VARIANT
Declare Function ArrayToVariantB(A() As BOOL)As VARIANT
Declare Function ArrayToVariant(A() As Any Ptr)As VARIANT
Declare Function ArrayToVariant(A() As String)As VARIANT
Declare Function ArrayToVariant(A() As IDISPATCH Ptr)As VARIANT
Declare Function ArrayToVariant(A() As IUNKNOWN Ptr)As VARIANT
Declare Sub ArrayToVariant OverLoad (ByVal pVariant As VARIANT Ptr ,M() As Double)
Declare Sub ArrayToVariant (ByVal pVariant As VARIANT Ptr , A() As Single)
Declare Sub ArrayToVariant (ByVal pVariant As VARIANT Ptr , A() As Long)
Declare Sub ArrayToVariant (ByVal pVariant As VARIANT Ptr , A() As Integer)
Declare Sub ArrayToVariant (ByVal pVariant As VARIANT Ptr , A() As short)
Declare Sub ArrayToVariant (ByVal pVariant As VARIANT Ptr , A() As String)
Declare Sub ArrayToVariant (ByVal pVariant As VARIANT Ptr , A() As Any Ptr)
Declare Sub ArrayToVariant (ByVal pVariant As VARIANT Ptr , A() As IDISPATCH Ptr)
Declare Sub ArrayToVariant (ByVal pVariant As VARIANT Ptr , A() As IUNKNOWN Ptr)
Declare Sub VariantToArray OverLoad(M() As Double,ByVal V As VARIANT)
Declare Sub VariantToArray(M() As Single,ByVal V As VARIANT)
Declare Sub VariantToArray(M() As Long,ByVal V As VARIANT)
Declare Sub VariantToArray(M() As Integer,ByVal V As VARIANT)
Declare Sub VariantToArray(M() As Short,ByVal V As VARIANT)
Declare Sub VariantToArray (M() As BSTR,ByVal v As VARIANT )
Declare Sub VariantToArray(M() As String,ByVal v As VARIANT )
Declare Sub VariantToArray(M() As Any Ptr,ByVal v As VARIANT )
Declare Sub VariantToArray(M() As IDISPATCH Ptr,ByVal v As VARIANT )
Declare Sub VariantToArray(M() As IUNKNOWN Ptr,ByVal v As VARIANT )
Declare Sub VariantToSafeArray OverLoad (ByVal V As VARIANT ,ByRef P As SAFEARRAY ptr)
Declare Function VariantToSafeArray (ByVal V As VARIANT) As SAFEARRAY ptr
Declare Function SafeArrayToVariant OverLoad (ByVal P As SAFEARRAY Ptr)As VARIANT
Declare Sub SafeArrayToVariant (ByVal V As VARIANT Ptr,ByVal P As SAFEARRAY Ptr)
Declare function VarArrayCreate(Bounds()As Integer,AVarType As VARTYPE)As VARIANT
Declare function VarArrayDimCount(ByVal A As Variant)As Integer
Declare Sub VarArrayRedim(ByRef A As Variant, HighBound As Integer)
Declare Function VarArrayLowBound(ByVal A as Variant, iDim as Integer)As Integer
Declare function VarArrayHighBound(ByVal A As Variant, iDim As Integer)as Integer
Declare function VarArrayLock(ByVal A As Variant) As Any Ptr
Declare Sub VarArrayUnlock(ByVal A as Variant)
DECLARE Function StrToVariant(s As String) AS VARIANT
DECLARE Function ToVariant OverLoad (s As String)As VARIANT
DECLARE Function ToVariant (BYVAL value AS Short) AS VARIANT
DECLARE Function ToVariant (BYVAL value AS Integer) AS VARIANT
DECLARE Function ToVariant (BYVAL value AS Long) AS VARIANT
DECLARE Function ToVariant (BYVAL value AS Single) AS VARIANT
DECLARE Function ToVariant (BYVAL value AS Double) AS VARIANT
DECLARE Function ToVariant (BYVAL value AS BSTR) AS VARIANT
DECLARE Function ToVariant (BYVAL value AS SAFEARRAY Ptr) AS VARIANT
DECLARE Function ToVariant(BYVAL value AS LPDISPATCH) AS VARIANT
DECLARE Function ToVariant(BYVAL value AS IUnknown Ptr) AS VARIANT
DECLARE Function ToVariant(BYVAL value AS CY) AS VARIANT
DECLARE Function VariantToShort OverLoad (BYVAL value AS VARIANT) AS SHORT
DECLARE Function VariantToInteger OverLoad (BYVAL value AS VARIANT) AS INTEGER
DECLARE Function VariantToLong (BYVAL value AS VARIANT) AS LONG
DECLARE Function VariantToSingle(BYVAL value AS VARIANT) AS SINGLE
DECLARE Function VariantToDouble(BYVAL value AS VARIANT) AS DOUBLE
DECLARE Function VariantToBstr(BYVAL value AS VARIANT) AS BSTR
DECLARE Function VariantToarray (BYVAL value AS VARIANT) AS SAFEARRAY PTR
DECLARE Function VariantToDispatch (BYVAL value AS VARIANT) AS LPDISPATCH
DECLARE Function VariantToUnknown (BYVAL value AS VARIANT) AS LPUNKNOWN
DECLARE Function VariantTodate (BYVAL value AS VARIANT) AS DATE_
DECLARE Function VariantTocy (BYVAL value AS VARIANT) AS CY
DECLARE Function VariantToBool (BYVAL value AS VARIANT) AS VARIANT_BOOL
Declare Function PrintMatrix OverLoad (ByVal Title AS STRING, A() AS DOUBLE) As String
Declare Function PrintMatrix (ByVal Title AS STRING, A() AS Double, col1 As Integer,col2 As Integer)As String
Declare Function PrintVector(ByVal Title AS STRING, B() AS Double,outlineorcol As Integer=0) As String
Declare Function RoundFloat( Byval d As Double, Byval p As Integer ) As Double
Declare Function Matrix_ToStr OverLoad (ByVal Title AS STRING, A() AS DOUBLE)As String
Declare Function Matrix_ToStr (ByVal Title AS STRING, A() AS Double, col1 As Integer,col2 As Integer)As String
Declare Function Vector_ToStr(ByVal Title AS STRING, B() AS Double,outlineorCol As Integer)As String
'Declare(s) for "InvokeEx.bas"
DECLARE Function InvokeGetDISPID(pDispatch As IDispatch Ptr,lpszName As LPCWSTR , pdispid as DISPID ptr) As HRESULT
DECLARE Function InvokePropGet OverLoad (pDispatch as IDispatch Ptr,propid As DISPID ,pVarRes As VARIANT Ptr,nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT
DECLARE Function InvokePropPut OverLoad (pDispatch As IDispatch Ptr,propid As DISPID , nParamCount As Integer =1,pVarNew As VARIANT Ptr=NULL )As HRESULT
DECLARE Function InvokeMethod OverLoad (pDispatch As IDispatch Ptr,pVarRes As VARIANT Ptr,methodid As DISPID, nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT
' IDispatch Ptr + NOM DES FUNCTIONS EN LPCWSTR
Declare Function InvokePropPut OverLoad (pDispatch As IDispatch Ptr,lpszPropName As LPCWSTR , nParamCount As Integer =1,pVarNew As VARIANT Ptr=NULL )As HRESULT
DECLARE Function InvokePropGet OverLoad (pDispatch as IDispatch Ptr,pVarRes As VARIANT Ptr,lpszPropName As LPCWSTR , nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT
DECLARE Function InvokeMethod OverLoad (pDispatch as IDispatch Ptr,pVarRes As VARIANT Ptr,lpszMethodName As LPCWSTR, nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT
' VARIANT + NOM DES FUNCTIONS EN LPCWSTR
DECLARE Function InvokePropPut (ByVal pDispV as VARIANT,sName As LPCWSTR, nParamCount As Integer =1,pParams As VARIANT Ptr=NULL )As HRESULT
DECLARE Function InvokePropGet (ByVal pDispV as VARIANT,pVarRes As VARIANT Ptr,sName As LPCWSTR , nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT
DECLARE Function InvokeMethod (ByVal pDispV as VARIANT,pVarRes As VARIANT Ptr,sName As LPCWSTR, nParamCount As Integer =0,pParams As VARIANT Ptr=NULL )As HRESULT
' VARIANT + NOM DES FUNCTIONS EN STRING
DECLARE Function InvokePropPut (ByVal pDispV as VARIANT,sName As String,pParams As VARIANT Ptr=NULL,nParamCount As Integer =1 )As HRESULT
DECLARE Function InvokePropGet (ByVal pDispV as VARIANT,pVarRes As VARIANT Ptr,sName As String,pParams As VARIANT Ptr=NULL , nParamCount As Integer =0)As HRESULT
DECLARE Function InvokePropGet (ByVal pDispV as VARIANT,sName As String,pParams As VARIANT Ptr=NULL , nParamCount As Integer =0)As VARIANT
DECLARE Function InvokeMethod (ByVal pDispV as VARIANT,pVarRes As VARIANT Ptr,sName As String,pParams As VARIANT Ptr=NULL, nParamCount As Integer =0 )As HRESULT
DECLARE Function InvokeMethod (ByVal pDispV as VARIANT,sName As String,pParams As VARIANT Ptr=NULL, nParamCount As Integer =0 )As VARIANT
' IDispatch Ptr + NOM DES FUNCTIONS EN STRING
Declare Function InvokePropPut (pDisp as IDispatch Ptr,sName As String,pParams As VARIANT Ptr=NULL , nParamCount As Integer =1 )As HRESULT
DECLARE Function InvokePropGet (pDisp as IDispatch Ptr,pVarRes As VARIANT Ptr,sName As String ,pParams As VARIANT Ptr=NULL, nParamCount As Integer =0 )As HRESULT
DECLARE Function InvokePropGet (ByVal pDispV as IDispatch Ptr,sName As String,pParams As VARIANT Ptr=NULL , nParamCount As Integer =0)As VARIANT
DECLARE Function InvokeMethod (pDisp as IDispatch Ptr,pVarRes As VARIANT Ptr,sName As String,pParams As VARIANT Ptr=NULL, nParamCount As Integer =0 )As HRESULT
DECLARE Function InvokeMethod (ByVal pDispV as IDispatch Ptr,sName As String,pParams As VARIANT Ptr=NULL, nParamCount As Integer =0 )As VARIANT
'Declare(s) for "ComWrapper.bas"
DECLARE Function CheckError(hr As HRESULT) As String
DECLARE Sub ShowOleError OverLoad ( hr As HRESULT, addit As String="")
DECLARE Function BstrToStr(ByVal mbStr As BSTR)As String
DECLARE Function GUIDTXT(uuid AS UUID PTR) AS String
DECLARE Function BGUIDTXT (uuid AS UUID PTR) AS String
DECLARE Function StringToGUID(S As String)as GUID ' Convert a string to a GUID
DECLARE Function GUIDToString( ClassID As GUID) As string ' Convert a GUID to a string
DECLARE Function ProgIDToClassID( ProgID As Const String)As GUID ' Convert a programmatic ID to a class ID
DECLARE Function ClassIDToProgID OverLoad (ClassID As GUID)As string ' Convert a class ID to a programmatic ID '
DECLARE Function ClassIDToProgID (sClassID As String)As string
DECLARE Sub CLSIDtoString( clsid As GUID , szCLSID As ZString Ptr,length As Integer ) ' Convert a CLSID to a char string.
DECLARE Function CreateClassID() As string
DECLARE Function GetActiveOleObject(ClassName As const string)As IDispatch Ptr
DECLARE Function CreateComObject OverLoad(strClassID As String)as IUnknown Ptr
DECLARE Function CreateComObject(ClassID as GUID)as IUnknown Ptr
DECLARE Function CreateOleObject (progIDName As const String)As IDispatch Ptr
DECLARE Function CreateObject OverLoad (ByVal ProgID as String,ByVal ppdisp As IDISPATCH Ptr Ptr) as HRESULT ' ProgID is progid or clsid string
DECLARE Function CreateObject(ByVal ProgID as String,ByVal ppunk As IUNKNOWN Ptr Ptr) as HRESULT ' ProgID is progid or clsid string
DECLARE Function CreateObject(ByVal ProgID as string) as VARIANT ' ProgID is progid or clsid string result is variant(iunknown or idispatch)
DECLARE Function CreateRemoteObject(szProgId As LPCOLESTR ,riid As REFIID , dwClsContext As DWORD , _
pServerInfo as COSERVERINFO Ptr ) As pvoid Ptr
DECLARE Function CreateObject(szProgId As LPCOLESTR ,szMachine As LPCWSTR=NULL ) As IDispatch Ptr
DECLARE Function CreateObjectEx(szProgId As String ,szMachine As string="" ) As IDispatch Ptr
'dans InvokeEx
Declare Function CreateObject (ByVal szProgId As String ,ByVal riid As REFIID ,ByVal dwClsContext As DWORD , _
ByVal mpServerInfo As COSERVERINFO ptr ,ByVal ppv as lpvoid Ptr ) As HRESULT
Declare Function GetObjectEx(ByVal szPathName As String ,ByVal szProgId As String ,ByVal riid As REFIID , _
ByVal dwClsContext As DWORD ,ByVal lpvReserved As LPVOID ,ByVal ppv As LPVOID Ptr) As HRESULT
Declare Function _GetObject OverLoad (ByVal szPathName As String ,ByVal szProgId As String ,ByVal ppDisp As IDispatch Ptr ptr ) As HRESULT
Declare Function _GetObject (ByVal szPathName As String="" ,ByVal szProgId As String ) As IDispatch Ptr
Declare Function GetObjectv (ByVal szPathName As String ="",ByVal szProgId As String) As VARIANT
Declare Function ComDllGetClassObject OverLoad (Byval hdll As HINSTANCE,Byval CLSIDS As String,Byval IIDS As String,ByVal pObj As PVOID Ptr) As HRESULT
Declare Function ComDllGetClassObject OverLoad (Byval hdll As HINSTANCE,Byval rclsid As REFCLSID,Byval riid As REFIID,ByVal pObj As PVOID Ptr) As HRESULT
Declare Function ShowProperty (ByVal punk as LPVOID , ByVal title as ZSTRING PTR) As HRESULT
' ========================================================================================
' Creates a standard IFont object
' ========================================================================================
Declare Function OleCreateFont OverLoad ( ByVal szFontName AS STRING , _
ByVal cySize AS float,ByVal fWeight AS INTEGER, _
ByVal fCharset AS INTEGER, BYVAL fItalic AS LONG, _
ByVal fUnderline AS LONG,BYVAL fStrikethrough AS LONG, ByVal pFont AS IFont Ptr PTR) AS HRESULT
' ========================================================================================
' Creates a standard IFontDisp object
' ========================================================================================
Declare Function OleCreateFontDisp OverLoad(BYVAL szFontName AS STRING,ByVal cySize AS float=10, _
ByVal fWeight AS Short=FW_NORMAL,BYVAL fCharset AS Short=FALSE,BYVAL fItalic AS LONG=FALSE, BYVAL fUnderline AS Long=FALSE, _
ByVal fStrikethrough AS LONG=FALSE,ByVal pFont AS IFontDisp Ptr Ptr ) AS HRESULT
Declare Function OleCreateFontDisp (BYVAL szFontName AS STRING,ByVal cySize AS float=10, _
ByVal fWeight AS Short=FW_NORMAL,BYVAL fCharset AS Short=FALSE,BYVAL fItalic AS LONG=FALSE, BYVAL fUnderline AS Long=FALSE, _
ByVal fStrikethrough AS LONG=FALSE) AS IFontDisp Ptr
Declare Function OleCreatePicture (ByVal hPicHandle AS HANDLE, _
ByVal picType AS UINT, _
ByVal fOwn AS INTEGER, _
ByVAL pPicture AS IPicture Ptr Ptr _
) AS HRESULT ' Creates a standard IPicture object.
Declare Function LoadPictureFile(ByVal szFile As String)AS LPPICTURE
Declare Function LoadPictureRes(ByVal hInst As HINSTANCE ,ByVal resID As Integer)AS LPPICTURE ' This function loads rc into an IStream.
Declare Function OleCreatePictureDisp overload (ByVal hPicHandle AS HANDLE, _
ByVal picType AS UINT, _
ByVal fOwn AS INTEGER, _
ByVAL pPicture AS IPictureDisp Ptr PTR _
) AS HRESULT ' Creates a standard IPictureDisp object.
Declare Function OleCreatePictureDisp (ByVal hPicHandle AS HANDLE, _
ByVal picType AS UINT, _
ByVal fOwn AS INTEGER) As IPictureDisp Ptr
' ****************************************************************************************
' Creates an instance of a visual control (OCX), and a window and attaches the instance to the window.
' StrProgID can be the ProgID or the ClsID.
' return the handle of the window created.
' ****************************************************************************************
Declare Function CreateOcxControl (BYVAL strProgID AS STRING,hWndparent AS HWND,ByVal id As Integer, _
ByVal ileft As Integer=0,ByVal itop As Integer=0,ByVal iwidth As Integer=0,ByVal iheight As Integer=0, _
ByVal istyle As Integer=WS_VISIBLE And WS_CHILD,ByVal istyleex As Integer=WS_EX_CLIENTEDGE) AS HWND
Declare Function CreateControlLic (BYVAL strProgID AS STRING, BYVAL bstrLicKey AS BSTR) AS IDispatch ptr
' ****************************************************************************************
' Creates a licensed instance of a visual control (OCX) and attaches it to a window.
' StrProgID can be the ProgID or the ClsID. If you pass a version dependent ProgID or a ClsID,
' it will work only with this particular version.
' hWndControl is the handle of the window and strLicKey the license key.
' ****************************************************************************************
Declare Function AtlCreateControlLic (BYVAL strProgID AS STRING, BYVAL hWndControl AS HWND, BYVAL strLicKey AS STRING) AS HRESULT
' ****************************************************************************************
' Retrieves the interface of the ActiveX control given the handle of its ATL container
' ****************************************************************************************
Declare Function AtlAxGetDispatch OverLoad (BYVAL hWndControl AS HWND, ByVal ppdisp AS IDispatch Ptr Ptr) AS HRESULT
Declare Function AtlAxGetDispatch OverLoad (BYVAL hWndControl AS HWND, ByVal ppunk AS IUNKNOWN Ptr Ptr) AS HRESULT
Declare Function AtlAxGetDispatch OverLoad (BYVAL hWndControl AS HWND) AS IDISPATCH Ptr
#Macro CREATE_INTERFACE(C,I)
FUNCTION Create_##I () As I Ptr
dim hr As HRESULT
If ComWrapper_oleInitialized=false Then
oleInitialize(NULL)
ComWrapper_oleInitialized=TRUE
EndIf
Dim pobj As IDISPATCH Ptr
Dim As IUNKNOWN Ptr punk = NULL
hr=CoCreateInstance(@CLSID_##C, NULL,CLSCTX_ALL, @IID_IUNKNOWN, cast(LPVOID Ptr,@punk))
if hr=S_OK then
hr = punk->QueryInterface(@IID_IDISPATCH, cast(LPVOID Ptr,@pobj))
if hr=S_OK then
punk->Release()
Return Cast(I Ptr,pobj)
Else
Return Cast(I Ptr,punk)
EndIf
else
MessageBox NULL,"Error number hr=" & hr,"Can't create " & ##I ,0
Return NULL
END IF
END Function
#EndMacro
#Define INTERFACE_NEW(C,I) Create_##I
'NB: you must define CLSIDS_##_object_##
#Define New_(_object_) ##_object_## =Cast(##_object_##,CreateComObject(CLSIDS_##_object_##))
'NB: you must define CLSID_##_object_##
#Define NewCOM(_object_) ##_object_## =Cast(##_object_##,CreateComObject(CLSID_##_object_##))
http://www.2shared.com/file/wrQXkGRb/Co ... s_lib.html
-
- Posts: 507
- Joined: Jan 13, 2009 19:23
Re: INSIDE ACTIVEX WITH FREEBASIC
the list of files already modified is:marpon
Code: Select all
1-amaudio.bi
amvideo.bi
comcat.bi
control.bi
ddraw.bi
dimm.bi
dinput.bi
disphelper.bi
dmplugin.bi
dmusicc.bi
dmusici.bi
dmusics.bi
docobj.bi
dpaddr.bi
dplay.bi
dplay8.bi
dsound.bi
exdisp.bi
guiddef.bi
intchcut.bi
mshtmhst.bi
oaidl.bi
objidl.bi
objidlbase.bi
objsafe.bi
ocidl.bi
ole.bi
ole2.bi
oleacc.bi
oledlg.bi
oleidl.bi
portabledeviceconnectapi.bi
propidl.bi
richole.bi
rpcde.bi with #inclib "rpcrt4"
servprov.bi
shlwapi.bi
strmif.bi
structuredquerycondition
unknwnbase.bi
vfw.bi
Re: INSIDE ACTIVEX WITH FREEBASIC
Hi ... link not working anymore, can you upload it again? Thanks.aloberoger wrote:Comobjects.bi
source code of the library
http://www.2shared.com/file/wrQXkGRb/Co ... s_lib.html
-
- Posts: 507
- Joined: Jan 13, 2009 19:23
Re: INSIDE ACTIVEX WITH FREEBASIC
Code: Select all
#Include Once "win/ocidl.bi"
#Include Once "crt.bi"
#Ifndef __COMVARIANT_INC__
#Define __COMVARIANT_INC__
'NOTE: VARIANT_BOLL must be contruct normally like variant example: dim v as COMVARIANT:v.vt=VT_BOOL: v.boolval=-1
#Ifndef __WIDESTRING_INC__
Function BstrWriteToStream(m_bstr As BSTR,pStream As IStream Ptr ) As HRESULT
Assert(pStream <> NULL)
Dim As ULong cb
Dim As ULong cbStrLen =IIf( m_bstr , SysStringByteLen(m_bstr)+sizeof(OLECHAR) , 0)
#If Not Defined( _FB_COM_VTBL_)
Dim As HRESULT hr = pStream->Write(cast(void ptr, @cbStrLen), sizeof(cbStrLen), @cb)
#Else
Dim As HRESULT hr = pStream->lpvtbl->Write(pStream,Cast(void ptr, @cbStrLen), sizeof(cbStrLen), @cb)
#EndIf
if (FAILED(hr)) Then
return hr
EndIf
If cbStrLen Then
#If Not Defined( _FB_COM_VTBL_)
Return pStream->Write(cast(void ptr, m_bstr), cbStrLen, @cb)
#Else
Return pStream->lpvtbl->Write(pStream,Cast(void ptr, m_bstr), cbStrLen, @cb)
#EndIf
Else
Return S_OK
EndIf
End Function
#EndIf
Extern "windows" Lib "atl"
Declare Function AtlAxAttachControl(As IUnknown Ptr,As HWND,As IUnknown Ptr Ptr) As HRESULT ' Attaches a previously created control to the specified window.
End Extern
' COMVARIANT
Type COMVARIANT extends VARIANTARG
Private:
Declare Function InternalClear() As HRESULT
Declare Sub InternalCopy(ByVal pSrc as VARIANT Ptr )
'private functions
Declare Function CountArgsInFormat(pszFmt As String) As UINT
Declare Function GetVarType(psmzFmt As String ,pvt as VARTYPE Ptr ) As String
Declare FUNCTION PARSE (source as string, delimiter as String="|", index as integer)as String
Declare Function PARSECOUNT( source As String, delimiter As String=",")As Long
Declare Sub OleErrorShow ( hr As HRESULT, addit As String="")
public:
Declare Constructor ()
Declare Destructor ()
Declare Constructor (ByRef varSrc As Const VARIANT )
Declare Constructor (ByRef varSrc As VARIANT )
Declare Constructor (ByRef varSrc As COMVARIANT)
Declare Constructor (byval bstrSrc AS BSTR)
Declare Constructor (byval value as String )
Declare Constructor (byval lpszSrc AS LPCOLESTR)
'Declare Constructor (byval bSrc as BOOLEAN)
Declare Constructor (byval nSrc AS Integer)
Declare Constructor (byval nSrc AS Byte)
Declare Constructor (byval nSrc AS Short)
Declare Constructor (byval nSrc AS Long,vtSrc As VARTYPE = VT_I4)
Declare Constructor (byval fltSrc AS float)
Declare Constructor (byval dblSrc AS Double)
Declare Constructor (byval cySrc AS CY)
Declare Constructor (byval pSrc AS IDispatch Ptr,fAddRef As bool = CTRUE)
Declare Constructor (byval pSrc AS IUnknown Ptr,fAddRef As bool = CTRUE)
Declare Constructor (byval as SAFEARRAY Ptr)
Declare Constructor (ByRef decSrc As Const DECIMAL )
Declare operator Let(ByRef lvarSrc AS COMVARIANT)
Declare operator Let(ByVal varSrc as VARIANT)
Declare operator Let(byval bstrSrc AS BSTR)
Declare operator Let(byval bstrSrc AS String)
Declare operator Let(byval lpszSrc AS LPCOLESTR)
' Declare operator Let(byval bSrc as BOOLEAN)
Declare Operator Let(byval nSrc AS Integer)
Declare operator Let(byval nSrc AS BYTE)
Declare operator Let(byval nSrc AS Short)
Declare Operator Let(byval nSrc AS Long)
Declare operator Let(byval fltSrc AS float)
Declare operator Let(byval dblSrc AS double)
Declare operator Let(byval cySrc AS CY)
Declare operator Let(byval pSrc AS IDispatch ptr)
Declare operator Let(byval pSrc AS IUnknown ptr)
Declare Operator Let(byval as SAFEARRAY Ptr)
Declare Operator Let(ByRef decSrc As Const DECIMAL )
'Declare operator Let(ByVal varSrc as VARIANT)
Declare Function Clear() As HRESULT
Declare Function Copy(pSrc As VARIANT ptr ) As HRESULT
Declare Function Attach(pSrc As VARIANT ptr) As HRESULT
Declare Function Detach(pDest As VARIANT Ptr )As HRESULT
Declare Function Detach() As VARIANT Ptr
Declare Function ChangeType(vtNew As VARTYPE ,ByVal pSrc As VARIANT ptr = NULL) As HRESULT
Declare Function WriteToStream(pStream As IStream Ptr) As HRESULT
Declare Function ReadFromStream(pStream As IStream Ptr ) As HRESULT
Declare Operator cast() as Integer
Declare Operator cast() As Byte
Declare Operator cast() AS Short
Declare operator cast() AS Long
Declare operator cast() AS float
Declare operator cast() AS Double
Declare operator cast() AS CY
Declare Operator Cast() AS DECIMAL
Declare Operator cast() as String
Declare Operator cast() as BSTR
Declare operator cast() AS IDispatch Ptr
Declare operator cast() AS IUnknown Ptr
Declare Operator Cast() as SAFEARRAY Ptr
Declare Operator += ( byval rhs as string )
Declare Sub CreateObject (ByVal ProgID as LPCOLESTR)
Declare Sub CreateObject(szProgId As LPCOLESTR ,szMachine As LPCWSTR)
Declare Function CreateObject (szProgId As LPCOLESTR ,riid As REFIID ,dwClsContext As DWORD , _
mpServerInfo As COSERVERINFO ptr ,ppv as lpvoid Ptr ) As HRESULT
Declare Function GetObjectEx(szPathName As LPCOLESTR ,szProgId As LPCOLESTR ,riid As REFIID , _
dwClsContext As DWORD ,lpvReserved As LPVOID , ppv As LPVOID Ptr) As HRESULT
Declare sub GetObject (szPathName As LPCOLESTR =NULL,szProgId As LPCOLESTR)
Declare Sub AttachControl(hwnd As HWND) ' if .ocx attach a prébuild control Handle
Declare Function Invoke Cdecl (wFlags As WORD ,szName As LPCOLESTR , pszFmt as String="" ,argList As Any Ptr)As COMVARIANT
Declare Function Method Cdecl(MethodName As LPCOLESTR , pszFmt as String="" ,...)As COMVARIANT
Declare Function PropGet Cdecl (PropName As LPCOLESTR , pszFmt as String="" , ...)As COMVARIANT
Declare Sub PropPut Cdecl (szName As LPCOLESTR,pszFmt as String,...)
Declare Sub PropPutRef Cdecl (szName As LPCOLESTR,pszFmt as String,...)
End Type
Constructor COMVARIANT()
vt = VT_EMPTY
End Constructor
Destructor COMVARIANT()
Clear()
End Destructor
Constructor COMVARIANT(ByRef varSrc As Const VARIANT )
vt = VT_EMPTY
InternalCopy(@Cast(VARIANT,varSrc))
End Constructor
Constructor COMVARIANT(ByRef varSrc As VARIANT )
vt = VT_EMPTY
InternalCopy(@varSrc)
End Constructor
Constructor COMVARIANT(ByRef varSrc As COMVARIANT )
vt = VT_EMPTY
InternalCopy(@varSrc)
End Constructor
Constructor COMVARIANT(byval bstrSrc AS BSTR)
vt = VT_BSTR
bstrval = bstrSrc
End Constructor
constructor COMVARIANT (byval value as String )
Var wlen = MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, StrPtr(value), -1, 0, 0)-1
vt = VT_BSTR
bstrval = SysAllocStringLen(NULL, wlen)
MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED,StrPtr(value), -1, V_BSTR(@This), wlen)
End constructor
Constructor COMVARIANT(byval lpszSrc AS LPCOLESTR)
vt = VT_EMPTY
bstrval = Cast(BSTR,lpszSrc)
End Constructor
'Constructor COMVARIANT(byval bSrc as BOOLEAN)
' vt = VT_BOOL
' boolVal = bSrc
'End Constructor
Constructor COMVARIANT(byval nSrc AS Integer)
vt = VT_I4
lVal = nSrc
End Constructor
Constructor COMVARIANT(byval nSrc AS Byte)
vt = VT_UI1
bVal = nSrc
End Constructor
Constructor COMVARIANT(byval nSrc AS Short)
vt = VT_I2
iVal = nSrc
End Constructor
Constructor COMVARIANT(byval nSrc AS Long, vtSrc As VARTYPE = VT_I4)
Assert(vtSrc = VT_I4 OR vtSrc = VT_ERROR)
vt = vtSrc
lVal = nSrc
End Constructor
Constructor COMVARIANT(byval fltSrc AS float)
vt = VT_R4
fltVal = fltSrc
End Constructor
Constructor COMVARIANT(byval dblSrc AS Double)
V_VT(@this) = VT_R8
V_R8(@this) = dblSrc
End Constructor
Constructor COMVARIANT(byval cySrc AS CY)
'vt = VT_CY
'cyVal.Hi = cySrc.Hi
'cyVal.Lo = cySrc.Lo
V_VT(@this) = VT_CY
V_CY(@this) = cySrc
End Constructor
Constructor COMVARIANT(byval pSrc AS IDispatch Ptr,fAddRef As BOOL)
vt = VT_DISPATCH
pdispVal = pSrc
If (pdispVal <> NULL) Then ' Need to AddRef as VariantClear will Release
if (fAddRef) Then
#If Not Defined( _FB_COM_VTBL_)
pdispVal->AddRef()
#Else
pdispVal->lpvtbl->Release(pdispVal)
#EndIf
EndIf
EndIf
End Constructor
Constructor COMVARIANT(byval pSrc AS IUnknown Ptr,fAddRef As BOOL)
vt = VT_UNKNOWN
punkVal = pSrc
If (punkVal <> NULL) Then
if (fAddRef) Then
#If Not Defined( _FB_COM_VTBL_)
punkVal->AddRef() ' Need to AddRef as VariantClear will Release
#Else
punkVal->lpvtbl->AddRef(punkVal)
#EndIf
EndIf
endif
End Constructor
Constructor COMVARIANT(ByVal value As SAFEARRAY Ptr)
Dim vvt As VARTYPE
SafeArrayGetVartype(value,@vvt)
vt=vvt Or VT_ARRAY
parray=value
End Constructor
Constructor COMVARIANT(ByRef decSrc As Const DECIMAL )
' Order is important here! Setting V_DECIMAL wipes out the entire VARIANT
V_DECIMAL(@this) = decSrc
V_VT(@this) = VT_DECIMAL
End Constructor
' Assignment Operators
operator COMVARIANT.let(ByRef lvarSrc AS COMVARIANT)
InternalCopy(Cast(VARIANT Ptr,@lvarSrc))
End Operator
operator COMVARIANT.let(ByVal varSrc as VARIANT)
InternalCopy(@varSrc)
End Operator
operator COMVARIANT.let(byval bstrSrc AS BSTR)
InternalClear()
vt = VT_BSTR
bstrVal = ..SysAllocString(bstrSrc)
if (bstrVal = NULL And bstrSrc <> NULL) Then
vt = VT_ERROR
scode = E_OUTOFMEMORY
EndIf
End Operator
operator COMVARIANT.let(byval lpszSrc AS LPCOLESTR)
InternalClear()
vt = VT_BSTR
bstrVal = SysAllocString(lpszSrc)
if (bstrVal = NULL And lpszSrc <> NULL) Then
vt = VT_ERROR
scode = E_OUTOFMEMORY
EndIf
End Operator
operator COMVARIANT.let(byval value as STRING)
if (vt <> VT_BSTR) Then
InternalClear()
vt = VT_BSTR
EndIf
Var wlen = MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, StrPtr(value) , -1, 0, 0)-1
bstrval = SysAllocStringLen(NULL, wlen)
MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, StrPtr(value) , -1,V_BSTR(@This), wlen)
End Operator
/'operator COMVARIANT.let(byval bSrc as BOOLEAN)
if (vt <> VT_BOOL) Then
InternalClear()
vt = VT_BOOL
EndIf
boolVal = bSrc
End Operator
'/
operator COMVARIANT.let(byval nSrc AS Integer)
if (vt <> VT_I4) Then
InternalClear()
vt = VT_I4
EndIf
lVal = nSrc
End Operator
operator COMVARIANT.let(byval nSrc AS BYTE)
if (vt <>VT_UI1) Then
InternalClear()
vt = VT_UI1
EndIf
bVal = nSrc
End Operator
operator COMVARIANT.let(byval nSrc AS Short)
if (vt <>VT_I2) Then
InternalClear()
vt = VT_I2
EndIf
iVal = nSrc
End Operator
operator COMVARIANT.let(byval nSrc AS Long)
if (vt <> VT_I4) Then
InternalClear()
vt = VT_I4
EndIf
lVal = nSrc
End Operator
operator COMVARIANT.let(byval fltSrc AS float)
if (vt <> VT_R4) Then
InternalClear()
vt = VT_R4
End If
fltVal = fltSrc
End Operator
operator COMVARIANT.let(byval dblSrc As double)
if (vt <>VT_R8) Then
InternalClear()
vt = VT_R8
End If
dblVal = dblSrc
End Operator
operator COMVARIANT.let(byval cySrc AS CY)
if (vt <> VT_CY)Then
InternalClear()
vt = VT_CY
EndIf
cyVal.Hi = cySrc.Hi
cyVal.Lo = cySrc.Lo
End Operator
operator COMVARIANT.let(byval pSrc AS IDispatch ptr)
InternalClear()
vt = VT_DISPATCH
pdispVal = pSrc
If (pdispVal <> NULL) Then
#If Not Defined( _FB_COM_VTBL_)
pdispVal->AddRef() ' Need to AddRef as VariantClear will Release
#Else
pdispVal->lpvtbl->AddRef(pdispVal)
#EndIf
End If
End Operator
operator COMVARIANT.let(byval pSrc AS IUnknown ptr)
InternalClear()
vt = VT_UNKNOWN
punkVal = pSrc
if (punkVal <> NULL) Then
#If Not Defined( _FB_COM_VTBL_)
punkVal->AddRef() ' Need to AddRef as VariantClear will Release
#Else
punkVal->lpvtbl->AddRef(punkVal)
#EndIf
EndIf
Return
End Operator
Operator COMVARIANT.Let(byval p as SAFEARRAY Ptr)
InternalClear()
Dim vvt As VARTYPE
SafeArrayGetVartype(p,@vvt)
vt= vvt Or VT_ARRAY
parray=p
End Operator
Operator COMVARIANT.Let(ByRef decSrc As Const DECIMAL )
if (V_VT(@this) <> VT_DECIMAL) Then
this.Clear()
End If
' Order is important here! Setting V_DECIMAL wipes out the entire VARIANT
V_DECIMAL(@this) = decSrc
V_VT(@this) = VT_DECIMAL
End Operator
Function COMVARIANT.Clear() As HRESULT
return VariantClear(@this)
End Function
Function COMVARIANT.Copy(pSrc As VARIANT ptr ) As HRESULT
Return VariantCopy(@this, pSrc)
End Function
Function COMVARIANT.Attach(pSrc As VARIANT ptr) As HRESULT
Dim As HRESULT hr = Clear() ' Clear out the variant
if (0=FAILED(hr)) Then
memcpy(@this, pSrc, sizeof(VARIANT)) ' Copy the contents and give control to COMVARIANT
pSrc->vt = VT_EMPTY
hr = S_OK
endif
return hr
End Function
Function COMVARIANT.Detach(pDest As VARIANT Ptr )As HRESULT
Dim As HRESULT hr = VariantClear(pDest) ' Clear out the variant
if (0=FAILED(hr)) Then
memcpy(pDest, @this, sizeof(VARIANT)) ' Copy the contents and remove control from COMVARIANT
vt = VT_EMPTY
hr = S_OK
EndIf
return hr
End Function
Function COMVARIANT.Detach() As VARIANT Ptr
Dim pDest As VARIANT Ptr
Dim As HRESULT hr
memcpy(pDest, @this, sizeof(VARIANT)) ' Copy the contents and remove control from COMVARIANT
Return pDest
End Function
Function COMVARIANT.ChangeType(vtNew As VARTYPE ,ByVal pSrc As VARIANT ptr = NULL) As HRESULT
Dim As VARIANT Ptr pVar = cast(VARIANT Ptr,pSrc)
If (pVar = NULL) Then
pVar = @This ' Convert in place if pSrc is NULL
EndIf
' Do nothing if doing in place convert and vts not different
return ..VariantChangeType(@this, pVar, 0, vtNew)
End Function
Function COMVARIANT.InternalClear() As HRESULT
Dim As HRESULT hr = Clear()
Assert(SUCCEEDED(hr))
if (FAILED(hr)) Then
vt = VT_ERROR
scode = hr
EndIf
return hr
End Function
Sub COMVARIANT.InternalCopy(ByVal pSrc as VARIANT Ptr )
Dim As HRESULT hr = Copy(pSrc)
if (FAILED(hr)) Then
vt = VT_ERROR
scode = hr
EndIf
End Sub
'Operator COMVARIANT.cast() as BOOLEAN
' Return this.boolval
'End Operator
Operator COMVARIANT.cast() as Integer
If (V_VT(@this) = VT_INT) Then
return V_INT(@this)
End If
Dim vvar As variant
VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_INT)
return V_INT(@vvar)
End Operator
Operator COMVARIANT.cast()As Byte
If (V_VT(@this) = VT_UI1) Then
return V_UI1(@this)
End If
Dim vvar As variant
VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_UI1)
return V_UI1(@vvar)
End Operator
Operator COMVARIANT.cast() AS Short
If (V_VT(@this) = VT_I2) Then
return V_I2(@this)
End If
Dim vvar As variant
VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_I2)
return V_I2(@vvar)
End Operator
operator COMVARIANT.cast() AS Long
If (V_VT(@this) = VT_I4) Then
return V_I4(@this)
End If
Dim vvar As variant
VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_I4)
return V_I4(@vvar)
End Operator
operator COMVARIANT.cast() AS float
If (V_VT(@this) = VT_R4) Then
return V_R4(@this)
End If
Dim vvar As variant
VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_R4)
return V_R4(@vvar)
End Operator
operator COMVARIANT.cast() AS Double
If (V_VT(@this) = VT_R8) Then
return V_R8(@this)
End If
Dim vvar As variant
VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_R8)
return V_R8(@vvar)
End Operator
operator COMVARIANT.cast() AS CY
if (V_VT(@this) = VT_CY) Then
return V_CY(@this)
End If
Dim vvar As variant
VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_CY)
return V_CY(@vvar)
End Operator
operator COMVARIANT.cast() AS DECIMAL
if (V_VT(@this) = VT_DECIMAL) Then
return V_DECIMAL(@this)
End If
Dim vvar As variant
VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_DECIMAL)
return V_DECIMAL(@vvar)
End Operator
Operator COMVARIANT.cast() as String
Dim vvar As variant
VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_BSTR)
return *Cast(wString Ptr,vvar.bstrval)
End Operator
Operator COMVARIANT.cast() as BSTR
Dim vvar As variant
VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_BSTR)
return vvar.bstrval
End Operator
operator COMVARIANT.cast() AS IDispatch Ptr
If (V_VT(@this) = VT_DISPATCH) then
V_DISPATCH(@this)->AddRef()
return V_DISPATCH(@this)
End If
Dim vvar As variant
VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_DISPATCH)
V_DISPATCH(@vvar)->AddRef()
return V_DISPATCH(@vvar)
End Operator
operator COMVARIANT.cast() AS IUnknown Ptr
if (V_VT(@this) = VT_UNKNOWN) then
V_UNKNOWN(@this)->AddRef()
return V_UNKNOWN(@this)
End If
Dim vvar As variant
VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_UNKNOWN)
V_UNKNOWN(@vvar)->AddRef()
return V_UNKNOWN(@vvar)
End Operator
operator COMVARIANT.cast() as SAFEARRAY Ptr
if (vt And VT_ARRAY)=VT_ARRAY Then
Return this.parray
Else
Dim vvar As variant
VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_ARRAY Or (vt Xor VT_ARRAY) )
Return vvar.parray
EndIf
End Operator
Function COMVARIANT.WriteToStream(pStream As IStream Ptr) As HRESULT
Dim As HRESULT hr = pStream->Write(@vt, sizeof(VARTYPE), NULL)
if (FAILED(hr)) Then
return hr
EndIf
Dim As Integer cbWrite = 0
Select Case (vt)
case VT_UNKNOWN,VT_DISPATCH:
Dim spStream As IPersistStream Ptr
if (punkVal <> NULL) Then
#If Not Defined( _FB_COM_VTBL_)
hr = punkVal->QueryInterface(@IID_IPersistStream, cast(lpvoid Ptr,@spStream))
#Else
hr=punkVal->lpvtbl->QueryInterface(punkVal,@IID_IPersistStream, cast(lpvoid Ptr,@spStream))
#EndIf
if (FAILED(hr)) Then
return hr
EndIf
EndIf
if (spStream <> NULL) Then
return OleSaveToStream(spStream, pStream)
else
return WriteClassStm(pStream,@CLSID_NULL)
EndIf
case VT_UI1,VT_I1:
cbWrite = sizeof(BYTE)
case VT_I2,VT_UI2,VT_BOOL:
cbWrite = sizeof(short)
case VT_I4,VT_UI4,VT_R4,VT_INT,VT_UINT, VT_ERROR:
cbWrite = sizeof(long)
case VT_R8,VT_CY,VT_DATE:
cbWrite = sizeof(double)
Case Else
End Select
if (cbWrite <> 0) Then
#If Not Defined( _FB_COM_VTBL_)
Return pStream->Write(cast(lpvoid Ptr, @bVal), cbWrite, NULL)
#Else
Return pStream->lpvtbl->Write(pStream,Cast(lpvoid Ptr, @bVal), cbWrite, NULL)
#EndIf
EndIf
'bon pour finaliser
#Ifndef __WIDESTRING_INC__
Dim As BSTR bstrWrite
#Else
Dim As WideString bstrWrite
#EndIf
Dim As COMVARIANT varBSTR
if (vt <> VT_BSTR)Then
hr = VariantChangeType(@varBSTR, @this, VARIANT_NOVALUEPROP, VT_BSTR)
if (FAILED(hr)) Then
return hr
EndIf
bstrWrite = varBSTR.bstrVal
else
bstrWrite = bstrVal
EndIf
#Ifndef __WIDESTRING_INC__
Return BstrWriteToStream(bstrWrite,pStream)
#Else
Return bstrWrite.WriteToStream(pStream)
#EndIf
Return S_OK
End Function
Function COMVARIANT.ReadFromStream(pStream As IStream Ptr ) As HRESULT
Assert(pStream <> NULL)
Dim As HRESULT hr
hr = VariantClear(@this)
if (FAILED(hr)) Then
return hr
EndIf
Dim As VARTYPE vtRead
#If Not Defined( _FB_COM_VTBL_)
hr = pStream->Read(@vtRead, sizeof(VARTYPE), NULL)
#Else
hr= pStream->lpvtbl->Read(pStream,@vtRead, sizeof(VARTYPE), NULL)
#EndIf
if (hr = S_FALSE) Then
hr = E_FAIL
EndIf
if (FAILED(hr)) Then
return hr
EndIf
vt = vtRead
Dim As Integer cbRead = 0
Select Case (vtRead)
case VT_UNKNOWN,VT_DISPATCH:
punkVal = NULL
hr = OleLoadFromStream(pStream, _
iif(vtRead = VT_UNKNOWN, @IID_IUnknown , @IID_IDispatch), _
cast(LPVOID Ptr,@punkVal))
if (hr = REGDB_E_CLASSNOTREG) Then
hr = S_OK
EndIf
return S_OK
case VT_UI1,VT_I1:
cbRead = sizeof(BYTE)
Case VT_I2,VT_UI2,VT_BOOL:
cbRead = sizeof(short)
case VT_I4,VT_UI4,VT_R4,VT_INT,VT_UINT,VT_ERROR:
cbRead = sizeof(long)
case VT_R8,VT_CY,VT_DATE:
cbRead = sizeof(double)
Case Else
End Select
if (cbRead <> 0)Then
#If Not Defined( _FB_COM_VTBL_)
hr = pStream->Read(cast(lpvoid,@bVal), cbRead, NULL)
#Else
hr= pStream->lpvtbl->Read(pStream,Cast(lpvoid,@bVal), cbRead, NULL)
#EndIf
if (hr = S_FALSE) Then
hr = E_FAIL
EndIf
return hr
EndIf
Dim As COMVARIANT bstrRead
Dim tempv As VARIANT
hr = bstrRead.ReadFromStream(pStream)
if (FAILED(hr)) Then
return hr
EndIf
vt = VT_BSTR
bstrRead.Detach(@tempv)
bstrVal= tempv.bstrVal
if (vtRead <> VT_BSTR) Then
hr = ChangeType(vtRead)
EndIf
return hr
End Function
Operator COMVARIANT.+= ( byval rhs as string )
Dim as VARIANT tmp = any, res = any
VariantInit( @tmp )
Var wlen = MultiByteToWideChar(CP_ACP, NULL, StrPtr(rhs), &HFFFFFFFF, 0, 0)-1
V_VT(@tmp) = VT_BSTR
V_BSTR(@tmp) = SysAllocStringLen(NULL, wlen)
MultiByteToWideChar(CP_ACP, NULL, StrPtr(rhs), &HFFFFFFFF, V_BSTR(@tmp), wlen)
VarAdd( @This, @tmp, @res )
VariantClear( @This )
This = res
VariantClear( @tmp )
End Operator
Sub COMVARIANT.CreateObject (ByVal ProgID as LPCOLESTR)
Dim As IDISPATCH Ptr pdisp = NULL
Dim As IUNKNOWN Ptr punk = NULL
Dim as HRESULT hr
oleInitialize(NULL)
Dim As CLSID clsid
hr=CLSIDFromProgID(ProgID, @clsid)
If clsid=CLSID_NULL Then hr=CLSIDFromString(ProgID, @clsid)
If clsid=CLSID_NULL Then goto errorn
hr = CoCreateInstance(@clsid, NULL,CLSCTX_LOCAL_SERVER Or CLSCTX_INPROC_SERVER, @IID_IUNKNOWN, cast(LPVOID Ptr,@punk))
If FAILED(hr) then goto errorn
#If Not Defined( _FB_COM_VTBL_)
hr = punk->QueryInterface(@IID_IDispatch, cast(LPVOID Ptr,@pdisp))
#Else
hr = punk->lpvtbl->QueryInterface(punk,@IID_IDispatch, cast(LPVOID Ptr,@pdisp))
#EndIf
If FAILED(hr) Then goto errorn
#If Not Defined( _FB_COM_VTBL_)
punk->Release()
#Else
punk->lpvtbl->Release(punk)
#EndIf
This.vt=VT_DISPATCH
this.pdispval= pdisp
Return
errorn:
OleErrorShow(hr,"CreateObject(" & Chr(34) & *Cast(WString Ptr,ProgID) & Chr(34) & ")" )
#If Not Defined( _FB_COM_VTBL_)
If (punk) Then punk->Release()
If (pdisp) Then pdisp->Release()
#Else
If (punk) Then punk->lpvtbl->Release(punk)
If (pdisp) Then pdisp->lpvtbl->Release(pdisp)
#EndIf
End Sub
Sub COMVARIANT.CreateObject(szProgId As LPCOLESTR ,szMachine As LPCWSTR)
Dim As COSERVERINFO si
si.pwszName = Cast(LPWSTR,szMachine)
CreateObject(szProgId, @IID_IDispatch, _
IIf( szMachine , CLSCTX_REMOTE_SERVER , CLSCTX_LOCAL_SERVER Or CLSCTX_INPROC_SERVER), _
IIf( szMachine , @si , NULL), cast(LPVOID Ptr, @pdispval))
End Sub
Function COMVARIANT.CreateObject (szProgId As LPCOLESTR ,riid As REFIID ,dwClsContext As DWORD , _
mpServerInfo As COSERVERINFO ptr ,ppv as lpvoid Ptr ) As HRESULT
Dim As CLSID clsid
Dim As HRESULT hr
Dim As IClassFactory ptr pCf = NULL
if (Len(szProgId)=0 or riid=NULL or ppv=NULL) Then Return E_INVALIDARG
hr = CLSIDFromProgID(szProgId, @clsid)
If clsid=IID_NULL Then
hr = CLSIDFromString(szProgId, @clsid)
EndIf
If clsid=IID_NULL Then
OleErrorShow(hr,"CreateObject(" & Chr(34) & *Cast(WString Ptr,szProgId) & Chr(34) & ")" )
Return hr
EndIf
hr = CoGetClassObject(@clsid, dwClsContext, mpServerInfo, @IID_IClassFactory, Cast(lpvoid Ptr, @pCf))
#If Not Defined( _FB_COM_VTBL_)
If (SUCCEEDED(hr)) Then hr = pCf->CreateInstance(NULL, riid, ppv)
if (pCf) Then pCf->Release()
#Else
If (SUCCEEDED(hr)) Then hr = pCf->lpVtbl->CreateInstance(pCf, NULL, riid, ppv)
if (pCf) Then pCf->lpVtbl->Release(pCf)
#EndIf
return hr
End Function
Function COMVARIANT.GetObjectEx(szPathName As LPCOLESTR ,szProgId As LPCOLESTR ,riid As REFIID , _
dwClsContext As DWORD ,lpvReserved As LPVOID , ppv As LPVOID Ptr) As HRESULT
Dim As HRESULT hr
if ((Len(szProgId)=0 and Len(szPathName)=0) Or riid=NULL Or ppv=NULL Or lpvReserved<>0) Then Return E_INVALIDARG
if Len(szPathName) Then
if len(szProgId)=0 Then
hr = CoGetObject(szPathName, NULL, riid, ppv)
else
Dim As IPersistFile ptr ppf = NULL
hr = CreateObject(szProgId, @IID_IPersistFile, dwClsContext, NULL, cast(lpvoid Ptr, @ppf))
#If Not Defined( _FB_COM_VTBL_)
If (SUCCEEDED(hr)) Then hr = ppf->Load(szPathName, 0)
If (SUCCEEDED(hr)) Then hr = ppf->QueryInterface(riid, ppv)
If (ppf) Then ppf->Release()
#Else
If (SUCCEEDED(hr)) Then hr = ppf->lpVtbl->Load(ppf, szPathName, 0)
If (SUCCEEDED(hr)) Then hr = ppf->lpVtbl->QueryInterface(ppf, riid, ppv)
If (ppf) Then ppf->lpVtbl->Release(ppf)
#EndIf
EndIf
else
Dim As CLSID clsid
Dim As IUnknown Ptr pUnk = NULL
hr = CLSIDFromProgID(szProgId, @clsid)
If clsid=IID_NULL Then
hr = CLSIDFromString(szProgId, @clsid)
EndIf
If clsid=IID_NULL Then
OleErrorShow(hr,"CreateObject(" & Chr(34) & *szProgId & Chr(34) & ")" )
Return hr
EndIf
hr = GetActiveObject(@clsid, NULL, @pUnk)
#If Not Defined( _FB_COM_VTBL_)
If (SUCCEEDED(hr)) Then hr = pUnk->QueryInterface(riid, ppv)
If (pUnk) Then pUnk->Release()
#Else
If (SUCCEEDED(hr)) Then hr = pUnk->lpVtbl->QueryInterface(pUnk, riid, ppv)
If (pUnk) Then pUnk->lpVtbl->Release(pUnk)
#EndIf
EndIf
return hr
End Function
Sub COMVARIANT.GetObject(szPathName As LPCOLESTR =NULL,szProgId As LPCOLESTR)
Dim pDisp As IDispatch Ptr
GetObjectEx(szPathName, szProgId, @IID_IDispatch,CLSCTX_LOCAL_SERVER Or CLSCTX_INPROC_SERVER, NULL,@pDisp) ' curiosly bug with Cast(LPVOID Ptr,@pDisp))
this.vt=VT_DISPATCH
this.pdispval=pDisp
End Sub
Sub COMVARIANT.AttachControl(hwnd As HWND)
AtlAxAttachControl(Cast(IUnknown Ptr,this.pdispval),hwnd,NULL)
End Sub
Function COMVARIANT.Invoke Cdecl (wFlags As WORD ,szName As LPCOLESTR , pszFmt as String="" ,argList As Any Ptr)As COMVARIANT
Dim vRet As VARIANT
'Dim As Any Ptr argList
'argList= va_first()
Dim As ..DISPID dispidm
Dim As HRESULT hr
Dim As VARIANTARG ptr pvarg = NULL
Dim As VARIANTARG ptr pParams = NULL
variantinit(@vRet)
if (this.pdispval = NULL)Then
OleErrorShow(E_INVALIDARG)
vRet.vt = VT_ERROR
vRet.scode = -1
return vRet
End If
' Get DISPID of property/method
#If Defined (_FB_COM_VTBL_)
hr = this.pdispval->lpvtbl->GetIDsOfNames(this.pdispval,@IID_NULL, Cast(LPOLESTR Ptr,@szName), 1, LOCALE_USER_DEFAULT, @dispidm)
#Else
hr = this.pdispval->GetIDsOfNames(@IID_NULL,Cast(LPOLESTR Ptr,@szName), 1, LOCALE_USER_DEFAULT, @dispidm)
#EndIf
if(FAILED(hr))Then
OleErrorShow(hr,*Cast(WString Ptr,szName))
vRet.vt = VT_ERROR
vRet.scode = -1
Return vRet
End If
Dim As ..DISPPARAMS dispparams
memset(@dispparams, 0, SizeOf(..DISPPARAMS))
' determine number of arguments
if (Len(pszFmt) <> NULL)Then
dispparams.cArgs=CountArgsInFormat(pszFmt)
End If
' Property puts have a named argument that represents the value that the property is
' being assigned.
Dim As ..DISPID dispidNamed = DISPID_PROPERTYPUT
if (wFlags And(DISPATCH_PROPERTYPUT Or DISPATCH_PROPERTYPUTREF))Then
If (dispparams.cArgs = 0)Then
OleErrorShow(ResultFromScode(E_INVALIDARG),*Cast(WString Ptr,szName))
vRet.vt = VT_ERROR
vRet.scode = -1
Return vRet
End If
dispparams.cNamedArgs = 1
dispparams.rgdispidNamedArgs = @dispidNamed
End If
if (dispparams.cArgs <> 0)Then
pParams= new VARIANTARG[dispparams.cArgs] ' allocate memory for all VARIANTARG parameters
pvarg = new VARIANTARG[dispparams.cArgs]
if(pvarg = NULL)Then
OleErrorShow(ResultFromScode(E_OUTOFMEMORY),*Cast(WString Ptr,szName))
vRet.vt = VT_ERROR
vRet.scode = -1
Return vRet
End If
'memset(pvarg, 0, sizeof(VARIANTARG) * dispparams.cArgs)
Dim vt As VARTYPE
For i As Integer=1 To dispparams.cArgs
GetVarType(PARSE(pszFmt,",",i),@vt)
pParams[i-1].vt=vt
Select Case (pParams[i-1].vt)
case VT_UI1:
V_UI1(@pParams[i-1]) = va_arg(argList, UByte)
argList=va_next(argList,UByte)
case VT_I2:
V_I2(@pParams[i-1]) = va_arg(argList, short)
argList=va_next(argList,short)
case VT_I4:
V_I4(@pParams[i-1]) = va_arg(argList, long)
argList=va_next(argList,long)
case VT_R4:
V_R4(@pParams[i-1]) = va_arg(argList, float)
argList=va_next(argList,float)
Case VT_DATE:
pParams[i-1].date = va_arg(argList,DATE_)
argList=va_next(argList, DATE_)
case VT_R8:
pParams[i-1].dblval = va_arg(argList, double)
argList=va_next(argList, double)
case VT_CY:
V_CY(@pParams[i-1]) = va_arg(argList, CY)
argList=va_next(argList, CY)
case VT_BSTR:
V_BSTR(@pParams[i-1]) = SysAllocString(va_arg(argList, OLECHAR Ptr))
If (pParams[i-1].bstrVal = NULL) Then
hr = ResultFromScode(E_OUTOFMEMORY)
pParams[i-1].vt = VT_EMPTY
GoTo cleanup
End If
argList=va_next(argList, OLECHAR Ptr)
case VT_DISPATCH:
'V_DISPATCH(@pvarg[i-1]) = va_arg(argList, LPDISPATCH)
pParams[i-1].pdispval=va_arg(argList, LPDISPATCH)
argList= va_next(argList,Any Ptr) 'LPDISPATCH)
case VT_ERROR:
V_ERROR(@pParams[i-1]) = va_arg(argList, SCODE)
argList=va_next(argList, SCODE)
case VT_BOOL:
V_BOOL(@pParams[i-1]) = IIf(va_arg(argList,VARIANT_BOOL),-1,0)
argList=va_next(argList,VARIANT_BOOL)
case VT_VARIANT:
pParams[i-1] = *va_arg(argList, VARIANTARG Ptr)
argList=va_next(argList,VARIANTARG Ptr)
case VT_UNKNOWN:
V_UNKNOWN(@pParams[i-1]) = va_arg(argList, LPUNKNOWN)
argList= va_next(argList,Any Ptr) 'LPUNKNOWN)
case VT_UI1 OR VT_BYREF:
V_UI1REF(@pParams[i-1]) = va_arg(argList, UByte Ptr)
argList=va_next(argList,UByte Ptr)
case VT_I2 OR VT_BYREF:
V_I2REF(@pParams[i-1]) = va_arg(argList, short Ptr)
argList=va_next(argList,short Ptr)
case VT_I4 OR VT_BYREF:
V_I4REF(@pParams[i-1]) = va_arg(argList, long Ptr)
argList=va_next(argList,long Ptr)
case VT_R4 OR VT_BYREF:
V_R4REF(@pParams[i-1]) = va_arg(argList, float Ptr)
argList=va_next(argList,float Ptr)
case VT_R8 OR VT_BYREF:
V_R8REF(@pParams[i-1]) = va_arg(argList, double Ptr)
argList=va_next(argList,double Ptr)
case VT_DATE OR VT_BYREF:
V_DATEREF(@pParams[i-1]) = va_arg(argList, DATE_ Ptr)
argList=va_next(argList,DATE_ Ptr)
case VT_CY OR VT_BYREF:
V_CYREF(@pParams[i-1]) = va_arg(argList, CY Ptr)
argList=va_next(argList, CY Ptr)
case VT_BSTR OR VT_BYREF:
V_BSTRREF(@pParams[i-1]) = va_arg(argList, BSTR Ptr)
argList=va_next(argList,BSTR Ptr)
case VT_DISPATCH OR VT_BYREF:
' V_DISPATCHREF(@pvarg[i-1]) = va_arg(argList, LPDISPATCH Ptr)
pParams[i-1].ppdispval = va_arg(argList, LPDISPATCH Ptr)
argList=va_next(argList,Any Ptr Ptr) 'LPDISPATCH Ptr)
case VT_ERROR OR VT_BYREF:
V_ERRORREF(@pParams[i-1]) = va_arg(argList, SCODE Ptr)
argList=va_next(argList,SCODE Ptr)
case VT_BOOL OR VT_BYREF:
Dim As VARIANT_BOOL Ptr pbool = va_arg(argList, VARIANT_BOOL Ptr)
'*pbool = 0
V_BOOLREF(@pParams[i-1]) = Cast(VARIANT_BOOL Ptr,pbool)
argList=va_next(argList,VARIANT_BOOL Ptr)
case VT_VARIANT OR VT_BYREF:
V_VARIANTREF(@pParams[i-1]) = va_arg(argList, VARIANTARG Ptr)
argList=va_next(argList,VARIANTARG Ptr)
case VT_UNKNOWN OR VT_BYREF:
V_UNKNOWNREF(@pParams[i-1]) = va_arg(argList, LPUNKNOWN Ptr)
argList=va_next(argList,Any Ptr Ptr) 'LPUNKNOWN Ptr)
case VT_RECORD :
pParams[i-1].pvRecord = va_arg(argList, Any Ptr)
argList=va_next(argList,Any Ptr Ptr)
Case Else:
If (pParams[i-1].vt And (VT_ARRAY Or VT_BYREF)) Then
pParams[i-1].pparray=va_arg(argList, SAFEARRAY Ptr Ptr )
argList=va_next(argList,SAFEARRAY Ptr Ptr)
Exit Select
EndIf
OleErrorShow(ResultFromScode(E_OUTOFMEMORY),*Cast(WString Ptr,szName))
End Select
Next i
End if 'if
' Initialize return variant, in case caller forgot. Caller can pass NULL if return
' value is not expected.
'if (@vRet)Then
' VariantInit(@vRet)
'End If
' inverser les parametres avant de les passer à dispparams
For i As Integer= 0 to dispparams.cArgs-1
pvarg[i] = pParams[dispparams.cArgs-i-1]
Next
dispparams.rgvarg = pvarg
' make the call
#If Defined (_FB_COM_VTBL_)
hr = this.pdispval->lpvtbl->Invoke(this.pdispval,dispidm, @IID_NULL, LOCALE_USER_DEFAULT, wFlags,@dispparams, @vRet, NULL, NULL)
#Else
hr = this.pdispval->Invoke(dispidm, @IID_NULL, LOCALE_USER_DEFAULT, wFlags,@dispparams, @vRet, NULL, NULL)
#EndIf
OleErrorShow(hr,"pdisp->Invoke in " & *szName)
cleanup:
' cleanup any arguments that need cleanup
If(dispparams.cArgs > 0)Then
for i As Integer= 0 to dispparams.cArgs-1
pParams[dispparams.cArgs-i-1]=pvarg[i]
next
End If
if (dispparams.cArgs <> 0)Then
For i As Integer= 0 to dispparams.cArgs-1
If pvarg[i].vt=VT_BSTR Then VariantClear(@pvarg[i])
Next
End If
delete dispparams.rgvarg
delete pParams
return vRet
End function
Function COMVARIANT.Method Cdecl( MethodName As LPCOLESTR , pszFmt as String="" ,...)As COMVARIANT
Return Invoke(DISPATCH_METHOD,MethodName,pszFmt,va_first())
End function
Function COMVARIANT.PropGet Cdecl ( PropName As LPCOLESTR , pszFmt as String="" , ...)As COMVARIANT
Return Invoke(DISPATCH_PROPERTYGET,PropName,pszFmt,va_first())
End function
Sub COMVARIANT.PropPut Cdecl ( szName As LPCOLESTR,pszFmt as String,...)
Invoke(DISPATCH_PROPERTYPUT,szName,pszFmt,va_first())
End Sub
Sub COMVARIANT.PropPutRef Cdecl ( szName As LPCOLESTR,pszFmt as String,...)
Invoke(DISPATCH_PROPERTYPUTREF,szName,pszFmt,va_first())
End Sub
''''''''''''''''' PRIVATE FUNCTIONS '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Function COMVARIANT.CountArgsInFormat(pszFmt As String) As UINT
return PARSECOUNT(pszFmt,",")
End Function
Private Function COMVARIANT.GetVarType(psmzFmt As String ,pvt as VARTYPE Ptr ) As String
*pvt = 0
' Cas Particulier des safearrays
If InStr(psmzFmt,"%t") Then
*pvt =VT_ARRAY Or VT_BYREF
psmzFmt=Right(psmzFmt,1)
Select Case Trim(psmzFmt)
Case "a"
*pvt OR = VT_UI1
case ("b"):
*pvt OR = VT_BOOL
case ("i"):
*pvt OR = VT_I2
case ("I"):
*pvt OR = VT_I4
case ("r"):
*pvt OR = VT_R4
case ("R"):
*pvt OR = VT_R8
case ("c"):
*pvt OR = VT_CY
case ("s"):
*pvt OR = VT_BSTR
case ("e"):
*pvt OR = VT_ERROR
case ("d"):
*pvt OR = VT_DATE
case ("v"):
*pvt OR = VT_VARIANT
Case ("U"):
*pvt OR = VT_UNKNOWN
case ("D"):
*pvt Or = VT_DISPATCH
case ("p"):
*pvt= VT_RECORD
Case (!"\0")
return "" ' End of Format string
Case else:
return ""
End Select
End If
' Cas des parametres byref
if InStr(psmzFmt,"@") Then
*pvt = VT_BYREF
If (NULL=Len(psmzFmt))Then
return ""
End If
End If
psmzFmt=Right(psmzFmt,1)
Select Case Trim(psmzFmt)
Case "a"
*pvt OR = VT_UI1
case ("b"):
*pvt OR = VT_BOOL
case ("i"):
*pvt OR = VT_I2
case ("I"):
*pvt OR = VT_I4
case ("r"):
*pvt OR = VT_R4
case ("R"):
*pvt OR = VT_R8
case ("c"):
*pvt OR = VT_CY
case ("s"):
*pvt OR = VT_BSTR
case ("e"):
*pvt OR = VT_ERROR
case ("d"):
*pvt OR = VT_DATE
case ("v"):
*pvt OR = VT_VARIANT
Case ("U"):
*pvt OR = VT_UNKNOWN
Case ("D"):
*pvt Or = VT_DISPATCH
Case ("p"):
*pvt = VT_RECORD
case (!"\0")
return "" ' End of Format string
Case else:
return ""
End Select
return psmzFmt
End Function
Private Function COMVARIANT.PARSECOUNT( source As String, delimiter As String=",")As Long
Dim As Long i,s,c,l
s=1
l=1
Do
i=Instr(s,source,Any delimiter)
If i>0 Then
c+=1
s=i+l
End If
Loop Until i=0
Function=c+1
End Function
Private Function COMVARIANT.PARSE (source as string, delimiter as String="|", index as integer)as String
Dim As Long i,s,c,l
s=1
l=Len(delimiter)
do
If c=index-1 then
function=mid(source,s,instr(s,source,delimiter)-s)
exit function
end if
i=instr(s,source,delimiter)
If i>0 then
c+=1
s=i+l
end if
loop until i=0
End Function
Private Sub COMVARIANT.OleErrorShow ( hr As HRESULT, addit As String="")
Dim serr As String
If hr=s_ok Then Exit Sub
Dim As Any Ptr pMsg
FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_FROM_SYSTEM,NULL,hr, _
MAKELANGID(LANG_NEUTRAL,SUBLANG_DEFAULT),Cast(LPTSTR,@pMsg),0,NULL)
Dim As String sCheckError= " : Error(&h" & Hex(hr) & "): " & *Cast(ZString Ptr,pMsg)
LocalFree(pMsg)
serr=addit & " " & sCheckError
MessageBox (getactiveWindow(),serr,"OLE ERROR ",MB_ICONERROR Or MB_TASKMODAL)
End Sub
Operator <>(ByVal V As COMVARIANT,ByVal varSrc as VARIANT) As BOOL
Return (@v=@varSrc)
End Operator
Operator <(ByVal V As COMVARIANT,ByVal varSrc as VARIANT) As BOOL
Return VarCmp(@V,@varSrc, LOCALE_USER_DEFAULT, 0)=VARCMP_LT
End Operator
Operator >(ByVal V As COMVARIANT,ByVal varSrc as VARIANT) As BOOL
Return VarCmp(@V,@varSrc, LOCALE_USER_DEFAULT, 0)=VARCMP_GT
End Operator
Operator =(ByVal V As COMVARIANT,ByVal varSrc as VARIANT) As BOOL
if (@V = @varSrc) Then
return TRUE
EndIf
' Variants not equal if types don't match
if (V.vt <>varSrc.vt) Then
return FALSE
EndIf
' Check type specific values
Select Case (V.vt)
case VT_EMPTY,VT_NULL:
return TRUE
case VT_BOOL:
return (V.boolVal = varSrc.boolVal)
case VT_UI1:
return (V.bVal = varSrc.bVal)
case VT_I2:
return V.iVal = varSrc.iVal
case VT_I4:
return V.lVal = varSrc.lVal
case VT_R4:
return V.fltVal = varSrc.fltVal
case VT_R8:
return V.dblVal = varSrc.dblVal
case VT_BSTR:
return (SysStringByteLen(V.bstrVal) = SysStringByteLen(varSrc.bstrVal)) And _
(memcmp(V.bstrVal, varSrc.bstrVal, SysStringByteLen(V.bstrVal)) = 0)
case VT_ERROR:
return V.scode = varSrc.scode
case VT_DISPATCH:
return V.pdispVal = varSrc.pdispVal
case VT_UNKNOWN:
return V.punkVal = varSrc.punkVal
Case Else
Assert(false)
' fall through
End Select
return FALSE
End Operator
#EndIf
Re: INSIDE ACTIVEX WITH FREEBASIC
None of the links to 2shared are anymore working.
That's the problem when using general sharing sites :(
That's the problem when using general sharing sites :(
Re: INSIDE ACTIVEX WITH FREEBASIC
Errors in Variants.bi and InvokeHelper.bi
IDE FbIde
FreeBasic V 1.0.8
C:\Archivos de programa\FreeBASIC\inc\variants.bi(976) error 18: Element not defined, AddRef in 'If v.punkVal THEN pUnk->AddRef(pUnk)'
C:\Archivos de programa\FreeBASIC\inc\variants.bi(987) error 3: Expected End-of-Line, found '(' in 'If v.ppunkVal THEN (*pUnk)->AddRef()'
C:\Archivos de programa\FreeBASIC\inc\variants.bi(1346) error 9: Expected expression, found ')' in 'v.punkVal->AddRef()'
C:\Archivos de programa\FreeBASIC\inc\variants.bi(1355) error 9: Expected expression, found ')' in 'vvar.punkVal->AddRef()'
C:\Archivos de programa\FreeBASIC\inc\variants.bi(1366) error 3: Expected End-of-Line, found '(' in 'Cast(IUnknown Ptr,*(v.ppunkVal))->AddRef()'
C:\Archivos de programa\FreeBASIC\inc\variants.bi(1375) error 3: Expected End-of-Line, found '(' in 'Cast(IUnknown Ptr,*(vvar.ppunkVal))->AddRef()'
C:\Archivos de programa\FreeBASIC\inc\InvokeHelper.bi(17) warning 44(1): Suffix ignored in 'FORMAT$'
C:\Archivos de programa\FreeBASIC\inc\InvokeHelper.bi(109) error 18: Element not defined, QueryInterface in 'hr = rVal.punkval->QueryInterface(@IID_IDispatch, cast(lpvoid Ptr,@rVal.pdispval))'
C:\Archivos de programa\FreeBASIC\inc\InvokeHelper.bi(125) error 18: Element not defined, Release in 'rVal.punkval->Release()'
C:\Archivos de programa\FreeBASIC\inc\InvokeHelper.bi(137) error 9: Expected expression, found ')' in 'If (rVal.punkval) Then rVal.punkval->Release()'
C:\Archivos de programa\FreeBASIC\inc\InvokeHelper.bi(138) error 9: Expected expression, found ')' in 'If (rVal.pdispval) Then rVal.pdispval->Release()'
C:\Archivos de programa\FreeBASIC\inc\InvokeHelper.bi(138) error 133: Too many errors, exiting
IDE FbIde
FreeBasic V 1.0.8
C:\Archivos de programa\FreeBASIC\inc\variants.bi(976) error 18: Element not defined, AddRef in 'If v.punkVal THEN pUnk->AddRef(pUnk)'
C:\Archivos de programa\FreeBASIC\inc\variants.bi(987) error 3: Expected End-of-Line, found '(' in 'If v.ppunkVal THEN (*pUnk)->AddRef()'
C:\Archivos de programa\FreeBASIC\inc\variants.bi(1346) error 9: Expected expression, found ')' in 'v.punkVal->AddRef()'
C:\Archivos de programa\FreeBASIC\inc\variants.bi(1355) error 9: Expected expression, found ')' in 'vvar.punkVal->AddRef()'
C:\Archivos de programa\FreeBASIC\inc\variants.bi(1366) error 3: Expected End-of-Line, found '(' in 'Cast(IUnknown Ptr,*(v.ppunkVal))->AddRef()'
C:\Archivos de programa\FreeBASIC\inc\variants.bi(1375) error 3: Expected End-of-Line, found '(' in 'Cast(IUnknown Ptr,*(vvar.ppunkVal))->AddRef()'
C:\Archivos de programa\FreeBASIC\inc\InvokeHelper.bi(17) warning 44(1): Suffix ignored in 'FORMAT$'
C:\Archivos de programa\FreeBASIC\inc\InvokeHelper.bi(109) error 18: Element not defined, QueryInterface in 'hr = rVal.punkval->QueryInterface(@IID_IDispatch, cast(lpvoid Ptr,@rVal.pdispval))'
C:\Archivos de programa\FreeBASIC\inc\InvokeHelper.bi(125) error 18: Element not defined, Release in 'rVal.punkval->Release()'
C:\Archivos de programa\FreeBASIC\inc\InvokeHelper.bi(137) error 9: Expected expression, found ')' in 'If (rVal.punkval) Then rVal.punkval->Release()'
C:\Archivos de programa\FreeBASIC\inc\InvokeHelper.bi(138) error 9: Expected expression, found ')' in 'If (rVal.pdispval) Then rVal.pdispval->Release()'
C:\Archivos de programa\FreeBASIC\inc\InvokeHelper.bi(138) error 133: Too many errors, exiting
-
- Posts: 507
- Joined: Jan 13, 2009 19:23
Re: INSIDE ACTIVEX WITH FREEBASIC
you don't have modified .bi so use lptvbl->