Variants in Free Basic

[José Roca]

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:

Code Select Expand


#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 <> ""


Code Select Expand


#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 <> ""


Code Select Expand


#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 <> ""


[José Roca]

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.

[José Roca]

The Free Basic intrinsic functions can also be used with the returned results, e.g.

Code Select Expand


#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.

[José Roca]

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.

[Paul Squires]

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.

[José Roca]

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++.

[Paul Squires]

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 

[José Roca]

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.

[José Roca]

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:

Code Select Expand


' ****************************************************************************************
' 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:

Code Select Expand


' ****************************************************************************************
' 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