variant class

[aloberr]

variant_s.bi

Code Select Expand

#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

Code Select Expand

#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