variant_s.bi
#Include Once "windows.bi"
#Include Once "win/ole2.bi"
' Small VARIANT CLASS that not performing the necessary indirection of a variant(with VT_BYREF)
Type VARIANT_S extends ..VARIANT
private:
dim onull as Short
public:
declare constructor()
declare constructor(ByRef value As VARIANT_S) ' pour retouner un VARIANT_S dans une function
declare constructor(ByVal value As VARIANT) ' pour pouvoir écrire: dim as VARIANT_S vv=v
declare Constructor (byval value as String )
declare Constructor (ByVal value as wstring Ptr)
declare constructor(ByVal value As Single)
declare constructor(ByVal value As BSTR)
Declare constructor(ByVal value As Integer)
declare constructor(ByVal value As Long)
declare constructor(ByVal value As SAFEARRAY Ptr)
declare constructor(ByVal value As IDispatch Ptr)
declare Constructor(ByVal value as IUnknown Ptr)
declare destructor()
Declare Constructor(value As Short , vtSrc as VARTYPE = VT_I2) ' Creates a VT_I2, or a VT_BOOL
Declare Constructor(value As Double , vtSrc as VARTYPE = VT_R8) ' Creates a VT_R8, or a VT_DATE
Declare Constructor(value As Byte )
declare Constructor (BYVAL value AS Boolean)
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 ChangeType(vtNew As VARTYPE ,ByVal pSrc As VARIANT ptr = NULL) As HRESULT
Declare Sub CopyInd (ByVal value AS VARIANT)
Declare Function IsArray As Boolean
declare operator let(byval value as Single)
declare operator let(byval d as double)
Declare operator let(byval d as BSTR)
declare operator let(byval s as String)
Declare Operator Let (ByVal value AS WSTRING Ptr)
declare operator let(byval value as Byte)
Declare Operator Let (BYVAL value AS Short)
Declare Operator Let (ByVal value As Integer)
declare operator Let (byval value as LONG)
declare Operator Let (BYVAL value AS Boolean)
Declare Operator let(ByVal value as VARIANT)
declare operator Let(ByRef value as VARIANT_S)
declare operator let(byval d as SAFEARRAY Ptr)
Declare Operator Let (BYVAL pDisp AS IDispatch Ptr)
Declare Operator Let(BYVAL pUnk AS IUnknown Ptr)
declare operator Cast() as Single
declare operator cast() as Double
declare Operator cast() as BSTR
declare operator cast() as String
Declare Operator cast() as WString Ptr
Declare Operator cast() as Byte
Declare Operator cast() as Short
Declare Operator Cast() As Integer
declare operator cast() as Long
Declare Operator cast() as Boolean
' declare operator cast() as VARIANT ' with extends variant not implement this
declare operator cast() as SAFEARRAY Ptr
Declare Operator cast() as IDispatch Ptr
Declare Operator cast() as IUnknown Ptr
end Type
constructor VARIANT_S
variantClear(@this)
variantinit(@this)
end constructor
destructor VARIANT_S()
variantClear(@this)
end Destructor
Constructor VARIANT_S(ByRef value As VARIANT_S)
This=value
End Constructor
Constructor VARIANT_S(ByVal value As VARIANT)
variantcopy(@This,@value)
End Constructor
constructor VARIANT_S (byval value as String )
VariantInit( @This )
Var wlen = MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, StrPtr(value), -1, 0, 0)-1
V_VT(@This) = VT_BSTR
V_BSTR(@This) = SysAllocStringLen(NULL, wlen)
MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED,StrPtr(value), -1, V_BSTR(@This), wlen)
end constructor
constructor VARIANT_S (ByVal value as wstring Ptr)
VariantInit( @This)
V_VT(@This) = VT_BSTR
V_BSTR(@This) = SysAllocStringlen(value, len(*value) )
if (this.bstrval = NULL And value <> NULL) Then
MessageBox (getactiveWindow(),"Enable to convert wstring to bstr"," VARIANT_S ERROR ",MB_OK OR MB_ICONERROR OR MB_SYSTEMMODAL)
End If
end Constructor
Constructor VARIANT_S(ByVal value As BSTR)
VariantClear(@This)
this.vt=VT_BSTR
this.bstrval=sysallocstring(Cast(OLECHAR Ptr,value))
End Constructor
Constructor VARIANT_S(ByVal value As Single)
VariantClear(@This)
this.vt=VT_R4
this.fltVal=value
End Constructor
Constructor VARIANT_S(ByVal value As Integer)
VariantClear(@This)
this.vt=VT_I4
this.lVal=value
End Constructor
Constructor VARIANT_S(ByVal value As Long)
VariantClear(@This)
this.vt=VT_I4
this.lVal=value
End Constructor
Constructor VARIANT_S(ByVal value As SAFEARRAY Ptr)
VariantClear(@This)
Dim vvt As VARTYPE
SafeArrayGetVartype(value,@vvt)
this.vt=vvt Or VT_ARRAY
this.parray=value
End Constructor
Constructor VARIANT_S(ByVal value As IDispatch Ptr)
VariantClear(@This)
this.vt = VT_DISPATCH
this.pdispVal = value
End Constructor
Constructor VARIANT_S(ByVal value as IUnknown Ptr)
VariantClear(@This)
this.vt = VT_UNKNOWN
this.punkval = value
End Constructor
' Creates a VT_I2, or a VT_BOOL
Constructor VARIANT_S(value As Short , vtSrc as VARTYPE = VT_I2)
if ((vtSrc <> VT_I2) And (vtSrc <> VT_BOOL)) Then
MessageBox (getactiveWindow(),"vt must be VT_I2 OR VT_BOOL"," VARIANT_S ERROR ",MB_OK OR MB_ICONERROR OR MB_SYSTEMMODAL)
Return
End If
VariantClear(@This)
if (vtSrc = VT_BOOL) Then
this.VT = VT_BOOL
this.boolval = iif(value , VARIANT_TRUE , VARIANT_FALSE)
else
this.vt = VT_I2
this.ival = value
End If
End Constructor
' Creates a VT_R8, or a VT_DATE
Constructor VARIANT_S(value As Double , vtSrc as VARTYPE = VT_R8)
If ((vtSrc <> VT_R8) And (vtSrc <> VT_DATE)) Then
MessageBox (getactiveWindow(),"vt must be VT_R8 OR VT_DATE"," VARIANT_S ERROR ",MB_OK OR MB_ICONERROR OR MB_SYSTEMMODAL)
Return
End If
VariantClear(@This)
if (vtSrc = VT_DATE) Then
this.VT = VT_DATE
this.date = value
else
this.VT = VT_R8
this.dblval = value
End If
End Constructor
Constructor VARIANT_S(value As Byte )
VariantClear(@This)
this.VT = VT_UI1
this.bval = value
End Constructor
Constructor VARIANT_S(BYVAL value AS Boolean)
VariantClear(@This)
this.vt = VT_BOOL
this.boolVal = IIf(value = 0,VARIANT_FALSE,VARIANT_TRUE)
End Constructor
Function VARIANT_S.Clear () As HRESULT
Return VariantClear(@this)
END Function
Function VARIANT_S.Copy(pSrc As VARIANT ptr ) As HRESULT
Return VariantCopy(@this, pSrc)
End Function
Function VARIANT_S.Attach(pSrc As VARIANT ptr) As HRESULT
Dim As HRESULT hr = this.Clear() ' ''Clear out the variant
if (0=FAILED(hr)) Then
memcpy(@this, pSrc, sizeof(VARIANT)) ' Copy the contents and give control to Olevariant
pSrc->vt = VT_EMPTY
hr = S_OK
endif
return hr
End Function
Function VARIANT_S.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 Olevariant
vt = VT_EMPTY
hr = S_OK
EndIf
return hr
End Function
Function VARIANT_S.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
' =====================================================================================
' Frees any existing content of the destination variant and makes a copy of the source
' VARIANT, performing the necessary indirection if the source is specified to be VT_BYREF.
' =====================================================================================
Sub VARIANT_S.CopyInd (ByVal value AS VARIANT)
VariantCopyInd(@This, @value)
End Sub
Function VARIANT_S.IsArray As boolean
Return IIf((this.vt AND VT_ARRAY)=VT_ARRAY,TRUE,FALSE)
End Function
operator VARIANT_S.let(byval value as Single)
VariantClear(@This)
this.vt=VT_R4
this.fltVal=value
end Operator
operator VARIANT_S.let(byval d as double)
VariantClear(@This)
this.vt=VT_R8
this.dblval=d
end Operator
operator VARIANT_S.let(byval d as BSTR)
VariantClear(@This)
this.vt=VT_BSTR
this.bstrval=sysallocstring(Cast(OLECHAR Ptr,d))
End Operator
Operator VARIANT_S.let(byval s as STRING)
VariantClear(@This)
Var wlen = MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, StrPtr(s) , -1, 0, 0)-1
V_VT(@This) = VT_BSTR
V_BSTR(@This) = SysAllocStringLen(NULL, wlen)
MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, StrPtr(s) , -1, V_BSTR(@This), wlen)
End Operator
Operator VARIANT_S.Let (ByVal value AS WSTRING Ptr)
Dim hr AS HRESULT
VariantClear(@This)
this.vt = VT_BSTR
this.bstrVal = SysAllocStringlen(value,Len(*value))
hr = IIF (this.bstrVal <> 0, S_OK, E_OUTOFMEMORY)
IF FAILED(hr) THEN VariantInit(@This)
end Operator
Operator VARIANT_S.Let (BYVAL value AS Byte)
VariantClear(@This)
this.vt = VT_UI1
this.bval =value
END Operator
Operator VARIANT_S.Let (ByVal value AS Short)
If this.vt = VT_I2 Then
this.iVal = value
ElseIf (this.vt = VT_BOOL)Then
this.boolval = iif(value , VARIANT_TRUE , VARIANT_FALSE)
Else
VariantClear(@This)
this.vt = VT_I2
this.iVal = value
End If
END operator
Operator VARIANT_S.Let ( ByVal value As Integer)
VariantClear(@This)
this.vt=VT_I4
this.lVal=value
End Operator
Operator VARIANT_S.Let(BYVAL value AS Boolean)
VariantClear(@This)
this.vt = VT_BOOL
this.boolVal = IIf(value <> 0, -1, 0)
End Operator
operator VARIANT_S.let(ByVal value as VARIANT)
variantcopy(@This,@value)
end operator
operator VARIANT_S.let(byval p as SAFEARRAY Ptr)
VariantClear(@This)
Dim vvt As VARTYPE
SafeArrayGetVartype(p,@vvt)
this.vt= vvt Or VT_ARRAY
this.parray=p
End Operator
Operator VARIANT_S.Let (BYVAL pDisp AS IDispatch Ptr)
VariantClear(@This)
this.vt = VT_DISPATCH
this.pdispVal = pDisp
End Operator
Operator VARIANT_S.Let(BYVAL pUnk AS IUnknown Ptr)
VariantClear(@This)
this.vt = VT_UNKNOWN
this.punkVal = pUnk
#If Not Defined( _FB_COM_VTBL_) And (__FB_VERSION__ >= "0.90")
If this.punkVal THEN pUnk->AddRef()
#Else
IF this.punkVal THEN pUnk->lpvtbl->AddRef(pUnk)
#EndIf
END Operator
operator VARIANT_S.let(ByRef value as VARIANT_S)
This=value
End Operator
operator VARIANT_S.cast()as Single
If this.vt=VT_R4 then
return this.fltval
Else
Dim vvar As variant
VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_R4)
Return vvar.fltval
EndIf
end Operator
Operator VARIANT_S.cast()as double
if this.vt=VT_R8 then
return this.dblval
Else
Dim vvar As variant
VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_R8)
Operator= vvar.dblval
variantClear(@vvar)
EndIf
end Operator
operator VARIANT_S.cast() as BSTR
if this.vt=VT_BSTR then
return this.bstrval
Else
Dim vvar As variant
VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_BSTR)
return vvar.bstrval
EndIf
end Operator
operator VARIANT_S.cast() as STRING
'If this.vt=VT_BSTR then
' Return *Cast(WString Ptr,this.bstrval)
'Else
Dim vvar As variant
VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_BSTR)
return *Cast(wString Ptr,vvar.bstrval)
'EndIf
end operator
Operator VARIANT_S.cast() as WString Ptr
If this.vt=VT_BSTR then
Return Cast(WString PTR,this.bstrval)
Else
Dim vvar As variant
VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_BSTR)
return Cast(wstring Ptr,vvar.bstrval)
EndIf
End Operator
Operator VARIANT_S.cast() as Short
if this.vt=VT_I2 then
return this.ival
Else
Dim vvar As variant
VariantChangeTypeEx(@vvar,@this,NULL,VARIANT_NOVALUEPROP,VT_I2)
Return vvar.ival
EndIf
End Operator
Operator VARIANT_S.cast()AS Integer
If this.vt=VT_I4 Then
return this.lVal
Else
Dim vvar As variant
VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_I4)
Return vvar.lval
EndIf
End Operator
operator VARIANT_S.cast() as LONG
if this.vt=VT_I4 then
return this.lval
Else
Dim vvar As variant
VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_I4)
Return vvar.lval
EndIf
end operator
Operator VARIANT_S.cast() as Boolean
if this.vt=VT_BOOL then return IIf(this.boolVal<>0,TRUE,FALSE)
End Operator
'operator VARIANT_S.cast() as VARIANT
' If this.isarray=TRUE Then
' Static v1 As VARIANT
' variantcopy(@v1,@This)
' Return v1
' EndIf
' Return This
'end operator
operator VARIANT_S.cast() as SAFEARRAY Ptr
if (this.vt And VT_ARRAY)=VT_ARRAY Then
Return this.parray
Else
Dim vvar As variant
VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_ARRAY Or (this.vt Xor VT_ARRAY) )
Return vvar.parray
EndIf
End Operator
Operator VARIANT_S.cast() as IDispatch Ptr
if this.vt=VT_DISPATCH then
return this.pdispVal
Else
Dim vvar As variant
VariantChangeTypeEx(@vvar,@This,NULL,VARIANT_NOVALUEPROP,VT_DISPATCH)
Return vvar.pdispVal
EndIf
End Operator
variant_s_test.bas
#Include Once "variant_s.bi"
Dim As VARIANT_S v="ayelma"
Print v , v.vt
Print
v=50
Print v , v.vt
Print
v=CShort(50)
Print v , v.vt
v=123.35#
Print
Print v , v.vt
v=123.35f
Print
Print v , v.vt
Dim vv As VARIANT=v
Print
Print vv.fltval , vv.vt
Print "normal end"
Sleep
