First version of the CVariant class. The most essential procedures are done. I will add some procedures to deal with arrays, DECIMAL type, etc., later.
Some usage examples:
#define unicode
#INCLUDE ONCE "windows.bi"
#INCLUDE ONCE "Afx/CBStr.inc"
#INCLUDE ONCE "Afx/CVariant.inc"
using Afx.CBStrClass
using Afx.CVariantClass
' Creates a instance of CVariant and assigns a string to it
DIM cv AS CVariant = "Test string"
' --or--
' DIM cv AS CVariant
' cv = "Test string"
' Creates an instance of the CBStr class
DIM cbs AS CBStr
' Attaches the returned BSTR to it
cbs = CAST(BSTR, cv)
' Prints the content
print **cbs
print "press esc"
dim as string k
do
k = inkey( )
loop until k <> ""
#define unicode
#INCLUDE ONCE "windows.bi"
#INCLUDE ONCE "Afx/CVariant.inc"
using Afx.CVariantClass
' Creates a instance of CVariant and assigns a string to it
DIM cv AS CVariant = "Test string"
' Cast it as a Free Basic string
DIM s AS STRING = CAST(STRING, cv)
' Prints the content
print s
print "press esc"
dim as string k
do
k = inkey( )
loop until k <> ""
#define unicode
#INCLUDE ONCE "windows.bi"
#INCLUDE ONCE "Afx/CVariant.inc"
using Afx.CVariantClass
' Creates a instance of CVariant and assigns a double to it
DIM cv AS CVariant = CDBL(12345.6789)
' Round it to 2 decimal places
cv.Round(2)
' Prints the content
print CAST(DOUBLE, cv)
' --or-- you can use other casts, e.g.
' print CAST(STRING, cv)
print "press esc"
dim as string k
do
k = inkey( )
loop until k <> ""
Almost any kind of variants can be cast to a STRING or a BSTR. If the variant contains an array, each element of the array is appended to the resulting string separated with a semicolon and a space.
It is not possible to return an array of bytes as a FB STRING or a BSTR, because the array of bytes can contain embedded nulls and the FB STRING is asciiz, and the BSTR unicode.
The class provides two procedures to deal with them, FromBuffer and ToBuffer.
In some procedures, I have needed to use DyLibLoad because the current version of Free Basic does not provide an header and a library for the "propvarutil.dll". Unfortunately, a lot of useful funtions to deal with variants are exported by this dll.
The Free Basic intrinsic functions can also be used with the returned results, e.g.
#define unicode
#INCLUDE ONCE "windows.bi"
#INCLUDE ONCE "Afx/CVariant.inc"
using Afx.CVariantClass
' Creates a instance of CVariant and assigns a double to it
DIM cv AS CVariant = CLNG(-12345)
' Prints the content
DIM n AS LONG
n = ABS(CAST(LONG, cv))
print n
print "press esc"
dim as string k
do
k = inkey( )
loop until k <> ""
But if the returned result is a BSTR or a VARIANT, we must attach it to a CBSTR/CVARIANT class to avoid memory leaks.
It is not possible to check for memory leaks with the process manager because the Windows OLE string engine caches BSTRings. It is possible to disable it, but that could cause other kind of problems. Besides, it is not easy to do.
Excellent! Thanks Jose :)
By the way, the only other person that I can think of that is doing anything in the areas of COM and ActiveX is aloberoger over on the FB forum. Not sure if you search his posts that you might some header translations already done(?).
This Variant class will be very useful for some code projects that I have in mind.
He wrote a wrapper for COM automation usage, but it is written in C++. I intend to use direct calls, not automation, and with Free Basic, not C++.
Quote from: Jose Roca on August 30, 2015, 01:10:20 PM
He wrote a wrapper for COM automation usage, but it is written in C++. I intend to use direct calls, not automation, and with Free Basic, not C++.
Jose, you are like the super hero of programming :)
I see that he has code written with FB. Will look at it to see if I can borrow something useful. I had confused him with another user that did write something called AxSuite.
I could write hundreds of functions and operators for the CVariant class, but this will add excesive bloat. Therefore, I will add only the really needed ones.
The main advantages of a native implementation is less bloat and automatic memory cleanup. The compiler can detect if the returned BSTR or VARIANT is being used in an expression instead of being assigned to a variable and free these temporary handles, making its use more flexible.
In the BSTR class I have needed to use a trick to detect if the passed BSTR is a real one, that must be freed, or a temporary WSTRING variable created by the compiler, that must no be freed if you don't want to get a GPF. If the compiler had a real BSTR data type, this problem won't happen.
With PB, we often used non unicode strings as buffers for binary data. We can't do that with FB strings because they are asciiz.
I see that they have borrowed my code, so it will be fair if I borrow from them.
For example, this code is a traslation to FB of code that I wrote in 2005 and posted there:
http://www.powerbasic.com/support/pbforums/showthread.php?t=21597&highlight=CreateControlLic
Look at the comments: they are identical.
FreeBasic traslation:
' ****************************************************************************************
' 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.
' ****************************************************************************************
FUNCTION CreateControlLic (BYVAL strProgID AS STRING, BYVAL hWndControl AS HWND, BYVAL strLicKey AS STRING) AS LONG
DIM hr As HRESULT ' Result code
Dim ppUnknown AS IUnknown Ptr ' IUnknown pointer
Dim ppDispatch AS IDispatch Ptr ' IDispatch pointer
Dim ppObj AS DWORD ' Dispatch interface of the control
Dim ppClassFactory2 AS IClassFactory2 Ptr ' IClassFactory2 pointer
Dim ppUnkContainer AS IUnknown Ptr ' IUnknown of the container
Dim ClassID AS GUID ' CLSID
Dim pbstrLicKey AS STRING ' Unicode license key string
pbstrLicKey = UCODE$(strLicKey) ' Convert the license key to Unicode
' Standard interface GUIDs
' Exit if strProgID is a null string
IF strProgID = "" THEN
FUNCTION = &H80070057 ' %E_INVALIDARG
EXIT FUNCTION
END IF
' Convert the ProgID to a CLSID
ClassID = CLSID$(strProgID)
' If it fails, see if it is a CLSID
IF ClassID = IID_NULL THEN ClassID = GUID$(strProgID)
' If not a valid ProgID or CLSID return an error
IF ClassID = IID_NULL THEN
FUNCTION = &H80070057 ' %E_INVALIDARG
EXIT FUNCTION
END IF
' Get a reference to the IClassFactory2 interface of the control
Hr = CoGetClassObject(@ClassID,CLSCTX_ALL, NULL, @IID_IClassFactory2, ppClassFactory2)
IF hr<>0 THEN
Function = hr
Exit FUNCTION
END IF
' Create a licensed instance of the control
hr = IClassFactory2_CreateInstanceLic(ppClassFactory2, %NULL, %NULL, @IID_IUnknown, STRPTR(pbstrLicKey), ppUnknown)
' First release the IClassFactory2 interface
IUnknown_Release ppClassFactory2
IF hr <> S_OK OR ppUnknown = %NULL THEN
FUNCTION = hr
EXIT FUNCTION
END IF
' Ask for the dispatch interface of the control
hr = IUnknown_QueryInterface(ppUnknown, @IID_IDispatch, ppDispatch)
' If it fails, use the IUnknown of the control, else use IDispatch
IF hr <> S_OK OR ppDispatch = NULL THEN
ppObj = ppUnknown
ELSE
' Release the IUnknown interface
IUnknown_Release ppUnknown
ppObj = ppDispatch
END IF
' Attach the control to the window
hr = AtlAxAttachControl(ppObj, hWndControl, ppUnkContainer)
' Note: Do not release ppObj or your application will GPF when it ends because
' ATL will release it when the window that hosts the control is destroyed.
FUNCTION = hr
END Function
' ****************************************************************************************
My original code:
' ****************************************************************************************
' 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.
' ****************************************************************************************
FUNCTION TB_CreateControlLic (BYVAL strProgID AS STRING, BYVAL hWndControl AS DWORD, BYVAL strLicKey AS STRING) AS LONG
LOCAL HRESULT AS LONG ' Result code
LOCAL ppUnknown AS DWORD ' IUnknown pointer
LOCAL ppDispatch AS DWORD ' IDispatch pointer
LOCAL ppObj AS DWORD ' Dispatch interface of the control
LOCAL ppClassFactory2 AS DWORD ' IClassFactory2 pointer
LOCAL ppUnkContainer AS DWORD ' IUnknown of the container
LOCAL IID_NULL AS GUID ' Null GUID
LOCAL IID_IUnknown AS GUID ' Iunknown GUID
LOCAL IID_IDispatch AS GUID ' IDispatch GUID
LOCAL IID_IClassFactory2 AS GUID ' IClassFactory2 GUID
LOCAL ClassID AS GUID ' CLSID
LOCAL pbstrLicKey AS STRING ' Unicode license key string
pbstrLicKey = UCODE$(strLicKey) ' Convert the license key to Unicode
' Standard interface GUIDs
IID_NULL = GUID$("{00000000-0000-0000-0000-000000000000}")
IID_IUnknown = GUID$("{00000000-0000-0000-c000-000000000046}")
IID_IDispatch = GUID$("{00020400-0000-0000-c000-000000000046}")
IID_IClassFactory2 = GUID$("{b196b28f-bab4-101a-b69c-00aa00341d07}")
' Exit if strProgID is a null string
IF strProgID = "" THEN
FUNCTION = &H80070057 ' %E_INVALIDARG
EXIT FUNCTION
END IF
' Convert the ProgID to a CLSID
ClassID = CLSID$(strProgID)
' If it fails, see if it is a CLSID
IF ClassID = IID_NULL THEN ClassID = GUID$(strProgID)
' If not a valid ProgID or CLSID return an error
IF ClassID = IID_NULL THEN
FUNCTION = &H80070057 ' %E_INVALIDARG
EXIT FUNCTION
END IF
' Get a reference to the IClassFactory2 interface of the control
' Context: &H17 (%CLSCTX_ALL) =
' %CLSCTX_INPROC_SERVER OR %CLSCTX_INPROC_HANDLER OR _
' %CLSCTX_LOCAL_SERVER OR %CLSCTX_REMOTE_SERVER
HRESULT = CoGetClassObject(ClassID, &H17, %NULL, IID_IClassFactory2, ppClassFactory2)
IF ISTRUE HRESULT THEN
FUNCTION = HRESULT
EXIT FUNCTION
END IF
' Create a licensed instance of the control
HRESULT = IClassFactory2_CreateInstanceLic(ppClassFactory2, %NULL, %NULL, IID_IUnknown, STRPTR(pbstrLicKey), ppUnknown)
' First release the IClassFactory2 interface
IUnknown_Release ppClassFactory2
IF ISTRUE HRESULT OR ISFALSE ppUnknown THEN
FUNCTION = HRESULT
EXIT FUNCTION
END IF
' Ask for the dispatch interface of the control
HRESULT = IUnknown_QueryInterface(ppUnknown, IID_IDispatch, ppDispatch)
' If it fails, use the IUnknown of the control, else use IDispatch
IF ISTRUE HRESULT OR ISFALSE ppDispatch THEN
ppObj = ppUnknown
ELSE
' Release the IUnknown interface
IUnknown_Release ppUnknown
ppObj = ppDispatch
END IF
' Attach the control to the window
HRESULT = AtlAxAttachControl(ppObj, hWndControl, ppUnkContainer)
' Note: Do not release ppObj or your application will GPF when it ends because
' ATL will release it when the window that hosts the control is destroyed.
FUNCTION = HRESULT
END FUNCTION
' ****************************************************************************************
I see that the code that I wrote ten years ago can now be useful to work with FB :)